aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2017-10-26 21:41:41 -0400
committerEduardo Julian2017-10-26 21:41:41 -0400
commit3439602c2b356eaef3359b6496a0237f1af55e33 (patch)
tree90c3c1d0f97fc30b1a991de50977d8a075564724
parente2621632653ad1252744eecff6da143faaf90787 (diff)
- Added a new piece of compiler state, just for storing the current-module.
Diffstat (limited to '')
-rw-r--r--luxc/src/lux/analyser/module.clj3
-rw-r--r--luxc/src/lux/base.clj11
-rw-r--r--new-luxc/source/luxc/base.lux15
-rw-r--r--new-luxc/source/luxc/generator.lux1
-rw-r--r--new-luxc/source/luxc/module.lux3
-rw-r--r--new-luxc/test/test/luxc/common.lux35
-rw-r--r--stdlib/source/lux.lux76
-rw-r--r--stdlib/source/lux/meta.lux109
8 files changed, 122 insertions, 131 deletions
diff --git a/luxc/src/lux/analyser/module.clj b/luxc/src/lux/analyser/module.clj
index 8c5a2d286..c8a263030 100644
--- a/luxc/src/lux/analyser/module.clj
+++ b/luxc/src/lux/analyser/module.clj
@@ -279,7 +279,8 @@
(fn [state]
(return* (->> state
(&/update$ &/$modules #(&/|put name (new-module hash) %))
- (&/set$ &/$scopes (&/|list (&/env name &/$Nil))))
+ (&/set$ &/$scopes (&/|list (&/env name &/$Nil)))
+ (&/set$ &/$current-module (&/$Some name)))
nil)))
(do-template [<name> <tag> <type>]
diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj
index 3bf0eaf08..910bdfadf 100644
--- a/luxc/src/lux/base.clj
+++ b/luxc/src/lux/base.clj
@@ -151,6 +151,7 @@
["info"
"source"
"cursor"
+ "current-module"
"modules"
"scopes"
"type-context"
@@ -819,6 +820,8 @@
$Nil
;; "lux;cursor"
(T ["" -1 -1])
+ ;; "current-module"
+ $None
;; "lux;modules"
(|table)
;; "lux;scopes"
@@ -910,13 +913,13 @@
(def get-module-name
(fn [state]
- (|case (|reverse (get$ $scopes state))
- ($Nil)
+ (|case (get$ $current-module state)
+ ($None)
((fail-with-loc "[Analyser Error] Cannot get the module-name without a module.")
state)
- ($Cons ?global _)
- (return* state (|head (get$ $name ?global))))))
+ ($Some module-name)
+ (return* state module-name))))
(defn find-module [name]
"(-> Text (Lux (Module Compiler)))"
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux
index 28b5437e9..bac16fd79 100644
--- a/new-luxc/source/luxc/base.lux
+++ b/new-luxc/source/luxc/base.lux
@@ -145,7 +145,7 @@
(def: fresh-scope
Scope
- {#;name (list "lux")
+ {#;name (list)
#;inner +0
#;locals fresh-bindings
#;captured fresh-bindings})
@@ -166,6 +166,19 @@
(#e;Error error)
(#e;Error error))))
+(def: #export (with-current-module name action)
+ (All [a] (-> Text (Meta a) (Meta a)))
+ (function [compiler]
+ (case (action (set@ #;current-module (#;Some name) compiler))
+ (#e;Success [compiler' output])
+ (#e;Success [(set@ #;current-module
+ (get@ #;current-module compiler)
+ compiler')
+ output])
+
+ (#e;Error error)
+ (#e;Error error))))
+
(def: #export (with-cursor cursor action)
(All [a] (-> Cursor (Meta a) (Meta a)))
(if (text/= "" (product;left cursor))
diff --git a/new-luxc/source/luxc/generator.lux b/new-luxc/source/luxc/generator.lux
index f64ca333e..4ac937402 100644
--- a/new-luxc/source/luxc/generator.lux
+++ b/new-luxc/source/luxc/generator.lux
@@ -158,6 +158,7 @@
{#;info init-info
#;source [init-cursor +0 ""]
#;cursor init-cursor
+ #;current-module #;None
#;modules (list)
#;scopes (list)
#;type-context init-type-context
diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux
index 39d3679e6..2bb7eedcd 100644
--- a/new-luxc/source/luxc/module.lux
+++ b/new-luxc/source/luxc/module.lux
@@ -56,7 +56,8 @@
(All [a] (-> Nat Text (Meta a) (Meta [Module a])))
(do Monad<Meta>
[_ (create hash name)
- output (&scope;with-scope name action)
+ output (&;with-current-module name
+ (&scope;with-scope name action))
module (meta;find-module name)]
(wrap [module output])))
diff --git a/new-luxc/test/test/luxc/common.lux b/new-luxc/test/test/luxc/common.lux
index 2e725be5d..5b6fed8ec 100644
--- a/new-luxc/test/test/luxc/common.lux
+++ b/new-luxc/test/test/luxc/common.lux
@@ -1,36 +1,9 @@
(;module:
lux
- (lux (control pipe)
- ["r" math/random "r/" Monad<Random>]
- (data ["R" error])
- [meta]
- (meta [code])
- [io])
- (luxc ["&" base]
- [analyser]
- ["&;" host]))
-
-(def: init-info
- Info
- {#;target "JVM"
- #;version &;version
- #;mode #;Build})
-
-(def: init-type-context
- Type-Context
- {#;ex-counter +0
- #;var-counter +0
- #;var-bindings (list)})
+ (lux [io])
+ (luxc ["&;" host]
+ [";G" generator]))
(def: #export (init-compiler _)
(-> Top Compiler)
- {#;info init-info
- #;source [dummy-cursor +0 ""]
- #;cursor dummy-cursor
- #;modules (list)
- #;scopes (list)
- #;type-context init-type-context
- #;expected #;None
- #;seed +0
- #;scope-type-vars (list)
- #;host (:! Void (io;run &host;init-host))})
+ (generatorG;init-compiler (io;run &host;init-host)))
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 9509c7ad5..7aa9a96a6 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -710,6 +710,7 @@
## {#info Info
## #source Source
## #cursor Cursor
+## #current-module (Maybe Text)
## #modules (List [Text Module])
## #scopes (List Scope)
## #type-context Type-Context
@@ -725,32 +726,35 @@
Source
(#Product ## "lux;cursor"
Cursor
- (#Product ## "lux;modules"
- (#Apply (#Product Text Module) List)
- (#Product ## "lux;scopes"
- (#Apply Scope List)
- (#Product ## "lux;type-context"
- Type-Context
- (#Product ## "lux;expected"
- (#Apply Type Maybe)
- (#Product ## "lux;seed"
- Nat
- (#Product ## scope-type-vars
- (#Apply Nat List)
- ## "lux;host"
- Void))))))))))
+ (#Product ## "lux;current-module"
+ (#Apply Text Maybe)
+ (#Product ## "lux;modules"
+ (#Apply (#Product Text Module) List)
+ (#Product ## "lux;scopes"
+ (#Apply Scope List)
+ (#Product ## "lux;type-context"
+ Type-Context
+ (#Product ## "lux;expected"
+ (#Apply Type Maybe)
+ (#Product ## "lux;seed"
+ Nat
+ (#Product ## scope-type-vars
+ (#Apply Nat List)
+ ## "lux;host"
+ Void)))))))))))
(record$ (#Cons [(tag$ ["lux" "tags"])
(tuple$ (#Cons (text$ "info")
(#Cons (text$ "source")
(#Cons (text$ "cursor")
- (#Cons (text$ "modules")
- (#Cons (text$ "scopes")
- (#Cons (text$ "type-context")
- (#Cons (text$ "expected")
- (#Cons (text$ "seed")
- (#Cons (text$ "scope-type-vars")
- (#Cons (text$ "host")
- #Nil)))))))))))]
+ (#Cons (text$ "current-module")
+ (#Cons (text$ "modules")
+ (#Cons (text$ "scopes")
+ (#Cons (text$ "type-context")
+ (#Cons (text$ "expected")
+ (#Cons (text$ "seed")
+ (#Cons (text$ "scope-type-vars")
+ (#Cons (text$ "host")
+ #Nil))))))))))))]
(#Cons [(tag$ ["lux" "doc"])
(text$ "Represents the state of the Lux compiler during a run.
@@ -1807,7 +1811,7 @@
#Nil
(-> Ident ($' Meta Ident))
(let' [[module name] ident
- {#info info #source source #modules modules
+ {#info info #source source #current-module _ #modules modules
#scopes scopes #type-context types #host host
#seed seed #expected expected #cursor cursor
#scope-type-vars scope-type-vars} state]
@@ -1970,12 +1974,12 @@
#Nil
($' Meta Text)
("lux case" state
- {#info info #source source #modules modules
+ {#info info #source source #current-module current-module #modules modules
#scopes scopes #type-context types #host host
#seed seed #expected expected #cursor cursor
#scope-type-vars scope-type-vars}
- ("lux case" (reverse scopes)
- (#Cons {#name (#;Cons module-name #Nil) #inner _ #locals _ #captured _} _)
+ ("lux case" current-module
+ (#;Some module-name)
(#Right [state module-name])
_
@@ -2440,7 +2444,7 @@
(let' [[module name] ident]
(function' [state]
("lux case" state
- {#info info #source source #modules modules
+ {#info info #source source #current-module _ #modules modules
#scopes scopes #type-context types #host host
#seed seed #expected expected
#cursor cursor
@@ -2698,12 +2702,12 @@
#Nil
(-> Text ($' Meta Code))
("lux case" state
- {#info info #source source #modules modules
+ {#info info #source source #current-module _ #modules modules
#scopes scopes #type-context types #host host
#seed seed #expected expected
#cursor cursor
#scope-type-vars scope-type-vars}
- (#Right {#info info #source source #modules modules
+ (#Right {#info info #source source #current-module _ #modules modules
#scopes scopes #type-context types #host host
#seed (n.+ +1 seed) #expected expected
#cursor cursor
@@ -3562,7 +3566,7 @@
(def: (find-module name)
(-> Text (Meta Module))
(function [state]
- (let [{#info info #source source #modules modules
+ (let [{#info info #source source #current-module _ #modules modules
#scopes scopes #type-context types #host host
#seed seed #expected expected #cursor cursor
#scope-type-vars scope-type-vars} state]
@@ -3625,7 +3629,7 @@
(def: get-expected-type
(Meta Type)
(function [state]
- (let [{#info info #source source #modules modules
+ (let [{#info info #source source #current-module _ #modules modules
#scopes scopes #type-context types #host host
#seed seed #expected expected #cursor cursor
#scope-type-vars scope-type-vars} state]
@@ -4145,7 +4149,7 @@
(def: (exported-defs module state)
(-> Text (Meta (List Text)))
(let [modules (case state
- {#info info #source source #modules modules
+ {#info info #source source #current-module _ #modules modules
#scopes scopes #type-context types #host host
#seed seed #expected expected #cursor cursor
#scope-type-vars scope-type-vars}
@@ -4200,7 +4204,7 @@
(def: (find-in-env name state)
(-> Text Compiler (Maybe Type))
(case state
- {#info info #source source #modules modules
+ {#info info #source source #current-module _ #modules modules
#scopes scopes #type-context types #host host
#seed seed #expected expected #cursor cursor
#scope-type-vars scope-type-vars}
@@ -4223,7 +4227,7 @@
(def: (find-def-type name state)
(-> Ident Compiler (Maybe Type))
(let [[v-prefix v-name] name
- {#info info #source source #modules modules
+ {#info info #source source #current-module _ #modules modules
#scopes scopes #type-context types #host host
#seed seed #expected expected #cursor cursor
#scope-type-vars scope-type-vars} state]
@@ -4242,7 +4246,7 @@
(def: (find-def-value name state)
(-> Ident (Meta [Type Top]))
(let [[v-prefix v-name] name
- {#info info #source source #modules modules
+ {#info info #source source #current-module _ #modules modules
#scopes scopes #type-context types #host host
#seed seed #expected expected #cursor cursor
#scope-type-vars scope-type-vars} state]
@@ -5609,7 +5613,7 @@
(def: (get-scope-type-vars state)
(Meta (List Nat))
(case state
- {#info info #source source #modules modules
+ {#info info #source source #current-module _ #modules modules
#scopes scopes #type-context types #host host
#seed seed #expected expected #cursor cursor
#scope-type-vars scope-type-vars}
diff --git a/stdlib/source/lux/meta.lux b/stdlib/source/lux/meta.lux
index 6f1fb2720..e65e09b58 100644
--- a/stdlib/source/lux/meta.lux
+++ b/stdlib/source/lux/meta.lux
@@ -7,44 +7,44 @@
[product]
[ident "ident/" Codec<Text,Ident> Eq<Ident>]
[maybe]
- ["E" error]
+ ["e" error]
[text "text/" Monoid<Text> Eq<Text>]
(coll [list "list/" Monoid<List> Monad<List>])))
(. [code]))
## (type: (Meta a)
-## (-> Compiler (E;Error [Compiler a])))
+## (-> Compiler (e;Error [Compiler a])))
(struct: #export _ (F;Functor Meta)
(def: (map f fa)
(function [state]
(case (fa state)
- (#E;Error msg)
- (#E;Error msg)
+ (#e;Error msg)
+ (#e;Error msg)
- (#E;Success [state' a])
- (#E;Success [state' (f a)])))))
+ (#e;Success [state' a])
+ (#e;Success [state' (f a)])))))
(struct: #export _ (A;Applicative Meta)
(def: functor Functor<Meta>)
(def: (wrap x)
(function [state]
- (#E;Success [state x])))
+ (#e;Success [state x])))
(def: (apply ff fa)
(function [state]
(case (ff state)
- (#E;Success [state' f])
+ (#e;Success [state' f])
(case (fa state')
- (#E;Success [state'' a])
- (#E;Success [state'' (f a)])
+ (#e;Success [state'' a])
+ (#e;Success [state'' (f a)])
- (#E;Error msg)
- (#E;Error msg))
+ (#e;Error msg)
+ (#e;Error msg))
- (#E;Error msg)
- (#E;Error msg)))))
+ (#e;Error msg)
+ (#e;Error msg)))))
(struct: #export _ (Monad Meta)
(def: applicative Applicative<Meta>)
@@ -52,10 +52,10 @@
(def: (join mma)
(function [state]
(case (mma state)
- (#E;Error msg)
- (#E;Error msg)
+ (#e;Error msg)
+ (#e;Error msg)
- (#E;Success [state' ma])
+ (#e;Success [state' ma])
(ma state')))))
(def: (get k plist)
@@ -71,68 +71,63 @@
(get k plist'))))
(def: #export (run' compiler action)
- (All [a] (-> Compiler (Meta a) (E;Error [Compiler a])))
+ (All [a] (-> Compiler (Meta a) (e;Error [Compiler a])))
(action compiler))
(def: #export (run compiler action)
- (All [a] (-> Compiler (Meta a) (E;Error a)))
+ (All [a] (-> Compiler (Meta a) (e;Error a)))
(case (action compiler)
- (#E;Error error)
- (#E;Error error)
+ (#e;Error error)
+ (#e;Error error)
- (#E;Success [_ output])
- (#E;Success output)))
+ (#e;Success [_ output])
+ (#e;Success output)))
(def: #export (either left right)
{#;doc "Pick whichever computation succeeds."}
(All [a] (-> (Meta a) (Meta a) (Meta a)))
(function [compiler]
(case (left compiler)
- (#E;Error error)
+ (#e;Error error)
(right compiler)
- (#E;Success [compiler' output])
- (#E;Success [compiler' output]))))
+ (#e;Success [compiler' output])
+ (#e;Success [compiler' output]))))
(def: #export (assert message test)
{#;doc "Fails with the given message if the test is false."}
(-> Text Bool (Meta Unit))
(function [compiler]
(if test
- (#E;Success [compiler []])
- (#E;Error message))))
+ (#e;Success [compiler []])
+ (#e;Error message))))
(def: #export (fail msg)
{#;doc "Fails with the given message."}
(All [a]
(-> Text (Meta a)))
(function [_]
- (#E;Error msg)))
+ (#e;Error msg)))
(def: #export (find-module name)
(-> Text (Meta Module))
(function [state]
(case (get name (get@ #;modules state))
(#;Some module)
- (#E;Success [state module])
+ (#e;Success [state module])
_
- (#E;Error ($_ text/compose "Unknown module: " name)))))
+ (#e;Error ($_ text/compose "Unknown module: " name)))))
(def: #export current-module-name
(Meta Text)
(function [state]
- (case (list;last (get@ #;scopes state))
- (#;Some scope)
- (case (get@ #;name scope)
- (#;Cons m-name #;Nil)
- (#E;Success [state m-name])
-
- _
- (#E;Error "Improper name for scope."))
+ (case (get@ #;current-module state)
+ (#;Some current-module)
+ (#e;Success [state current-module])
_
- (#E;Error "Empty environment!")
+ (#e;Error "No current module.")
)))
(def: #export current-module
@@ -262,7 +257,7 @@
(let [[module name] ident]
(: (Meta (Maybe Macro))
(function [state]
- (#E;Success [state (find-macro' (get@ #;modules state) this-module module name)]))))))
+ (#e;Success [state (find-macro' (get@ #;modules state) this-module module name)]))))))
(def: #export (normalize ident)
{#;doc "If given an identifier without a module prefix, gives it the current module's name as prefix.
@@ -361,7 +356,7 @@
A prefix can be given (or just be empty text \"\") to better identify the code for debugging purposes."}
(-> Text (Meta Code))
(function [state]
- (#E;Success [(update@ #;seed n.inc state)
+ (#e;Success [(update@ #;seed n.inc state)
(code;symbol ["" ($_ text/compose "__gensym__" prefix (:: number;Codec<Text,Nat> encode (get@ #;seed state)))])])))
(def: (get-local-symbol ast)
@@ -412,7 +407,7 @@
(def: #export (module-exists? module)
(-> Text (Meta Bool))
(function [state]
- (#E;Success [state (case (get module (get@ #;modules state))
+ (#e;Success [state (case (get module (get@ #;modules state))
(#;Some _)
true
@@ -446,10 +441,10 @@
(get@ [#;captured #;mappings] scope)))]
(wrap type))
(#;Some var-type)
- (#E;Success [state var-type])
+ (#e;Success [state var-type])
#;None
- (#E;Error ($_ text/compose "Unknown variable: " name))))))
+ (#e;Error ($_ text/compose "Unknown variable: " name))))))
(def: #export (find-def name)
{#;doc "Looks-up a definition's whole data in the available modules (including the current one)."}
@@ -461,10 +456,10 @@
(^slots [#;defs]) (get v-prefix (get@ #;modules state))]
(get v-name defs)))
(#;Some _anns)
- (#E;Success [state _anns])
+ (#e;Success [state _anns])
_
- (#E;Error ($_ text/compose "Unknown definition: " (ident/encode name))))))
+ (#e;Error ($_ text/compose "Unknown definition: " (ident/encode name))))))
(def: #export (find-def-type name)
{#;doc "Looks-up a definition's type in the available modules (including the current one)."}
@@ -495,8 +490,8 @@
(-> Text (Meta (List [Text Def])))
(function [state]
(case (get module-name (get@ #;modules state))
- #;None (#E;Error ($_ text/compose "Unknown module: " module-name))
- (#;Some module) (#E;Success [state (get@ #;defs module)])
+ #;None (#e;Error ($_ text/compose "Unknown module: " module-name))
+ (#;Some module) (#e;Success [state (get@ #;defs module)])
)))
(def: #export (exports module-name)
@@ -516,7 +511,7 @@
(|> state
(get@ #;modules)
[state]
- #E;Success)))
+ #e;Success)))
(def: #export (tags-of type-name)
{#;doc "All the tags associated with a type definition."}
@@ -535,7 +530,7 @@
{#;doc "The cursor of the current expression being analyzed."}
(Meta Cursor)
(function [state]
- (#E;Success [state (get@ #;cursor state)])))
+ (#e;Success [state (get@ #;cursor state)])))
(def: #export expected-type
{#;doc "The expected type of the current expression being analyzed."}
@@ -543,10 +538,10 @@
(function [state]
(case (get@ #;expected state)
(#;Some type)
- (#E;Success [state type])
+ (#e;Success [state type])
#;None
- (#E;Error "Not expecting any type."))))
+ (#e;Error "Not expecting any type."))))
(def: #export (imported-modules module-name)
{#;doc "All the modules imported by a specified module."}
@@ -591,10 +586,10 @@
(function [state]
(case (list;inits (get@ #;scopes state))
#;None
- (#E;Error "No local environment")
+ (#e;Error "No local environment")
(#;Some scopes)
- (#E;Success [state
+ (#e;Success [state
(list/map (|>. (get@ [#;locals #;mappings])
(list/map (function [[name [type _]]]
[name type])))
@@ -617,12 +612,12 @@
{#;doc "Obtains the current state of the compiler."}
(Meta Compiler)
(function [compiler]
- (#E;Success [compiler compiler])))
+ (#e;Success [compiler compiler])))
(def: #export type-context
(Meta Type-Context)
(function [compiler]
- (#E;Success [compiler (get@ #;type-context compiler)])))
+ (#e;Success [compiler (get@ #;type-context compiler)])))
(do-template [<macro> <func> <desc>]
[(macro: #export (<macro> tokens)