diff options
| author | Eduardo Julian | 2017-04-11 00:01:51 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2017-04-11 00:01:51 -0400 |
| commit | e74edcf1040303a7c25d34bbfb391a75f011a4ac (patch) | |
| tree | 2d858e6ec89bce60bab85e6b8a1a55da9e003c8b | |
| parent | cb792cb800790e89b371832e46cfe958b7c683d0 (diff) | |
- Fused the lux/compiler and lux/macro modules.
40 files changed, 842 insertions, 843 deletions
diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux index 4d729af37..c148161ee 100644 --- a/stdlib/source/lux/cli.lux +++ b/stdlib/source/lux/cli.lux @@ -8,7 +8,7 @@ error (sum #as sum)) [io] - [compiler #+ with-gensyms Functor<Lux> Monad<Lux>] + [macro #+ with-gensyms Functor<Lux> Monad<Lux>] (macro [ast] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/compiler.lux b/stdlib/source/lux/compiler.lux deleted file mode 100644 index 0f95defb6..000000000 --- a/stdlib/source/lux/compiler.lux +++ /dev/null @@ -1,610 +0,0 @@ -(;module: {#;doc "Functions for extracting information from the state of the compiler."} - lux - (lux (macro [ast]) - (control functor - applicative - monad) - (data (coll [list #* "List/" Monoid<List> Monad<List>]) - [number] - [text "Text/" Monoid<Text> Eq<Text>] - [product] - [ident "Ident/" Codec<Text,Ident>] - maybe - [error #- fail]))) - -## (type: (Lux a) -## (-> Compiler (Error [Compiler a]))) - -(struct: #export _ (Functor Lux) - (def: (map f fa) - (function [state] - (case (fa state) - (#;Left msg) - (#;Left msg) - - (#;Right [state' a]) - (#;Right [state' (f a)]))))) - -(struct: #export _ (Applicative Lux) - (def: functor Functor<Lux>) - - (def: (wrap x) - (function [state] - (#;Right [state x]))) - - (def: (apply ff fa) - (function [state] - (case (ff state) - (#;Right [state' f]) - (case (fa state') - (#;Right [state'' a]) - (#;Right [state'' (f a)]) - - (#;Left msg) - (#;Left msg)) - - (#;Left msg) - (#;Left msg))))) - -(struct: #export _ (Monad Lux) - (def: applicative Applicative<Lux>) - - (def: (join mma) - (function [state] - (case (mma state) - (#;Left msg) - (#;Left msg) - - (#;Right [state' ma]) - (ma state'))))) - -(def: (get k plist) - (All [a] - (-> Text (List [Text a]) (Maybe a))) - (case plist - #;Nil - #;None - - (#;Cons [k' v] plist') - (if (Text/= k k') - (#;Some v) - (get k plist')))) - -(def: #export (run' compiler action) - (All [a] (-> Compiler (Lux a) (Error [Compiler a]))) - (action compiler)) - -(def: #export (run compiler action) - (All [a] (-> Compiler (Lux a) (Error a))) - (case (action compiler) - (#;Left error) - (#;Left error) - - (#;Right [_ output]) - (#;Right output))) - -(def: #export (either left right) - {#;doc "Pick whichever computation succeeds."} - (All [a] (-> (Lux a) (Lux a) (Lux a))) - (function [compiler] - (case (left compiler) - (#;Left error) - (right compiler) - - (#;Right [compiler' output]) - (#;Right [compiler' output])))) - -(def: #export (assert message test) - {#;doc "Fails with the given message if the test is false."} - (-> Text Bool (Lux Unit)) - (function [compiler] - (if test - (#;Right [compiler []]) - (#;Left message)))) - -(def: #export (fail msg) - {#;doc "Fails with the given message."} - (All [a] - (-> Text (Lux a))) - (function [_] - (#;Left msg))) - -(def: #export (find-module name) - (-> Text (Lux Module)) - (function [state] - (case (get name (get@ #;modules state)) - (#;Some module) - (#;Right [state module]) - - _ - (#;Left ($_ Text/append "Unknown module: " name))))) - -(def: #export current-module-name - (Lux Text) - (function [state] - (case (list;last (get@ #;scopes state)) - (#;Some scope) - (case (get@ #;name scope) - (#;Cons m-name #;Nil) - (#;Right [state m-name]) - - _ - (#;Left "Improper name for scope.")) - - _ - (#;Left "Empty environment!") - ))) - -(def: #export current-module - (Lux Module) - (do Monad<Lux> - [this-module-name current-module-name] - (find-module this-module-name))) - -(def: #export (get-ann tag anns) - {#;doc "Looks-up a particular annotation's value within the set of annotations."} - (-> Ident Anns (Maybe Ann-Value)) - (let [[p n] tag] - (case anns - (#;Cons [[p' n'] dmv] anns') - (if (and (Text/= p p') - (Text/= n n')) - (#;Some dmv) - (get-ann tag anns')) - - #;Nil - #;None))) - -(do-template [<name> <tag> <type>] - [(def: #export (<name> tag anns) - (-> Ident Anns (Maybe <type>)) - (case (get-ann tag anns) - (#;Some (<tag> value)) - (#;Some value) - - _ - #;None))] - - [get-bool-ann #;BoolA Bool] - [get-int-ann #;IntA Int] - [get-real-ann #;RealA Real] - [get-char-ann #;CharA Char] - [get-text-ann #;TextA Text] - [get-ident-ann #;IdentA Ident] - [get-list-ann #;ListA (List Ann-Value)] - [get-dict-ann #;DictA (List [Text Ann-Value])] - ) - -(def: #export (get-doc anns) - {#;doc "Looks-up a definition's documentation."} - (-> Anns (Maybe Text)) - (get-text-ann ["lux" "doc"] anns)) - -(def: #export (flag-set? flag-name anns) - {#;doc "Finds out whether an annotation-as-a-flag is set (has value 'true')."} - (-> Ident Anns Bool) - (case (get-ann flag-name anns) - (#;Some (#;BoolA true)) - true - - _ - false)) - -(do-template [<name> <tag> <desc>] - [(def: #export <name> - {#;doc (#;TextA ($_ Text/append "Checks whether a definition is " <desc> "."))} - (-> Anns Bool) - (flag-set? (ident-for <tag>)))] - - [export? #;export? "exported"] - [hidden? #;hidden? "hidden"] - [macro? #;macro? "a macro"] - [type? #;type? "a type"] - [struct? #;struct? "a structure"] - [type-rec? #;type-rec? "a recursive type"] - [sig? #;sig? "a signature"] - ) - -(do-template [<name> <tag> <type>] - [(def: (<name> dmv) - (-> Ann-Value (Maybe <type>)) - (case dmv - (<tag> actual-value) - (#;Some actual-value) - - _ - #;None))] - - [try-mlist #;ListA (List Ann-Value)] - [try-mtext #;TextA Text] - ) - -(do-template [<name> <tag> <desc>] - [(def: #export (<name> anns) - {#;doc (#;TextA ($_ Text/append "Looks up the arguments of a " <desc> "."))} - (-> Anns (List Text)) - (default (list) - (do Monad<Maybe> - [_args (get-ann (ident-for <tag>) anns) - args (try-mlist _args)] - (mapM @ try-mtext args))))] - - [func-args #;func-args "function"] - [type-args #;type-args "parameterized type"] - ) - -(def: (find-macro' modules this-module module name) - (-> (List [Text Module]) Text Text Text - (Maybe Macro)) - (do Monad<Maybe> - [$module (get module modules) - [def-type def-anns def-value] (: (Maybe Def) (|> (: Module $module) (get@ #;defs) (get name)))] - (if (and (macro? def-anns) - (or (export? def-anns) (Text/= module this-module))) - (#;Some (:! Macro def-value)) - (case (get-ann ["lux" "alias"] def-anns) - (#;Some (#;IdentA [r-module r-name])) - (find-macro' modules this-module r-module r-name) - - _ - #;None)))) - -(def: #export (find-macro ident) - (-> Ident (Lux (Maybe Macro))) - (do Monad<Lux> - [this-module current-module-name] - (let [[module name] ident] - (: (Lux (Maybe Macro)) - (function [state] - (#;Right [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. - - Otherwise, returns the identifier as-is."} - (-> Ident (Lux Ident)) - (case ident - ["" name] - (do Monad<Lux> - [module-name current-module-name] - (wrap [module-name name])) - - _ - (:: Monad<Lux> wrap ident))) - -(def: #export (macro-expand-once syntax) - {#;doc "Given code that requires applying a macro, does it once and returns the result. - - Otherwise, returns the code as-is."} - (-> AST (Lux (List AST))) - (case syntax - [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] - (do Monad<Lux> - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (case ?macro - (#;Some macro) - (macro args) - - #;None - (:: Monad<Lux> wrap (list syntax)))) - - _ - (:: Monad<Lux> wrap (list syntax)))) - -(def: #export (macro-expand syntax) - {#;doc "Given code that requires applying a macro, expands repeatedly until no more direct macro-calls are left. - - Otherwise, returns the code as-is."} - (-> AST (Lux (List AST))) - (case syntax - [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] - (do Monad<Lux> - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (case ?macro - (#;Some macro) - (do Monad<Lux> - [expansion (macro args) - expansion' (mapM Monad<Lux> macro-expand expansion)] - (wrap (:: Monad<List> join expansion'))) - - #;None - (:: Monad<Lux> wrap (list syntax)))) - - _ - (:: Monad<Lux> wrap (list syntax)))) - -(def: #export (macro-expand-all syntax) - {#;doc "Expands all macro-calls everywhere recursively, until only primitive/base code remains."} - (-> AST (Lux (List AST))) - (case syntax - [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] - (do Monad<Lux> - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (case ?macro - (#;Some macro) - (do Monad<Lux> - [expansion (macro args) - expansion' (mapM Monad<Lux> macro-expand-all expansion)] - (wrap (:: Monad<List> join expansion'))) - - #;None - (do Monad<Lux> - [parts' (mapM Monad<Lux> macro-expand-all (list& (ast;symbol macro-name) args))] - (wrap (list (ast;form (:: Monad<List> join parts'))))))) - - [_ (#;FormS (#;Cons [harg targs]))] - (do Monad<Lux> - [harg+ (macro-expand-all harg) - targs+ (mapM Monad<Lux> macro-expand-all targs)] - (wrap (list (ast;form (List/append harg+ (:: Monad<List> join (: (List (List AST)) targs+))))))) - - [_ (#;TupleS members)] - (do Monad<Lux> - [members' (mapM Monad<Lux> macro-expand-all members)] - (wrap (list (ast;tuple (:: Monad<List> join members'))))) - - _ - (:: Monad<Lux> wrap (list syntax)))) - -(def: #export (gensym prefix) - {#;doc "Generates a unique identifier as an AST node (ready to be used in code templates). - - A prefix can be given (or just be empty text \"\") to better identify the code for debugging purposes."} - (-> Text (Lux AST)) - (function [state] - (#;Right [(update@ #;seed n.inc state) - (ast;symbol ["" ($_ Text/append "__gensym__" prefix (:: number;Codec<Text,Nat> encode (get@ #;seed state)))])]))) - -(def: (get-local-symbol ast) - (-> AST (Lux Text)) - (case ast - [_ (#;SymbolS [_ name])] - (:: Monad<Lux> wrap name) - - _ - (fail (Text/append "AST is not a local symbol: " (ast;to-text ast))))) - -(macro: #export (with-gensyms tokens) - {#;doc (doc "Creates new symbols and offers them to the body expression." - (syntax: #export (synchronized lock body) - (with-gensyms [g!lock g!body g!_] - (wrap (list (` (let [(~ g!lock) (~ lock) - (~ g!_) (;_jvm_monitorenter (~ g!lock)) - (~ g!body) (~ body) - (~ g!_) (;_jvm_monitorexit (~ g!lock))] - (~ g!body))))) - )))} - (case tokens - (^ (list [_ (#;TupleS symbols)] body)) - (do Monad<Lux> - [symbol-names (mapM @ get-local-symbol symbols) - #let [symbol-defs (List/join (List/map (: (-> Text (List AST)) - (function [name] (list (ast;symbol ["" name]) (` (gensym (~ (ast;text name))))))) - symbol-names))]] - (wrap (list (` (do Monad<Lux> - [(~@ symbol-defs)] - (~ body)))))) - - _ - (fail "Wrong syntax for with-gensyms"))) - -(def: #export (macro-expand-1 token) - {#;doc "Works just like macro-expand, except that it ensures that the output is a single AST token."} - (-> AST (Lux AST)) - (do Monad<Lux> - [token+ (macro-expand token)] - (case token+ - (^ (list token')) - (wrap token') - - _ - (fail "Macro expanded to more than 1 element.")))) - -(def: #export (module-exists? module) - (-> Text (Lux Bool)) - (function [state] - (#;Right [state (case (get module (get@ #;modules state)) - (#;Some _) - true - - #;None - false)]))) - -(def: (try-both f x1 x2) - (All [a b] - (-> (-> a (Maybe b)) a a (Maybe b))) - (case (f x1) - #;None (f x2) - (#;Some y) (#;Some y))) - -(def: #export (find-var-type name) - {#;doc "Looks-up the type of a local variable somewhere in the environment."} - (-> Text (Lux Type)) - (function [state] - (let [test (: (-> [Text Analysis] Bool) - (|>. product;left (Text/= name)))] - (case (do Monad<Maybe> - [scope (find (function [env] - (or (any? test (get@ [#;locals #;mappings] env)) - (any? test (get@ [#;closure #;mappings] env)))) - (get@ #;scopes state)) - [_ [[type _] _]] (try-both (find test) - (get@ [#;locals #;mappings] scope) - (get@ [#;closure #;mappings] scope))] - (wrap type)) - (#;Some var-type) - (#;Right [state var-type]) - - #;None - (#;Left ($_ Text/append "Unknown variable: " name)))))) - -(def: #export (find-def name) - {#;doc "Looks-up a definition's whole data in the available modules (including the current one)."} - (-> Ident (Lux Def)) - (function [state] - (case (: (Maybe Def) - (do Monad<Maybe> - [#let [[v-prefix v-name] name] - (^slots [#;defs]) (get v-prefix (get@ #;modules state))] - (get v-name defs))) - (#;Some _anns) - (#;Right [state _anns]) - - _ - (#;Left ($_ Text/append "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)."} - (-> Ident (Lux Type)) - (do Monad<Lux> - [[def-type def-data def-value] (find-def name)] - (wrap def-type))) - -(def: #export (find-type name) - {#;doc "Looks-up the type of either a local variable or a definition."} - (-> Ident (Lux Type)) - (do Monad<Lux> - [#let [[_ _name] name]] - (either (find-var-type _name) - (do @ - [name (normalize name)] - (find-def-type name))))) - -(def: #export (find-type-def name) - {#;doc "Finds the value of a type definition (such as Int, Top or Compiler)."} - (-> Ident (Lux Type)) - (do Monad<Lux> - [[def-type def-data def-value] (find-def name)] - (wrap (:! Type def-value)))) - -(def: #export (defs module-name) - {#;doc "The entire list of definitions in a module (including the unexported/private ones)."} - (-> Text (Lux (List [Text Def]))) - (function [state] - (case (get module-name (get@ #;modules state)) - #;None (#;Left ($_ Text/append "Unknown module: " module-name)) - (#;Some module) (#;Right [state (get@ #;defs module)]) - ))) - -(def: #export (exports module-name) - {#;doc "All the exported definitions in a module."} - (-> Text (Lux (List [Text Def]))) - (do Monad<Lux> - [defs (defs module-name)] - (wrap (filter (function [[name [def-type def-anns def-value]]] - (and (export? def-anns) - (not (hidden? def-anns)))) - defs)))) - -(def: #export modules - {#;doc "All the available modules (including the current one)."} - (Lux (List [Text Module])) - (function [state] - (|> state - (get@ #;modules) - [state] - #;Right))) - -(def: #export (tags-of type-name) - {#;doc "All the tags associated with a type definition."} - (-> Ident (Lux (List Ident))) - (do Monad<Lux> - [#let [[module name] type-name] - module (find-module module)] - (case (get name (get@ #;types module)) - (#;Some [tags _]) - (wrap tags) - - _ - (wrap (list))))) - -(def: #export cursor - {#;doc "The cursor of the current expression being analyzed."} - (Lux Cursor) - (function [state] - (#;Right [state (get@ #;cursor state)]))) - -(def: #export expected-type - {#;doc "The expected type of the current expression being analyzed."} - (Lux Type) - (function [state] - (case (get@ #;expected state) - (#;Some type) - (#;Right [state type]) - - #;None - (#;Left "Not expecting any type.")))) - -(def: #export (imported-modules module-name) - {#;doc "All the modules imported by a specified module."} - (-> Text (Lux (List Text))) - (do Monad<Lux> - [(^slots [#;imports]) (find-module module-name)] - (wrap imports))) - -(def: #export (resolve-tag tag) - {#;doc "Given a tag, finds out what is its index, its related tag-list and it's associated type."} - (-> Ident (Lux [Nat (List Ident) Type])) - (do Monad<Lux> - [#let [[module name] tag] - =module (find-module module) - this-module-name current-module-name] - (case (get name (get@ #;tags =module)) - (#;Some [idx tag-list exported? type]) - (if (or exported? - (Text/= this-module-name module)) - (wrap [idx tag-list type]) - (fail ($_ Text/append "Can't access tag: " (Ident/encode tag) " from module " this-module-name))) - - _ - (fail ($_ Text/append "Unknown tag: " (Ident/encode tag)))))) - -(def: #export (tag-lists module) - {#;doc "All the tag-lists defined in a module, with their associated types."} - (-> Text (Lux (List [(List Ident) Type]))) - (do Monad<Lux> - [=module (find-module module) - this-module-name current-module-name] - (wrap (|> (get@ #;types =module) - (list;filter (function [[type-name [tag-list exported? type]]] - (or exported? - (Text/= this-module-name module)))) - (List/map (function [[type-name [tag-list exported? type]]] - [tag-list type])))))) - -(def: #export locals - {#;doc "All the local variables currently in scope, separated in different scopes."} - (Lux (List (List [Text Type]))) - (function [state] - (case (list;inits (get@ #;scopes state)) - #;None - (#;Left "No local environment") - - (#;Some scopes) - (#;Right [state - (List/map (|>. (get@ [#;locals #;mappings]) - (List/map (function [[name [[type cursor] analysis]]] - [name type]))) - scopes)])))) - -(def: #export (un-alias def-name) - {#;doc "Given an aliased definition's name, returns the original definition being referenced."} - (-> Ident (Lux Ident)) - (do Monad<Lux> - [def-name (normalize def-name) - [_ def-anns _] (find-def def-name)] - (case (get-ann (ident-for #;alias) def-anns) - (#;Some (#;IdentA real-def-name)) - (wrap real-def-name) - - _ - (wrap def-name)))) - -(def: #export get-compiler - {#;doc "Obtains the current state of the compiler."} - (Lux Compiler) - (function [compiler] - (#;Right [compiler compiler]))) diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index 281e42fdd..f60bb61b4 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -8,7 +8,7 @@ (coll [list "List/" Monoid<List> Monad<List>]) [product] [number "Nat/" Codec<Text,Nat>]) - [compiler #+ with-gensyms] + [macro #+ with-gensyms] (macro [ast] ["s" syntax #+ syntax: Syntax] (syntax [common])) diff --git a/stdlib/source/lux/concurrency/frp.lux b/stdlib/source/lux/concurrency/frp.lux index a45d01485..e84534bbc 100644 --- a/stdlib/source/lux/concurrency/frp.lux +++ b/stdlib/source/lux/concurrency/frp.lux @@ -7,7 +7,7 @@ [io #- run] (data (coll [list "L/" Monoid<List>]) text/format) - [compiler] + [macro] (macro ["s" syntax #+ syntax: Syntax])) (.. ["&" promise])) diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux index 0d3619925..f6c19eeab 100644 --- a/stdlib/source/lux/concurrency/promise.lux +++ b/stdlib/source/lux/concurrency/promise.lux @@ -9,7 +9,7 @@ (control functor applicative monad) - [compiler] + [macro] (macro ["s" syntax #+ syntax: Syntax]) (concurrency [atom #+ Atom atom]) )) diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux index 8f8fe4828..31ddf804c 100644 --- a/stdlib/source/lux/concurrency/stm.lux +++ b/stdlib/source/lux/concurrency/stm.lux @@ -12,7 +12,7 @@ maybe [number "Nat/" Codec<Text,Nat>] text/format) - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax]) (concurrency [atom #+ Atom atom] diff --git a/stdlib/source/lux/control/cont.lux b/stdlib/source/lux/control/cont.lux index 08f784035..cbce3b70c 100644 --- a/stdlib/source/lux/control/cont.lux +++ b/stdlib/source/lux/control/cont.lux @@ -4,7 +4,7 @@ applicative monad) function - [compiler #+ with-gensyms] + [macro #+ with-gensyms] (macro [ast] [syntax #+ syntax:]))) diff --git a/stdlib/source/lux/control/contract.lux b/stdlib/source/lux/control/contract.lux index 2f347dfa5..d3523d564 100644 --- a/stdlib/source/lux/control/contract.lux +++ b/stdlib/source/lux/control/contract.lux @@ -2,7 +2,7 @@ lux (lux (control monad) (data text/format) - [compiler #+ Monad<Lux>] + [macro #+ Monad<Lux>] (macro [ast] ["s" syntax #+ syntax:]))) @@ -30,7 +30,7 @@ (@post i.even? (i.+ 2 2)))} (do @ - [g!output (compiler;gensym "")] + [g!output (macro;gensym "")] (wrap (list (` (let [(~ g!output) (~ expr)] (exec (assert! (~ (ast;text (format "Post-condition failed: " (%ast test)))) ((~ test) (~ g!output))) diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux index 6c432c47b..fd0973470 100644 --- a/stdlib/source/lux/control/effect.lux +++ b/stdlib/source/lux/control/effect.lux @@ -10,7 +10,6 @@ error [ident "Ident/" Eq<Ident>] [text]) - [compiler] [macro] (macro [ast] ["s" syntax #+ syntax: Syntax] @@ -74,7 +73,7 @@ (|H io;Monad<IO> Handler<EffA,IO> Handler<EffB,IO> Handler<EffC,IO>)))} (do @ - [g!combiner (compiler;gensym "")] + [g!combiner (macro;gensym "")] (wrap (list (` (let [(~ g!combiner) (;;combine-handlers (~ monad))] ($_ (~ g!combiner) (~@ handlers)))))))) @@ -105,7 +104,7 @@ "In this case, 'opA' will be a function (-> Nat Text Bool)." "'fieldA' will be a value provided by a handler.")} (do @ - [g!output (compiler;gensym "g!output") + [g!output (macro;gensym "g!output") #let [op-types (List/map (function [op] (let [g!tag (ast;tag ["" (get@ #name op)]) g!inputs (` [(~@ (get@ #inputs op))]) @@ -174,11 +173,11 @@ "Since a name for the handler was not specified, 'handler:' will generate the name as Handler<EffA,IO>.")} (do @ - [(^@ effect [e-module _]) (compiler;un-alias effect) - g!input (compiler;gensym "g!input") - g!cont (compiler;gensym "g!cont") - g!value (compiler;gensym "value") - g!wrap (compiler;gensym "wrap") + [(^@ effect [e-module _]) (macro;un-alias effect) + g!input (macro;gensym "g!input") + g!cont (macro;gensym "g!cont") + g!value (macro;gensym "value") + g!wrap (macro;gensym "wrap") #let [g!cases (|> defs (List/map (function [def] (let [g!tag (ast;tag [e-module (get@ #common;def-name def)]) @@ -254,7 +253,7 @@ c (lift fieldC)] (wrap ($_ n.+ a b c)))))} (do @ - [g!output (compiler;gensym "")] + [g!output (macro;gensym "")] (wrap (list (` (let [(~ g!functor) (~ functor)] (do (Monad<Free> (~ g!functor)) [(~@ bindings) @@ -317,8 +316,8 @@ (case value (#;Left var) (do @ - [input (compiler;find-type var) - output compiler;expected-type] + [input (macro;find-type var) + output macro;expected-type] (case [input output] (^=> [(#;AppT eff0 _) (#;AppT stackT0 recT0)] [(type;apply-type stackT0 recT0) (#;Some unfoldT0)] @@ -334,10 +333,10 @@ (~ (nest-effect idx (list;size stack) (ast;symbol var)))))))) _ - (compiler;fail (format "Invalid type to lift: " (%type output))))) + (macro;fail (format "Invalid type to lift: " (%type output))))) (#;Right node) (do @ - [g!value (compiler;gensym "")] + [g!value (macro;gensym "")] (wrap (list (` (let [(~ g!value) (~ node)] (;;lift (~ g!value))))))))) diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux index 20d506dc7..26a94a554 100644 --- a/stdlib/source/lux/control/pipe.lux +++ b/stdlib/source/lux/control/pipe.lux @@ -3,7 +3,7 @@ (lux (control monad) (data (coll [list #+ Monad<List> "" Fold<List> "List/" Monad<List>]) maybe) - [compiler #+ with-gensyms Monad<Lux>] + [macro #+ with-gensyms Monad<Lux>] (macro ["s" syntax #+ syntax: Syntax] [ast]) )) @@ -106,7 +106,7 @@ (~> [int-to-nat %n log!]) (i.* 10)))} (do @ - [g!temp (compiler;gensym "")] + [g!temp (macro;gensym "")] (wrap (list (` (let [(~ g!temp) (~ prev)] (exec (|> (~ g!temp) (~@ body)) (~ g!temp)))))))) @@ -120,7 +120,7 @@ [Int/encode])) "Will become: [50 2 \"5\"]")} (do @ - [g!temp (compiler;gensym "")] + [g!temp (macro;gensym "")] (wrap (list (` (let [(~ g!temp) (~ prev)] [(~@ (List/map (function [body] (` (|> (~ g!temp) (~@ body)))) paths))])))))) diff --git a/stdlib/source/lux/control/thunk.lux b/stdlib/source/lux/control/thunk.lux index 03545b8b6..a78f78023 100644 --- a/stdlib/source/lux/control/thunk.lux +++ b/stdlib/source/lux/control/thunk.lux @@ -3,7 +3,7 @@ (lux [io] (control monad) (concurrency ["A" atom]) - [compiler] + [macro] (macro ["s" syntax #+ syntax:]))) (type: #export (Thunk a) @@ -25,7 +25,7 @@ (syntax: #export (freeze expr) (do @ - [g!arg (compiler;gensym "")] + [g!arg (macro;gensym "")] (wrap (list (` (freeze' (function [(~ g!arg)] (~ expr)))))))) (def: #export (thaw thunk) diff --git a/stdlib/source/lux/data/coll/ordered.lux b/stdlib/source/lux/data/coll/ordered.lux index 568a3f1be..5ecf96781 100644 --- a/stdlib/source/lux/data/coll/ordered.lux +++ b/stdlib/source/lux/data/coll/ordered.lux @@ -6,7 +6,7 @@ (data (coll [list "" Monad<List> "L/" Monoid<List> Fold<List>]) ["p" product] ["M" maybe #+ Functor<Maybe>]) - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/data/coll/seq.lux b/stdlib/source/lux/data/coll/seq.lux index 0e28d7f91..e72b9436d 100644 --- a/stdlib/source/lux/data/coll/seq.lux +++ b/stdlib/source/lux/data/coll/seq.lux @@ -9,7 +9,7 @@ (tree ["F" finger])) [number] maybe) - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/data/coll/stream.lux b/stdlib/source/lux/data/coll/stream.lux index b620c5af2..ccfa391b5 100644 --- a/stdlib/source/lux/data/coll/stream.lux +++ b/stdlib/source/lux/data/coll/stream.lux @@ -4,7 +4,7 @@ monad comonad [cont #+ pending Cont]) - [compiler #+ with-gensyms] + [macro #+ with-gensyms] (macro ["s" syntax #+ syntax: Syntax]) (data (coll [list "List/" Monad<List>]) bool))) diff --git a/stdlib/source/lux/data/coll/tree/rose.lux b/stdlib/source/lux/data/coll/tree/rose.lux index dc44510d5..1f377fb70 100644 --- a/stdlib/source/lux/data/coll/tree/rose.lux +++ b/stdlib/source/lux/data/coll/tree/rose.lux @@ -4,7 +4,7 @@ monad eq) (data (coll [list "L/" Monad<List>])) - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/data/coll/tree/zipper.lux b/stdlib/source/lux/data/coll/tree/zipper.lux index d5e2e47c8..fd198a815 100644 --- a/stdlib/source/lux/data/coll/tree/zipper.lux +++ b/stdlib/source/lux/data/coll/tree/zipper.lux @@ -6,7 +6,7 @@ (tree [rose #+ Tree "T/" Functor<Tree>]) [stack #+ Stack]) [maybe "M/" Monad<Maybe>]) - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/data/coll/vector.lux b/stdlib/source/lux/data/coll/vector.lux index efb52e01b..d99a4d77a 100644 --- a/stdlib/source/lux/data/coll/vector.lux +++ b/stdlib/source/lux/data/coll/vector.lux @@ -12,7 +12,7 @@ [bit] [number "Int/" Number<Int>] [product]) - [compiler #+ with-gensyms] + [macro #+ with-gensyms] (macro [ast] ["s" syntax #+ syntax: Syntax]) )) diff --git a/stdlib/source/lux/data/error/exception.lux b/stdlib/source/lux/data/error/exception.lux index 4e18836d7..94cdf4dd5 100644 --- a/stdlib/source/lux/data/error/exception.lux +++ b/stdlib/source/lux/data/error/exception.lux @@ -3,7 +3,7 @@ (lux (control monad) (data [error #- fail] [text]) - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax] (syntax [common])))) @@ -60,7 +60,7 @@ "It moslty just serves as a way to tag error messages for later catching." (exception: #export Some-Exception))} (do @ - [current-module compiler;current-module-name + [current-module macro;current-module-name #let [g!message (ast;symbol ["" "message"])]] (wrap (list (` (def: (~@ (common;gen-export-level _ex-lev)) ((~ (ast;symbol ["" name])) (~ g!message)) Exception diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 91bd9c2fd..f6bbe08b3 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -20,7 +20,7 @@ (coll [list "" Fold<List> "List/" Monad<List>] [vector #+ Vector vector "Vector/" Monad<Vector>] [dict #+ Dict])) - [compiler #+ Monad<Lux> with-gensyms] + [macro #+ Monad<Lux> with-gensyms] (macro [syntax #+ syntax:] [ast] [poly #+ poly:]) @@ -97,7 +97,7 @@ (wrap (` [(~ (ast;text key-name)) (~ (wrapper value))])) _ - (compiler;fail "Wrong syntax for JSON object."))) + (macro;fail "Wrong syntax for JSON object."))) pairs)] (wrap (list (` (: JSON (#Object (dict;from-list text;Hash<Text> (list (~@ pairs'))))))))) @@ -782,7 +782,7 @@ [Real poly;real ;;gen-number] [Char poly;char (|>. char;as-text ;;gen-string)] [Text poly;text ;;gen-string])] - ($_ compiler;either + ($_ macro;either <basic> (with-gensyms [g!type-fun g!case g!input g!key g!val] (do @ @@ -794,7 +794,7 @@ (wrap :val:)) _ - (compiler;fail "")) + (macro;fail "")) #let [new-*env* (poly;extend-env [:x: g!type-fun] (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) @@ -891,7 +891,7 @@ pattern-matching (mapM @ (function [:member:] (do @ - [g!member (compiler;gensym "g!member") + [g!member (macro;gensym "g!member") encoder (Codec<JSON,?>//encode new-*env* :member:)] (wrap [g!member encoder]))) members) @@ -918,7 +918,7 @@ (wrap (` (: (~ (->Codec//encode (type;to-ast :x:))) ((~ .func.) (~@ .args.)))))) (poly;bound *env* :x:) - (compiler;fail (format "Can't create JSON encoder for: " (%type :x:))) + (macro;fail (format "Can't create JSON encoder for: " (%type :x:))) )))) (poly: #hidden (Codec<JSON,?>//decode *env* :x:) @@ -942,7 +942,7 @@ [Maybe poly;maybe ;;nullable] [List poly;list ;;array])] - ($_ compiler;either + ($_ macro;either <basic> (with-gensyms [g!type-fun g!case g!input g!key g!val] (do @ @@ -954,7 +954,7 @@ (wrap :val:)) _ - (compiler;fail "")) + (macro;fail "")) #let [new-*env* (poly;extend-env [:x: g!type-fun] (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) *env*)] @@ -1056,7 +1056,7 @@ pattern-matching (mapM @ (function [:member:] (do @ - [g!member (compiler;gensym "g!member") + [g!member (macro;gensym "g!member") decoder (Codec<JSON,?>//decode new-*env* :member:)] (wrap [g!member decoder]))) members) @@ -1086,7 +1086,7 @@ (do @ [g!bound (poly;bound *env* :x:)] (wrap g!bound)) - (compiler;fail (format "Can't create JSON decoder for: " (%type :x:))) + (macro;fail (format "Can't create JSON decoder for: " (%type :x:))) )))) (syntax: #export (Codec<JSON,?> :x:) diff --git a/stdlib/source/lux/data/number/complex.lux b/stdlib/source/lux/data/number/complex.lux index 86fb73515..8b7b21400 100644 --- a/stdlib/source/lux/data/number/complex.lux +++ b/stdlib/source/lux/data/number/complex.lux @@ -11,7 +11,7 @@ error maybe (coll [list "List/" Monad<List>])) - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/data/number/ratio.lux b/stdlib/source/lux/data/number/ratio.lux index 52fa2c2a9..40b909c80 100644 --- a/stdlib/source/lux/data/number/ratio.lux +++ b/stdlib/source/lux/data/number/ratio.lux @@ -11,7 +11,7 @@ text/format error [product]) - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 575448be2..1793ed977 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -8,7 +8,7 @@ [ident] (coll [list "" Monad<List>])) [type] - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux index c1075af34..b7101a48a 100644 --- a/stdlib/source/lux/data/text/regex.lux +++ b/stdlib/source/lux/data/text/regex.lux @@ -8,7 +8,7 @@ [number "Int/" Codec<Text,Int>] [product] (coll [list "" Fold<List> "List/" Monad<List>])) - [compiler #- run] + [macro #- run] (macro [ast] ["s" syntax #+ syntax:]))) @@ -475,12 +475,12 @@ (regex "a(.)(.)|b(.)(.)") )} (do @ - [current-module compiler;current-module-name] + [current-module macro;current-module-name] (case (|> (regex^ current-module) (&;before &;end) (&;run pattern)) (#;Left error) - (compiler;fail error) + (macro;fail error) (#;Right regex) (wrap (list regex)) @@ -501,7 +501,7 @@ _ do-something-else))} (do @ - [g!temp (compiler;gensym "temp")] + [g!temp (macro;gensym "temp")] (wrap (list& (` (^=> (~ g!temp) [(&;run (~ g!temp) (regex (~ (ast;text pattern)))) (#;Right (~ (default g!temp diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux index 0d8d182a7..c1bb5f1f8 100644 --- a/stdlib/source/lux/host.js.lux +++ b/stdlib/source/lux/host.js.lux @@ -2,7 +2,7 @@ lux (lux (control monad) (data (coll [list #* "L/" Fold<List>])) - [compiler #+ with-gensyms] + [macro #+ with-gensyms] (macro [ast] ["s" syntax #+ syntax: Syntax]) )) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index 84edbd1ed..0c648c037 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -11,7 +11,7 @@ [text "Text/" Eq<Text> Monoid<Text>] text/format [bool "Bool/" Codec<Text,Bool>]) - [compiler #+ with-gensyms Functor<Lux> Monad<Lux>] + [macro #+ with-gensyms Functor<Lux> Monad<Lux>] (macro [ast] ["s" syntax #+ syntax: Syntax]) [type] @@ -367,21 +367,21 @@ (def: (class-imports compiler) (-> Compiler ClassImports) - (case (compiler;run compiler - (: (Lux ClassImports) - (do Monad<Lux> - [current-module compiler;current-module-name - defs (compiler;defs current-module)] - (wrap (fold (: (-> [Text Def] ClassImports ClassImports) - (function [[short-name [_ meta _]] imports] - (case (compiler;get-text-ann (ident-for #;;jvm-class) meta) - (#;Some full-class-name) - (add-import [short-name full-class-name] imports) - - _ - imports))) - empty-imports - defs))))) + (case (macro;run compiler + (: (Lux ClassImports) + (do Monad<Lux> + [current-module macro;current-module-name + defs (macro;defs current-module)] + (wrap (fold (: (-> [Text Def] ClassImports ClassImports) + (function [[short-name [_ meta _]] imports] + (case (macro;get-text-ann (ident-for #;;jvm-class) meta) + (#;Some full-class-name) + (add-import [short-name full-class-name] imports) + + _ + imports))) + empty-imports + defs))))) (#;Left _) (list) (#;Right imports) imports)) @@ -1328,7 +1328,7 @@ sleepers-count (java.util.List.size [] sleepers)] (map (function [idx] (let [sleeper (java.util.List.get [(l2i idx)] sleepers)] - (Executor.execute [(@runnable (lux.Function.apply [(:! Object value)] sleeper))] + (Executor.execute [(runnable (lux.Function.apply [(:! Object value)] sleeper))] executor))) (i.range 0 (i.dec (i2l sleepers-count))))) (:= .waitingList (null)) @@ -1359,7 +1359,7 @@ "(.resolve! container [value]) for calling the \"resolve\" method." )} (do Monad<Lux> - [current-module compiler;current-module-name + [current-module macro;current-module-name #let [fully-qualified-class-name (format (text;replace-all "/" "." current-module) "." full-class-name) field-parsers (map (field->parser fully-qualified-class-name) fields) method-parsers (map (method->parser (product;right class-decl) fully-qualified-class-name) methods) @@ -1489,7 +1489,7 @@ #;None (do @ - [g!obj (compiler;gensym "obj")] + [g!obj (macro;gensym "obj")] (wrap (list (` (: (-> (host (~' java.lang.Object)) Bool) (function [(~ g!obj)] (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ g!obj)]))))))) @@ -1609,7 +1609,7 @@ (:: Monad<Lux> wrap (class->type mode type-params (get@ #import-method-return method))) _ - (compiler;fail "Only methods have return values."))) + (macro;fail "Only methods have return values."))) (def: (decorate-return-maybe member [return-type return-term]) (-> ImportMemberDecl [AST AST] [AST AST]) @@ -1912,7 +1912,7 @@ #Class)) (#;Left _) - (compiler;fail (format "Unknown class: " class-name)))) + (macro;fail (format "Unknown class: " class-name)))) (syntax: #export (jvm-import [#let [imports (class-imports *compiler*)]] [long-name? (s;this? (' #long))] @@ -2007,7 +2007,7 @@ (#;AppT F A) (case (type;apply-type F A) #;None - (compiler;fail (format "Can't apply type: " (type;to-text F) " to " (type;to-text A))) + (macro;fail (format "Can't apply type: " (type;to-text F) " to " (type;to-text A))) (#;Some type') (type->class-name type')) @@ -2019,7 +2019,7 @@ (:: Monad<Lux> wrap "java.lang.Object") (^or #;VoidT (#;VarT _) (#;ExT _) (#;BoundT _) (#;SumT _) (#;ProdT _) (#;FunctionT _) (#;UnivQ _) (#;ExQ _)) - (compiler;fail (format "Can't convert to JvmType: " (type;to-text type))) + (macro;fail (format "Can't convert to JvmType: " (type;to-text type))) )) (syntax: #export (array-load idx array) @@ -2028,7 +2028,7 @@ (case array [_ (#;SymbolS array-name)] (do Monad<Lux> - [array-type (compiler;find-type array-name) + [array-type (macro;find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type (^template [<type> <array-op>] @@ -2057,7 +2057,7 @@ (case array [_ (#;SymbolS array-name)] (do Monad<Lux> - [array-type (compiler;find-type array-name) + [array-type (macro;find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type (^template [<type> <array-op>] @@ -2142,4 +2142,4 @@ (wrap fqcn) #;None - (compiler;fail (Text/append "Unknown class: " class))))) + (macro;fail (Text/append "Unknown class: " class))))) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index 2a4f5b3c1..e012e2aa0 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -1,32 +1,643 @@ -(;module: +(;module: {#;doc "Functions for extracting information from the state of the compiler."} lux - (lux (control monad) - (data (coll [list "List/" Monad<List>]) - text/format) - [compiler] - (macro ["s" syntax #+ syntax: Syntax]))) - -(def: omit^ - (Syntax Bool) - (s;this? (' #omit))) - -(do-template [<macro> <func>] - [(syntax: #export (<macro> [? omit^] token) + (lux (macro [ast]) + (control functor + applicative + monad) + (data (coll [list #* "List/" Monoid<List> Monad<List>]) + [number] + [text "Text/" Monoid<Text> Eq<Text>] + [product] + [ident "Ident/" Codec<Text,Ident>] + maybe + [error #- fail]))) + +## (type: (Lux a) +## (-> Compiler (Error [Compiler a]))) + +(struct: #export _ (Functor Lux) + (def: (map f fa) + (function [state] + (case (fa state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' a]) + (#;Right [state' (f a)]))))) + +(struct: #export _ (Applicative Lux) + (def: functor Functor<Lux>) + + (def: (wrap x) + (function [state] + (#;Right [state x]))) + + (def: (apply ff fa) + (function [state] + (case (ff state) + (#;Right [state' f]) + (case (fa state') + (#;Right [state'' a]) + (#;Right [state'' (f a)]) + + (#;Left msg) + (#;Left msg)) + + (#;Left msg) + (#;Left msg))))) + +(struct: #export _ (Monad Lux) + (def: applicative Applicative<Lux>) + + (def: (join mma) + (function [state] + (case (mma state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' ma]) + (ma state'))))) + +(def: (get k plist) + (All [a] + (-> Text (List [Text a]) (Maybe a))) + (case plist + #;Nil + #;None + + (#;Cons [k' v] plist') + (if (Text/= k k') + (#;Some v) + (get k plist')))) + +(def: #export (run' compiler action) + (All [a] (-> Compiler (Lux a) (Error [Compiler a]))) + (action compiler)) + +(def: #export (run compiler action) + (All [a] (-> Compiler (Lux a) (Error a))) + (case (action compiler) + (#;Left error) + (#;Left error) + + (#;Right [_ output]) + (#;Right output))) + +(def: #export (either left right) + {#;doc "Pick whichever computation succeeds."} + (All [a] (-> (Lux a) (Lux a) (Lux a))) + (function [compiler] + (case (left compiler) + (#;Left error) + (right compiler) + + (#;Right [compiler' output]) + (#;Right [compiler' output])))) + +(def: #export (assert message test) + {#;doc "Fails with the given message if the test is false."} + (-> Text Bool (Lux Unit)) + (function [compiler] + (if test + (#;Right [compiler []]) + (#;Left message)))) + +(def: #export (fail msg) + {#;doc "Fails with the given message."} + (All [a] + (-> Text (Lux a))) + (function [_] + (#;Left msg))) + +(def: #export (find-module name) + (-> Text (Lux Module)) + (function [state] + (case (get name (get@ #;modules state)) + (#;Some module) + (#;Right [state module]) + + _ + (#;Left ($_ Text/append "Unknown module: " name))))) + +(def: #export current-module-name + (Lux Text) + (function [state] + (case (list;last (get@ #;scopes state)) + (#;Some scope) + (case (get@ #;name scope) + (#;Cons m-name #;Nil) + (#;Right [state m-name]) + + _ + (#;Left "Improper name for scope.")) + + _ + (#;Left "Empty environment!") + ))) + +(def: #export current-module + (Lux Module) + (do Monad<Lux> + [this-module-name current-module-name] + (find-module this-module-name))) + +(def: #export (get-ann tag anns) + {#;doc "Looks-up a particular annotation's value within the set of annotations."} + (-> Ident Anns (Maybe Ann-Value)) + (let [[p n] tag] + (case anns + (#;Cons [[p' n'] dmv] anns') + (if (and (Text/= p p') + (Text/= n n')) + (#;Some dmv) + (get-ann tag anns')) + + #;Nil + #;None))) + +(do-template [<name> <tag> <type>] + [(def: #export (<name> tag anns) + (-> Ident Anns (Maybe <type>)) + (case (get-ann tag anns) + (#;Some (<tag> value)) + (#;Some value) + + _ + #;None))] + + [get-bool-ann #;BoolA Bool] + [get-int-ann #;IntA Int] + [get-real-ann #;RealA Real] + [get-char-ann #;CharA Char] + [get-text-ann #;TextA Text] + [get-ident-ann #;IdentA Ident] + [get-list-ann #;ListA (List Ann-Value)] + [get-dict-ann #;DictA (List [Text Ann-Value])] + ) + +(def: #export (get-doc anns) + {#;doc "Looks-up a definition's documentation."} + (-> Anns (Maybe Text)) + (get-text-ann ["lux" "doc"] anns)) + +(def: #export (flag-set? flag-name anns) + {#;doc "Finds out whether an annotation-as-a-flag is set (has value 'true')."} + (-> Ident Anns Bool) + (case (get-ann flag-name anns) + (#;Some (#;BoolA true)) + true + + _ + false)) + +(do-template [<name> <tag> <desc>] + [(def: #export <name> + {#;doc (#;TextA ($_ Text/append "Checks whether a definition is " <desc> "."))} + (-> Anns Bool) + (flag-set? (ident-for <tag>)))] + + [export? #;export? "exported"] + [hidden? #;hidden? "hidden"] + [macro? #;macro? "a macro"] + [type? #;type? "a type"] + [struct? #;struct? "a structure"] + [type-rec? #;type-rec? "a recursive type"] + [sig? #;sig? "a signature"] + ) + +(do-template [<name> <tag> <type>] + [(def: (<name> dmv) + (-> Ann-Value (Maybe <type>)) + (case dmv + (<tag> actual-value) + (#;Some actual-value) + + _ + #;None))] + + [try-mlist #;ListA (List Ann-Value)] + [try-mtext #;TextA Text] + ) + +(do-template [<name> <tag> <desc>] + [(def: #export (<name> anns) + {#;doc (#;TextA ($_ Text/append "Looks up the arguments of a " <desc> "."))} + (-> Anns (List Text)) + (default (list) + (do Monad<Maybe> + [_args (get-ann (ident-for <tag>) anns) + args (try-mlist _args)] + (mapM @ try-mtext args))))] + + [func-args #;func-args "function"] + [type-args #;type-args "parameterized type"] + ) + +(def: (find-macro' modules this-module module name) + (-> (List [Text Module]) Text Text Text + (Maybe Macro)) + (do Monad<Maybe> + [$module (get module modules) + [def-type def-anns def-value] (: (Maybe Def) (|> (: Module $module) (get@ #;defs) (get name)))] + (if (and (macro? def-anns) + (or (export? def-anns) (Text/= module this-module))) + (#;Some (:! Macro def-value)) + (case (get-ann ["lux" "alias"] def-anns) + (#;Some (#;IdentA [r-module r-name])) + (find-macro' modules this-module r-module r-name) + + _ + #;None)))) + +(def: #export (find-macro ident) + (-> Ident (Lux (Maybe Macro))) + (do Monad<Lux> + [this-module current-module-name] + (let [[module name] ident] + (: (Lux (Maybe Macro)) + (function [state] + (#;Right [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. + + Otherwise, returns the identifier as-is."} + (-> Ident (Lux Ident)) + (case ident + ["" name] + (do Monad<Lux> + [module-name current-module-name] + (wrap [module-name name])) + + _ + (:: Monad<Lux> wrap ident))) + +(def: #export (macro-expand-once syntax) + {#;doc "Given code that requires applying a macro, does it once and returns the result. + + Otherwise, returns the code as-is."} + (-> AST (Lux (List AST))) + (case syntax + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] + (do Monad<Lux> + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (macro args) + + #;None + (:: Monad<Lux> wrap (list syntax)))) + + _ + (:: Monad<Lux> wrap (list syntax)))) + +(def: #export (macro-expand syntax) + {#;doc "Given code that requires applying a macro, expands repeatedly until no more direct macro-calls are left. + + Otherwise, returns the code as-is."} + (-> AST (Lux (List AST))) + (case syntax + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] + (do Monad<Lux> + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Monad<Lux> + [expansion (macro args) + expansion' (mapM Monad<Lux> macro-expand expansion)] + (wrap (:: Monad<List> join expansion'))) + + #;None + (:: Monad<Lux> wrap (list syntax)))) + + _ + (:: Monad<Lux> wrap (list syntax)))) + +(def: #export (macro-expand-all syntax) + {#;doc "Expands all macro-calls everywhere recursively, until only primitive/base code remains."} + (-> AST (Lux (List AST))) + (case syntax + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] + (do Monad<Lux> + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Monad<Lux> + [expansion (macro args) + expansion' (mapM Monad<Lux> macro-expand-all expansion)] + (wrap (:: Monad<List> join expansion'))) + + #;None + (do Monad<Lux> + [parts' (mapM Monad<Lux> macro-expand-all (list& (ast;symbol macro-name) args))] + (wrap (list (ast;form (:: Monad<List> join parts'))))))) + + [_ (#;FormS (#;Cons [harg targs]))] + (do Monad<Lux> + [harg+ (macro-expand-all harg) + targs+ (mapM Monad<Lux> macro-expand-all targs)] + (wrap (list (ast;form (List/append harg+ (:: Monad<List> join (: (List (List AST)) targs+))))))) + + [_ (#;TupleS members)] + (do Monad<Lux> + [members' (mapM Monad<Lux> macro-expand-all members)] + (wrap (list (ast;tuple (:: Monad<List> join members'))))) + + _ + (:: Monad<Lux> wrap (list syntax)))) + +(def: #export (gensym prefix) + {#;doc "Generates a unique identifier as an AST node (ready to be used in code templates). + + A prefix can be given (or just be empty text \"\") to better identify the code for debugging purposes."} + (-> Text (Lux AST)) + (function [state] + (#;Right [(update@ #;seed n.inc state) + (ast;symbol ["" ($_ Text/append "__gensym__" prefix (:: number;Codec<Text,Nat> encode (get@ #;seed state)))])]))) + +(def: (get-local-symbol ast) + (-> AST (Lux Text)) + (case ast + [_ (#;SymbolS [_ name])] + (:: Monad<Lux> wrap name) + + _ + (fail (Text/append "AST is not a local symbol: " (ast;to-text ast))))) + +(macro: #export (with-gensyms tokens) + {#;doc (doc "Creates new symbols and offers them to the body expression." + (syntax: #export (synchronized lock body) + (with-gensyms [g!lock g!body g!_] + (wrap (list (` (let [(~ g!lock) (~ lock) + (~ g!_) (;_jvm_monitorenter (~ g!lock)) + (~ g!body) (~ body) + (~ g!_) (;_jvm_monitorexit (~ g!lock))] + (~ g!body))))) + )))} + (case tokens + (^ (list [_ (#;TupleS symbols)] body)) + (do Monad<Lux> + [symbol-names (mapM @ get-local-symbol symbols) + #let [symbol-defs (List/join (List/map (: (-> Text (List AST)) + (function [name] (list (ast;symbol ["" name]) (` (gensym (~ (ast;text name))))))) + symbol-names))]] + (wrap (list (` (do Monad<Lux> + [(~@ symbol-defs)] + (~ body)))))) + + _ + (fail "Wrong syntax for with-gensyms"))) + +(def: #export (macro-expand-1 token) + {#;doc "Works just like macro-expand, except that it ensures that the output is a single AST token."} + (-> AST (Lux AST)) + (do Monad<Lux> + [token+ (macro-expand token)] + (case token+ + (^ (list token')) + (wrap token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(def: #export (module-exists? module) + (-> Text (Lux Bool)) + (function [state] + (#;Right [state (case (get module (get@ #;modules state)) + (#;Some _) + true + + #;None + false)]))) + +(def: (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def: #export (find-var-type name) + {#;doc "Looks-up the type of a local variable somewhere in the environment."} + (-> Text (Lux Type)) + (function [state] + (let [test (: (-> [Text Analysis] Bool) + (|>. product;left (Text/= name)))] + (case (do Monad<Maybe> + [scope (find (function [env] + (or (any? test (get@ [#;locals #;mappings] env)) + (any? test (get@ [#;closure #;mappings] env)))) + (get@ #;scopes state)) + [_ [[type _] _]] (try-both (find test) + (get@ [#;locals #;mappings] scope) + (get@ [#;closure #;mappings] scope))] + (wrap type)) + (#;Some var-type) + (#;Right [state var-type]) + + #;None + (#;Left ($_ Text/append "Unknown variable: " name)))))) + +(def: #export (find-def name) + {#;doc "Looks-up a definition's whole data in the available modules (including the current one)."} + (-> Ident (Lux Def)) + (function [state] + (case (: (Maybe Def) + (do Monad<Maybe> + [#let [[v-prefix v-name] name] + (^slots [#;defs]) (get v-prefix (get@ #;modules state))] + (get v-name defs))) + (#;Some _anns) + (#;Right [state _anns]) + + _ + (#;Left ($_ Text/append "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)."} + (-> Ident (Lux Type)) + (do Monad<Lux> + [[def-type def-data def-value] (find-def name)] + (wrap def-type))) + +(def: #export (find-type name) + {#;doc "Looks-up the type of either a local variable or a definition."} + (-> Ident (Lux Type)) + (do Monad<Lux> + [#let [[_ _name] name]] + (either (find-var-type _name) + (do @ + [name (normalize name)] + (find-def-type name))))) + +(def: #export (find-type-def name) + {#;doc "Finds the value of a type definition (such as Int, Top or Compiler)."} + (-> Ident (Lux Type)) + (do Monad<Lux> + [[def-type def-data def-value] (find-def name)] + (wrap (:! Type def-value)))) + +(def: #export (defs module-name) + {#;doc "The entire list of definitions in a module (including the unexported/private ones)."} + (-> Text (Lux (List [Text Def]))) + (function [state] + (case (get module-name (get@ #;modules state)) + #;None (#;Left ($_ Text/append "Unknown module: " module-name)) + (#;Some module) (#;Right [state (get@ #;defs module)]) + ))) + +(def: #export (exports module-name) + {#;doc "All the exported definitions in a module."} + (-> Text (Lux (List [Text Def]))) + (do Monad<Lux> + [defs (defs module-name)] + (wrap (filter (function [[name [def-type def-anns def-value]]] + (and (export? def-anns) + (not (hidden? def-anns)))) + defs)))) + +(def: #export modules + {#;doc "All the available modules (including the current one)."} + (Lux (List [Text Module])) + (function [state] + (|> state + (get@ #;modules) + [state] + #;Right))) + +(def: #export (tags-of type-name) + {#;doc "All the tags associated with a type definition."} + (-> Ident (Lux (List Ident))) + (do Monad<Lux> + [#let [[module name] type-name] + module (find-module module)] + (case (get name (get@ #;types module)) + (#;Some [tags _]) + (wrap tags) + + _ + (wrap (list))))) + +(def: #export cursor + {#;doc "The cursor of the current expression being analyzed."} + (Lux Cursor) + (function [state] + (#;Right [state (get@ #;cursor state)]))) + +(def: #export expected-type + {#;doc "The expected type of the current expression being analyzed."} + (Lux Type) + (function [state] + (case (get@ #;expected state) + (#;Some type) + (#;Right [state type]) + + #;None + (#;Left "Not expecting any type.")))) + +(def: #export (imported-modules module-name) + {#;doc "All the modules imported by a specified module."} + (-> Text (Lux (List Text))) + (do Monad<Lux> + [(^slots [#;imports]) (find-module module-name)] + (wrap imports))) + +(def: #export (resolve-tag tag) + {#;doc "Given a tag, finds out what is its index, its related tag-list and it's associated type."} + (-> Ident (Lux [Nat (List Ident) Type])) + (do Monad<Lux> + [#let [[module name] tag] + =module (find-module module) + this-module-name current-module-name] + (case (get name (get@ #;tags =module)) + (#;Some [idx tag-list exported? type]) + (if (or exported? + (Text/= this-module-name module)) + (wrap [idx tag-list type]) + (fail ($_ Text/append "Can't access tag: " (Ident/encode tag) " from module " this-module-name))) + + _ + (fail ($_ Text/append "Unknown tag: " (Ident/encode tag)))))) + +(def: #export (tag-lists module) + {#;doc "All the tag-lists defined in a module, with their associated types."} + (-> Text (Lux (List [(List Ident) Type]))) + (do Monad<Lux> + [=module (find-module module) + this-module-name current-module-name] + (wrap (|> (get@ #;types =module) + (list;filter (function [[type-name [tag-list exported? type]]] + (or exported? + (Text/= this-module-name module)))) + (List/map (function [[type-name [tag-list exported? type]]] + [tag-list type])))))) + +(def: #export locals + {#;doc "All the local variables currently in scope, separated in different scopes."} + (Lux (List (List [Text Type]))) + (function [state] + (case (list;inits (get@ #;scopes state)) + #;None + (#;Left "No local environment") + + (#;Some scopes) + (#;Right [state + (List/map (|>. (get@ [#;locals #;mappings]) + (List/map (function [[name [[type cursor] analysis]]] + [name type]))) + scopes)])))) + +(def: #export (un-alias def-name) + {#;doc "Given an aliased definition's name, returns the original definition being referenced."} + (-> Ident (Lux Ident)) + (do Monad<Lux> + [def-name (normalize def-name) + [_ def-anns _] (find-def def-name)] + (case (get-ann (ident-for #;alias) def-anns) + (#;Some (#;IdentA real-def-name)) + (wrap real-def-name) + + _ + (wrap def-name)))) + +(def: #export get-compiler + {#;doc "Obtains the current state of the compiler."} + (Lux Compiler) + (function [compiler] + (#;Right [compiler compiler]))) + +(do-template [<macro> <func> <desc>] + [(macro: #export (<macro> tokens) {#;doc (doc "Performs a macro-expansion and logs the resulting ASTs." "You can either use the resulting ASTs, or omit them." "By omitting them, this macro produces nothing (just like the lux;comment macro)." - (<macro> (def: (foo bar baz) + (<macro> #omit + (def: (foo bar baz) (-> Int Int Int) (i.+ bar baz))))} - (do @ - [output (<func> token) - #let [_ (List/map (. log! %ast) - output)]] - (if ? - (wrap (list)) - (wrap output))))] - - [expand compiler;macro-expand] - [expand-all compiler;macro-expand-all] - [expand-once compiler;macro-expand-once] + (case tokens + (^ (list [_ (#;TagS ["" "omit"])] + token)) + (do Monad<Lux> + [output (<func> token) + #let [_ (List/map (. log! ast;to-text) + output)]] + (wrap (list))) + + (^ (list token)) + (do Monad<Lux> + [output (<func> token) + #let [_ (List/map (. log! ast;to-text) + output)]] + (wrap output)) + + _ + (fail ($_ Text/append "Wrong syntax for " <desc> "."))))] + + [log-expand macro-expand "log-macro-expand"] + [log-expand-all macro-expand-all "log-macro-expand-all"] + [log-expand-once macro-expand-once "log-macro-expand-once"] ) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index ad966c153..8fed3fb4c 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -11,7 +11,7 @@ [bool] [char] [maybe]) - [compiler #+ Monad<Lux> with-gensyms] + [macro #+ Monad<Lux> with-gensyms] (macro [ast] ["s" syntax #+ syntax: Syntax] (syntax [common])) @@ -31,10 +31,10 @@ (;function [:type:] (case (type;un-name :type:) <type> - (:: compiler;Monad<Lux> wrap []) + (:: macro;Monad<Lux> wrap []) _ - (compiler;fail (format "Not " <name> " type: " (%type :type:))))))] + (macro;fail (format "Not " <name> " type: " (%type :type:))))))] [void "Void" #;VoidT] [unit "Unit" #;UnitT] @@ -46,10 +46,10 @@ (;function [:type:] (case (type;un-alias :type:) (#;NamedT ["lux" <name>] _) - (:: compiler;Monad<Lux> wrap []) + (:: macro;Monad<Lux> wrap []) _ - (compiler;fail (format "Not " <name> " type: " (%type :type:))))))] + (macro;fail (format "Not " <name> " type: " (%type :type:))))))] [bool "Bool"] [nat "Nat"] @@ -77,7 +77,7 @@ [real Real] [char Char] [text Text])] - ($_ compiler;either + ($_ macro;either <primitives>)))) (syntax: ($AST$ ast) @@ -89,18 +89,18 @@ (;function [:type:] (case (type;un-name :type:) (<tag> :left: :right:) - (:: compiler;Monad<Lux> wrap [:left: :right:]) + (:: macro;Monad<Lux> wrap [:left: :right:]) _ - (compiler;fail (format "Not a " ($AST$ <tag>) " type: " (%type :type:)))))) + (macro;fail (format "Not a " ($AST$ <tag>) " type: " (%type :type:)))))) (def: #export <multi> (Matcher (List Type)) (;function [:type:] (let [members (<flattener> (type;un-name :type:))] (if (n.> +1 (list;size members)) - (:: compiler;Monad<Lux> wrap members) - (compiler;fail (format "Not a " ($AST$ <tag>) " type: " (%type :type:)))))))] + (:: macro;Monad<Lux> wrap members) + (macro;fail (format "Not a " ($AST$ <tag>) " type: " (%type :type:)))))))] [sum sum+ type;flatten-variant #;SumT] [prod prod+ type;flatten-tuple #;ProdT] @@ -111,30 +111,30 @@ (;function [:type:] (case (type;un-name :type:) (#;FunctionT :left: :right:) - (:: compiler;Monad<Lux> wrap [:left: :right:]) + (:: macro;Monad<Lux> wrap [:left: :right:]) _ - (compiler;fail (format "Not a FunctionT type: " (%type :type:)))))) + (macro;fail (format "Not a FunctionT type: " (%type :type:)))))) (def: #export func+ (Matcher [(List Type) Type]) (;function [:type:] (let [[ins out] (type;flatten-function (type;un-name :type:))] (if (n.> +0 (list;size ins)) - (:: compiler;Monad<Lux> wrap [ins out]) - (compiler;fail (format "Not a FunctionT type: " (%type :type:))))))) + (:: macro;Monad<Lux> wrap [ins out]) + (macro;fail (format "Not a FunctionT type: " (%type :type:))))))) (def: #export tagged (Matcher [(List Ident) Type]) (;function [:type:] (case (type;un-alias :type:) (#;NamedT type-name :def:) - (do compiler;Monad<Lux> - [tags (compiler;tags-of type-name)] + (do macro;Monad<Lux> + [tags (macro;tags-of type-name)] (wrap [tags :def:])) _ - (compiler;fail (format "Unnamed types can't have tags: " (%type :type:)))))) + (macro;fail (format "Unnamed types can't have tags: " (%type :type:)))))) (def: #export polymorphic (Matcher [(List AST) Type]) @@ -142,22 +142,22 @@ (loop [:type: (type;un-name :type:)] (case :type: (#;UnivQ _ :type:') - (do compiler;Monad<Lux> + (do macro;Monad<Lux> [[g!tail :type:''] (recur :type:') - g!head (compiler;gensym "type-var")] + g!head (macro;gensym "type-var")] (wrap [(list& g!head g!tail) :type:''])) _ - (:: compiler;Monad<Lux> wrap [(;list) :type:]))))) + (:: macro;Monad<Lux> wrap [(;list) :type:]))))) (do-template [<combinator> <sub-comb> <build>] [(def: #export <combinator> (Matcher [(List AST) (List [Ident Type])]) (;function [:type:] - (do compiler;Monad<Lux> + (do macro;Monad<Lux> [[tags :type:] (tagged :type:) - _ (compiler;assert "Records and variants must have tags." + _ (macro;assert "Records and variants must have tags." (n.> +0 (list;size tags))) [vars :type:] (polymorphic :type:) members (<sub-comb> :type:) @@ -176,7 +176,7 @@ (def: #export tuple (Matcher [(List AST) (List Type)]) (;function [:type:] - (do compiler;Monad<Lux> + (do macro;Monad<Lux> [[vars :type:] (polymorphic :type:) members (prod+ :type:)] (wrap [vars members])))) @@ -184,7 +184,7 @@ (def: #export function (Matcher [(List AST) [(List Type) Type]]) (;function [:type:] - (do compiler;Monad<Lux> + (do macro;Monad<Lux> [[vars :type:] (polymorphic :type:) ins+out (func+ :type:)] (wrap [vars ins+out])))) @@ -192,7 +192,7 @@ (def: #export apply (Matcher [Type (List Type)]) (;function [:type:] - (do compiler;Monad<Lux> + (do macro;Monad<Lux> [#let [[:func: :args:] (loop [:type: (type;un-name :type:)] (case :type: (#;AppT :func: :arg:) @@ -203,7 +203,7 @@ [:type: (;list)]))]] (case :args: #;Nil - (compiler;fail "Not a type application.") + (macro;fail "Not a type application.") _ (wrap [:func: (list;reverse :args:)]))))) @@ -215,10 +215,10 @@ (case (type;un-name :type:) (^=> (#;AppT :quant: :arg:) [(type;un-alias :quant:) (#;NamedT ["lux" <name>] _)]) - (:: compiler;Monad<Lux> wrap :arg:) + (:: macro;Monad<Lux> wrap :arg:) _ - (compiler;fail (format "Not " <name> " type: " (%type :type:))))))] + (macro;fail (format "Not " <name> " type: " (%type :type:))))))] [maybe "Maybe"] [list "List"] @@ -238,13 +238,13 @@ (#;BoundT idx) (case (dict;get (adjusted-idx env idx) env) (#;Some [poly-type poly-ast]) - (:: compiler;Monad<Lux> wrap poly-ast) + (:: macro;Monad<Lux> wrap poly-ast) #;None - (compiler;fail (format "Unknown bound type: " (%type :type:)))) + (macro;fail (format "Unknown bound type: " (%type :type:)))) _ - (compiler;fail (format "Not a bound type: " (%type :type:)))))) + (macro;fail (format "Not a bound type: " (%type :type:)))))) (def: #export (recur env) (-> Env (Matcher AST)) @@ -269,7 +269,7 @@ (wrap call) _ - (compiler;fail (format "Type is not a recursive instance: " (%type :type:)))) + (macro;fail (format "Type is not a recursive instance: " (%type :type:)))) ))) (def: #export (var env var-id) @@ -278,10 +278,10 @@ (case :type: (^=> (#;BoundT idx) (n.= var-id (adjusted-idx env idx))) - (:: compiler;Monad<Lux> wrap []) + (:: macro;Monad<Lux> wrap []) _ - (compiler;fail (format "Not a bound type: " (%type :type:)))))) + (macro;fail (format "Not a bound type: " (%type :type:)))))) ## [Syntax] (def: #export (extend-env [funcT funcA] type-vars env) @@ -312,7 +312,7 @@ (wrap (;list (` (syntax: (~@ (common;gen-export-level _ex-lev)) ((~ g!name) (~@ (List/map (;function [g!input] (` [(~ g!input) s;symbol])) g!inputs))) (do Monad<Lux> - [(~@ (List/join (List/map (;function [g!input] (;list g!input (` (compiler;find-type-def (~ g!input))))) + [(~@ (List/join (List/map (;function [g!input] (;list g!input (` (macro;find-type-def (~ g!input))))) g!inputs))) (~' #let) [(~ g!env) (: Env (dict;new number;Hash<Nat>))] (~ g!body) (: (Lux AST) @@ -338,7 +338,7 @@ [[poly-func poly-args] (s;form (s;seq s;symbol (s;many s;symbol)))] [?custom-impl (s;opt s;any)]) (do @ - [poly-args (mapM @ compiler;normalize poly-args) + [poly-args (mapM @ macro;normalize poly-args) name (case ?name (#;Some name) (wrap name) @@ -349,7 +349,7 @@ (wrap derived-name) _ - (compiler;fail "derived: was given no explicit name, and can't generate one from given information.")) + (macro;fail "derived: was given no explicit name, and can't generate one from given information.")) #let [impl (case ?custom-impl (#;Some custom-impl) custom-impl diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux index 174d8e51e..a72fa85f6 100644 --- a/stdlib/source/lux/macro/poly/eq.lux +++ b/stdlib/source/lux/macro/poly/eq.lux @@ -11,7 +11,7 @@ [bool] [char] [maybe]) - [compiler #+ Monad<Lux> with-gensyms] + [macro #+ Monad<Lux> with-gensyms] (macro [ast] [syntax #+ syntax: Syntax] (syntax [common]) @@ -49,7 +49,7 @@ [Real poly;real number;Eq<Real>] [Char poly;char char;Eq<Char>] [Text poly;text text;Eq<Text>])] - ($_ compiler;either + ($_ macro;either ## Primitive types <basic> ## Variants @@ -83,8 +83,8 @@ pattern-matching (mapM @ (function [:member:] (do @ - [g!left (compiler;gensym "g!left") - g!right (compiler;gensym "g!right") + [g!left (macro;gensym "g!left") + g!right (macro;gensym "g!right") g!eq (Eq<?> new-env :member:)] (wrap [g!left g!right g!eq]))) members) @@ -109,5 +109,5 @@ ## Bound type-vars (poly;bound env :x:) ## If all else fails... - (compiler;fail (format "Can't create Eq for: " (%type :x:))) + (macro;fail (format "Can't create Eq for: " (%type :x:))) )))) diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux index f6961d717..c90766c48 100644 --- a/stdlib/source/lux/macro/poly/functor.lux +++ b/stdlib/source/lux/macro/poly/functor.lux @@ -13,7 +13,7 @@ [maybe] [ident "Ident/" Codec<Text,Ident>] error) - [compiler #+ Monad<Lux> with-gensyms] + [macro #+ Monad<Lux> with-gensyms] (macro [ast] [syntax #+ syntax: Syntax] (syntax [common]) @@ -31,7 +31,7 @@ new-env (poly;extend-env [:x: g!type-fun] (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) env)] - _ (compiler;assert "Functors must have at least 1 type-variable." + _ (macro;assert "Functors must have at least 1 type-variable." (n.> +0 num-vars))] (let [->Functor (: (-> AST AST) (function [.type.] @@ -41,7 +41,7 @@ (` (All [(~@ type-params)] (functor;Functor ((~ .type.) (~@ type-params))))))))) Arg<?> (: (-> AST (poly;Matcher AST)) (function Arg<?> [value :type:] - ($_ compiler;either + ($_ macro;either ## Nothing to do. (do @ [_ (poly;primitive :type:)] @@ -60,7 +60,7 @@ pm (mapM @ (function [:slot:] (do @ - [g!slot (compiler;gensym "g!slot") + [g!slot (macro;gensym "g!slot") body (Arg<?> g!slot :slot:)] (wrap [g!slot body]))) members)] @@ -73,7 +73,7 @@ [_ (poly;recur new-env :type:)] (wrap (` ((~ g!map) (~ g!func) (~ value))))) )))] - ($_ compiler;either + ($_ macro;either ## Variants (do @ [[g!vars cases] (poly;variant :x:) @@ -96,7 +96,7 @@ pm (mapM @ (function [:slot:] (do @ - [g!slot (compiler;gensym "g!slot") + [g!slot (macro;gensym "g!slot") body (Arg<?> g!slot :slot:)] (wrap [g!slot body]))) members)] @@ -113,7 +113,7 @@ .out. (Arg<?> g!out :out:) g!envs (seqM @ (list;repeat (list;size :ins:) - (compiler;gensym "g!envs")))] + (macro;gensym "g!envs")))] (wrap (` (: (~ (->Functor (type;to-ast :x:))) (struct (def: ((~ g!map) (~ g!func) (~ g!input)) (function [(~@ g!envs)] @@ -126,6 +126,6 @@ (struct (def: ((~ g!map) (~ g!func) (~ g!input)) ((~ g!func) (~ g!input)))))))) ## Failure... - (compiler;fail (format "Can't create Functor for: " (%type :x:))) + (macro;fail (format "Can't create Functor for: " (%type :x:))) )) ))) diff --git a/stdlib/source/lux/macro/poly/text-encoder.lux b/stdlib/source/lux/macro/poly/text-encoder.lux index 5649622de..b0774ca64 100644 --- a/stdlib/source/lux/macro/poly/text-encoder.lux +++ b/stdlib/source/lux/macro/poly/text-encoder.lux @@ -13,7 +13,7 @@ [maybe] [ident "Ident/" Codec<Text,Ident>] error) - [compiler #+ Monad<Lux> with-gensyms] + [macro #+ Monad<Lux> with-gensyms] (macro [ast] [syntax #+ syntax: Syntax] (syntax [common]) @@ -50,7 +50,7 @@ [Real poly;real (:: number;Codec<Text,Real> encode)] [Char poly;char (:: char;Codec<Text,Char> encode)] [Text poly;text (:: text;Codec<Text,Text> encode)])] - ($_ compiler;either + ($_ macro;either ## Primitives <basic> ## Variants @@ -110,7 +110,7 @@ parts (mapM @ (function [:member:] (do @ - [g!member (compiler;gensym "g!member") + [g!member (macro;gensym "g!member") encoder (Codec<Text,?>::encode new-env :member:)] (wrap [g!member encoder]))) members) @@ -138,5 +138,5 @@ ## Bound type-variables (poly;bound env :x:) ## Failure... - (compiler;fail (format "Can't create Text encoder for: " (%type :x:))) + (macro;fail (format "Can't create Text encoder for: " (%type :x:))) )))) diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index 3d7b4575f..071e5716a 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -1,6 +1,6 @@ (;module: [lux #- not default] - (lux [compiler #+ Monad<Lux> with-gensyms] + (lux [macro #+ Monad<Lux> with-gensyms] (control functor applicative monad @@ -378,7 +378,7 @@ {#;doc "Run a Lux operation as if it was a Syntax parser."} (All [a] (-> Compiler (Lux a) (Syntax a))) (function [input] - (case (compiler;run compiler action) + (case (macro;run compiler action) (#;Left error) (#;Left error) @@ -467,7 +467,7 @@ (wrap [(ast;symbol var-name) (` any)]) _ - (compiler;fail "Syntax pattern expects tuples or symbols.")))) + (macro;fail "Syntax pattern expects tuples or symbols.")))) args) #let [g!state (ast;symbol ["" "*compiler*"]) g!end (ast;symbol ["" ""]) @@ -499,4 +499,4 @@ (#;Left (text.join-with ": " (list (~ error-msg) (~ g!msg)))))))))))) _ - (compiler;fail "Wrong syntax for syntax:")))) + (macro;fail "Wrong syntax for syntax:")))) diff --git a/stdlib/source/lux/macro/syntax/common.lux b/stdlib/source/lux/macro/syntax/common.lux index cbeb1cfcf..a77a2428a 100644 --- a/stdlib/source/lux/macro/syntax/common.lux +++ b/stdlib/source/lux/macro/syntax/common.lux @@ -7,7 +7,7 @@ text/format [ident "Ident/" Eq<Ident>] [product]) - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax]))) @@ -130,7 +130,7 @@ (do s;Monad<Syntax> [def-raw s;any me-def-raw (s;on compiler - (compiler;macro-expand-all def-raw))] + (macro;macro-expand-all def-raw))] (s;local me-def-raw (s;form (do @ [_ (s;this! (' lux;_lux_def)) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index 7ebce4268..4782b365b 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -5,7 +5,7 @@ [number "Int/" Number<Int>] [product] text/format) - [compiler] + [macro] (macro ["s" syntax #+ syntax: Syntax "s/" Functor<Syntax>] [ast]))) diff --git a/stdlib/source/lux/math/simple.lux b/stdlib/source/lux/math/simple.lux index aaffaa967..6a2f2f710 100644 --- a/stdlib/source/lux/math/simple.lux +++ b/stdlib/source/lux/math/simple.lux @@ -4,7 +4,7 @@ (data text/format [product] (coll [list])) - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax]) [type] @@ -20,20 +20,20 @@ (find-type-var id' env) _ - (:: compiler;Monad<Lux> wrap type)) + (:: macro;Monad<Lux> wrap type)) (#;Some [_ #;None]) - (compiler;fail (format "Unbound type-var " (%n id))) + (macro;fail (format "Unbound type-var " (%n id))) #;None - (compiler;fail (format "Unknown type-var " (%n id))) + (macro;fail (format "Unknown type-var " (%n id))) )) (def: (resolve-type var-name) (-> Ident (Lux Type)) - (do compiler;Monad<Lux> - [raw-type (compiler;find-type var-name) - compiler compiler;get-compiler] + (do macro;Monad<Lux> + [raw-type (macro;find-type var-name) + compiler macro;get-compiler] (case raw-type (#;VarT id) (find-type-var id (get@ #;type-vars compiler)) @@ -70,18 +70,18 @@ (check;checks? Deg =x) (wrap (` <deg-op>)) - (compiler;fail (format "No operation for types: " (%type =x))))] + (macro;fail (format "No operation for types: " (%type =x))))] (wrap (list (` ($_ (~ op) (~ (ast;symbol x)) (~@ ys)))))) (+0 [(#;Right x) ys]) (do @ - [g!x (compiler;gensym "g!x")] + [g!x (macro;gensym "g!x")] (wrap (list (` (let [(~ g!x) (~ x)] (<rec> (~ g!x) (~@ ys))))))) (+1 []) (do @ - [=e compiler;expected-type + [=e macro;expected-type op (cond (check;checks? (-> Nat Nat Nat) =e) (wrap (` <nat-op>)) @@ -94,7 +94,7 @@ (check;checks? (-> Deg Deg Deg) =e) (wrap (` <deg-op>)) - (compiler;fail (format "No operation for type: " (%type =e))))] + (macro;fail (format "No operation for type: " (%type =e))))] (wrap (list op))) ))] @@ -134,18 +134,18 @@ (check;checks? Deg =x) (wrap (` <deg-op>)) - (compiler;fail (format "No operation for types: " (%type =x))))] + (macro;fail (format "No operation for types: " (%type =x))))] (wrap (list (` ($_ (~ op) (~ (ast;symbol x)) (~@ ys)))))) (+0 [(#;Right x) ys]) (do @ - [g!x (compiler;gensym "g!x")] + [g!x (macro;gensym "g!x")] (wrap (list (` (let [(~ g!x) (~ x)] (<rec> (~ g!x) (~@ ys))))))) (+1 []) (do @ - [=e compiler;expected-type + [=e macro;expected-type op (cond (check;checks? (-> Nat Nat Bool) =e) (wrap (` <nat-op>)) @@ -158,7 +158,7 @@ (check;checks? (-> Deg Deg Bool) =e) (wrap (` <deg-op>)) - (compiler;fail (format "No operation for type: " (%type =e))))] + (macro;fail (format "No operation for type: " (%type =e))))] (wrap (list op))) ))] @@ -188,25 +188,25 @@ (check;checks? Int =x) (wrap (` <int-op>)) - (compiler;fail (format "No operation for types: " (%type =x))))] + (macro;fail (format "No operation for types: " (%type =x))))] (wrap (list (` ($_ (~ op) (~ (ast;symbol x)) (~@ ys)))))) (+0 [(#;Right x) ys]) (do @ - [g!x (compiler;gensym "g!x")] + [g!x (macro;gensym "g!x")] (wrap (list (` (let [(~ g!x) (~ x)] (<rec> (~ g!x) (~@ ys))))))) (+1 []) (do @ - [=e compiler;expected-type + [=e macro;expected-type op (cond (check;checks? (-> Nat Nat Nat) =e) (wrap (` <nat-op>)) (check;checks? (-> Int Int Int) =e) (wrap (` <int-op>)) - (compiler;fail (format "No operation for type: " (%type =e))))] + (macro;fail (format "No operation for type: " (%type =e))))] (wrap (list op))) ))] @@ -233,25 +233,25 @@ (check;checks? Int =x) (wrap (` <int-op>)) - (compiler;fail (format "No operation for type: " (%type =x))))] + (macro;fail (format "No operation for type: " (%type =x))))] (wrap (list (` ((~ op) (~ (ast;symbol x))))))) (+1 x) (do @ - [g!x (compiler;gensym "g!x")] + [g!x (macro;gensym "g!x")] (wrap (list (` (let [(~ g!x) (~ x)] (<rec> (~ g!x))))))) (+2 []) (do @ - [=e compiler;expected-type + [=e macro;expected-type op (cond (check;checks? (-> Nat Nat) =e) (wrap (` <nat-op>)) (check;checks? (-> Int Int) =e) (wrap (` <int-op>)) - (compiler;fail (format "No operation for type: " (%type =e))))] + (macro;fail (format "No operation for type: " (%type =e))))] (wrap (list op))) ))] @@ -278,25 +278,25 @@ (check;checks? Int =x) (wrap (` <int-op>)) - (compiler;fail (format "No operation for type: " (%type =x))))] + (macro;fail (format "No operation for type: " (%type =x))))] (wrap (list (` ((~ op) (~ (ast;symbol x))))))) (+1 x) (do @ - [g!x (compiler;gensym "g!x")] + [g!x (macro;gensym "g!x")] (wrap (list (` (let [(~ g!x) (~ x)] (<rec> (~ g!x))))))) (+2 []) (do @ - [=e compiler;expected-type + [=e macro;expected-type op (cond (check;checks? (-> Nat Bool) =e) (wrap (` <nat-op>)) (check;checks? (-> Int Bool) =e) (wrap (` <int-op>)) - (compiler;fail (format "No operation for type: " (%type =e))))] + (macro;fail (format "No operation for type: " (%type =e))))] (wrap (list op))) ))] diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index 6465cd632..8d786920c 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -1,6 +1,6 @@ (;module: {#;doc "Tools for unit & property-based/generative testing."} lux - (lux [compiler #+ Monad<Lux> with-gensyms] + (lux [macro #+ Monad<Lux> with-gensyms] (macro ["s" syntax #+ syntax: Syntax] [ast]) (control functor @@ -249,10 +249,10 @@ (def: (exported-tests module-name) (-> Text (Lux (List [Text Text Text]))) (do Monad<Lux> - [defs (compiler;exports module-name)] + [defs (macro;exports module-name)] (wrap (|> defs (List/map (function [[def-name [_ def-anns _]]] - (case (compiler;get-text-ann (ident-for #;;test) def-anns) + (case (macro;get-text-ann (ident-for #;;test) def-anns) (#;Some description) [true module-name def-name description] @@ -269,8 +269,8 @@ (run))} (with-gensyms [g!_ g!accum] (do @ - [current-module compiler;current-module-name - modules (compiler;imported-modules current-module) + [current-module macro;current-module-name + modules (macro;imported-modules current-module) tests (: (Lux (List [Text Text Text])) (|> (#;Cons current-module modules) list;reverse diff --git a/stdlib/source/lux/type/auto.lux b/stdlib/source/lux/type/auto.lux index 0ee373f8e..db19ad0aa 100644 --- a/stdlib/source/lux/type/auto.lux +++ b/stdlib/source/lux/type/auto.lux @@ -9,7 +9,7 @@ [dict]) [bool] [product]) - [compiler #+ Monad<Lux>] + [macro #+ Monad<Lux>] (macro [ast] ["s" syntax #+ syntax: Syntax]) [type] @@ -29,17 +29,17 @@ (:: Monad<Lux> wrap type)) (#;Some [_ #;None]) - (compiler;fail (format "Unbound type-var " (%n id))) + (macro;fail (format "Unbound type-var " (%n id))) #;None - (compiler;fail (format "Unknown type-var " (%n id))) + (macro;fail (format "Unknown type-var " (%n id))) )) (def: (resolve-type var-name) (-> Ident (Lux Type)) (do Monad<Lux> - [raw-type (compiler;find-type var-name) - compiler compiler;get-compiler] + [raw-type (macro;find-type var-name) + compiler macro;get-compiler] (case raw-type (#;VarT id) (find-type-var id (get@ #;type-vars compiler)) @@ -75,26 +75,26 @@ (-> Ident (Lux Ident)) (case member ["" simple-name] - (compiler;either (do Monad<Lux> - [member (compiler;normalize member) - _ (compiler;resolve-tag member)] + (macro;either (do Monad<Lux> + [member (macro;normalize member) + _ (macro;resolve-tag member)] (wrap member)) (do Monad<Lux> - [this-module-name compiler;current-module-name - imp-mods (compiler;imported-modules this-module-name) - tag-lists (mapM @ compiler;tag-lists imp-mods) + [this-module-name macro;current-module-name + imp-mods (macro;imported-modules this-module-name) + tag-lists (mapM @ macro;tag-lists imp-mods) #let [tag-lists (|> tag-lists List/join (List/map product;left) List/join) candidates (list;filter (. (Text/= simple-name) product;right) tag-lists)]] (case candidates #;Nil - (compiler;fail (format "Unknown tag: " (%ident member))) + (macro;fail (format "Unknown tag: " (%ident member))) (#;Cons winner #;Nil) (wrap winner) _ - (compiler;fail (format "Too many candidate tags: " (%list %ident candidates)))))) + (macro;fail (format "Too many candidate tags: " (%list %ident candidates)))))) _ (:: Monad<Lux> wrap member))) @@ -103,21 +103,21 @@ (-> Ident (Lux [Nat Type])) (do Monad<Lux> [member (find-member-name member) - [idx tag-list sig-type] (compiler;resolve-tag member)] + [idx tag-list sig-type] (macro;resolve-tag member)] (wrap [idx sig-type]))) (def: (prepare-defs this-module-name defs) (-> Text (List [Text Def]) (List [Ident Type])) (|> defs (list;filter (function [[name [def-type def-anns def-value]]] - (compiler;struct? def-anns))) + (macro;struct? def-anns))) (List/map (function [[name [def-type def-anns def-value]]] [[this-module-name name] def-type])))) (def: local-env (Lux (List [Ident Type])) (do Monad<Lux> - [local-batches compiler;locals + [local-batches macro;locals #let [total-locals (List/fold (function [[name type] table] (dict;put~ name type table)) (: (dict;Dict Text Type) @@ -130,18 +130,18 @@ (def: local-structs (Lux (List [Ident Type])) (do Monad<Lux> - [this-module-name compiler;current-module-name - defs (compiler;defs this-module-name)] + [this-module-name macro;current-module-name + defs (macro;defs this-module-name)] (wrap (prepare-defs this-module-name defs)))) (def: import-structs (Lux (List [Ident Type])) (do Monad<Lux> - [this-module-name compiler;current-module-name - imp-mods (compiler;imported-modules this-module-name) + [this-module-name macro;current-module-name + imp-mods (macro;imported-modules this-module-name) export-batches (mapM @ (function [imp-mod] (do @ - [exports (compiler;exports imp-mod)] + [exports (macro;exports imp-mod)] (wrap (prepare-defs imp-mod exports)))) imp-mods)] (wrap (List/join export-batches)))) @@ -209,7 +209,7 @@ tc;Context Type (List [Ident Type]) (Lux (List Instance))) (do Monad<Lux> - [compiler compiler;get-compiler] + [compiler macro;get-compiler] (case (|> alts (List/map (function [[alt-name alt-type]] (case (tc;run context @@ -227,15 +227,15 @@ (list [alt-name =deps])))) List/join) #;Nil - (compiler;fail (format "No candidates for provisioning: " (%type dep))) + (macro;fail (format "No candidates for provisioning: " (%type dep))) found (wrap found)))) (def: (provision compiler context dep) (-> Compiler tc;Context Type (Check Instance)) - (case (compiler;run compiler - ($_ compiler;either + (case (macro;run compiler + ($_ macro;either (do Monad<Lux> [alts local-env] (test-provision provision context dep alts)) (do Monad<Lux> [alts local-structs] (test-provision provision context dep alts)) (do Monad<Lux> [alts import-structs] (test-provision provision context dep alts)))) @@ -257,7 +257,7 @@ (def: (test-alternatives sig-type member-idx input-types output-type alts) (-> Type Nat (List Type) Type (List [Ident Type]) (Lux (List Instance))) (do Monad<Lux> - [compiler compiler;get-compiler + [compiler macro;get-compiler context compiler-type-context] (case (|> alts (List/map (function [[alt-name alt-type]] @@ -278,7 +278,7 @@ (list [alt-name =deps])))) List/join) #;Nil - (compiler;fail (format "No alternatives for " (%type (type;function input-types output-type)))) + (macro;fail (format "No alternatives for " (%type (type;function input-types output-type)))) found (wrap found)))) @@ -286,7 +286,7 @@ (def: (find-alternatives sig-type member-idx input-types output-type) (-> Type Nat (List Type) Type (Lux (List Instance))) (let [test (test-alternatives sig-type member-idx input-types output-type)] - ($_ compiler;either + ($_ macro;either (do Monad<Lux> [alts local-env] (test alts)) (do Monad<Lux> [alts local-structs] (test alts)) (do Monad<Lux> [alts import-structs] (test alts))))) @@ -344,11 +344,11 @@ (do @ [[member-idx sig-type] (resolve-member member) input-types (mapM @ resolve-type args) - output-type compiler;expected-type + output-type macro;expected-type chosen-ones (find-alternatives sig-type member-idx input-types output-type)] (case chosen-ones #;Nil - (compiler;fail (format "No structure option could be found for member: " (%ident member))) + (macro;fail (format "No structure option could be found for member: " (%ident member))) (#;Cons chosen #;Nil) (wrap (list (` (:: (~ (instance$ chosen)) @@ -356,7 +356,7 @@ (~@ (List/map ast;symbol args)))))) _ - (compiler;fail (format "Too many options available: " + (macro;fail (format "Too many options available: " (|> chosen-ones (List/map (. %ident product;left)) (text;join-with ", ")) @@ -365,7 +365,7 @@ (#;Right [args _]) (do @ [labels (seqM @ (list;repeat (list;size args) - (compiler;gensym ""))) + (macro;gensym ""))) #let [retry (` (let [(~@ (|> (list;zip2 labels args) (List/map join-pair) List/join))] (;;::: (~ (ast;symbol member)) (~@ labels))))]] (wrap (list retry))) diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux index 225467526..fd69b1e22 100644 --- a/stdlib/test/test/lux.lux +++ b/stdlib/test/test/lux.lux @@ -7,7 +7,7 @@ ["R" math/random] (data [text "T/" Eq<Text>] text/format) - [compiler] + [macro] (macro ["s" syntax #+ syntax:]))) (test: "Value identity." diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index 6328533bc..c481fa60e 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -16,8 +16,7 @@ (coll [vector #+ vector] [dict] [list])) - [compiler #+ with-gensyms] - [macro] + [macro #+ with-gensyms] (macro [ast] [syntax #+ syntax:] [poly #+ derived:]) diff --git a/stdlib/test/test/lux/data/text/regex.lux b/stdlib/test/test/lux/data/text/regex.lux index e737d5ee4..64be4766e 100644 --- a/stdlib/test/test/lux/data/text/regex.lux +++ b/stdlib/test/test/lux/data/text/regex.lux @@ -9,7 +9,7 @@ text/format (text [lexer] ["&" regex])) - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax:]) ["R" math/random]) diff --git a/stdlib/test/test/lux/macro/syntax.lux b/stdlib/test/test/lux/macro/syntax.lux index 11d456236..19607f16e 100644 --- a/stdlib/test/test/lux/macro/syntax.lux +++ b/stdlib/test/test/lux/macro/syntax.lux @@ -11,7 +11,7 @@ [ident] [error #- fail]) ["R" math/random] - [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax])) lux/test) |