diff options
-rw-r--r-- | luxc/src/lux/analyser/module.clj | 3 | ||||
-rw-r--r-- | luxc/src/lux/base.clj | 11 | ||||
-rw-r--r-- | new-luxc/source/luxc/base.lux | 15 | ||||
-rw-r--r-- | new-luxc/source/luxc/generator.lux | 1 | ||||
-rw-r--r-- | new-luxc/source/luxc/module.lux | 3 | ||||
-rw-r--r-- | new-luxc/test/test/luxc/common.lux | 35 | ||||
-rw-r--r-- | stdlib/source/lux.lux | 76 | ||||
-rw-r--r-- | stdlib/source/lux/meta.lux | 109 |
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) |