From c10e3c13866ef25bab020ec597fd11aa8d01c862 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 16 Sep 2020 05:54:25 -0400 Subject: Changed the format of project descriptor files. --- stdlib/source/lux/abstract/monad/indexed.lux | 5 +- stdlib/source/lux/control/concatenative.lux | 25 +- stdlib/source/lux/control/concurrency/actor.lux | 18 +- .../source/lux/control/concurrency/semaphore.lux | 3 +- stdlib/source/lux/control/continuation.lux | 3 +- stdlib/source/lux/control/exception.lux | 9 +- stdlib/source/lux/control/function/contract.lux | 3 +- stdlib/source/lux/control/io.lux | 3 +- stdlib/source/lux/control/parser/cli.lux | 3 +- stdlib/source/lux/control/pipe.lux | 3 +- stdlib/source/lux/control/remember.lux | 5 +- stdlib/source/lux/control/security/capability.lux | 9 +- .../lux/data/collection/dictionary/ordered.lux | 5 +- stdlib/source/lux/data/collection/row.lux | 3 +- stdlib/source/lux/data/collection/sequence.lux | 3 +- stdlib/source/lux/data/collection/tree.lux | 2 +- stdlib/source/lux/data/format/json.lux | 29 +- stdlib/source/lux/data/lazy.lux | 3 +- stdlib/source/lux/data/number/complex.lux | 2 +- stdlib/source/lux/data/number/ratio.lux | 2 +- stdlib/source/lux/data/text/format.lux | 2 +- stdlib/source/lux/data/text/regex.lux | 11 +- stdlib/source/lux/extension.lux | 3 +- stdlib/source/lux/host.js.lux | 5 +- stdlib/source/lux/host.jvm.lux | 98 +-- stdlib/source/lux/host.old.lux | 80 +-- stdlib/source/lux/locale.lux | 3 +- stdlib/source/lux/macro.lux | 701 --------------------- stdlib/source/lux/macro/poly.lux | 37 +- stdlib/source/lux/macro/syntax.lux | 15 +- stdlib/source/lux/macro/syntax/common/reader.lux | 9 +- stdlib/source/lux/macro/template.lux | 13 +- stdlib/source/lux/meta.lux | 701 +++++++++++++++++++++ stdlib/source/lux/target/jvm/modifier.lux | 3 +- stdlib/source/lux/test.lux | 11 +- .../compiler/language/lux/phase/analysis/type.lux | 4 +- stdlib/source/lux/type.lux | 21 +- stdlib/source/lux/type/abstract.lux | 9 +- stdlib/source/lux/type/dynamic.lux | 3 +- stdlib/source/lux/type/implicit.lux | 139 ++-- stdlib/source/lux/type/refinement.lux | 5 +- stdlib/source/lux/type/resource.lux | 15 +- stdlib/source/lux/type/unit.lux | 2 +- stdlib/source/poly/lux/abstract/equivalence.lux | 6 +- stdlib/source/poly/lux/abstract/functor.lux | 2 +- stdlib/source/poly/lux/data/format/json.lux | 2 +- stdlib/source/program/aedifex/parser.lux | 166 +++-- stdlib/source/test/lux/control/remember.lux | 13 +- stdlib/source/test/lux/data/text/regex.lux | 5 +- stdlib/source/test/lux/macro.lux | 2 - stdlib/source/test/lux/macro/poly/equivalence.lux | 2 +- stdlib/source/test/lux/macro/syntax.lux | 2 +- stdlib/source/test/lux/meta.lux | 295 ++++++++- 53 files changed, 1441 insertions(+), 1082 deletions(-) delete mode 100644 stdlib/source/lux/macro.lux create mode 100644 stdlib/source/lux/meta.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/abstract/monad/indexed.lux b/stdlib/source/lux/abstract/monad/indexed.lux index caa233884..2f42c0176 100644 --- a/stdlib/source/lux/abstract/monad/indexed.lux +++ b/stdlib/source/lux/abstract/monad/indexed.lux @@ -7,7 +7,8 @@ [data [collection ["." list ("#@." functor fold)]]] - ["." macro + ["." meta] + [macro [syntax (#+ syntax:)] ["." code]]]) @@ -53,7 +54,7 @@ (syntax: #export (do {[?name monad] ..named-monad} {context (s.tuple (p.some context))} expression) - (macro.with-gensyms [g!_ g!bind] + (meta.with-gensyms [g!_ g!bind] (let [body (list@fold (function (_ context next) (case context (#Let bindings) diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux index 1ba47f1af..5f2b553d3 100644 --- a/stdlib/source/lux/control/concatenative.lux +++ b/stdlib/source/lux/control/concatenative.lux @@ -13,7 +13,8 @@ ["i" int] ["r" rev] ["f" frac]]] - ["." macro (#+ with-gensyms) + ["." meta (#+ with-gensyms)] + [macro ["." code] [syntax (#+ syntax:) ["cs" common @@ -56,15 +57,15 @@ (def: (singleton expander) (-> (Meta (List Code)) (Meta Code)) - (monad.do macro.monad + (monad.do meta.monad [expansion expander] (case expansion (#.Cons singleton #.Nil) (wrap singleton) _ - (macro.fail (format "Cannot expand to more than a single AST/Code node:" text.new-line - (|> expansion (list@map %.code) (text.join-with " "))))))) + (meta.fail (format "Cannot expand to more than a single AST/Code node:" text.new-line + (|> expansion (list@map %.code) (text.join-with " "))))))) (syntax: #export (=> {aliases aliases^} {inputs stack^} @@ -77,17 +78,17 @@ (case [(|> inputs (get@ #bottom) (maybe@map (|>> code.nat (~) #.Parameter (`)))) (|> outputs (get@ #bottom) (maybe@map (|>> code.nat (~) #.Parameter (`))))] [(#.Some bottomI) (#.Some bottomO)] - (monad.do macro.monad - [inputC (singleton (macro.expand-all (stack-fold (get@ #top inputs) bottomI))) - outputC (singleton (macro.expand-all (stack-fold (get@ #top outputs) bottomO)))] + (monad.do meta.monad + [inputC (singleton (meta.expand-all (stack-fold (get@ #top inputs) bottomI))) + outputC (singleton (meta.expand-all (stack-fold (get@ #top outputs) bottomO)))] (wrap (list (` (-> (~ (de-alias inputC)) (~ (de-alias outputC))))))) [?bottomI ?bottomO] (with-gensyms [g!stack] - (monad.do macro.monad - [inputC (singleton (macro.expand-all (stack-fold (get@ #top inputs) (maybe.default g!stack ?bottomI)))) - outputC (singleton (macro.expand-all (stack-fold (get@ #top outputs) (maybe.default g!stack ?bottomO))))] + (monad.do meta.monad + [inputC (singleton (meta.expand-all (stack-fold (get@ #top inputs) (maybe.default g!stack ?bottomI)))) + outputC (singleton (meta.expand-all (stack-fold (get@ #top outputs) (maybe.default g!stack ?bottomO))))] (wrap (list (` (All [(~ g!stack)] (-> (~ (de-alias inputC)) (~ (de-alias outputC)))))))))))) @@ -115,8 +116,8 @@ (syntax: #export (apply {arity (|> .nat (<>.filter (n.> 0)))}) (with-gensyms [g! g!func g!stack g!output] - (monad.do {@ macro.monad} - [g!inputs (|> (macro.gensym "input") (list.repeat arity) (monad.seq @))] + (monad.do {@ meta.monad} + [g!inputs (|> (meta.gensym "input") (list.repeat arity) (monad.seq @))] (wrap (list (` (: (All [(~+ g!inputs) (~ g!output)] (-> (-> (~+ g!inputs) (~ g!output)) (=> [(~+ g!inputs)] [(~ g!output)]))) diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux index fb782b169..851a7c790 100644 --- a/stdlib/source/lux/control/concurrency/actor.lux +++ b/stdlib/source/lux/control/concurrency/actor.lux @@ -18,13 +18,13 @@ ["%" format (#+ format)]] [collection ["." list ("#@." monoid monad fold)]]] - ["." macro (#+ with-gensyms monad) + [macro ["." code] [syntax (#+ syntax:) ["cs" common ["csr" reader] ["csw" writer]]]] - [meta + ["." meta (#+ with-gensyms monad) ["." annotation]] [type abstract]] @@ -191,8 +191,8 @@ (def: ( name) (-> Name (Meta Name)) - (do macro.monad - [constant (macro.find-def name)] + (do meta.monad + [constant (meta.find-def name)] (case constant (#.Left de-aliased) ( de-aliased) @@ -203,7 +203,7 @@ (wrap actor-name) _ - (macro.fail (format "Definition is not " "."))))))] + (meta.fail (format "Definition is not " "."))))))] [with-actor resolve-actor #..actor "an actor"] [with-message resolve-message #..message "a message"] @@ -268,8 +268,8 @@ #let [_ (log! "AFTER")]] (wrap output)))))} (with-gensyms [g!_ g!init] - (do macro.monad - [module macro.current-module-name + (do meta.monad + [module meta.current-module-name #let [g!type (code.local-identifier (state-name _name)) g!behavior (code.local-identifier (behavior-name _name)) g!actor (code.local-identifier _name) @@ -358,8 +358,8 @@ (let [state' (#.Cons value state)] (promise.resolved (#try.Success [state' state'])))))} (with-gensyms [g!_ g!return g!error g!task g!sent? g!resolve] - (do macro.monad - [current-module macro.current-module-name + (do meta.monad + [current-module meta.current-module-name actor-name (resolve-actor actor-name) #let [message-name [current-module (get@ #name signature)] g!type (code.identifier (product.both function.identity state-name actor-name)) diff --git a/stdlib/source/lux/control/concurrency/semaphore.lux b/stdlib/source/lux/control/concurrency/semaphore.lux index 3edcbd332..83e5ad005 100644 --- a/stdlib/source/lux/control/concurrency/semaphore.lux +++ b/stdlib/source/lux/control/concurrency/semaphore.lux @@ -16,8 +16,7 @@ ["." queue (#+ Queue)]]] [type abstract - ["." refinement]] - ["." macro]] + ["." refinement]]] [// ["." atom (#+ Atom)] ["." promise (#+ Promise Resolver)]]) diff --git a/stdlib/source/lux/control/continuation.lux b/stdlib/source/lux/control/continuation.lux index d53f103cf..ca5a4d183 100644 --- a/stdlib/source/lux/control/continuation.lux +++ b/stdlib/source/lux/control/continuation.lux @@ -8,7 +8,8 @@ ["." function] [parser ["s" code]]] - [macro (#+ with-gensyms) + [meta (#+ with-gensyms)] + [macro ["." code] [syntax (#+ syntax:)]]]) diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index f170baffe..5d0a04ea9 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -13,7 +13,8 @@ ["n" nat ("#@." decimal)]] [collection ["." list ("#@." functor fold)]]] - ["." macro + ["." meta] + [macro ["." code] [syntax (#+ syntax:) ["sc" common @@ -96,9 +97,9 @@ "Complex case:" (exception: #export [optional type variables] (some-exception {optional Text} {arguments Int}) optional-body))} - (macro.with-gensyms [g!descriptor] - (do macro.monad - [current-module macro.current-module-name + (meta.with-gensyms [g!descriptor] + (do meta.monad + [current-module meta.current-module-name #let [descriptor ($_ text@compose "{" current-module "." name "}" text.new-line) g!self (code.local-identifier name)]] (wrap (list (` (def: (~+ (scw.export export)) diff --git a/stdlib/source/lux/control/function/contract.lux b/stdlib/source/lux/control/function/contract.lux index 1c9236877..9333846fe 100644 --- a/stdlib/source/lux/control/function/contract.lux +++ b/stdlib/source/lux/control/function/contract.lux @@ -7,7 +7,8 @@ ["i" int]] [text ["%" format (#+ format)]]] - [macro (#+ with-gensyms) + [meta (#+ with-gensyms)] + [macro [syntax (#+ syntax:)] ["." code]]]) diff --git a/stdlib/source/lux/control/io.lux b/stdlib/source/lux/control/io.lux index 24b1c2e61..442cf0a1c 100644 --- a/stdlib/source/lux/control/io.lux +++ b/stdlib/source/lux/control/io.lux @@ -9,7 +9,8 @@ ["s" code]]] [type abstract] - ["." macro (#+ with-gensyms) + [meta (#+ with-gensyms)] + [macro [syntax (#+ syntax:)] ["." template]]]) diff --git a/stdlib/source/lux/control/parser/cli.lux b/stdlib/source/lux/control/parser/cli.lux index e4330b129..08e20ca26 100644 --- a/stdlib/source/lux/control/parser/cli.lux +++ b/stdlib/source/lux/control/parser/cli.lux @@ -10,7 +10,8 @@ ["." list ("#@." monoid monad)]] ["." text ("#@." equivalence) ["%" format (#+ format)]]] - [macro (#+ with-gensyms) + [meta (#+ with-gensyms)] + [macro ["." code] [syntax (#+ syntax:)]]] ["." // diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux index 23440ca83..fb9a8c6f7 100644 --- a/stdlib/source/lux/control/pipe.lux +++ b/stdlib/source/lux/control/pipe.lux @@ -12,7 +12,8 @@ ["i" int]] [collection ["." list ("#@." fold monad)]]] - [macro (#+ with-gensyms) + [meta (#+ with-gensyms)] + [macro [syntax (#+ syntax:)] ["." code]]]) diff --git a/stdlib/source/lux/control/remember.lux b/stdlib/source/lux/control/remember.lux index 24bdacb03..c2ceb36ee 100644 --- a/stdlib/source/lux/control/remember.lux +++ b/stdlib/source/lux/control/remember.lux @@ -14,7 +14,8 @@ [time ["." instant] ["." date (#+ Date) ("#@." order)]] - ["." macro + ["." meta] + [macro ["." code] [syntax (#+ syntax:)]]]) @@ -54,7 +55,7 @@ #.None (list))) - (macro.fail (exception.construct ..must-remember [deadline today message focus]))))) + (meta.fail (exception.construct ..must-remember [deadline today message focus]))))) (template [ ] [(syntax: #export ( {deadline ..deadline} {message .text} {focus (<>.maybe .any)}) diff --git a/stdlib/source/lux/control/security/capability.lux b/stdlib/source/lux/control/security/capability.lux index 54ea35281..485c1091c 100644 --- a/stdlib/source/lux/control/security/capability.lux +++ b/stdlib/source/lux/control/security/capability.lux @@ -15,7 +15,8 @@ ["." list ("#;." functor)]]] [type abstract] - ["." macro + ["." meta] + [macro ["." code] [syntax (#+ syntax:) [common @@ -45,11 +46,11 @@ {declaration reader.declaration} {annotations (<>.maybe reader.annotations)} {[forge input output] (.form ($_ <>.and .local-identifier .any .any))}) - (do {@ macro.monad} - [this-module macro.current-module-name + (do {@ meta.monad} + [this-module meta.current-module-name #let [[name vars] declaration] g!brand (:: @ map (|>> %.code code.text) - (macro.gensym (format (%.name [this-module name])))) + (meta.gensym (format (%.name [this-module name])))) #let [capability (` (..Capability (.primitive (~ g!brand)) (~ input) (~ output)))]] (wrap (list (` (type: (~+ (writer.export export)) (~ (writer.declaration declaration)) diff --git a/stdlib/source/lux/data/collection/dictionary/ordered.lux b/stdlib/source/lux/data/collection/dictionary/ordered.lux index a2f03683a..9ae66df08 100644 --- a/stdlib/source/lux/data/collection/dictionary/ordered.lux +++ b/stdlib/source/lux/data/collection/dictionary/ordered.lux @@ -11,10 +11,11 @@ ["n" nat]] [collection ["." list ("#@." monoid fold)]]] - ["." macro + [macro ["." code]]]) -(def: error-message Text "Invariant violation") +(def: error-message + "Invariant violation") (type: Color #Red diff --git a/stdlib/source/lux/data/collection/row.lux b/stdlib/source/lux/data/collection/row.lux index 6df0325cd..8c0ce748c 100644 --- a/stdlib/source/lux/data/collection/row.lux +++ b/stdlib/source/lux/data/collection/row.lux @@ -23,7 +23,8 @@ [collection ["." list ("#@." fold functor monoid)] ["." array (#+ Array) ("#@." functor fold)]]] - [macro (#+ with-gensyms) + [meta (#+ with-gensyms)] + [macro ["." code] [syntax (#+ syntax:)]]]) diff --git a/stdlib/source/lux/data/collection/sequence.lux b/stdlib/source/lux/data/collection/sequence.lux index 98df00636..5755e8214 100644 --- a/stdlib/source/lux/data/collection/sequence.lux +++ b/stdlib/source/lux/data/collection/sequence.lux @@ -7,7 +7,8 @@ ["." continuation (#+ Cont pending)] ["p" parser ["s" code (#+ Parser)]]] - [macro (#+ with-gensyms) + [meta (#+ with-gensyms)] + [macro ["." code] [syntax (#+ syntax:)]] [data diff --git a/stdlib/source/lux/data/collection/tree.lux b/stdlib/source/lux/data/collection/tree.lux index eed5bd860..612d8be49 100644 --- a/stdlib/source/lux/data/collection/tree.lux +++ b/stdlib/source/lux/data/collection/tree.lux @@ -11,7 +11,7 @@ [data [collection ["." list ("#@." monad fold)]]] - ["." macro + [macro [syntax (#+ syntax:)] ["." code]]]) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 12e94a331..e9b6ab8b6 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -22,7 +22,8 @@ ["." list ("#@." fold functor)] ["." row (#+ Row row) ("#@." monad)] ["." dictionary (#+ Dictionary)]]] - ["." macro (#+ monad with-gensyms) + ["." meta (#+ monad with-gensyms)] + [macro [syntax (#+ syntax:)] ["." code]]]) @@ -88,7 +89,7 @@ (wrap (` [(~ (code.text key-name)) (~ (wrapper value))])) _ - (macro.fail "Wrong syntax for JSON object."))) + (meta.fail "Wrong syntax for JSON object."))) pairs)] (wrap (list (` (: JSON (#..Object ((~! dictionary.from-list) (~! text.hash) @@ -334,18 +335,18 @@ (wrap chars)))) (def: (kv~ json~) - (-> (-> Any (Parser JSON)) (Parser [String JSON])) + (-> (Parser JSON) (Parser [String JSON])) (do <>.monad [key string~ _ space~ _ (.this ":") _ space~ - value (json~ [])] + value json~] (wrap [key value]))) (template [ ] [(def: ( json~) - (-> (-> Any (Parser JSON)) (Parser )) + (-> (Parser JSON) (Parser )) (do <>.monad [_ (.this ) _ space~ @@ -354,16 +355,24 @@ _ (.this )] (wrap ( elems))))] - [array~ Array "[" "]" (json~ []) row.from-list] + [array~ Array "[" "]" json~ row.from-list] [object~ Object "{" "}" (kv~ json~) (dictionary.from-list text.hash)] ) -(def: (json~' _) - (-> Any (Parser JSON)) - ($_ <>.or null~ boolean~ number~ string~ (array~ json~') (object~ json~'))) +(def: json~ + (Parser JSON) + (<>.rec + (function (_ json~) + ($_ <>.or + null~ + boolean~ + number~ + string~ + (array~ json~) + (object~ json~))))) (structure: #export codec (Codec Text JSON) (def: encode ..format) - (def: decode (.run (json~' [])))) + (def: decode (.run json~))) diff --git a/stdlib/source/lux/data/lazy.lux b/stdlib/source/lux/data/lazy.lux index 89b75d3b6..705e88682 100644 --- a/stdlib/source/lux/data/lazy.lux +++ b/stdlib/source/lux/data/lazy.lux @@ -11,7 +11,8 @@ ["s" code]] [concurrency ["." atom]]] - [macro (#+ with-gensyms) + [meta (#+ with-gensyms)] + [macro [syntax (#+ syntax:)]] [type abstract]]) diff --git a/stdlib/source/lux/data/number/complex.lux b/stdlib/source/lux/data/number/complex.lux index ede5bb980..114398a9a 100644 --- a/stdlib/source/lux/data/number/complex.lux +++ b/stdlib/source/lux/data/number/complex.lux @@ -17,7 +17,7 @@ ["." text ("#;." monoid)] [collection ["." list ("#;." functor)]]] - ["." macro + [macro ["." code] [syntax (#+ syntax:)]]]) diff --git a/stdlib/source/lux/data/number/ratio.lux b/stdlib/source/lux/data/number/ratio.lux index dcca35bf9..17bc1f2b4 100644 --- a/stdlib/source/lux/data/number/ratio.lux +++ b/stdlib/source/lux/data/number/ratio.lux @@ -19,7 +19,7 @@ ["n" nat ("#@." decimal)]] ["." text ("#@." monoid)]] ["." math] - ["." macro + [macro ["." code] [syntax (#+ syntax:)]]]) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 9f47c4292..335c120be 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -26,7 +26,7 @@ ["." date]] [math ["." modular]] - ["." macro + [macro ["." code] [syntax (#+ syntax:)]] ["." type]]) diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux index 1777c2cac..98d33258b 100644 --- a/stdlib/source/lux/data/text/regex.lux +++ b/stdlib/source/lux/data/text/regex.lux @@ -14,7 +14,8 @@ ["n" nat ("#@." decimal)]] [collection ["." list ("#@." fold monad)]]] - ["." macro (#+ with-gensyms) + ["." meta (#+ with-gensyms)] + [macro [syntax (#+ syntax:)] ["." code]]] ["." // @@ -458,13 +459,13 @@ (regex "a|b") (regex "a(.)(.)|b(.)(.)") )} - (do macro.monad - [current-module macro.current-module-name] + (do meta.monad + [current-module meta.current-module-name] (case (.run (regex^ current-module) pattern) (#try.Failure error) - (macro.fail (format "Error while parsing regular-expression:" //.new-line - error)) + (meta.fail (format "Error while parsing regular-expression:" //.new-line + error)) (#try.Success regex) (wrap (list regex)) diff --git a/stdlib/source/lux/extension.lux b/stdlib/source/lux/extension.lux index a4254807b..b880d6e7d 100644 --- a/stdlib/source/lux/extension.lux +++ b/stdlib/source/lux/extension.lux @@ -11,7 +11,8 @@ ["." product] [collection ["." list ("#@." functor)]]] - [macro (#+ with-gensyms) + [meta (#+ with-gensyms)] + [macro ["." code] [syntax (#+ syntax:)]] [tool diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux index 2770108cc..08a1bf830 100644 --- a/stdlib/source/lux/host.js.lux +++ b/stdlib/source/lux/host.js.lux @@ -15,7 +15,8 @@ ["." list ("#@." functor fold)]]] [type abstract] - ["." macro (#+ with-gensyms) + ["." meta (#+ with-gensyms)] + [macro [syntax (#+ syntax:)] ["." code] ["." template]]]) @@ -237,7 +238,7 @@ (#Field [static? field fieldT]) (if static? (` ((~! syntax:) ((~ (qualify field))) - (:: (~! macro.monad) (~' wrap) + (:: (~! meta.monad) (~' wrap) (list (` (.:coerce (~ (nullable-type fieldT)) ("js constant" (~ (code.text (format real-class "." field)))))))))) (` (def: ((~ (qualify field)) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index 4664a266f..14c8161c9 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -23,11 +23,11 @@ ["." array] ["." list ("#@." monad fold monoid)] ["." dictionary (#+ Dictionary)]]] - ["." macro (#+ with-gensyms) + [macro [syntax (#+ syntax:)] ["." code] ["." template]] - [meta + ["." meta (#+ with-gensyms) ["." annotation]] [target [jvm @@ -402,21 +402,21 @@ (def: (context compiler) (-> Lux Context) - (case (macro.run compiler - (: (Meta Context) - (do macro.monad - [current-module macro.current-module-name - definitions (macro.definitions current-module)] - (wrap (list@fold (: (-> [Text Definition] Context Context) - (function (_ [short-name [_ _ meta _]] imports) - (case (annotation.text (name-of #..jvm-class) meta) - (#.Some full-class-name) - (add-import [short-name full-class-name] imports) - - _ - imports))) - ..fresh - definitions))))) + (case (meta.run compiler + (: (Meta Context) + (do meta.monad + [current-module meta.current-module-name + definitions (meta.definitions current-module)] + (wrap (list@fold (: (-> [Text Definition] Context Context) + (function (_ [short-name [_ _ meta _]] imports) + (case (annotation.text (name-of #..jvm-class) meta) + (#.Some full-class-name) + (add-import [short-name full-class-name] imports) + + _ + imports))) + ..fresh + definitions))))) (#.Left _) (list) (#.Right imports) imports)) @@ -1265,8 +1265,8 @@ "(::new! []) for calling the class's constructor." "(::resolve! container [value]) for calling the 'resolve' method." )} - (do macro.monad - [current-module macro.current-module-name + (do meta.monad + [current-module meta.current-module-name #let [fully-qualified-class-name (name.qualify current-module full-class-name) field-parsers (list@map (field->parser fully-qualified-class-name) fields) method-parsers (list@map (method->parser fully-qualified-class-name) methods) @@ -1295,8 +1295,8 @@ {#.doc (doc "Allows defining JVM interfaces." (interface: TestInterface ([] foo [boolean String] void #throws [Exception])))} - (do macro.monad - [current-module macro.current-module-name] + (do meta.monad + [current-module meta.current-module-name] (wrap (list (` ("jvm class interface" (~ (declaration$ (type.declaration (name.qualify current-module full-class-name) class-vars))) [(~+ (list@map class$ supers))] @@ -1462,7 +1462,7 @@ (case member (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) (let [(^slots [#import-member-tvars #import-member-args]) commons] - (do {@ macro.monad} + (do {@ meta.monad} [arg-inputs (monad.map @ (: (-> [Bit (Type Value)] (Meta [Bit Code])) (function (_ [maybe? _]) @@ -1480,7 +1480,7 @@ (wrap [arg-inputs input-jvm-types arg-types]))) _ - (:: macro.monad wrap [(list) (list) (list)]))) + (:: meta.monad wrap [(list) (list) (list)]))) (def: (decorate-return-maybe member never-null? unboxed return-term) (-> Import-Member-Declaration Bit (Type Value) Code Code) @@ -1605,7 +1605,7 @@ (let [[full-name class-tvars] (parser.declaration class)] (case member (#EnumDecl enum-members) - (do macro.monad + (do meta.monad [#let [enum-type (: Code (case class-tvars #.Nil @@ -1623,7 +1623,7 @@ (wrap (list@map getter-interop enum-members))) (#ConstructorDecl [commons _]) - (do macro.monad + (do meta.monad [#let [classT (type.class full-name (list)) def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) jvm-interop (|> [classT @@ -1643,7 +1643,7 @@ (#MethodDecl [commons method]) (with-gensyms [g!obj] - (do macro.monad + (do meta.monad [#let [def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) (^slots [#import-member-kind]) commons (^slots [#import-method-name]) method @@ -1696,7 +1696,7 @@ ((~' wrap) (.list (.` (~ jvm-interop)))))))))) (#FieldAccessDecl fad) - (do macro.monad + (do meta.monad [#let [(^open ".") fad getter-name (code.identifier ["" (format method-prefix member-separator import-field-name)]) setter-name (code.identifier ["" (format method-prefix member-separator import-field-name "!")])] @@ -1746,7 +1746,7 @@ method-prefix (..internal (if long-name? full-name (short-class-name full-name)))] - (do macro.monad + (do meta.monad [=args (member-def-arg-bindings vars member)] (member-def-interop vars kind class =args member method-prefix)))) @@ -1769,12 +1769,12 @@ (let [[class-name _] (parser.declaration declaration)] (case (load-class class-name) (#.Right class) - (:: macro.monad wrap (if (interface? class) - #Interface - #Class)) + (:: meta.monad wrap (if (interface? class) + #Interface + #Class)) (#.Left _) - (macro.fail (format "Unknown class: " class-name))))) + (meta.fail (format "Unknown class: " class-name))))) (syntax: #export (import: {#let [imports (..context *compiler*)]} @@ -1831,7 +1831,7 @@ (java/util/List::size [] my-list) Character$UnicodeScript::LATIN )} - (do {@ macro.monad} + (do {@ meta.monad} [kind (class-kind declaration) =members (monad.map @ (member-import$ class-type-vars long-name? kind declaration) members)] (wrap (list& (class-import$ long-name? declaration) (list@join =members))))) @@ -1866,18 +1866,18 @@ (exception.report ["Lux Type" (%.type type)])) -(with-expansions [ (as-is (macro.fail (exception.construct ..cannot-convert-to-jvm-type [type])))] +(with-expansions [ (as-is (meta.fail (exception.construct ..cannot-convert-to-jvm-type [type])))] (def: (lux-type->jvm-type type) (-> .Type (Meta (Type Value))) (if (lux-type@= Any type) - (:: macro.monad wrap $Object) + (:: meta.monad wrap $Object) (case type (#.Primitive name params) (`` (cond (~~ (template [] [(text@= (..reflection ) name) (case params #.Nil - (:: macro.monad wrap ) + (:: meta.monad wrap ) _ )] @@ -1895,7 +1895,7 @@ [(text@= (..reflection (type.array )) name) (case params #.Nil - (:: macro.monad wrap (type.array )) + (:: meta.monad wrap (type.array )) _ )] @@ -1912,7 +1912,7 @@ (text@= array.type-name name) (case params (#.Cons elementLT #.Nil) - (:: macro.monad map type.array + (:: meta.monad map type.array (lux-type->jvm-type elementLT)) _ @@ -1922,18 +1922,18 @@ (case params #.Nil (let [[_ unprefixed] (maybe.assume (text.split-with descriptor.array-prefix name))] - (:: macro.monad map type.array + (:: meta.monad map type.array (lux-type->jvm-type (#.Primitive unprefixed (list))))) _ ) ## else - (:: macro.monad map (type.class name) + (:: meta.monad map (type.class name) (: (Meta (List (Type Parameter))) - (monad.map macro.monad + (monad.map meta.monad (function (_ paramLT) - (do macro.monad + (do meta.monad [paramJT (lux-type->jvm-type paramLT)] (case (parser.parameter? paramJT) (#.Some paramJT) @@ -1962,8 +1962,8 @@ (array-length my-array))} (case array [_ (#.Identifier array-name)] - (do macro.monad - [array-type (macro.find-type array-name) + (do meta.monad + [array-type (meta.find-type array-name) array-jvm-type (lux-type->jvm-type array-type) #let [g!extension (code.text (`` (cond (~~ (template [ ] [(:: type.equivalence = @@ -1998,8 +1998,8 @@ (array-read 10 my-array))} (case array [_ (#.Identifier array-name)] - (do macro.monad - [array-type (macro.find-type array-name) + (do meta.monad + [array-type (meta.find-type array-name) array-jvm-type (lux-type->jvm-type array-type) #let [g!idx (` (.|> (~ idx) (.: .Nat) @@ -2036,8 +2036,8 @@ (array-write 10 my-object my-array))} (case array [_ (#.Identifier array-name)] - (do macro.monad - [array-type (macro.find-type array-name) + (do meta.monad + [array-type (meta.find-type array-name) array-jvm-type (lux-type->jvm-type array-type) #let [g!idx (` (.|> (~ idx) (.: .Nat) @@ -2086,7 +2086,7 @@ => "java.lang.String")} (-> External (Meta External)) - (do macro.monad + (do meta.monad [*compiler* get-compiler] (wrap (qualify (..context *compiler*) class)))) diff --git a/stdlib/source/lux/host.old.lux b/stdlib/source/lux/host.old.lux index 59f6dd659..ee37cc55d 100644 --- a/stdlib/source/lux/host.old.lux +++ b/stdlib/source/lux/host.old.lux @@ -20,10 +20,10 @@ ["." array (#+ Array)] ["." list ("#@." monad fold monoid)]]] ["." type ("#@." equivalence)] - ["." macro (#+ with-gensyms) + [macro ["." code] [syntax (#+ syntax:)]] - [meta + ["." meta (#+ with-gensyms) ["." annotation]]]) (template [ ] @@ -366,21 +366,21 @@ (def: (class-imports compiler) (-> Lux Class-Imports) - (case (macro.run compiler - (: (Meta Class-Imports) - (do macro.monad - [current-module macro.current-module-name - definitions (macro.definitions current-module)] - (wrap (list@fold (: (-> [Text Definition] Class-Imports Class-Imports) - (function (_ [short-name [_ _ meta _]] imports) - (case (annotation.text (name-of #..jvm-class) meta) - (#.Some full-class-name) - (add-import [short-name full-class-name] imports) - - _ - imports))) - empty-imports - definitions))))) + (case (meta.run compiler + (: (Meta Class-Imports) + (do meta.monad + [current-module meta.current-module-name + definitions (meta.definitions current-module)] + (wrap (list@fold (: (-> [Text Definition] Class-Imports Class-Imports) + (function (_ [short-name [_ _ meta _]] imports) + (case (annotation.text (name-of #..jvm-class) meta) + (#.Some full-class-name) + (add-import [short-name full-class-name] imports) + + _ + imports))) + empty-imports + definitions))))) (#.Left _) (list) @@ -1344,8 +1344,8 @@ "(::new! []) for calling the class's constructor." "(::resolve! container [value]) for calling the 'resolve' method." )} - (do macro.monad - [current-module macro.current-module-name + (do meta.monad + [current-module meta.current-module-name #let [fully-qualified-class-name (format (sanitize current-module) "." full-class-name) field-parsers (list@map (field->parser fully-qualified-class-name) fields) method-parsers (list@map (method->parser (product.right class-decl) fully-qualified-class-name) methods) @@ -1542,7 +1542,7 @@ (case member (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) (let [(^slots [#import-member-tvars #import-member-args]) commons] - (do {@ macro.monad} + (do {@ meta.monad} [arg-inputs (monad.map @ (: (-> [Bit GenericType] (Meta [Bit Code])) (function (_ [maybe? _]) @@ -1562,7 +1562,7 @@ (wrap [arg-inputs arg-classes arg-types]))) _ - (:: macro.monad wrap [(list) (list) (list)]))) + (:: meta.monad wrap [(list) (list) (list)]))) (def: (decorate-return-maybe member return-term) (-> Import-Member-Declaration Code Code) @@ -1648,7 +1648,7 @@ (list@map type-param->type-arg))] (case member (#EnumDecl enum-members) - (do {@ macro.monad} + (do {@ meta.monad} [#let [enum-type (: Code (case class-tvars #.Nil @@ -1668,7 +1668,7 @@ (wrap (list@map getter-interop enum-members))) (#ConstructorDecl [commons _]) - (do macro.monad + (do meta.monad [#let [def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) jvm-extension (code.text (format "jvm new" ":" full-name ":" (text.join-with "," arg-classes))) jvm-interop (|> (` ((~ jvm-extension) @@ -1681,7 +1681,7 @@ (#MethodDecl [commons method]) (with-gensyms [g!obj] - (do macro.monad + (do meta.monad [#let [def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) (^slots [#import-member-kind]) commons (^slots [#import-method-name]) method @@ -1713,7 +1713,7 @@ ((~' wrap) (.list (.` (~ jvm-interop)))))))))) (#FieldAccessDecl fad) - (do macro.monad + (do meta.monad [#let [(^open ".") fad base-gtype (class->type import-field-mode type-params import-field-type) classC (class-decl-type$ class) @@ -1774,7 +1774,7 @@ method-prefix (if long-name? full-name (short-class-name full-name))] - (do macro.monad + (do meta.monad [=args (member-def-arg-bindings type-params class member)] (member-def-interop type-params kind class =args member method-prefix)))) @@ -1791,12 +1791,12 @@ (let [class-name (sanitize class-name)] (case (load-class class-name) (#.Right class) - (:: macro.monad wrap (if (interface? class) - #Interface - #Class)) + (:: meta.monad wrap (if (interface? class) + #Interface + #Class)) (#.Left _) - (macro.fail (format "Unknown class: " class-name))))) + (meta.fail (format "Unknown class: " class-name))))) (syntax: #export (import: {#let [imports (class-imports *compiler*)]} @@ -1852,7 +1852,7 @@ (java/util/List::size [] my-list) Character$UnicodeScript::LATIN )} - (do {@ macro.monad} + (do {@ meta.monad} [kind (class-kind class-decl) =members (monad.map @ (member-import$ (product.right class-decl) long-name? kind class-decl) members)] (wrap (list& (class-import$ long-name? class-decl) (list@join =members))))) @@ -1886,15 +1886,15 @@ (def: (type->class-name type) (-> Type (Meta Text)) (if (type@= Any type) - (:: macro.monad wrap "java.lang.Object") + (:: meta.monad wrap "java.lang.Object") (case type (#.Primitive name params) - (:: macro.monad wrap name) + (:: meta.monad wrap name) (#.Apply A F) (case (type.apply (list A) F) #.None - (macro.fail (format "Cannot apply type: " (type.to-text F) " to " (type.to-text A))) + (meta.fail (format "Cannot apply type: " (type.to-text F) " to " (type.to-text A))) (#.Some type') (type->class-name type')) @@ -1903,15 +1903,15 @@ (type->class-name type') _ - (macro.fail (format "Cannot convert to JvmType: " (type.to-text type)))))) + (meta.fail (format "Cannot convert to JvmType: " (type.to-text type)))))) (syntax: #export (array-read idx array) {#.doc (doc "Loads an element from an array." (array-read 10 my-array))} (case array [_ (#.Identifier array-name)] - (do macro.monad - [array-type (macro.find-type array-name) + (do meta.monad + [array-type (meta.find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type (^template [ ] @@ -1939,8 +1939,8 @@ (array-write 10 my-object my-array))} (case array [_ (#.Identifier array-name)] - (do macro.monad - [array-type (macro.find-type array-name) + (do meta.monad + [array-type (meta.find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type (^template [ ] @@ -1980,7 +1980,7 @@ => "java.lang.String")} (-> Text (Meta Text)) - (do macro.monad + (do meta.monad [*compiler* get-compiler] (wrap (qualify (class-imports *compiler*) class)))) diff --git a/stdlib/source/lux/locale.lux b/stdlib/source/lux/locale.lux index 5205c2f85..b49909be6 100644 --- a/stdlib/source/lux/locale.lux +++ b/stdlib/source/lux/locale.lux @@ -9,8 +9,7 @@ ["%" format (#+ format)] ["." encoding (#+ Encoding)]]] [type - abstract] - ["." macro]] + abstract]] [/ ["." language (#+ Language)] ["." territory (#+ Territory)]]) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux deleted file mode 100644 index 3dadc236d..000000000 --- a/stdlib/source/lux/macro.lux +++ /dev/null @@ -1,701 +0,0 @@ -(.module: {#.doc "Functions for extracting information from the state of the compiler."} - [lux #* - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)]] - [data - ["." product] - ["." name ("#@." codec equivalence)] - ["." maybe] - [number - ["n" nat] - ["i" int]] - ["." text ("#@." monoid equivalence)] - [collection - ["." list ("#@." monoid monad)]]]] - [/ - ["." code]]) - -## (type: (Meta a) -## (-> Lux (Try [Lux a]))) - -(structure: #export functor - (Functor Meta) - - (def: (map f fa) - (function (_ compiler) - (case (fa compiler) - (#try.Failure msg) - (#try.Failure msg) - - (#try.Success [compiler' a]) - (#try.Success [compiler' (f a)]))))) - -(structure: #export apply - (Apply Meta) - - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ compiler) - (case (ff compiler) - (#try.Success [compiler' f]) - (case (fa compiler') - (#try.Success [compiler'' a]) - (#try.Success [compiler'' (f a)]) - - (#try.Failure msg) - (#try.Failure msg)) - - (#try.Failure msg) - (#try.Failure msg))))) - -(structure: #export monad - (Monad Meta) - - (def: &functor ..functor) - - (def: (wrap x) - (function (_ compiler) - (#try.Success [compiler x]))) - - (def: (join mma) - (function (_ compiler) - (case (mma compiler) - (#try.Failure msg) - (#try.Failure msg) - - (#try.Success [compiler' ma]) - (ma compiler'))))) - -(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] (-> Lux (Meta a) (Try [Lux a]))) - (action compiler)) - -(def: #export (run compiler action) - (All [a] (-> Lux (Meta a) (Try a))) - (case (action compiler) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [_ output]) - (#try.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) - (#try.Failure error) - (right compiler) - - (#try.Success [compiler' output]) - (#try.Success [compiler' output])))) - -(def: #export (assert message test) - {#.doc "Fails with the given message if the test is #0."} - (-> Text Bit (Meta Any)) - (function (_ compiler) - (if test - (#try.Success [compiler []]) - (#try.Failure message)))) - -(def: #export (fail msg) - {#.doc "Fails with the given message."} - (All [a] - (-> Text (Meta a))) - (function (_ _) - (#try.Failure msg))) - -(def: #export (find-module name) - (-> Text (Meta Module)) - (function (_ compiler) - (case (get name (get@ #.modules compiler)) - (#.Some module) - (#try.Success [compiler module]) - - _ - (#try.Failure ($_ text@compose "Unknown module: " name))))) - -(def: #export current-module-name - (Meta Text) - (function (_ compiler) - (case (get@ #.current-module compiler) - (#.Some current-module) - (#try.Success [compiler current-module]) - - _ - (#try.Failure "No current module.") - ))) - -(def: #export current-module - (Meta Module) - (do ..monad - [this-module-name current-module-name] - (find-module this-module-name))) - -(def: (macro-type? type) - (-> Type Bit) - (case type - (#.Named ["lux" "Macro"] (#.Primitive "#Macro" #.Nil)) - true - - _ - false)) - -(def: (find-macro' modules this-module module name) - (-> (List [Text Module]) Text Text Text - (Maybe Macro)) - (do maybe.monad - [$module (get module modules) - definition (: (Maybe Global) - (|> (: Module $module) - (get@ #.definitions) - (get name)))] - (case definition - (#.Left [r-module r-name]) - (find-macro' modules this-module r-module r-name) - - (#.Right [exported? def-type def-anns def-value]) - (if (macro-type? def-type) - (#.Some (:coerce Macro def-value)) - #.None)))) - -(def: #export (normalize name) - {#.doc (doc "If given a name without a module prefix, gives it the current module's name as prefix." - "Otherwise, returns the name as-is.")} - (-> Name (Meta Name)) - (case name - ["" name] - (do ..monad - [module-name current-module-name] - (wrap [module-name name])) - - _ - (:: ..monad wrap name))) - -(def: #export (find-macro full-name) - (-> Name (Meta (Maybe Macro))) - (do ..monad - [[module name] (normalize full-name) - this-module current-module-name] - (: (Meta (Maybe Macro)) - (function (_ compiler) - (#try.Success [compiler (find-macro' (get@ #.modules compiler) this-module module name)]))))) - -(def: #export (expand-once syntax) - {#.doc (doc "Given code that requires applying a macro, does it once and returns the result." - "Otherwise, returns the code as-is.")} - (-> Code (Meta (List Code))) - (case syntax - [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] - (do ..monad - [?macro (find-macro name)] - (case ?macro - (#.Some macro) - ((:coerce Macro' macro) args) - - #.None - (:: ..monad wrap (list syntax)))) - - _ - (:: ..monad wrap (list syntax)))) - -(def: #export (expand syntax) - {#.doc (doc "Given code that requires applying a macro, expands repeatedly until no more direct macro-calls are left." - "Otherwise, returns the code as-is.")} - (-> Code (Meta (List Code))) - (case syntax - [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] - (do ..monad - [?macro (find-macro name)] - (case ?macro - (#.Some macro) - (do ..monad - [expansion ((:coerce Macro' macro) args) - expansion' (monad.map ..monad expand expansion)] - (wrap (list@join expansion'))) - - #.None - (:: ..monad wrap (list syntax)))) - - _ - (:: ..monad wrap (list syntax)))) - -(def: #export (expand-all syntax) - {#.doc "Expands all macro-calls everywhere recursively, until only primitive/base code remains."} - (-> Code (Meta (List Code))) - (case syntax - [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] - (do ..monad - [?macro (find-macro name)] - (case ?macro - (#.Some macro) - (do ..monad - [expansion ((:coerce Macro' macro) args) - expansion' (monad.map ..monad expand-all expansion)] - (wrap (list@join expansion'))) - - #.None - (do ..monad - [parts' (monad.map ..monad expand-all (list& (code.identifier name) args))] - (wrap (list (code.form (list@join parts'))))))) - - [_ (#.Form (#.Cons [harg targs]))] - (do ..monad - [harg+ (expand-all harg) - targs+ (monad.map ..monad expand-all targs)] - (wrap (list (code.form (list@compose harg+ (list@join (: (List (List Code)) targs+))))))) - - [_ (#.Tuple members)] - (do ..monad - [members' (monad.map ..monad expand-all members)] - (wrap (list (code.tuple (list@join members'))))) - - _ - (:: ..monad wrap (list syntax)))) - -(def: #export count - (Meta Nat) - (function (_ compiler) - (#try.Success [(update@ #.seed inc compiler) - (get@ #.seed compiler)]))) - -(def: #export (gensym prefix) - {#.doc (doc "Generates a unique name as an Code 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 (Meta Code)) - (do ..monad - [id ..count] - (wrap (|> id - (:: n.decimal encode) - ($_ text@compose "__gensym__" prefix) - [""] code.identifier)))) - -(def: (get-local-identifier ast) - (-> Code (Meta Text)) - (case ast - [_ (#.Identifier [_ name])] - (:: ..monad wrap name) - - _ - (fail (text@compose "Code is not a local identifier: " (code.to-text ast))))) - -(def: #export wrong-syntax-error - (-> Name Text) - (|>> name@encode - (text@compose "Wrong syntax for "))) - -(macro: #export (with-gensyms tokens) - {#.doc (doc "Creates new identifiers 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 [_ (#.Tuple identifiers)] body)) - (do {@ ..monad} - [identifier-names (monad.map @ get-local-identifier identifiers) - #let [identifier-defs (list@join (list@map (: (-> Text (List Code)) - (function (_ name) (list (code.identifier ["" name]) (` (gensym (~ (code.text name))))))) - identifier-names))]] - (wrap (list (` ((~! do) (~! ..monad) - [(~+ identifier-defs)] - (~ body)))))) - - _ - (fail (..wrong-syntax-error (name-of ..with-gensyms))))) - -(def: #export (expand-1 token) - {#.doc "Works just like expand, except that it ensures that the output is a single Code token."} - (-> Code (Meta Code)) - (do ..monad - [token+ (expand token)] - (case token+ - (^ (list token')) - (wrap token') - - _ - (fail "Macro expanded to more than 1 element.")))) - -(def: #export (module-exists? module) - (-> Text (Meta Bit)) - (function (_ compiler) - (#try.Success [compiler (case (get module (get@ #.modules compiler)) - (#.Some _) - #1 - - #.None - #0)]))) - -(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: (find-type-var idx bindings) - (-> Nat (List [Nat (Maybe Type)]) (Maybe Type)) - (case bindings - #.Nil - #.None - - (#.Cons [var bound] bindings') - (if (n.= idx var) - bound - (find-type-var idx bindings')))) - -(def: (clean-type type) - (-> Type (Meta Type)) - (case type - (#.Var var) - (function (_ compiler) - (case (|> compiler - (get@ [#.type-context #.var-bindings]) - (find-type-var var)) - (^or #.None (#.Some (#.Var _))) - (#try.Success [compiler type]) - - (#.Some type') - (#try.Success [compiler type']))) - - _ - (:: ..monad wrap type))) - -(def: #export (find-var-type name) - {#.doc "Looks-up the type of a local variable somewhere in the environment."} - (-> Text (Meta Type)) - (function (_ compiler) - (let [test (: (-> [Text [Type Any]] Bit) - (|>> product.left (text@= name)))] - (case (do maybe.monad - [scope (list.find (function (_ env) - (or (list.any? test (: (List [Text [Type Any]]) - (get@ [#.locals #.mappings] env))) - (list.any? test (: (List [Text [Type Any]]) - (get@ [#.captured #.mappings] env))))) - (get@ #.scopes compiler)) - [_ [type _]] (try-both (list.find test) - (: (List [Text [Type Any]]) - (get@ [#.locals #.mappings] scope)) - (: (List [Text [Type Any]]) - (get@ [#.captured #.mappings] scope)))] - (wrap type)) - (#.Some var-type) - ((clean-type var-type) compiler) - - #.None - (#try.Failure ($_ 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)."} - (-> Name (Meta Global)) - (do ..monad - [name (normalize name)] - (function (_ compiler) - (case (: (Maybe Global) - (do maybe.monad - [#let [[v-prefix v-name] name] - (^slots [#.definitions]) (get v-prefix (get@ #.modules compiler))] - (get v-name definitions))) - (#.Some definition) - (#try.Success [compiler definition]) - - _ - (let [current-module (|> compiler (get@ #.current-module) (maybe.default "???")) - separator ($_ text@compose text.new-line " ")] - (#try.Failure ($_ text@compose - "Unknown definition: " (name@encode name) text.new-line - " Current module: " current-module text.new-line - (case (get current-module (get@ #.modules compiler)) - (#.Some this-module) - ($_ text@compose - " Imports: " (|> this-module (get@ #.imports) (text.join-with separator)) text.new-line - " Aliases: " (|> this-module (get@ #.module-aliases) (list@map (function (_ [alias real]) ($_ text@compose alias " => " real))) (text.join-with separator)) text.new-line) - - _ - "") - " All Known modules: " (|> compiler (get@ #.modules) (list@map product.left) (text.join-with separator)) text.new-line))))))) - -(def: #export (find-export name) - {#.doc "Looks-up a definition's type in the available modules (including the current one)."} - (-> Name (Meta Definition)) - (do ..monad - [definition (..find-def name)] - (case definition - (#.Left de-aliased) - (fail ($_ text@compose - "Aliases are not considered exports: " - (name@encode name))) - - (#.Right definition) - (let [[exported? def-type def-data def-value] definition] - (if exported? - (wrap definition) - (fail ($_ text@compose "Definition is not an export: " (name@encode name)))))))) - -(def: #export (find-def-type name) - {#.doc "Looks-up a definition's type in the available modules (including the current one)."} - (-> Name (Meta Type)) - (do ..monad - [definition (find-def name)] - (case definition - (#.Left de-aliased) - (find-def-type de-aliased) - - (#.Right [exported? def-type def-data def-value]) - (clean-type def-type)))) - -(def: #export (find-type name) - {#.doc "Looks-up the type of either a local variable or a definition."} - (-> Name (Meta Type)) - (do ..monad - [#let [[_ _name] name]] - (case name - ["" _name] - (either (find-var-type _name) - (find-def-type name)) - - _ - (find-def-type name)))) - -(def: #export (find-type-def name) - {#.doc "Finds the value of a type definition (such as Int, Any or Lux)."} - (-> Name (Meta Type)) - (do ..monad - [definition (find-def name)] - (case definition - (#.Left de-aliased) - (find-type-def de-aliased) - - (#.Right [exported? def-type def-data def-value]) - (wrap (:coerce Type def-value))))) - -(def: #export (globals module) - {#.doc "The entire list of globals in a module (including the non-exported/private ones)."} - (-> Text (Meta (List [Text Global]))) - (function (_ compiler) - (case (get module (get@ #.modules compiler)) - #.None - (#try.Failure ($_ text@compose "Unknown module: " module)) - - (#.Some module) - (#try.Success [compiler (get@ #.definitions module)])))) - -(def: #export (definitions module) - {#.doc "The entire list of definitions in a module (including the non-exported/private ones)."} - (-> Text (Meta (List [Text Definition]))) - (:: ..monad map - (list.search-all (function (_ [name global]) - (case global - (#.Left de-aliased) - #.None - - (#.Right definition) - (#.Some [name definition])))) - (..globals module))) - -(def: #export (exports module-name) - {#.doc "All the exported definitions in a module."} - (-> Text (Meta (List [Text Definition]))) - (do ..monad - [constants (..definitions module-name)] - (wrap (do list.monad - [[name [exported? def-type def-data def-value]] constants] - (if exported? - (wrap [name [exported? def-type def-data def-value]]) - (list)))))) - -(def: #export modules - {#.doc "All the available modules (including the current one)."} - (Meta (List [Text Module])) - (function (_ compiler) - (|> compiler - (get@ #.modules) - [compiler] - #try.Success))) - -(def: #export (tags-of type-name) - {#.doc "All the tags associated with a type definition."} - (-> Name (Meta (Maybe (List Name)))) - (do ..monad - [#let [[module name] type-name] - module (find-module module)] - (case (get name (get@ #.types module)) - (#.Some [tags _]) - (wrap (#.Some tags)) - - _ - (wrap #.None)))) - -(def: #export cursor - {#.doc "The cursor of the current expression being analyzed."} - (Meta Cursor) - (function (_ compiler) - (#try.Success [compiler (get@ #.cursor compiler)]))) - -(def: #export expected-type - {#.doc "The expected type of the current expression being analyzed."} - (Meta Type) - (function (_ compiler) - (case (get@ #.expected compiler) - (#.Some type) - (#try.Success [compiler type]) - - #.None - (#try.Failure "Not expecting any type.")))) - -(def: #export (imported-modules module-name) - {#.doc "All the modules imported by a specified module."} - (-> Text (Meta (List Text))) - (do ..monad - [(^slots [#.imports]) (find-module module-name)] - (wrap imports))) - -(def: #export (imported-by? import module) - (-> Text Text (Meta Bit)) - (do ..monad - [(^slots [#.imports]) (find-module module)] - (wrap (list.any? (text@= import) imports)))) - -(def: #export (imported? import) - (-> Text (Meta Bit)) - (let [(^open ".") ..monad] - (|> current-module-name - (map find-module) join - (map (|>> (get@ #.imports) (list.any? (text@= import))))))) - -(def: #export (resolve-tag tag) - {#.doc "Given a tag, finds out what is its index, its related tag-list and it's associated type."} - (-> Name (Meta [Nat (List Name) Type])) - (do ..monad - [#let [[module name] tag] - =module (find-module module) - this-module-name current-module-name - imported! (..imported? module)] - (case (get name (get@ #.tags =module)) - (#.Some [idx tag-list exported? type]) - (if (or (text@= this-module-name module) - (and imported! exported?)) - (wrap [idx tag-list type]) - (fail ($_ text@compose "Cannot access tag: " (name@encode tag) " from module " this-module-name))) - - _ - (fail ($_ text@compose - "Unknown tag: " (name@encode tag) text.new-line - " Known tags: " (|> =module - (get@ #.tags) - (list@map (|>> product.left [module] name@encode (text.prefix text.new-line))) - (text.join-with "")) - ))))) - -(def: #export (tag-lists module) - {#.doc "All the tag-lists defined in a module, with their associated types."} - (-> Text (Meta (List [(List Name) Type]))) - (do ..monad - [=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."} - (Meta (List (List [Text Type]))) - (function (_ compiler) - (case (list.inits (get@ #.scopes compiler)) - #.None - (#try.Failure "No local environment") - - (#.Some scopes) - (#try.Success [compiler - (list@map (|>> (get@ [#.locals #.mappings]) - (list@map (function (_ [name [type _]]) - [name type]))) - scopes)])))) - -(def: #export (un-alias def-name) - {#.doc "Given an aliased definition's name, returns the original definition being referenced."} - (-> Name (Meta Name)) - (do ..monad - [constant (find-def def-name)] - (wrap (case constant - (#.Left real-def-name) - real-def-name - - (#.Right _) - def-name)))) - -(def: #export get-compiler - {#.doc "Obtains the current state of the compiler."} - (Meta Lux) - (function (_ compiler) - (#try.Success [compiler compiler]))) - -(def: #export type-context - (Meta Type-Context) - (function (_ compiler) - (#try.Success [compiler (get@ #.type-context compiler)]))) - -(template [ ] - [(macro: #export ( tokens) - {#.doc (doc "Performs a macro-expansion and logs the resulting code." - "You can either use the resulting code, or omit them." - "By omitting them, this macro produces nothing (just like the lux.comment macro)." - ( #omit - (def: (foo bar baz) - (-> Int Int Int) - (i.+ bar baz))))} - (case (: (Maybe [Bit Code]) - (case tokens - (^ (list [_ (#.Tag ["" "omit"])] - token)) - (#.Some [#1 token]) - - (^ (list token)) - (#.Some [#0 token]) - - _ - #.None)) - (#.Some [omit? token]) - (do ..monad - [cursor ..cursor - output ( token) - #let [_ (log! ($_ text@compose (name@encode (name-of )) " @ " (.cursor-description cursor))) - _ (list@map (|>> code.to-text log!) - output) - _ (log! "")]] - (wrap (if omit? - (list) - output))) - - #.None - (fail (..wrong-syntax-error (name-of )))))] - - [log-expand! expand] - [log-expand-all! expand-all] - [log-expand-once! expand-once] - ) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index 033a06e84..32c549a90 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -15,7 +15,8 @@ [collection ["." list ("#@." fold functor)] ["." dictionary]]] - ["." macro (#+ with-gensyms) + ["." meta (#+ with-gensyms)] + [macro ["." code] [syntax (#+ syntax:) [common @@ -28,19 +29,19 @@ body) (with-gensyms [g!_ g!type g!output] (let [g!name (code.identifier ["" name])] - (wrap (.list (` (syntax: (~+ (csw.export export)) ((~ g!name) {(~ g!type) s.identifier}) - (do macro.monad - [(~ g!type) (macro.find-type-def (~ g!type))] - (case (: (.Either .Text .Code) - ((~! .run) (p.rec - (function ((~ g!_) (~ g!name)) - (~ body))) - (~ g!type))) - (#.Left (~ g!output)) - (macro.fail (~ g!output)) + (wrap (.list (` ((~! syntax:) (~+ (csw.export export)) ((~ g!name) {(~ g!type) (~! s.identifier)}) + ((~! do) (~! meta.monad) + [(~ g!type) ((~! meta.find-type-def) (~ g!type))] + (case (: (.Either .Text .Code) + ((~! .run) ((~! p.rec) + (function ((~ g!_) (~ g!name)) + (~ body))) + (~ g!type))) + (#.Left (~ g!output)) + ((~! meta.fail) (~ g!output)) - (#.Right (~ g!output)) - ((~' wrap) (.list (~ g!output)))))))))))) + (#.Right (~ g!output)) + ((~' wrap) (.list (~ g!output)))))))))))) (def: (common-poly-name? poly-func) (-> Text Bit) @@ -56,8 +57,8 @@ {?name (p.maybe s.local-identifier)} {[poly-func poly-args] (s.form (p.and s.identifier (p.many s.identifier)))} {?custom-impl (p.maybe s.any)}) - (do {@ macro.monad} - [poly-args (monad.map @ macro.normalize poly-args) + (do {@ meta.monad} + [poly-args (monad.map @ meta.normalize poly-args) name (case ?name (#.Some name) (wrap name) @@ -110,11 +111,11 @@ (~ (to-code env right))))) ([#.Function] [#.Apply]) - (^template [ ] + (^template [ ] ( left right) (` ( (~+ (list@map (to-code env) ( type)))))) - ([#.Sum | type.flatten-variant] - [#.Product & type.flatten-tuple]) + ([| #.Sum type.flatten-variant] + [& #.Product type.flatten-tuple]) (#.Named name sub-type) (code.identifier name) diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index b8c452311..4963ef943 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -14,8 +14,9 @@ ["." frac]] ["." text ("#@." monoid)] [collection - ["." list ("#@." functor)]]]] - ["." // (#+ with-gensyms) + ["." list ("#@." functor)]]] + ["." meta (#+ with-gensyms)]] + [// ["." code]]) (def: (join-pairs pairs) @@ -64,7 +65,7 @@ (case ?parts (#.Some [name args meta body]) (with-gensyms [g!tokens g!body g!error] - (do {@ //.monad} + (do {@ meta.monad} [vars+parsers (monad.map @ (: (-> Code (Meta [Code Code])) (function (_ arg) @@ -76,11 +77,11 @@ (wrap [(code.identifier var-name) (` (~! .any))]) _ - (//.fail "Syntax pattern expects records or identifiers.")))) + (meta.fail "Syntax pattern expects records or identifiers.")))) args) - this-module //.current-module-name + this-module meta.current-module-name #let [g!state (code.identifier ["" "*compiler*"]) - error-msg (code.text (//.wrong-syntax-error [this-module name])) + error-msg (code.text (meta.wrong-syntax-error [this-module name])) export-ast (: (List Code) (if exported? (list (' #export)) @@ -100,4 +101,4 @@ (~ g!tokens))))))))) _ - (//.fail (//.wrong-syntax-error (name-of ..syntax:)))))) + (meta.fail (meta.wrong-syntax-error (name-of ..syntax:)))))) diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux index 989d2a0e2..680162742 100644 --- a/stdlib/source/lux/macro/syntax/common/reader.lux +++ b/stdlib/source/lux/macro/syntax/common/reader.lux @@ -10,9 +10,10 @@ ["." product] ["." maybe] [collection - ["." list]]]] + ["." list]]] + ["." meta]] ["." // - ["#//" /// + [/// [syntax (#+ syntax:)]]]) (def: #export export @@ -106,8 +107,8 @@ (do {@ p.monad} [definition-raw s.any me-definition-raw (|> definition-raw - ////.expand-all - (////.run compiler) + meta.expand-all + (meta.run compiler) p.lift)] (s.local me-definition-raw (s.form (do @ diff --git a/stdlib/source/lux/macro/template.lux b/stdlib/source/lux/macro/template.lux index 737efe433..22d8d9251 100644 --- a/stdlib/source/lux/macro/template.lux +++ b/stdlib/source/lux/macro/template.lux @@ -14,10 +14,11 @@ ["." rev ("#@." decimal)] ["." frac ("#@." decimal)]] [collection - ["." list ("#@." monad)]]]] - ["." // - ["." code] - [syntax (#+ syntax:)]]) + ["." list ("#@." monad)]]] + ["." meta]] + [// + [syntax (#+ syntax:)] + ["." code]]) (syntax: #export (splice {parts (s.tuple (p.some s.any))}) (wrap parts)) @@ -27,9 +28,9 @@ (syntax: #export (with-locals {locals (s.tuple (p.some s.local-identifier))} body) - (do {@ //.monad} + (do {@ meta.monad} [g!locals (|> locals - (list@map //.gensym) + (list@map meta.gensym) (monad.seq @))] (wrap (list (` (.with-expansions [(~+ (|> (list.zip2 locals g!locals) (list@map (function (_ [name identifier]) diff --git a/stdlib/source/lux/meta.lux b/stdlib/source/lux/meta.lux new file mode 100644 index 000000000..4a05763ce --- /dev/null +++ b/stdlib/source/lux/meta.lux @@ -0,0 +1,701 @@ +(.module: {#.doc "Functions for extracting information from the state of the compiler."} + [lux #* + [abstract + [functor (#+ Functor)] + [apply (#+ Apply)] + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)]] + [data + ["." product] + ["." name ("#@." codec equivalence)] + ["." maybe] + [number + ["n" nat] + ["i" int]] + ["." text ("#@." monoid equivalence)] + [collection + ["." list ("#@." monoid monad)]]] + [macro + ["." code]]]) + +## (type: (Meta a) +## (-> Lux (Try [Lux a]))) + +(structure: #export functor + (Functor Meta) + + (def: (map f fa) + (function (_ compiler) + (case (fa compiler) + (#try.Failure msg) + (#try.Failure msg) + + (#try.Success [compiler' a]) + (#try.Success [compiler' (f a)]))))) + +(structure: #export apply + (Apply Meta) + + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ compiler) + (case (ff compiler) + (#try.Success [compiler' f]) + (case (fa compiler') + (#try.Success [compiler'' a]) + (#try.Success [compiler'' (f a)]) + + (#try.Failure msg) + (#try.Failure msg)) + + (#try.Failure msg) + (#try.Failure msg))))) + +(structure: #export monad + (Monad Meta) + + (def: &functor ..functor) + + (def: (wrap x) + (function (_ compiler) + (#try.Success [compiler x]))) + + (def: (join mma) + (function (_ compiler) + (case (mma compiler) + (#try.Failure msg) + (#try.Failure msg) + + (#try.Success [compiler' ma]) + (ma compiler'))))) + +(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] (-> Lux (Meta a) (Try [Lux a]))) + (action compiler)) + +(def: #export (run compiler action) + (All [a] (-> Lux (Meta a) (Try a))) + (case (action compiler) + (#try.Failure error) + (#try.Failure error) + + (#try.Success [_ output]) + (#try.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) + (#try.Failure error) + (right compiler) + + (#try.Success [compiler' output]) + (#try.Success [compiler' output])))) + +(def: #export (assert message test) + {#.doc "Fails with the given message if the test is #0."} + (-> Text Bit (Meta Any)) + (function (_ compiler) + (if test + (#try.Success [compiler []]) + (#try.Failure message)))) + +(def: #export (fail msg) + {#.doc "Fails with the given message."} + (All [a] + (-> Text (Meta a))) + (function (_ _) + (#try.Failure msg))) + +(def: #export (find-module name) + (-> Text (Meta Module)) + (function (_ compiler) + (case (get name (get@ #.modules compiler)) + (#.Some module) + (#try.Success [compiler module]) + + _ + (#try.Failure ($_ text@compose "Unknown module: " name))))) + +(def: #export current-module-name + (Meta Text) + (function (_ compiler) + (case (get@ #.current-module compiler) + (#.Some current-module) + (#try.Success [compiler current-module]) + + _ + (#try.Failure "No current module.") + ))) + +(def: #export current-module + (Meta Module) + (do ..monad + [this-module-name current-module-name] + (find-module this-module-name))) + +(def: (macro-type? type) + (-> Type Bit) + (case type + (#.Named ["lux" "Macro"] (#.Primitive "#Macro" #.Nil)) + true + + _ + false)) + +(def: (find-macro' modules this-module module name) + (-> (List [Text Module]) Text Text Text + (Maybe Macro)) + (do maybe.monad + [$module (get module modules) + definition (: (Maybe Global) + (|> (: Module $module) + (get@ #.definitions) + (get name)))] + (case definition + (#.Left [r-module r-name]) + (find-macro' modules this-module r-module r-name) + + (#.Right [exported? def-type def-anns def-value]) + (if (macro-type? def-type) + (#.Some (:coerce Macro def-value)) + #.None)))) + +(def: #export (normalize name) + {#.doc (doc "If given a name without a module prefix, gives it the current module's name as prefix." + "Otherwise, returns the name as-is.")} + (-> Name (Meta Name)) + (case name + ["" name] + (do ..monad + [module-name current-module-name] + (wrap [module-name name])) + + _ + (:: ..monad wrap name))) + +(def: #export (find-macro full-name) + (-> Name (Meta (Maybe Macro))) + (do ..monad + [[module name] (normalize full-name) + this-module current-module-name] + (: (Meta (Maybe Macro)) + (function (_ compiler) + (#try.Success [compiler (find-macro' (get@ #.modules compiler) this-module module name)]))))) + +(def: #export (expand-once syntax) + {#.doc (doc "Given code that requires applying a macro, does it once and returns the result." + "Otherwise, returns the code as-is.")} + (-> Code (Meta (List Code))) + (case syntax + [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] + (do ..monad + [?macro (find-macro name)] + (case ?macro + (#.Some macro) + ((:coerce Macro' macro) args) + + #.None + (:: ..monad wrap (list syntax)))) + + _ + (:: ..monad wrap (list syntax)))) + +(def: #export (expand syntax) + {#.doc (doc "Given code that requires applying a macro, expands repeatedly until no more direct macro-calls are left." + "Otherwise, returns the code as-is.")} + (-> Code (Meta (List Code))) + (case syntax + [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] + (do ..monad + [?macro (find-macro name)] + (case ?macro + (#.Some macro) + (do ..monad + [expansion ((:coerce Macro' macro) args) + expansion' (monad.map ..monad expand expansion)] + (wrap (list@join expansion'))) + + #.None + (:: ..monad wrap (list syntax)))) + + _ + (:: ..monad wrap (list syntax)))) + +(def: #export (expand-all syntax) + {#.doc "Expands all macro-calls everywhere recursively, until only primitive/base code remains."} + (-> Code (Meta (List Code))) + (case syntax + [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] + (do ..monad + [?macro (find-macro name)] + (case ?macro + (#.Some macro) + (do ..monad + [expansion ((:coerce Macro' macro) args) + expansion' (monad.map ..monad expand-all expansion)] + (wrap (list@join expansion'))) + + #.None + (do ..monad + [parts' (monad.map ..monad expand-all (list& (code.identifier name) args))] + (wrap (list (code.form (list@join parts'))))))) + + [_ (#.Form (#.Cons [harg targs]))] + (do ..monad + [harg+ (expand-all harg) + targs+ (monad.map ..monad expand-all targs)] + (wrap (list (code.form (list@compose harg+ (list@join (: (List (List Code)) targs+))))))) + + [_ (#.Tuple members)] + (do ..monad + [members' (monad.map ..monad expand-all members)] + (wrap (list (code.tuple (list@join members'))))) + + _ + (:: ..monad wrap (list syntax)))) + +(def: #export count + (Meta Nat) + (function (_ compiler) + (#try.Success [(update@ #.seed inc compiler) + (get@ #.seed compiler)]))) + +(def: #export (gensym prefix) + {#.doc (doc "Generates a unique name as an Code 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 (Meta Code)) + (do ..monad + [id ..count] + (wrap (|> id + (:: n.decimal encode) + ($_ text@compose "__gensym__" prefix) + [""] code.identifier)))) + +(def: (get-local-identifier ast) + (-> Code (Meta Text)) + (case ast + [_ (#.Identifier [_ name])] + (:: ..monad wrap name) + + _ + (fail (text@compose "Code is not a local identifier: " (code.to-text ast))))) + +(def: #export wrong-syntax-error + (-> Name Text) + (|>> name@encode + (text@compose "Wrong syntax for "))) + +(macro: #export (with-gensyms tokens) + {#.doc (doc "Creates new identifiers 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 [_ (#.Tuple identifiers)] body)) + (do {@ ..monad} + [identifier-names (monad.map @ get-local-identifier identifiers) + #let [identifier-defs (list@join (list@map (: (-> Text (List Code)) + (function (_ name) (list (code.identifier ["" name]) (` (gensym (~ (code.text name))))))) + identifier-names))]] + (wrap (list (` ((~! do) (~! ..monad) + [(~+ identifier-defs)] + (~ body)))))) + + _ + (fail (..wrong-syntax-error (name-of ..with-gensyms))))) + +(def: #export (expand-1 token) + {#.doc "Works just like expand, except that it ensures that the output is a single Code token."} + (-> Code (Meta Code)) + (do ..monad + [token+ (expand token)] + (case token+ + (^ (list token')) + (wrap token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(def: #export (module-exists? module) + (-> Text (Meta Bit)) + (function (_ compiler) + (#try.Success [compiler (case (get module (get@ #.modules compiler)) + (#.Some _) + #1 + + #.None + #0)]))) + +(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: (find-type-var idx bindings) + (-> Nat (List [Nat (Maybe Type)]) (Maybe Type)) + (case bindings + #.Nil + #.None + + (#.Cons [var bound] bindings') + (if (n.= idx var) + bound + (find-type-var idx bindings')))) + +(def: (clean-type type) + (-> Type (Meta Type)) + (case type + (#.Var var) + (function (_ compiler) + (case (|> compiler + (get@ [#.type-context #.var-bindings]) + (find-type-var var)) + (^or #.None (#.Some (#.Var _))) + (#try.Success [compiler type]) + + (#.Some type') + (#try.Success [compiler type']))) + + _ + (:: ..monad wrap type))) + +(def: #export (find-var-type name) + {#.doc "Looks-up the type of a local variable somewhere in the environment."} + (-> Text (Meta Type)) + (function (_ compiler) + (let [test (: (-> [Text [Type Any]] Bit) + (|>> product.left (text@= name)))] + (case (do maybe.monad + [scope (list.find (function (_ env) + (or (list.any? test (: (List [Text [Type Any]]) + (get@ [#.locals #.mappings] env))) + (list.any? test (: (List [Text [Type Any]]) + (get@ [#.captured #.mappings] env))))) + (get@ #.scopes compiler)) + [_ [type _]] (try-both (list.find test) + (: (List [Text [Type Any]]) + (get@ [#.locals #.mappings] scope)) + (: (List [Text [Type Any]]) + (get@ [#.captured #.mappings] scope)))] + (wrap type)) + (#.Some var-type) + ((clean-type var-type) compiler) + + #.None + (#try.Failure ($_ 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)."} + (-> Name (Meta Global)) + (do ..monad + [name (normalize name)] + (function (_ compiler) + (case (: (Maybe Global) + (do maybe.monad + [#let [[v-prefix v-name] name] + (^slots [#.definitions]) (get v-prefix (get@ #.modules compiler))] + (get v-name definitions))) + (#.Some definition) + (#try.Success [compiler definition]) + + _ + (let [current-module (|> compiler (get@ #.current-module) (maybe.default "???")) + separator ($_ text@compose text.new-line " ")] + (#try.Failure ($_ text@compose + "Unknown definition: " (name@encode name) text.new-line + " Current module: " current-module text.new-line + (case (get current-module (get@ #.modules compiler)) + (#.Some this-module) + ($_ text@compose + " Imports: " (|> this-module (get@ #.imports) (text.join-with separator)) text.new-line + " Aliases: " (|> this-module (get@ #.module-aliases) (list@map (function (_ [alias real]) ($_ text@compose alias " => " real))) (text.join-with separator)) text.new-line) + + _ + "") + " All Known modules: " (|> compiler (get@ #.modules) (list@map product.left) (text.join-with separator)) text.new-line))))))) + +(def: #export (find-export name) + {#.doc "Looks-up a definition's type in the available modules (including the current one)."} + (-> Name (Meta Definition)) + (do ..monad + [definition (..find-def name)] + (case definition + (#.Left de-aliased) + (fail ($_ text@compose + "Aliases are not considered exports: " + (name@encode name))) + + (#.Right definition) + (let [[exported? def-type def-data def-value] definition] + (if exported? + (wrap definition) + (fail ($_ text@compose "Definition is not an export: " (name@encode name)))))))) + +(def: #export (find-def-type name) + {#.doc "Looks-up a definition's type in the available modules (including the current one)."} + (-> Name (Meta Type)) + (do ..monad + [definition (find-def name)] + (case definition + (#.Left de-aliased) + (find-def-type de-aliased) + + (#.Right [exported? def-type def-data def-value]) + (clean-type def-type)))) + +(def: #export (find-type name) + {#.doc "Looks-up the type of either a local variable or a definition."} + (-> Name (Meta Type)) + (do ..monad + [#let [[_ _name] name]] + (case name + ["" _name] + (either (find-var-type _name) + (find-def-type name)) + + _ + (find-def-type name)))) + +(def: #export (find-type-def name) + {#.doc "Finds the value of a type definition (such as Int, Any or Lux)."} + (-> Name (Meta Type)) + (do ..monad + [definition (find-def name)] + (case definition + (#.Left de-aliased) + (find-type-def de-aliased) + + (#.Right [exported? def-type def-data def-value]) + (wrap (:coerce Type def-value))))) + +(def: #export (globals module) + {#.doc "The entire list of globals in a module (including the non-exported/private ones)."} + (-> Text (Meta (List [Text Global]))) + (function (_ compiler) + (case (get module (get@ #.modules compiler)) + #.None + (#try.Failure ($_ text@compose "Unknown module: " module)) + + (#.Some module) + (#try.Success [compiler (get@ #.definitions module)])))) + +(def: #export (definitions module) + {#.doc "The entire list of definitions in a module (including the non-exported/private ones)."} + (-> Text (Meta (List [Text Definition]))) + (:: ..monad map + (list.search-all (function (_ [name global]) + (case global + (#.Left de-aliased) + #.None + + (#.Right definition) + (#.Some [name definition])))) + (..globals module))) + +(def: #export (exports module-name) + {#.doc "All the exported definitions in a module."} + (-> Text (Meta (List [Text Definition]))) + (do ..monad + [constants (..definitions module-name)] + (wrap (do list.monad + [[name [exported? def-type def-data def-value]] constants] + (if exported? + (wrap [name [exported? def-type def-data def-value]]) + (list)))))) + +(def: #export modules + {#.doc "All the available modules (including the current one)."} + (Meta (List [Text Module])) + (function (_ compiler) + (|> compiler + (get@ #.modules) + [compiler] + #try.Success))) + +(def: #export (tags-of type-name) + {#.doc "All the tags associated with a type definition."} + (-> Name (Meta (Maybe (List Name)))) + (do ..monad + [#let [[module name] type-name] + module (find-module module)] + (case (get name (get@ #.types module)) + (#.Some [tags _]) + (wrap (#.Some tags)) + + _ + (wrap #.None)))) + +(def: #export cursor + {#.doc "The cursor of the current expression being analyzed."} + (Meta Cursor) + (function (_ compiler) + (#try.Success [compiler (get@ #.cursor compiler)]))) + +(def: #export expected-type + {#.doc "The expected type of the current expression being analyzed."} + (Meta Type) + (function (_ compiler) + (case (get@ #.expected compiler) + (#.Some type) + (#try.Success [compiler type]) + + #.None + (#try.Failure "Not expecting any type.")))) + +(def: #export (imported-modules module-name) + {#.doc "All the modules imported by a specified module."} + (-> Text (Meta (List Text))) + (do ..monad + [(^slots [#.imports]) (..find-module module-name)] + (wrap imports))) + +(def: #export (imported-by? import module) + (-> Text Text (Meta Bit)) + (do ..monad + [(^slots [#.imports]) (..find-module module)] + (wrap (list.any? (text@= import) imports)))) + +(def: #export (imported? import) + (-> Text (Meta Bit)) + (let [(^open ".") ..monad] + (|> ..current-module-name + (map ..find-module) join + (map (|>> (get@ #.imports) (list.any? (text@= import))))))) + +(def: #export (resolve-tag tag) + {#.doc "Given a tag, finds out what is its index, its related tag-list and it's associated type."} + (-> Name (Meta [Nat (List Name) Type])) + (do ..monad + [#let [[module name] tag] + =module (..find-module module) + this-module-name ..current-module-name + imported! (..imported? module)] + (case (get name (get@ #.tags =module)) + (#.Some [idx tag-list exported? type]) + (if (or (text@= this-module-name module) + (and imported! exported?)) + (wrap [idx tag-list type]) + (..fail ($_ text@compose "Cannot access tag: " (name@encode tag) " from module " this-module-name))) + + _ + (..fail ($_ text@compose + "Unknown tag: " (name@encode tag) text.new-line + " Known tags: " (|> =module + (get@ #.tags) + (list@map (|>> product.left [module] name@encode (text.prefix text.new-line))) + (text.join-with "")) + ))))) + +(def: #export (tag-lists module) + {#.doc "All the tag-lists defined in a module, with their associated types."} + (-> Text (Meta (List [(List Name) Type]))) + (do ..monad + [=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."} + (Meta (List (List [Text Type]))) + (function (_ compiler) + (case (list.inits (get@ #.scopes compiler)) + #.None + (#try.Failure "No local environment") + + (#.Some scopes) + (#try.Success [compiler + (list@map (|>> (get@ [#.locals #.mappings]) + (list@map (function (_ [name [type _]]) + [name type]))) + scopes)])))) + +(def: #export (un-alias def-name) + {#.doc "Given an aliased definition's name, returns the original definition being referenced."} + (-> Name (Meta Name)) + (do ..monad + [constant (..find-def def-name)] + (wrap (case constant + (#.Left real-def-name) + real-def-name + + (#.Right _) + def-name)))) + +(def: #export get-compiler + {#.doc "Obtains the current state of the compiler."} + (Meta Lux) + (function (_ compiler) + (#try.Success [compiler compiler]))) + +(def: #export type-context + (Meta Type-Context) + (function (_ compiler) + (#try.Success [compiler (get@ #.type-context compiler)]))) + +(template [ ] + [(macro: #export ( tokens) + {#.doc (doc "Performs a macro-expansion and logs the resulting code." + "You can either use the resulting code, or omit them." + "By omitting them, this macro produces nothing (just like the lux.comment macro)." + ( #omit + (def: (foo bar baz) + (-> Int Int Int) + (i.+ bar baz))))} + (case (: (Maybe [Bit Code]) + (case tokens + (^ (list [_ (#.Tag ["" "omit"])] + token)) + (#.Some [#1 token]) + + (^ (list token)) + (#.Some [#0 token]) + + _ + #.None)) + (#.Some [omit? token]) + (do ..monad + [cursor ..cursor + output ( token) + #let [_ (log! ($_ text@compose (name@encode (name-of )) " @ " (.cursor-description cursor))) + _ (list@map (|>> code.to-text log!) + output) + _ (log! "")]] + (wrap (if omit? + (list) + output))) + + #.None + (fail (..wrong-syntax-error (name-of )))))] + + [log-expand! expand] + [log-expand-all! expand-all] + [log-expand-once! expand-once] + ) diff --git a/stdlib/source/lux/target/jvm/modifier.lux b/stdlib/source/lux/target/jvm/modifier.lux index c849e9020..c9fd34125 100644 --- a/stdlib/source/lux/target/jvm/modifier.lux +++ b/stdlib/source/lux/target/jvm/modifier.lux @@ -16,7 +16,8 @@ ["." list ("#@." functor)]]] [type abstract] - [macro (#+ with-gensyms) + [meta (#+ with-gensyms)] + [macro [syntax (#+ syntax:)] ["." code]]] ["." // #_ diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index e529fdd19..a62a056db 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -26,7 +26,8 @@ ["." duration (#+ Duration)]] [math ["." random (#+ Random) ("#@." monad)]] - ["." macro + ["." meta] + [macro [syntax (#+ syntax:)] ["." code]]]) @@ -259,8 +260,8 @@ (code.text (name.short name))))) (syntax: (reference {name .identifier}) - (do macro.monad - [_ (macro.find-export name)] + (do meta.monad + [_ (meta.find-export name)] (wrap (list (name-code name))))) (template [ ] @@ -305,9 +306,9 @@ (syntax: #export (covering {module .identifier} test) - (do macro.monad + (do meta.monad [#let [module (name.module module)] - definitions (macro.definitions module) + definitions (meta.definitions module) #let [coverage (|> definitions (list.filter (|>> product.right product.left)) (list@map product.left) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux index 1de24a1c0..5d5aa835d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux @@ -7,7 +7,7 @@ ["." try]] [type ["." check (#+ Check)]] - ["." macro]] + ["." meta]] ["." /// #_ ["#." extension] [// @@ -39,7 +39,7 @@ (def: #export (infer actualT) (-> Type (Operation Any)) (do ///.monad - [expectedT (///extension.lift macro.expected-type)] + [expectedT (///extension.lift meta.expected-type)] (with-env (check.check expectedT actualT)))) diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux index 0356d6b85..ed0dc3ce9 100644 --- a/stdlib/source/lux/type.lux +++ b/stdlib/source/lux/type.lux @@ -17,7 +17,8 @@ [collection ["." array] ["." list ("#@." functor monoid fold)]]] - ["." macro + ["." meta] + [macro ["." code] [syntax (#+ syntax:)]]]) @@ -356,9 +357,9 @@ s.any)}) (case input (#.Left valueN) - (do macro.monad - [cursor macro.cursor - valueT (macro.find-type valueN) + (do meta.monad + [cursor meta.cursor + valueT (meta.find-type valueN) #let [_ (log! ($_ text@compose (name@encode (name-of ..:log!)) " @ " (.cursor-description cursor) text.new-line "Value: " (name@encode valueN) text.new-line @@ -366,7 +367,7 @@ (wrap (list (code.identifier valueN)))) (#.Right valueC) - (macro.with-gensyms [g!value] + (meta.with-gensyms [g!value] (wrap (list (` (.let [(~ g!value) (~ valueC)] (..:log! (~ g!value))))))))) @@ -400,7 +401,7 @@ (syntax: #export (:share {type-vars type-parameters} {exemplar typed} {computation typed}) - (macro.with-gensyms [g!_] + (meta.with-gensyms [g!_] (let [shareC (` (: (All [(~+ (list@map code.local-identifier type-vars))] (-> (~ (get@ #type exemplar)) (~ (get@ #type computation)))) @@ -424,7 +425,7 @@ ["Type" (..to-text type)])) (syntax: #export (:hole) - (do macro.monad - [cursor macro.cursor - expectedT macro.expected-type] - (macro.fail (exception.construct ..hole-type [cursor expectedT])))) + (do meta.monad + [cursor meta.cursor + expectedT meta.expected-type] + (meta.fail (exception.construct ..hole-type [cursor expectedT])))) diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux index 227cfb3be..6f07e1deb 100644 --- a/stdlib/source/lux/type/abstract.lux +++ b/stdlib/source/lux/type/abstract.lux @@ -12,7 +12,8 @@ [collection ["." list ("#@." functor monoid)] ["." stack (#+ Stack)]]] - ["." macro ("#@." monad) + ["." meta] + [macro ["." code] [syntax (#+ syntax:) ["cs" common @@ -155,7 +156,7 @@ (template [ ] [(syntax: #export ( {[scope value] cast}) - (do macro.monad + (do meta.monad [[name type-vars abstraction representation] (peek! scope)] (wrap (list (` ((~! :cast) [(~+ type-vars)] (~ ) (~ ) (~ value)))))))] @@ -190,8 +191,8 @@ representation-type {annotations (<>.default cs.empty-annotations csr.annotations)} {primitives (<>.some .any)}) - (do macro.monad - [current-module macro.current-module-name + (do meta.monad + [current-module meta.current-module-name #let [type-varsC (list@map code.local-identifier type-vars) abstraction-declaration (` ((~ (code.local-identifier name)) (~+ type-varsC))) representation-declaration (` ((~ (code.local-identifier (representation-definition-name name))) diff --git a/stdlib/source/lux/type/dynamic.lux b/stdlib/source/lux/type/dynamic.lux index 1031f8f41..be017585e 100644 --- a/stdlib/source/lux/type/dynamic.lux +++ b/stdlib/source/lux/type/dynamic.lux @@ -7,7 +7,8 @@ [data [text ["%" format (#+ format)]]] - [macro (#+ with-gensyms) + [meta (#+ with-gensyms)] + [macro ["." syntax (#+ syntax:)]] ["." type abstract]]) diff --git a/stdlib/source/lux/type/implicit.lux b/stdlib/source/lux/type/implicit.lux index 9944fb488..4fb030df4 100644 --- a/stdlib/source/lux/type/implicit.lux +++ b/stdlib/source/lux/type/implicit.lux @@ -17,7 +17,8 @@ [collection ["." list ("#@." monad fold)] ["dict" dictionary (#+ Dictionary)]]] - ["." macro + ["." meta] + [macro ["." code] [syntax (#+ syntax:)]] [meta @@ -35,20 +36,20 @@ (find-type-var id' env) _ - (:: macro.monad wrap type)) + (:: meta.monad wrap type)) (#.Some [_ #.None]) - (macro.fail (format "Unbound type-var " (%.nat id))) + (meta.fail (format "Unbound type-var " (%.nat id))) #.None - (macro.fail (format "Unknown type-var " (%.nat id))) + (meta.fail (format "Unknown type-var " (%.nat id))) )) (def: (resolve-type var-name) (-> Name (Meta Type)) - (do macro.monad - [raw-type (macro.find-type var-name) - compiler macro.get-compiler] + (do meta.monad + [raw-type (meta.find-type var-name) + compiler meta.get-compiler] (case raw-type (#.Var id) (find-type-var id (get@ #.type-context compiler)) @@ -84,35 +85,35 @@ (-> Name (Meta Name)) (case member ["" simple-name] - (macro.either (do macro.monad - [member (macro.normalize member) - _ (macro.resolve-tag member)] - (wrap member)) - (do {@ macro.monad} - [this-module-name macro.current-module-name - imp-mods (macro.imported-modules this-module-name) - tag-lists (monad.map @ macro.tag-lists imp-mods) - #let [tag-lists (|> tag-lists list@join (list@map product.left) list@join) - candidates (list.filter (|>> product.right (text@= simple-name)) - tag-lists)]] - (case candidates - #.Nil - (macro.fail (format "Unknown tag: " (%.name member))) - - (#.Cons winner #.Nil) - (wrap winner) - - _ - (macro.fail (format "Too many candidate tags: " (%.list %.name candidates)))))) + (meta.either (do meta.monad + [member (meta.normalize member) + _ (meta.resolve-tag member)] + (wrap member)) + (do {@ meta.monad} + [this-module-name meta.current-module-name + imp-mods (meta.imported-modules this-module-name) + tag-lists (monad.map @ meta.tag-lists imp-mods) + #let [tag-lists (|> tag-lists list@join (list@map product.left) list@join) + candidates (list.filter (|>> product.right (text@= simple-name)) + tag-lists)]] + (case candidates + #.Nil + (meta.fail (format "Unknown tag: " (%.name member))) + + (#.Cons winner #.Nil) + (wrap winner) + + _ + (meta.fail (format "Too many candidate tags: " (%.list %.name candidates)))))) _ - (:: macro.monad wrap member))) + (:: meta.monad wrap member))) (def: (resolve-member member) (-> Name (Meta [Nat Type])) - (do macro.monad + (do meta.monad [member (find-member-name member) - [idx tag-list sig-type] (macro.resolve-tag member)] + [idx tag-list sig-type] (meta.resolve-tag member)] (wrap [idx sig-type]))) (def: (prepare-definitions source-module target-module constants) @@ -127,8 +128,8 @@ (def: local-env (Meta (List [Name Type])) - (do macro.monad - [local-batches macro.locals + (do meta.monad + [local-batches meta.locals #let [total-locals (list@fold (function (_ [name type] table) (try.default table (dict.try-put name type table))) (: (Dictionary Text Type) @@ -140,19 +141,19 @@ (def: local-structs (Meta (List [Name Type])) - (do {@ macro.monad} - [this-module-name macro.current-module-name] + (do {@ meta.monad} + [this-module-name meta.current-module-name] (:: @ map (prepare-definitions this-module-name this-module-name) - (macro.definitions this-module-name)))) + (meta.definitions this-module-name)))) (def: import-structs (Meta (List [Name Type])) - (do {@ macro.monad} - [this-module-name macro.current-module-name - imp-mods (macro.imported-modules this-module-name) + (do {@ meta.monad} + [this-module-name meta.current-module-name + imp-mods (meta.imported-modules this-module-name) export-batches (monad.map @ (function (_ imp-mod) (:: @ map (prepare-definitions imp-mod this-module-name) - (macro.definitions imp-mod))) + (meta.definitions imp-mod))) imp-mods)] (wrap (list@join export-batches)))) @@ -207,8 +208,8 @@ (-> (-> Lux Type-Context Type (Check Instance)) Type-Context Type (List [Name Type]) (Meta (List Instance))) - (do macro.monad - [compiler macro.get-compiler] + (do meta.monad + [compiler meta.get-compiler] (case (|> alts (list@map (function (_ [alt-name alt-type]) (case (check.run context @@ -226,18 +227,18 @@ (list [alt-name =deps])))) list@join) #.Nil - (macro.fail (format "No candidates for provisioning: " (%.type dep))) + (meta.fail (format "No candidates for provisioning: " (%.type dep))) found (wrap found)))) (def: (provision compiler context dep) (-> Lux Type-Context Type (Check Instance)) - (case (macro.run compiler - ($_ macro.either - (do macro.monad [alts ..local-env] (..test-provision provision context dep alts)) - (do macro.monad [alts ..local-structs] (..test-provision provision context dep alts)) - (do macro.monad [alts ..import-structs] (..test-provision provision context dep alts)))) + (case (meta.run compiler + ($_ meta.either + (do meta.monad [alts ..local-env] (..test-provision provision context dep alts)) + (do meta.monad [alts ..local-structs] (..test-provision provision context dep alts)) + (do meta.monad [alts ..import-structs] (..test-provision provision context dep alts)))) (#.Left error) (check.fail error) @@ -255,9 +256,9 @@ (def: (test-alternatives sig-type member-idx input-types output-type alts) (-> Type Nat (List Type) Type (List [Name Type]) (Meta (List Instance))) - (do macro.monad - [compiler macro.get-compiler - context macro.type-context] + (do meta.monad + [compiler meta.get-compiler + context meta.type-context] (case (|> alts (list@map (function (_ [alt-name alt-type]) (case (check.run context @@ -277,7 +278,7 @@ (list [alt-name =deps])))) list@join) #.Nil - (macro.fail (format "No alternatives for " (%.type (type.function input-types output-type)))) + (meta.fail (format "No alternatives for " (%.type (type.function input-types output-type)))) found (wrap found)))) @@ -285,10 +286,10 @@ (def: (find-alternatives sig-type member-idx input-types output-type) (-> Type Nat (List Type) Type (Meta (List Instance))) (let [test (test-alternatives sig-type member-idx input-types output-type)] - ($_ macro.either - (do macro.monad [alts local-env] (test alts)) - (do macro.monad [alts local-structs] (test alts)) - (do macro.monad [alts import-structs] (test alts))))) + ($_ meta.either + (do meta.monad [alts local-env] (test alts)) + (do meta.monad [alts local-structs] (test alts)) + (do meta.monad [alts import-structs] (test alts))))) (def: (var? input) (-> Code Bit) @@ -341,14 +342,14 @@ "Otherwise, this macro will not find it.")} (case args (#.Left [args _]) - (do {@ macro.monad} + (do {@ meta.monad} [[member-idx sig-type] (resolve-member member) input-types (monad.map @ resolve-type args) - output-type macro.expected-type + output-type meta.expected-type chosen-ones (find-alternatives sig-type member-idx input-types output-type)] (case chosen-ones #.Nil - (macro.fail (format "No structure option could be found for member: " (%.name member))) + (meta.fail (format "No structure option could be found for member: " (%.name member))) (#.Cons chosen #.Nil) (wrap (list (` (:: (~ (instance$ chosen)) @@ -356,31 +357,31 @@ (~+ (list@map code.identifier args)))))) _ - (macro.fail (format "Too many options available: " - (|> chosen-ones - (list@map (|>> product.left %.name)) - (text.join-with ", ")) - " --- for type: " (%.type sig-type))))) + (meta.fail (format "Too many options available: " + (|> chosen-ones + (list@map (|>> product.left %.name)) + (text.join-with ", ")) + " --- for type: " (%.type sig-type))))) (#.Right [args _]) - (do {@ macro.monad} - [labels (|> (macro.gensym "") (list.repeat (list.size args)) (monad.seq @))] + (do {@ meta.monad} + [labels (|> (meta.gensym "") (list.repeat (list.size args)) (monad.seq @))] (wrap (list (` (let [(~+ (|> (list.zip2 labels args) (list@map join-pair) list@join))] (..::: (~ (code.identifier member)) (~+ labels))))))) )) (def: (implicit-bindings amount) (-> Nat (Meta (List Code))) - (|> (macro.gensym "g!implicit") + (|> (meta.gensym "g!implicit") (list.repeat amount) - (monad.seq macro.monad))) + (monad.seq meta.monad))) (def: implicits (Parser (List Code)) (s.tuple (p.many s.any))) (syntax: #export (implicit {structures ..implicits} body) - (do macro.monad + (do meta.monad [g!implicit+ (implicit-bindings (list.size structures))] (wrap (list (` (let [(~+ (|> (list.zip2 g!implicit+ structures) (list@map (function (_ [g!implicit structure]) @@ -389,7 +390,7 @@ (~ body))))))) (syntax: #export (implicit: {structures ..implicits}) - (do macro.monad + (do meta.monad [g!implicit+ (implicit-bindings (list.size structures))] (wrap (|> (list.zip2 g!implicit+ structures) (list@map (function (_ [g!implicit structure]) diff --git a/stdlib/source/lux/type/refinement.lux b/stdlib/source/lux/type/refinement.lux index 210dd18d3..1daa8ff1b 100644 --- a/stdlib/source/lux/type/refinement.lux +++ b/stdlib/source/lux/type/refinement.lux @@ -2,7 +2,8 @@ [lux (#- type) [abstract [predicate (#+ Predicate)]] - ["." macro + ["." meta] + [macro [syntax (#+ syntax:)]] [type (#+ :by-example) abstract]]) @@ -80,7 +81,7 @@ (#.Cons head no)])))) (syntax: #export (type refiner) - (macro.with-gensyms [g!t g!r] + (meta.with-gensyms [g!t g!r] (wrap (list (` ((~! :by-example) [(~ g!t) (~ g!r)] {(..Refiner (~ g!t) (~ g!r)) (~ refiner)} diff --git a/stdlib/source/lux/type/resource.lux b/stdlib/source/lux/type/resource.lux index 16bb08f50..0bd65325b 100644 --- a/stdlib/source/lux/type/resource.lux +++ b/stdlib/source/lux/type/resource.lux @@ -22,7 +22,8 @@ ["." set] ["." row (#+ Row)] ["." list ("#@." functor fold)]]] - ["." macro + ["." meta] + [macro [syntax (#+ syntax:)]] [type abstract]]) @@ -154,15 +155,15 @@ (template [ ] [(syntax: #export ( {swaps ..indices}) - (macro.with-gensyms [g!_ g!context] + (meta.with-gensyms [g!_ g!context] (case swaps #.Nil (wrap (list (` ((~! no-op) )))) (#.Cons head tail) - (do {@ macro.monad} + (do {@ meta.monad} [#let [max-idx (list@fold n.max head tail)] - g!inputs (<| (monad.seq @) (list.repeat (inc max-idx)) (macro.gensym "input")) + g!inputs (<| (monad.seq @) (list.repeat (inc max-idx)) (meta.gensym "input")) #let [g!outputs (|> (monad.fold maybe.monad (function (_ from to) (do maybe.monad @@ -197,9 +198,9 @@ (template [ ] [(syntax: #export ( {amount ..amount}) - (macro.with-gensyms [g!_ g!context] - (do {@ macro.monad} - [g!keys (<| (monad.seq @) (list.repeat amount) (macro.gensym "keys"))] + (meta.with-gensyms [g!_ g!context] + (do {@ meta.monad} + [g!keys (<| (monad.seq @) (list.repeat amount) (meta.gensym "keys"))] (wrap (list (` (: (All [(~+ g!keys) (~ g!context)] (Procedure (~! ) [ (~ g!context)] diff --git a/stdlib/source/lux/type/unit.lux b/stdlib/source/lux/type/unit.lux index ef954441a..a56c22e3e 100644 --- a/stdlib/source/lux/type/unit.lux +++ b/stdlib/source/lux/type/unit.lux @@ -15,7 +15,7 @@ ["." ratio (#+ Ratio)]] [text ["%" format (#+ format)]]] - ["." macro + [macro ["." code] [syntax (#+ syntax:) ["cs" common diff --git a/stdlib/source/poly/lux/abstract/equivalence.lux b/stdlib/source/poly/lux/abstract/equivalence.lux index bb037c7cc..0fec32a2d 100644 --- a/stdlib/source/poly/lux/abstract/equivalence.lux +++ b/stdlib/source/poly/lux/abstract/equivalence.lux @@ -31,11 +31,11 @@ ["." instant] ["." day] ["." month]] - ["." macro + [macro ["." code] + ["." poly (#+ poly:)] [syntax (#+ syntax:) - ["." common]] - ["." poly (#+ poly:)]] + ["." common]]] ["." type ["." unit]]] {1 diff --git a/stdlib/source/poly/lux/abstract/functor.lux b/stdlib/source/poly/lux/abstract/functor.lux index 7381cc0b8..93d94e06b 100644 --- a/stdlib/source/poly/lux/abstract/functor.lux +++ b/stdlib/source/poly/lux/abstract/functor.lux @@ -14,7 +14,7 @@ ["%" format (#+ format)]] [collection ["." list ("#;." monad monoid)]]] - ["." macro + [macro ["." code] [syntax (#+ syntax:) ["." common]] diff --git a/stdlib/source/poly/lux/data/format/json.lux b/stdlib/source/poly/lux/data/format/json.lux index 8992b7ab6..cae14c54b 100644 --- a/stdlib/source/poly/lux/data/format/json.lux +++ b/stdlib/source/poly/lux/data/format/json.lux @@ -33,7 +33,7 @@ ["." date] ["." day] ["." month]] - [macro (#+ with-gensyms) + [macro [syntax (#+ syntax:)] ["." code] ["." poly (#+ poly:)]] diff --git a/stdlib/source/program/aedifex/parser.lux b/stdlib/source/program/aedifex/parser.lux index 508550a2a..bbcbabb95 100644 --- a/stdlib/source/program/aedifex/parser.lux +++ b/stdlib/source/program/aedifex/parser.lux @@ -1,12 +1,19 @@ (.module: - [lux (#- type) + [lux (#- Module type) [abstract [monad (#+ do)]] [control ["<>" parser ["" code (#+ Parser)]]] [data - ["." text]] + ["." text] + [collection + ["." dictionary (#+ Dictionary)]]] + [tool + [compiler + [meta + [archive + [descriptor (#+ Module)]]]]] [world [net (#+ URL)]]] [// @@ -14,6 +21,25 @@ ["//." artifact (#+ Artifact)] ["//." dependency]]) +(def: (as-input input) + (-> (Maybe Code) (List Code)) + (case input + (#.Some input) + (list input) + + #.None + (list))) + +(def: (singular input tag parser) + (All [a] (-> (Dictionary Text Code) Text (Parser a) (Parser a))) + (.local (..as-input (dictionary.get tag input)) + parser)) + +(def: (plural input tag parser) + (All [a] (-> (Dictionary Text Code) Text (Parser a) (Parser (List a)))) + (.local (..as-input (dictionary.get tag input)) + (.tuple (<>.some parser)))) + (def: group (Parser //artifact.Group) .text) @@ -42,42 +68,52 @@ (Parser /.SCM) ..url) +(def: description + (Parser Text) + .text) + (def: license (Parser /.License) - (.tuple ($_ <>.and - ..name - ..url - (<>.default #/.Repo - (<>.or (.this! (' #repo)) - (.this! (' #manual))))))) + (do {@ <>.monad} + [input (:: @ map + (dictionary.from-list text.hash) + (.record (<>.some (<>.and .local-tag + .any))))] + (.tuple ($_ <>.and + (..singular input "name" ..name) + (..singular input "url" ..url) + (<>.default #/.Repo + (..singular input "type" + (<>.or (.this! (' #repo)) + (.this! (' #manual))))))))) (def: organization (Parser /.Organization) - (<| .form - (<>.after (.this! (' #organization))) - ($_ <>.and - ..name - ..url))) - -(def: developer' - (Parser /.Developer) - ($_ <>.and - ..name - ..url - (<>.maybe ..organization) - )) + (do {@ <>.monad} + [input (:: @ map + (dictionary.from-list text.hash) + (.record (<>.some (<>.and .local-tag + .any))))] + ($_ <>.and + (..singular input "name" ..name) + (..singular input "url" ..url)))) (def: developer (Parser /.Developer) - (<| .form - (<>.after (.this! (' #developer))) - ..developer')) + (do {@ <>.monad} + [input (:: @ map + (dictionary.from-list text.hash) + (.record (<>.some (<>.and .local-tag + .any))))] + ($_ <>.and + (..singular input "name" ..name) + (..singular input "url" ..url) + (<>.maybe (..singular input "organization" ..organization)) + ))) (def: contributor (Parser /.Contributor) - (<| .form - (<>.after (.this! (' #contributor))) - ..developer')) + ..developer) (def: no-info /.Info @@ -89,26 +125,22 @@ #/.developers (list) #/.contributors (list)}) -(def: (singular tag parser) - (All [a] (-> Code (Parser a) (Parser a))) - (.form (<>.after (.this! tag) parser))) - -(def: (plural tag parser) - (All [a] (-> Code (Parser a) (Parser (List a)))) - (.form (<>.after (.this! tag) - (<>.some parser)))) - (def: info (Parser /.Info) - ($_ <>.and - (<>.maybe ..url) - (<>.maybe ..scm) - (<>.maybe .text) - (<>.default (list) (..plural (' #licenses) ..license)) - (<>.maybe ..organization) - (<>.default (list) (..plural (' #developers) ..developer)) - (<>.default (list) (..plural (' #contributors) ..contributor)) - )) + (do {@ <>.monad} + [input (:: @ map + (dictionary.from-list text.hash) + (.record (<>.some (<>.and .local-tag + .any))))] + ($_ <>.and + (<>.maybe (..singular input "url" ..url)) + (<>.maybe (..singular input "scm" ..scm)) + (<>.maybe (..singular input "description" ..description)) + (<>.default (list) (..plural input "licenses" ..license)) + (<>.maybe (..singular input "organization" ..organization)) + (<>.default (list) (..plural input "developers" ..developer)) + (<>.default (list) (..plural input "contributors" ..contributor)) + ))) (def: repository (Parser //dependency.Repository) @@ -130,25 +162,29 @@ (Parser /.Source) .text) +(def: module + (Parser Module) + .text) + (def: #export project (Parser /.Project) - (<| .form - (<>.after (.this! (' project:))) - (`` ($_ <>.and - ..artifact - (<| (<>.default ..no-info) - (..singular (' #info) ..info)) - (<| (<>.default (list)) - (..plural (' #repositories)) - ..repository) - (<| (<>.default (list)) - (..plural (' #dependencies)) - ..dependency) - (<| (<>.default (list "source")) - (..plural (' #sources)) - ..source) - (<| (<>.default "target") - (..singular (' #target) .text)) - (<>.maybe (..singular (' #program) .text)) - (<>.maybe (..singular (' #test) .text)) - )))) + (do {@ <>.monad} + [input (:: @ map + (dictionary.from-list text.hash) + (.record (<>.some (<>.and .local-tag + .any))))] + ($_ <>.and + (..singular input "identity" ..artifact) + (<>.default ..no-info + (..singular input "info" ..info)) + (<>.default (list) + (..plural input "repositories" ..repository)) + (<>.default (list) + (..plural input "dependencies" ..dependency)) + (<>.default (list "source") + (..plural input "sources" ..source)) + (<>.default "target" + (..singular input "target" .text)) + (<>.maybe (..singular input "program" ..module)) + (<>.maybe (..singular input "test" ..module)) + ))) diff --git a/stdlib/source/test/lux/control/remember.lux b/stdlib/source/test/lux/control/remember.lux index 66add3672..f9b261c9f 100644 --- a/stdlib/source/test/lux/control/remember.lux +++ b/stdlib/source/test/lux/control/remember.lux @@ -19,7 +19,8 @@ ["." date (#+ Date)] ["." instant] ["." duration]] - ["." macro + ["." meta] + [macro ["." code] ["." syntax (#+ syntax:)]]] {1 @@ -67,11 +68,11 @@ prng (random.pcg-32 [123 (instant.to-millis now)]) message (product.right (random.run prng ..message)) expected (product.right (random.run prng ..focus))] - (do macro.monad - [should-fail0 (..try (macro.expand (to-remember macro yesterday message #.None))) - should-fail1 (..try (macro.expand (to-remember macro yesterday message (#.Some expected)))) - should-succeed0 (..try (macro.expand (to-remember macro tomorrow message #.None))) - should-succeed1 (..try (macro.expand (to-remember macro tomorrow message (#.Some expected))))] + (do meta.monad + [should-fail0 (..try (meta.expand (to-remember macro yesterday message #.None))) + should-fail1 (..try (meta.expand (to-remember macro yesterday message (#.Some expected)))) + should-succeed0 (..try (meta.expand (to-remember macro tomorrow message #.None))) + should-succeed1 (..try (meta.expand (to-remember macro tomorrow message (#.Some expected))))] (wrap (list (code.bit (and (case should-fail0 (#try.Failure error) (and (test-failure yesterday message #.None error) diff --git a/stdlib/source/test/lux/data/text/regex.lux b/stdlib/source/test/lux/data/text/regex.lux index 49f20a726..bef97b853 100644 --- a/stdlib/source/test/lux/data/text/regex.lux +++ b/stdlib/source/test/lux/data/text/regex.lux @@ -14,7 +14,8 @@ ["." text ("#@." equivalence)]] [math ["r" random]] - ["." macro + ["." meta] + [macro [syntax (#+ syntax:)]]] {1 ["." /]}) @@ -50,7 +51,7 @@ false))) (syntax: (should-check pattern regex input) - (macro.with-gensyms [g!message g!_] + (meta.with-gensyms [g!message g!_] (wrap (list (` (|> (~ input) (.run (~ regex)) (case> (^ (#try.Success (~ pattern))) diff --git a/stdlib/source/test/lux/macro.lux b/stdlib/source/test/lux/macro.lux index 3b95e6f3a..35476eee0 100644 --- a/stdlib/source/test/lux/macro.lux +++ b/stdlib/source/test/lux/macro.lux @@ -1,8 +1,6 @@ (.module: [lux #* ["_" test (#+ Test)]] - {1 - ["." /]} ["." / #_ ["#." code] ["#." template] diff --git a/stdlib/source/test/lux/macro/poly/equivalence.lux b/stdlib/source/test/lux/macro/poly/equivalence.lux index 8280e000e..bfd0a2540 100644 --- a/stdlib/source/test/lux/macro/poly/equivalence.lux +++ b/stdlib/source/test/lux/macro/poly/equivalence.lux @@ -18,7 +18,7 @@ ["." text] [collection ["." list]]] - ["." macro + [macro [poly (#+ derived:)]]]) (type: Variant diff --git a/stdlib/source/test/lux/macro/syntax.lux b/stdlib/source/test/lux/macro/syntax.lux index 549967643..77ede35f3 100644 --- a/stdlib/source/test/lux/macro/syntax.lux +++ b/stdlib/source/test/lux/macro/syntax.lux @@ -19,7 +19,7 @@ ["." int] ["." rev] ["." frac]]] - ["." macro + [macro ["." code]]] {1 ["." / (#+ syntax:)]}) diff --git a/stdlib/source/test/lux/meta.lux b/stdlib/source/test/lux/meta.lux index d0a531404..ec400d5e3 100644 --- a/stdlib/source/test/lux/meta.lux +++ b/stdlib/source/test/lux/meta.lux @@ -1,14 +1,301 @@ (.module: [lux #* - ["_" test (#+ Test)]] - ## {1 - ## ["." /]} + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + ["$." functor (#+ Injection Comparison)] + ["$." apply] + ["$." monad]]}] + [control + ["." try]] + [data + ["." text ("#@." equivalence) + ["%" format (#+ format)]] + [number + ["n" nat]]] + [math + ["." random (#+ Random)]]] + {1 + ["." /]} ["." / #_ ["#." annotation]]) +(template: (!expect ) + (case + true + _ false)) + +(def: compiler-related + Test + (do random.monad + [target (random.ascii/upper-alpha 1) + version (random.ascii/upper-alpha 1) + source-code (random.ascii/upper-alpha 1) + expected-current-module (random.ascii/upper-alpha 1) + primitive-type (random.ascii/upper-alpha 1) + expected-seed random.nat + expected random.nat + dummy (random.filter (|>> (n.= expected) not) random.nat) + expected-error (random.ascii/upper-alpha 1) + expected-short (random.ascii/upper-alpha 1) + dummy-module (random.filter (|>> (text@= expected-current-module) not) + (random.ascii/upper-alpha 1)) + expected-gensym (random.ascii/upper-alpha 1) + #let [expected-lux {#.info {#.target target + #.version version + #.mode #.Build} + #.source [..dummy-cursor 0 source-code] + #.cursor ..dummy-cursor + #.current-module (#.Some expected-current-module) + #.modules (list) + #.scopes (list) + #.type-context {#.ex-counter 0 + #.var-counter 0 + #.var-bindings (list)} + #.expected (#.Some (#.Primitive primitive-type (list))) + #.seed expected-seed + #.scope-type-vars (list) + #.extensions [] + #.host []}]] + ($_ _.and + (_.cover [/.run] + (|> (:: /.monad wrap expected) + (/.run expected-lux) + (!expect (^multi (#try.Success actual) + (n.= expected actual))))) + (_.cover [/.run'] + (|> (:: /.monad wrap expected) + (/.run' expected-lux) + (!expect (^multi (#try.Success [actual-lux actual]) + (and (is? expected-lux actual-lux) + (n.= expected actual)))))) + (_.cover [/.get-compiler] + (|> /.get-compiler + (/.run expected-lux) + (!expect (^multi (#try.Success actual-lux) + (is? expected-lux actual-lux))))) + ))) + +(def: error-handling + Test + (do random.monad + [target (random.ascii/upper-alpha 1) + version (random.ascii/upper-alpha 1) + source-code (random.ascii/upper-alpha 1) + expected-current-module (random.ascii/upper-alpha 1) + primitive-type (random.ascii/upper-alpha 1) + expected-seed random.nat + expected random.nat + dummy (random.filter (|>> (n.= expected) not) random.nat) + expected-error (random.ascii/upper-alpha 1) + #let [expected-lux {#.info {#.target target + #.version version + #.mode #.Build} + #.source [..dummy-cursor 0 source-code] + #.cursor ..dummy-cursor + #.current-module (#.Some expected-current-module) + #.modules (list) + #.scopes (list) + #.type-context {#.ex-counter 0 + #.var-counter 0 + #.var-bindings (list)} + #.expected (#.Some (#.Primitive primitive-type (list))) + #.seed expected-seed + #.scope-type-vars (list) + #.extensions [] + #.host []}]] + ($_ _.and + (_.cover [/.fail] + (|> (/.fail expected-error) + (: (Meta Any)) + (/.run expected-lux) + (!expect (^multi (#try.Failure actual-error) + (text@= expected-error actual-error))))) + (_.cover [/.assert] + (and (|> (/.assert expected-error true) + (: (Meta Any)) + (/.run expected-lux) + (!expect (#try.Success []))) + (|> (/.assert expected-error false) + (/.run expected-lux) + (!expect (^multi (#try.Failure actual-error) + (text@= expected-error actual-error)))))) + (_.cover [/.either] + (and (|> (/.either (:: /.monad wrap expected) + (: (Meta Nat) + (/.fail expected-error))) + (/.run expected-lux) + (!expect (^multi (#try.Success actual) + (n.= expected actual)))) + (|> (/.either (: (Meta Nat) + (/.fail expected-error)) + (:: /.monad wrap expected)) + (/.run expected-lux) + (!expect (^multi (#try.Success actual) + (n.= expected actual)))) + (|> (/.either (: (Meta Nat) + (/.fail expected-error)) + (: (Meta Nat) + (/.fail expected-error))) + (/.run expected-lux) + (!expect (^multi (#try.Failure actual-error) + (text@= expected-error actual-error)))) + (|> (/.either (:: /.monad wrap expected) + (:: /.monad wrap dummy)) + (/.run expected-lux) + (!expect (^multi (#try.Success actual) + (n.= expected actual)))))) + ))) + +(def: module-related + Test + (do random.monad + [target (random.ascii/upper-alpha 1) + version (random.ascii/upper-alpha 1) + source-code (random.ascii/upper-alpha 1) + expected-current-module (random.ascii/upper-alpha 1) + primitive-type (random.ascii/upper-alpha 1) + expected-seed random.nat + expected random.nat + dummy (random.filter (|>> (n.= expected) not) random.nat) + expected-error (random.ascii/upper-alpha 1) + expected-short (random.ascii/upper-alpha 1) + dummy-module (random.filter (|>> (text@= expected-current-module) not) + (random.ascii/upper-alpha 1)) + #let [expected-lux {#.info {#.target target + #.version version + #.mode #.Build} + #.source [..dummy-cursor 0 source-code] + #.cursor ..dummy-cursor + #.current-module (#.Some expected-current-module) + #.modules (list) + #.scopes (list) + #.type-context {#.ex-counter 0 + #.var-counter 0 + #.var-bindings (list)} + #.expected (#.Some (#.Primitive primitive-type (list))) + #.seed expected-seed + #.scope-type-vars (list) + #.extensions [] + #.host []}]] + ($_ _.and + (_.cover [/.current-module-name] + (|> /.current-module-name + (/.run expected-lux) + (!expect (^multi (#try.Success actual-current-module) + (text@= expected-current-module actual-current-module))))) + (_.cover [/.normalize] + (and (|> (/.normalize ["" expected-short]) + (/.run expected-lux) + (!expect (^multi (#try.Success [actual-module actual-short]) + (and (text@= expected-current-module actual-module) + (is? expected-short actual-short))))) + (|> (/.normalize [dummy-module expected-short]) + (/.run expected-lux) + (!expect (^multi (#try.Success [actual-module actual-short]) + (and (text@= dummy-module actual-module) + (is? expected-short actual-short))))))) + ))) + +(def: random-cursor + (Random Cursor) + ($_ random.and + (random.ascii/upper-alpha 1) + random.nat + random.nat)) + +(def: injection + (Injection Meta) + (:: /.monad wrap)) + +(def: (comparison init) + (-> Lux (Comparison Meta)) + (function (_ == left right) + (case [(/.run init left) + (/.run init right)] + [(#try.Success left) (#try.Success right)] + (== left right) + + _ + false))) + (def: #export test Test - (<| ## (_.covering /._) + (<| (_.covering /._) ($_ _.and + (do {@ random.monad} + [target (random.ascii/upper-alpha 1) + version (random.ascii/upper-alpha 1) + source-code (random.ascii/upper-alpha 1) + expected-current-module (random.ascii/upper-alpha 1) + expected-type (:: @ map (function (_ name) + (#.Primitive name (list))) + (random.ascii/upper-alpha 1)) + expected-seed random.nat + expected random.nat + dummy (random.filter (|>> (n.= expected) not) random.nat) + expected-error (random.ascii/upper-alpha 1) + expected-short (random.ascii/upper-alpha 1) + dummy-module (random.filter (|>> (text@= expected-current-module) not) + (random.ascii/upper-alpha 1)) + expected-gensym (random.ascii/upper-alpha 1) + expected-cursor ..random-cursor + #let [expected-lux {#.info {#.target target + #.version version + #.mode #.Build} + #.source [.dummy-cursor 0 source-code] + #.cursor expected-cursor + #.current-module (#.Some expected-current-module) + #.modules (list) + #.scopes (list) + #.type-context {#.ex-counter 0 + #.var-counter 0 + #.var-bindings (list)} + #.expected (#.Some expected-type) + #.seed expected-seed + #.scope-type-vars (list) + #.extensions [] + #.host []}]] + ($_ _.and + (_.with-cover [/.functor] + ($functor.spec ..injection (..comparison expected-lux) /.functor)) + (_.with-cover [/.apply] + ($apply.spec ..injection (..comparison expected-lux) /.apply)) + (_.with-cover [/.monad] + ($monad.spec ..injection (..comparison expected-lux) /.monad)) + + ..compiler-related + ..error-handling + ..module-related + (_.cover [/.count] + (|> (do /.monad + [pre /.count + post /.count] + (wrap [pre post])) + (/.run expected-lux) + (!expect (^multi (#try.Success [actual-pre actual-post]) + (and (n.= expected-seed actual-pre) + (n.= (inc expected-seed) actual-post)))))) + (_.cover [/.gensym] + (|> (/.gensym expected-gensym) + (:: /.monad map %.code) + (/.run expected-lux) + (!expect (^multi (#try.Success actual-gensym) + (and (text.contains? expected-gensym actual-gensym) + (text.contains? (%.nat expected-seed) actual-gensym)))))) + (_.cover [/.cursor] + (|> /.cursor + (/.run expected-lux) + (!expect (^multi (#try.Success actual-cursor) + (is? expected-cursor actual-cursor))))) + (_.cover [/.expected-type] + (|> /.expected-type + (/.run expected-lux) + (!expect (^multi (#try.Success actual-type) + (is? expected-type actual-type))))) + )) + /annotation.test ))) -- cgit v1.2.3