From 190b512a822fefbb9c66271feb189cc6ccebaf85 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Nov 2017 23:22:30 -0400 Subject: - Re-named "lux/meta" to to "lux/macro". --- stdlib/source/lux/cli.lux | 6 +- stdlib/source/lux/concurrency/actor.lux | 22 +- stdlib/source/lux/concurrency/frp.lux | 4 +- stdlib/source/lux/concurrency/promise.lux | 4 +- stdlib/source/lux/concurrency/space.lux | 12 +- stdlib/source/lux/concurrency/stm.lux | 6 +- stdlib/source/lux/concurrency/task.lux | 4 +- stdlib/source/lux/control/concatenative.lux | 26 +- stdlib/source/lux/control/cont.lux | 6 +- stdlib/source/lux/control/contract.lux | 8 +- stdlib/source/lux/control/exception.lux | 14 +- stdlib/source/lux/control/pipe.lux | 10 +- stdlib/source/lux/data/coll/ordered/dict.lux | 6 +- stdlib/source/lux/data/coll/ordered/set.lux | 6 +- stdlib/source/lux/data/coll/sequence.lux | 6 +- stdlib/source/lux/data/coll/stream.lux | 4 +- stdlib/source/lux/data/coll/tree/rose.lux | 6 +- stdlib/source/lux/data/coll/tree/zipper.lux | 6 +- stdlib/source/lux/data/format/json.lux | 10 +- stdlib/source/lux/data/lazy.lux | 6 +- stdlib/source/lux/data/number/complex.lux | 6 +- stdlib/source/lux/data/number/ratio.lux | 6 +- stdlib/source/lux/data/text/format.lux | 6 +- stdlib/source/lux/data/text/lexer.lux | 2 +- stdlib/source/lux/data/text/regex.lux | 14 +- stdlib/source/lux/host.js.lux | 6 +- stdlib/source/lux/host.jvm.lux | 54 +- stdlib/source/lux/lang/type.lux | 2 +- stdlib/source/lux/macro.lux | 653 +++++++++++++++++++++++ stdlib/source/lux/macro/code.lux | 143 +++++ stdlib/source/lux/macro/poly.lux | 448 ++++++++++++++++ stdlib/source/lux/macro/poly/eq.lux | 147 +++++ stdlib/source/lux/macro/poly/functor.lux | 95 ++++ stdlib/source/lux/macro/poly/json.lux | 312 +++++++++++ stdlib/source/lux/macro/syntax.lux | 297 +++++++++++ stdlib/source/lux/macro/syntax/common.lux | 27 + stdlib/source/lux/macro/syntax/common/reader.lux | 150 ++++++ stdlib/source/lux/macro/syntax/common/writer.lux | 24 + stdlib/source/lux/math.lux | 6 +- stdlib/source/lux/meta.lux | 653 ----------------------- stdlib/source/lux/meta/code.lux | 143 ----- stdlib/source/lux/meta/poly.lux | 448 ---------------- stdlib/source/lux/meta/poly/eq.lux | 147 ----- stdlib/source/lux/meta/poly/functor.lux | 95 ---- stdlib/source/lux/meta/poly/json.lux | 312 ----------- stdlib/source/lux/meta/syntax.lux | 297 ----------- stdlib/source/lux/meta/syntax/common.lux | 27 - stdlib/source/lux/meta/syntax/common/reader.lux | 150 ------ stdlib/source/lux/meta/syntax/common/writer.lux | 24 - stdlib/source/lux/test.lux | 14 +- stdlib/source/lux/type/implicit.lux | 108 ++-- stdlib/source/lux/type/object.lux | 48 +- stdlib/source/lux/type/opaque.lux | 54 +- stdlib/source/lux/type/unit.lux | 12 +- stdlib/test/test/lux.lux | 4 +- stdlib/test/test/lux/control/parser.lux | 6 +- stdlib/test/test/lux/data/format/json.lux | 46 +- stdlib/test/test/lux/data/text/regex.lux | 6 +- stdlib/test/test/lux/lang/syntax.lux | 2 +- stdlib/test/test/lux/macro/code.lux | 32 ++ stdlib/test/test/lux/macro/poly/eq.lux | 72 +++ stdlib/test/test/lux/macro/poly/functor.lux | 30 ++ stdlib/test/test/lux/macro/syntax.lux | 153 ++++++ stdlib/test/test/lux/meta/code.lux | 32 -- stdlib/test/test/lux/meta/poly/eq.lux | 72 --- stdlib/test/test/lux/meta/poly/functor.lux | 30 -- stdlib/test/test/lux/meta/syntax.lux | 153 ------ stdlib/test/tests.lux | 10 +- 68 files changed, 2875 insertions(+), 2875 deletions(-) create mode 100644 stdlib/source/lux/macro.lux create mode 100644 stdlib/source/lux/macro/code.lux create mode 100644 stdlib/source/lux/macro/poly.lux create mode 100644 stdlib/source/lux/macro/poly/eq.lux create mode 100644 stdlib/source/lux/macro/poly/functor.lux create mode 100644 stdlib/source/lux/macro/poly/json.lux create mode 100644 stdlib/source/lux/macro/syntax.lux create mode 100644 stdlib/source/lux/macro/syntax/common.lux create mode 100644 stdlib/source/lux/macro/syntax/common/reader.lux create mode 100644 stdlib/source/lux/macro/syntax/common/writer.lux delete mode 100644 stdlib/source/lux/meta.lux delete mode 100644 stdlib/source/lux/meta/code.lux delete mode 100644 stdlib/source/lux/meta/poly.lux delete mode 100644 stdlib/source/lux/meta/poly/eq.lux delete mode 100644 stdlib/source/lux/meta/poly/functor.lux delete mode 100644 stdlib/source/lux/meta/poly/json.lux delete mode 100644 stdlib/source/lux/meta/syntax.lux delete mode 100644 stdlib/source/lux/meta/syntax/common.lux delete mode 100644 stdlib/source/lux/meta/syntax/common/reader.lux delete mode 100644 stdlib/source/lux/meta/syntax/common/writer.lux create mode 100644 stdlib/test/test/lux/macro/code.lux create mode 100644 stdlib/test/test/lux/macro/poly/eq.lux create mode 100644 stdlib/test/test/lux/macro/poly/functor.lux create mode 100644 stdlib/test/test/lux/macro/syntax.lux delete mode 100644 stdlib/test/test/lux/meta/code.lux delete mode 100644 stdlib/test/test/lux/meta/poly/eq.lux delete mode 100644 stdlib/test/test/lux/meta/poly/functor.lux delete mode 100644 stdlib/test/test/lux/meta/syntax.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux index d7e296b2f..6d4036b18 100644 --- a/stdlib/source/lux/cli.lux +++ b/stdlib/source/lux/cli.lux @@ -7,9 +7,9 @@ text/format ["E" error]) [io] - [meta #+ with-gensyms] - (meta [code] - ["s" syntax #+ syntax: Syntax]))) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) ## [Types] (type: #export (CLI a) diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index 7d5c41583..bdf0758c3 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -7,12 +7,12 @@ (data text/format (coll [list "list/" Monoid Monad Fold]) [product]) - [meta #+ with-gensyms Monad] - (meta [code] - ["s" syntax #+ syntax: Syntax] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))) + [macro #+ with-gensyms Monad] + (macro [code] + ["s" syntax #+ syntax: Syntax] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))) (type opaque) (lang [type])) (.. ["A" atom] @@ -152,14 +152,14 @@ (def: #hidden ( name) (-> Ident (Meta Ident)) (do Monad - [name (meta;normalize name) - [_ annotations _] (meta;find-def name)] - (case (meta;get-tag-ann (ident-for ) annotations) + [name (macro;normalize name) + [_ annotations _] (macro;find-def name)] + (case (macro;get-tag-ann (ident-for ) annotations) (#;Some actor-name) (wrap actor-name) _ - (meta;fail (format "Definition is not " ".")))))] + (macro;fail (format "Definition is not " ".")))))] [with-actor resolve-actor #;;actor "an actor"] [with-message resolve-message #;;message "a message"] @@ -224,7 +224,7 @@ (wrap output)))))} (with-gensyms [g!message g!self g!state g!init g!error g!return g!output] (do @ - [module meta;current-module-name + [module macro;current-module-name #let [g!type (code;local-symbol (state-name _name)) g!behavior (code;local-symbol (behavior-name _name)) g!actor (code;local-symbol _name) diff --git a/stdlib/source/lux/concurrency/frp.lux b/stdlib/source/lux/concurrency/frp.lux index 57789d708..d59b96563 100644 --- a/stdlib/source/lux/concurrency/frp.lux +++ b/stdlib/source/lux/concurrency/frp.lux @@ -8,8 +8,8 @@ [io #- run] (data (coll [list "L/" Monoid]) text/format) - [meta] - (meta ["s" syntax #+ syntax: Syntax])) + [macro] + (macro ["s" syntax #+ syntax: Syntax])) (.. ["&" promise])) ## [Types] diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux index 63cd88c77..115f60dc1 100644 --- a/stdlib/source/lux/concurrency/promise.lux +++ b/stdlib/source/lux/concurrency/promise.lux @@ -9,8 +9,8 @@ ["A" applicative] ["M" monad #+ do Monad] ["p" parser]) - [meta] - (meta ["s" syntax #+ syntax: Syntax]) + [macro] + (macro ["s" syntax #+ syntax: Syntax]) (concurrency [atom #+ Atom atom]) )) diff --git a/stdlib/source/lux/concurrency/space.lux b/stdlib/source/lux/concurrency/space.lux index df0ec47a9..8fe9fa583 100644 --- a/stdlib/source/lux/concurrency/space.lux +++ b/stdlib/source/lux/concurrency/space.lux @@ -9,12 +9,12 @@ (data [product] (coll [list "L/" Functor Fold])) [io #- run] - [meta #+ with-gensyms] - (meta [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))))) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))))) (with-expansions [ [e (A;Actor Top) (Space e)] diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux index d1762ee01..7886dda36 100644 --- a/stdlib/source/lux/concurrency/stm.lux +++ b/stdlib/source/lux/concurrency/stm.lux @@ -12,9 +12,9 @@ maybe [number "Nat/" Codec] text/format) - [meta] - (meta [code] - ["s" syntax #+ syntax: Syntax]) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]) (concurrency [atom #+ Atom atom] ["P" promise] [frp]) diff --git a/stdlib/source/lux/concurrency/task.lux b/stdlib/source/lux/concurrency/task.lux index fbc3cbf1e..374acee46 100644 --- a/stdlib/source/lux/concurrency/task.lux +++ b/stdlib/source/lux/concurrency/task.lux @@ -6,8 +6,8 @@ monad ["ex" exception #+ Exception]) (concurrency ["P" promise]) - [meta] - (meta ["s" syntax #+ syntax: Syntax]) + [macro] + (macro ["s" syntax #+ syntax: Syntax]) )) (type: #export (Task a) diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux index 549ac19b0..b0ed0f585 100644 --- a/stdlib/source/lux/control/concatenative.lux +++ b/stdlib/source/lux/control/concatenative.lux @@ -9,12 +9,12 @@ text/format [maybe "m/" Monad] (coll [list "L/" Fold Functor])) - [meta #+ with-gensyms Monad] - (meta [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))))) + [macro #+ with-gensyms Monad] + (macro [code] + ["s" syntax #+ syntax:] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))))) ## [Syntax] (type: Alias [Text Code]) @@ -57,8 +57,8 @@ (wrap singleton) _ - (meta;fail (format "Cannot expand to more than a single AST/Code node:\n" - (|> expansion (L/map %code) (text;join-with " "))))))) + (macro;fail (format "Cannot expand to more than a single AST/Code node:\n" + (|> expansion (L/map %code) (text;join-with " "))))))) (syntax: #export (=> [aliases aliases^] [inputs stack^] @@ -72,16 +72,16 @@ (|> outputs (get@ #bottom) (m/map (|>. code;nat (~) #;Bound (`))))] [(#;Some bottomI) (#;Some bottomO)] (monad;do @ - [inputC (singleton (meta;expand-all (stack-fold (get@ #top inputs) bottomI))) - outputC (singleton (meta;expand-all (stack-fold (get@ #top outputs) bottomO)))] + [inputC (singleton (macro;expand-all (stack-fold (get@ #top inputs) bottomI))) + outputC (singleton (macro;expand-all (stack-fold (get@ #top outputs) bottomO)))] (wrap (list (` (-> (~ (de-alias inputC)) (~ (de-alias outputC))))))) [?bottomI ?bottomO] (with-gensyms [g!stack] (monad;do @ - [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))))] + [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))))] (wrap (list (` (All [(~ g!stack)] (-> (~ (de-alias inputC)) (~ (de-alias outputC)))))))))))) @@ -124,7 +124,7 @@ (syntax: #export (apply [arity (|> s;nat (p;filter (;n.> +0)))]) (with-gensyms [g!func g!stack g!output] (monad;do @ - [g!inputs (|> (meta;gensym "input") (list;repeat arity) (monad;seq @))] + [g!inputs (|> (macro;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/cont.lux b/stdlib/source/lux/control/cont.lux index 0db72d0fc..81f62eccb 100644 --- a/stdlib/source/lux/control/cont.lux +++ b/stdlib/source/lux/control/cont.lux @@ -4,9 +4,9 @@ ["A" applicative] monad) function - [meta #+ with-gensyms] - (meta [code] - [syntax #+ syntax:]))) + [macro #+ with-gensyms] + (macro [code] + [syntax #+ syntax:]))) (type: #export (Cont i o) {#;doc "Continuations."} diff --git a/stdlib/source/lux/control/contract.lux b/stdlib/source/lux/control/contract.lux index 5ff6309ec..cc3267715 100644 --- a/stdlib/source/lux/control/contract.lux +++ b/stdlib/source/lux/control/contract.lux @@ -2,9 +2,9 @@ lux (lux (control monad) (data text/format) - [meta] - (meta [code] - ["s" syntax #+ syntax:]))) + [macro] + (macro [code] + ["s" syntax #+ syntax:]))) (def: #export (assert! message test) (-> Text Bool []) @@ -30,7 +30,7 @@ (post i.even? (i.+ 2 2)))} (do @ - [g!output (meta;gensym "")] + [g!output (macro;gensym "")] (wrap (list (` (let [(~ g!output) (~ expr)] (exec (assert! (~ (code;text (format "Post-condition failed: " (%code test)))) ((~ test) (~ g!output))) diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index 9732cd185..010fb562f 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -4,12 +4,12 @@ (data ["e" error] [maybe] [text "text/" Monoid]) - [meta] - (meta [code] - ["s" syntax #+ syntax: Syntax] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))))) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))))) ## [Types] (type: #export Exception @@ -71,7 +71,7 @@ "It moslty just serves as a way to tag error messages for later catching." (exception: #export Some-Exception))} (do @ - [current-module meta;current-module-name + [current-module macro;current-module-name #let [descriptor ($_ text/compose "{" current-module ";" name "}" "\n") g!message (code;symbol ["" "message"])]] (wrap (list (` (def: (~@ (csw;export _ex-lev)) ((~ (code;symbol ["" name])) (~ g!message)) diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux index f2a6950fb..6eb8e8156 100644 --- a/stdlib/source/lux/control/pipe.lux +++ b/stdlib/source/lux/control/pipe.lux @@ -3,9 +3,9 @@ (lux (control ["M" monad #+ do Monad] ["p" parser]) (data (coll [list #+ Monad "L/" Fold Monad])) - [meta #+ with-gensyms] - (meta ["s" syntax #+ syntax: Syntax] - [code]) + [macro #+ with-gensyms] + (macro ["s" syntax #+ syntax: Syntax] + [code]) )) ## [Syntax] @@ -98,7 +98,7 @@ (exec> [int-to-nat %n log!]) (i.* 10)))} (do @ - [g!temp (meta;gensym "")] + [g!temp (macro;gensym "")] (wrap (list (` (let [(~ g!temp) (~ prev)] (exec (|> (~ g!temp) (~@ body)) (~ g!temp)))))))) @@ -112,7 +112,7 @@ [Int/encode])) "Will become: [50 2 \"5\"]")} (do @ - [g!temp (meta;gensym "")] + [g!temp (macro;gensym "")] (wrap (list (` (let [(~ g!temp) (~ prev)] [(~@ (L/map (function [body] (` (|> (~ g!temp) (~@ body)))) paths))])))))) diff --git a/stdlib/source/lux/data/coll/ordered/dict.lux b/stdlib/source/lux/data/coll/ordered/dict.lux index 1151a018b..24b6b7c3b 100644 --- a/stdlib/source/lux/data/coll/ordered/dict.lux +++ b/stdlib/source/lux/data/coll/ordered/dict.lux @@ -6,9 +6,9 @@ (data (coll [list "L/" Monad Monoid Fold]) ["p" product] [maybe]) - [meta] - (meta [code] - ["s" syntax #+ syntax: Syntax]))) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) (def: error-message Text "Invariant violation") diff --git a/stdlib/source/lux/data/coll/ordered/set.lux b/stdlib/source/lux/data/coll/ordered/set.lux index 90026feab..376624033 100644 --- a/stdlib/source/lux/data/coll/ordered/set.lux +++ b/stdlib/source/lux/data/coll/ordered/set.lux @@ -7,9 +7,9 @@ (ordered ["d" dict])) ["p" product] ["M" maybe #+ Functor]) - [meta] - (meta [code] - ["s" syntax #+ syntax: Syntax]))) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) (type: #export (Set a) (d;Dict a a)) diff --git a/stdlib/source/lux/data/coll/sequence.lux b/stdlib/source/lux/data/coll/sequence.lux index c76735d3c..f85558c5e 100644 --- a/stdlib/source/lux/data/coll/sequence.lux +++ b/stdlib/source/lux/data/coll/sequence.lux @@ -12,9 +12,9 @@ [array "array/" Functor Fold]) [bit] [product]) - [meta #+ with-gensyms] - (meta [code] - ["s" syntax #+ syntax: Syntax]) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax: Syntax]) )) ## [Utils] diff --git a/stdlib/source/lux/data/coll/stream.lux b/stdlib/source/lux/data/coll/stream.lux index 61e3b3e6c..43ed0087c 100644 --- a/stdlib/source/lux/data/coll/stream.lux +++ b/stdlib/source/lux/data/coll/stream.lux @@ -5,8 +5,8 @@ comonad [cont #+ pending Cont] ["p" parser]) - [meta #+ with-gensyms] - (meta ["s" syntax #+ syntax: Syntax]) + [macro #+ with-gensyms] + (macro ["s" syntax #+ syntax: Syntax]) (data (coll [list "List/" Monad]) bool))) diff --git a/stdlib/source/lux/data/coll/tree/rose.lux b/stdlib/source/lux/data/coll/tree/rose.lux index b07f1ed84..546982dba 100644 --- a/stdlib/source/lux/data/coll/tree/rose.lux +++ b/stdlib/source/lux/data/coll/tree/rose.lux @@ -6,9 +6,9 @@ ["p" parser] fold) (data (coll [list "L/" Monad Fold])) - [meta] - (meta [code] - ["s" syntax #+ syntax: Syntax]))) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) ## [Types] (type: #export (Tree a) diff --git a/stdlib/source/lux/data/coll/tree/zipper.lux b/stdlib/source/lux/data/coll/tree/zipper.lux index ddab9d121..c8f9a9059 100644 --- a/stdlib/source/lux/data/coll/tree/zipper.lux +++ b/stdlib/source/lux/data/coll/tree/zipper.lux @@ -6,9 +6,9 @@ (tree [rose #+ Tree "T/" Functor]) [stack #+ Stack]) [maybe "M/" Monad]) - [meta] - (meta [code] - ["s" syntax #+ syntax: Syntax]))) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) ## Adapted from the clojure.zip namespace in the Clojure standard library. diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index ddc2b48cf..029d8dde7 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -17,10 +17,10 @@ (coll [list "list/" Fold Monad] [sequence #+ Sequence sequence "sequence/" Monad] [dict #+ Dict])) - [meta #+ Monad with-gensyms] - (meta ["s" syntax #+ syntax:] - [code] - [poly #+ poly:]) + [macro #+ Monad with-gensyms] + (macro ["s" syntax #+ syntax:] + [code] + [poly #+ poly:]) (lang [type]) )) @@ -86,7 +86,7 @@ (wrap (` [(~ (code;text key-name)) (~ (wrapper value))])) _ - (meta;fail "Wrong syntax for JSON object."))) + (macro;fail "Wrong syntax for JSON object."))) pairs)] (wrap (list (` (: JSON (#Object (dict;from-list text;Hash (list (~@ pairs'))))))))) diff --git a/stdlib/source/lux/data/lazy.lux b/stdlib/source/lux/data/lazy.lux index 547418d51..e344c6a0a 100644 --- a/stdlib/source/lux/data/lazy.lux +++ b/stdlib/source/lux/data/lazy.lux @@ -5,8 +5,8 @@ ["A" applicative] monad) (concurrency ["a" atom]) - [meta] - (meta ["s" syntax #+ syntax:]) + [macro] + (macro ["s" syntax #+ syntax:]) (type opaque))) (opaque: #export (Lazy a) @@ -31,7 +31,7 @@ (syntax: #export (freeze expr) (do @ - [g!_ (meta;gensym "_")] + [g!_ (macro;gensym "_")] (wrap (list (` (freeze' (function [(~ g!_)] (~ expr)))))))) (struct: #export _ (F;Functor Lazy) diff --git a/stdlib/source/lux/data/number/complex.lux b/stdlib/source/lux/data/number/complex.lux index 870474890..7fc8af1dd 100644 --- a/stdlib/source/lux/data/number/complex.lux +++ b/stdlib/source/lux/data/number/complex.lux @@ -12,9 +12,9 @@ ["E" error] [maybe] (coll [list "L/" Monad])) - [meta] - (meta [code] - ["s" syntax #+ syntax: Syntax]))) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) (type: #export Complex {#real Frac diff --git a/stdlib/source/lux/data/number/ratio.lux b/stdlib/source/lux/data/number/ratio.lux index d14e5e1f1..f3f9a1196 100644 --- a/stdlib/source/lux/data/number/ratio.lux +++ b/stdlib/source/lux/data/number/ratio.lux @@ -13,9 +13,9 @@ ["E" error] [product] [maybe]) - [meta] - (meta [code] - ["s" syntax #+ syntax: Syntax]))) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) (type: #export Ratio {#numerator Nat diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 7fdd9f552..9f8d2b25f 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -12,9 +12,9 @@ (time [instant] [duration] [date]) - [meta] - (meta [code] - ["s" syntax #+ syntax: Syntax]) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]) (lang [type]))) ## [Syntax] diff --git a/stdlib/source/lux/data/text/lexer.lux b/stdlib/source/lux/data/text/lexer.lux index 9ae2bdd8f..5fc638354 100644 --- a/stdlib/source/lux/data/text/lexer.lux +++ b/stdlib/source/lux/data/text/lexer.lux @@ -7,7 +7,7 @@ [maybe] ["E" error] (coll [list])) - (meta [code]))) + (macro [code]))) (type: Offset Nat) diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux index bcefa4331..07e2a6ea4 100644 --- a/stdlib/source/lux/data/text/regex.lux +++ b/stdlib/source/lux/data/text/regex.lux @@ -10,9 +10,9 @@ ["E" error] [maybe] (coll [list "L/" Fold Monad])) - [meta #- run] - (meta [code] - ["s" syntax #+ syntax:]))) + [macro #- run] + (macro [code] + ["s" syntax #+ syntax:]))) ## [Utils] (def: regex-char^ @@ -458,13 +458,13 @@ (regex "a(.)(.)|b(.)(.)") )} (do @ - [current-module meta;current-module-name] + [current-module macro;current-module-name] (case (|> (regex^ current-module) (p;before l;end) (l;run pattern)) (#E;Error error) - (meta;fail (format "Error while parsing regular-expression:\n" - error)) + (macro;fail (format "Error while parsing regular-expression:\n" + error)) (#E;Success regex) (wrap (list regex)) @@ -485,7 +485,7 @@ _ do-something-else))} (do @ - [g!temp (meta;gensym "temp")] + [g!temp (macro;gensym "temp")] (wrap (list& (` (^multi (~ g!temp) [(l;run (~ g!temp) (regex (~ (code;text pattern)))) (#E;Success (~ (maybe;default g!temp diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux index e9c987532..fdbc752c4 100644 --- a/stdlib/source/lux/host.js.lux +++ b/stdlib/source/lux/host.js.lux @@ -3,9 +3,9 @@ (lux (control monad ["p" parser]) (data (coll [list #* "L/" Fold])) - [meta #+ with-gensyms] - (meta [code] - ["s" syntax #+ syntax: Syntax]) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax: Syntax]) )) (do-template [ ] diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index 1b77e3016..1298a56d1 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -11,9 +11,9 @@ [text "text/" Eq Monoid] text/format [bool "bool/" Codec]) - [meta #+ with-gensyms Functor Monad] - (meta [code] - ["s" syntax #+ syntax: Syntax]) + [macro #+ with-gensyms Functor Monad] + (macro [code] + ["s" syntax #+ syntax: Syntax]) (lang [type]) )) @@ -352,21 +352,21 @@ (def: (class-imports compiler) (-> Compiler ClassImports) - (case (meta;run compiler - (: (Meta ClassImports) - (do Monad - [current-module meta;current-module-name - defs (meta;defs current-module)] - (wrap (list/fold (: (-> [Text Def] ClassImports ClassImports) - (function [[short-name [_ meta _]] imports] - (case (meta;get-text-ann (ident-for #;;jvm-class) meta) - (#;Some full-class-name) - (add-import [short-name full-class-name] imports) - - _ - imports))) - empty-imports - defs))))) + (case (macro;run compiler + (: (Meta ClassImports) + (do Monad + [current-module macro;current-module-name + defs (macro;defs current-module)] + (wrap (list/fold (: (-> [Text Def] ClassImports ClassImports) + (function [[short-name [_ meta _]] imports] + (case (macro;get-text-ann (ident-for #;;jvm-class) meta) + (#;Some full-class-name) + (add-import [short-name full-class-name] imports) + + _ + imports))) + empty-imports + defs))))) (#;Left _) (list) (#;Right imports) imports)) @@ -1305,7 +1305,7 @@ "(.resolve! container [value]) for calling the \"resolve\" method." )} (do Monad - [current-module meta;current-module-name + [current-module macro;current-module-name #let [fully-qualified-class-name (format (text;replace-all "/" "." current-module) "." full-class-name) field-parsers (list/map (field->parser fully-qualified-class-name) fields) method-parsers (list/map (method->parser (product;right class-decl) fully-qualified-class-name) methods) @@ -1435,7 +1435,7 @@ #;None (do @ - [g!obj (meta;gensym "obj")] + [g!obj (macro;gensym "obj")] (wrap (list (` (: (-> (primitive (~' java.lang.Object)) Bool) (function [(~ g!obj)] ((~ (code;text (format "jvm instanceof" ":" (simple-class$ (list) class)))) (~ g!obj)))))))) @@ -1540,7 +1540,7 @@ (:: Monad wrap (class->type mode type-params (get@ #import-method-return method))) _ - (meta;fail "Only methods have return values."))) + (macro;fail "Only methods have return values."))) (def: (decorate-return-maybe member [return-type return-term]) (-> ImportMemberDecl [Code Code] [Code Code]) @@ -1842,7 +1842,7 @@ #Class)) (#;Left _) - (meta;fail (format "Unknown class: " class-name)))) + (macro;fail (format "Unknown class: " class-name)))) (syntax: #export (import [#let [imports (class-imports *compiler*)]] [long-name? (s;this? (' #long))] @@ -1937,7 +1937,7 @@ (#;Apply A F) (case (type;apply (list A) F) #;None - (meta;fail (format "Cannot apply type: " (type;to-text F) " to " (type;to-text A))) + (macro;fail (format "Cannot apply type: " (type;to-text F) " to " (type;to-text A))) (#;Some type') (type->class-name type')) @@ -1949,7 +1949,7 @@ (:: Monad wrap "java.lang.Object") (^or #;Void (#;Var _) (#;Ex _) (#;Bound _) (#;Sum _) (#;Product _) (#;Function _) (#;UnivQ _) (#;ExQ _)) - (meta;fail (format "Cannot convert to JvmType: " (type;to-text type))) + (macro;fail (format "Cannot convert to JvmType: " (type;to-text type))) )) (syntax: #export (array-read idx array) @@ -1958,7 +1958,7 @@ (case array [_ (#;Symbol array-name)] (do Monad - [array-type (meta;find-type array-name) + [array-type (macro;find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type (^template [ ] @@ -1987,7 +1987,7 @@ (case array [_ (#;Symbol array-name)] (do Monad - [array-type (meta;find-type array-name) + [array-type (macro;find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type (^template [ ] @@ -2071,7 +2071,7 @@ (wrap fqcn) #;None - (meta;fail (text/compose "Unknown class: " class))))) + (macro;fail (text/compose "Unknown class: " class))))) (syntax: #export (type [#let [imports (class-imports *compiler*)]] [type (generic-type^ imports (list))]) diff --git a/stdlib/source/lux/lang/type.lux b/stdlib/source/lux/lang/type.lux index 9d6ed5162..974561605 100644 --- a/stdlib/source/lux/lang/type.lux +++ b/stdlib/source/lux/lang/type.lux @@ -7,7 +7,7 @@ [number "nat/" Codec] [maybe] (coll [list #+ "list/" Monad Monoid Fold])) - (meta [code]) + (macro [code]) )) ## [Utils] diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux new file mode 100644 index 000000000..e65e09b58 --- /dev/null +++ b/stdlib/source/lux/macro.lux @@ -0,0 +1,653 @@ +(;module: {#;doc "Functions for extracting information from the state of the compiler."} + lux + (lux (control ["F" functor] + ["A" applicative] + ["M" monad #+ do Monad]) + (data [number] + [product] + [ident "ident/" Codec Eq] + [maybe] + ["e" error] + [text "text/" Monoid Eq] + (coll [list "list/" Monoid Monad]))) + (. [code])) + +## (type: (Meta a) +## (-> Compiler (e;Error [Compiler a]))) + +(struct: #export _ (F;Functor Meta) + (def: (map f fa) + (function [state] + (case (fa state) + (#e;Error msg) + (#e;Error msg) + + (#e;Success [state' a]) + (#e;Success [state' (f a)]))))) + +(struct: #export _ (A;Applicative Meta) + (def: functor Functor) + + (def: (wrap x) + (function [state] + (#e;Success [state x]))) + + (def: (apply ff fa) + (function [state] + (case (ff state) + (#e;Success [state' f]) + (case (fa state') + (#e;Success [state'' a]) + (#e;Success [state'' (f a)]) + + (#e;Error msg) + (#e;Error msg)) + + (#e;Error msg) + (#e;Error msg))))) + +(struct: #export _ (Monad Meta) + (def: applicative Applicative) + + (def: (join mma) + (function [state] + (case (mma state) + (#e;Error msg) + (#e;Error msg) + + (#e;Success [state' ma]) + (ma state'))))) + +(def: (get k plist) + (All [a] + (-> Text (List [Text a]) (Maybe a))) + (case plist + #;Nil + #;None + + (#;Cons [k' v] plist') + (if (text/= k k') + (#;Some v) + (get k plist')))) + +(def: #export (run' compiler action) + (All [a] (-> Compiler (Meta a) (e;Error [Compiler a]))) + (action compiler)) + +(def: #export (run compiler action) + (All [a] (-> Compiler (Meta a) (e;Error a))) + (case (action compiler) + (#e;Error error) + (#e;Error error) + + (#e;Success [_ output]) + (#e;Success output))) + +(def: #export (either left right) + {#;doc "Pick whichever computation succeeds."} + (All [a] (-> (Meta a) (Meta a) (Meta a))) + (function [compiler] + (case (left compiler) + (#e;Error error) + (right compiler) + + (#e;Success [compiler' output]) + (#e;Success [compiler' output])))) + +(def: #export (assert message test) + {#;doc "Fails with the given message if the test is false."} + (-> Text Bool (Meta Unit)) + (function [compiler] + (if test + (#e;Success [compiler []]) + (#e;Error message)))) + +(def: #export (fail msg) + {#;doc "Fails with the given message."} + (All [a] + (-> Text (Meta a))) + (function [_] + (#e;Error msg))) + +(def: #export (find-module name) + (-> Text (Meta Module)) + (function [state] + (case (get name (get@ #;modules state)) + (#;Some module) + (#e;Success [state module]) + + _ + (#e;Error ($_ text/compose "Unknown module: " name))))) + +(def: #export current-module-name + (Meta Text) + (function [state] + (case (get@ #;current-module state) + (#;Some current-module) + (#e;Success [state current-module]) + + _ + (#e;Error "No current module.") + ))) + +(def: #export current-module + (Meta Module) + (do Monad + [this-module-name current-module-name] + (find-module this-module-name))) + +(def: #export (get-ann tag anns) + {#;doc "Looks-up a particular annotation's value within the set of annotations."} + (-> Ident Code (Maybe Code)) + (case anns + [_ (#;Record anns)] + (loop [anns anns] + (case anns + (#;Cons [key value] anns') + (case key + [_ (#;Tag tag')] + (if (ident/= tag tag') + (#;Some value) + (recur anns')) + + _ + (recur anns')) + + #;Nil + #;None)) + + _ + #;None)) + +(do-template [ ] + [(def: #export ( tag anns) + (-> Ident Code (Maybe )) + (case (get-ann tag anns) + (#;Some [_ ( value)]) + (#;Some value) + + _ + #;None))] + + [get-bool-ann #;Bool Bool] + [get-int-ann #;Int Int] + [get-frac-ann #;Frac Frac] + [get-text-ann #;Text Text] + [get-symbol-ann #;Symbol Ident] + [get-tag-ann #;Tag Ident] + [get-form-ann #;Form (List Code)] + [get-tuple-ann #;Tuple (List Code)] + [get-record-ann #;Record (List [Code Code])] + ) + +(def: #export (get-doc anns) + {#;doc "Looks-up a definition's documentation."} + (-> Code (Maybe Text)) + (get-text-ann ["lux" "doc"] anns)) + +(def: #export (flag-set? flag-name anns) + {#;doc "Finds out whether an annotation-as-a-flag is set (has value 'true')."} + (-> Ident Code Bool) + (maybe;default false (get-bool-ann flag-name anns))) + +(do-template [ ] + [(def: #export + {#;doc (code;text ($_ text/compose "Checks whether a definition is " "."))} + (-> Code Bool) + (flag-set? (ident-for )))] + + [export? #;export? "exported"] + [hidden? #;hidden? "hidden"] + [macro? #;macro? "a macro"] + [type? #;type? "a type"] + [struct? #;struct? "a structure"] + [type-rec? #;type-rec? "a recursive type"] + [sig? #;sig? "a signature"] + ) + +(do-template [ ] + [(def: ( input) + (-> Code (Maybe )) + (case input + [_ ( actual-value)] + (#;Some actual-value) + + _ + #;None))] + + [parse-tuple #;Tuple (List Code)] + [parse-text #;Text Text] + ) + +(do-template [ ] + [(def: #export ( anns) + {#;doc } + (-> Code (List Text)) + (maybe;default (list) + (do maybe;Monad + [_args (get-ann (ident-for ) anns) + args (parse-tuple _args)] + (M;map @ parse-text args))))] + + [func-args #;func-args "Looks up the arguments of a function."] + [type-args #;type-args "Looks up the arguments of a parameterized type."] + [declared-tags #;tags "Looks up the tags of a tagged (variant or record) type."] + ) + +(def: (find-macro' modules this-module module name) + (-> (List [Text Module]) Text Text Text + (Maybe Macro)) + (do maybe;Monad + [$module (get module modules) + [def-type def-anns def-value] (: (Maybe Def) (|> (: Module $module) (get@ #;defs) (get name)))] + (if (and (macro? def-anns) + (or (export? def-anns) (text/= module this-module))) + (#;Some (:! Macro def-value)) + (case (get-symbol-ann ["lux" "alias"] def-anns) + (#;Some [r-module r-name]) + (find-macro' modules this-module r-module r-name) + + _ + #;None)))) + +(def: #export (find-macro ident) + (-> Ident (Meta (Maybe Macro))) + (do Monad + [this-module current-module-name] + (let [[module name] ident] + (: (Meta (Maybe Macro)) + (function [state] + (#e;Success [state (find-macro' (get@ #;modules state) this-module module name)])))))) + +(def: #export (normalize ident) + {#;doc "If given an identifier without a module prefix, gives it the current module's name as prefix. + + Otherwise, returns the identifier as-is."} + (-> Ident (Meta Ident)) + (case ident + ["" name] + (do Monad + [module-name current-module-name] + (wrap [module-name name])) + + _ + (:: Monad wrap ident))) + +(def: #export (expand-once syntax) + {#;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 [[_ (#;Symbol name)] args]))] + (do Monad + [name' (normalize name) + ?macro (find-macro name')] + (case ?macro + (#;Some macro) + (macro args) + + #;None + (:: Monad wrap (list syntax)))) + + _ + (:: Monad wrap (list syntax)))) + +(def: #export (expand syntax) + {#;doc "Given code that requires applying a macro, expands repeatedly until no more direct macro-calls are left. + + Otherwise, returns the code as-is."} + (-> Code (Meta (List Code))) + (case syntax + [_ (#;Form (#;Cons [[_ (#;Symbol name)] args]))] + (do Monad + [name' (normalize name) + ?macro (find-macro name')] + (case ?macro + (#;Some macro) + (do Monad + [expansion (macro args) + expansion' (M;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 [[_ (#;Symbol name)] args]))] + (do Monad + [name' (normalize name) + ?macro (find-macro name')] + (case ?macro + (#;Some macro) + (do Monad + [expansion (macro args) + expansion' (M;map Monad expand-all expansion)] + (wrap (list/join expansion'))) + + #;None + (do Monad + [parts' (M;map Monad expand-all (list& (code;symbol name) args))] + (wrap (list (code;form (list/join parts'))))))) + + [_ (#;Form (#;Cons [harg targs]))] + (do Monad + [harg+ (expand-all harg) + targs+ (M;map Monad expand-all targs)] + (wrap (list (code;form (list/compose harg+ (list/join (: (List (List Code)) targs+))))))) + + [_ (#;Tuple members)] + (do Monad + [members' (M;map Monad expand-all members)] + (wrap (list (code;tuple (list/join members'))))) + + _ + (:: Monad wrap (list syntax)))) + +(def: #export (gensym prefix) + {#;doc "Generates a unique identifier 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)) + (function [state] + (#e;Success [(update@ #;seed n.inc state) + (code;symbol ["" ($_ text/compose "__gensym__" prefix (:: number;Codec encode (get@ #;seed state)))])]))) + +(def: (get-local-symbol ast) + (-> Code (Meta Text)) + (case ast + [_ (#;Symbol [_ name])] + (:: Monad wrap name) + + _ + (fail (text/compose "Code is not a local symbol: " (code;to-text ast))))) + +(macro: #export (with-gensyms tokens) + {#;doc (doc "Creates new symbols and offers them to the body expression." + (syntax: #export (synchronized lock body) + (with-gensyms [g!lock g!body g!_] + (wrap (list (` (let [(~ g!lock) (~ lock) + (~ g!_) (;_jvm_monitorenter (~ g!lock)) + (~ g!body) (~ body) + (~ g!_) (;_jvm_monitorexit (~ g!lock))] + (~ g!body))))) + )))} + (case tokens + (^ (list [_ (#;Tuple symbols)] body)) + (do Monad + [symbol-names (M;map @ get-local-symbol symbols) + #let [symbol-defs (list/join (list/map (: (-> Text (List Code)) + (function [name] (list (code;symbol ["" name]) (` (gensym (~ (code;text name))))))) + symbol-names))]] + (wrap (list (` (do Monad + [(~@ symbol-defs)] + (~ body)))))) + + _ + (fail "Wrong syntax for 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 Bool)) + (function [state] + (#e;Success [state (case (get module (get@ #;modules state)) + (#;Some _) + true + + #;None + false)]))) + +(def: (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def: #export (find-var-type name) + {#;doc "Looks-up the type of a local variable somewhere in the environment."} + (-> Text (Meta Type)) + (function [state] + (let [test (: (-> [Text [Type Top]] Bool) + (|>. product;left (text/= name)))] + (case (do maybe;Monad + [scope (list;find (function [env] + (or (list;any? test (: (List [Text [Type Top]]) + (get@ [#;locals #;mappings] env))) + (list;any? test (: (List [Text [Type Top]]) + (get@ [#;captured #;mappings] env))))) + (get@ #;scopes state)) + [_ [type _]] (try-both (list;find test) + (: (List [Text [Type Top]]) + (get@ [#;locals #;mappings] scope)) + (: (List [Text [Type Top]]) + (get@ [#;captured #;mappings] scope)))] + (wrap type)) + (#;Some var-type) + (#e;Success [state var-type]) + + #;None + (#e;Error ($_ text/compose "Unknown variable: " name)))))) + +(def: #export (find-def name) + {#;doc "Looks-up a definition's whole data in the available modules (including the current one)."} + (-> Ident (Meta Def)) + (function [state] + (case (: (Maybe Def) + (do maybe;Monad + [#let [[v-prefix v-name] name] + (^slots [#;defs]) (get v-prefix (get@ #;modules state))] + (get v-name defs))) + (#;Some _anns) + (#e;Success [state _anns]) + + _ + (#e;Error ($_ text/compose "Unknown definition: " (ident/encode name)))))) + +(def: #export (find-def-type name) + {#;doc "Looks-up a definition's type in the available modules (including the current one)."} + (-> Ident (Meta Type)) + (do Monad + [[def-type def-data def-value] (find-def name)] + (wrap def-type))) + +(def: #export (find-type name) + {#;doc "Looks-up the type of either a local variable or a definition."} + (-> Ident (Meta Type)) + (do Monad + [#let [[_ _name] name]] + (either (find-var-type _name) + (do @ + [name (normalize name)] + (find-def-type name))))) + +(def: #export (find-type-def name) + {#;doc "Finds the value of a type definition (such as Int, Top or Compiler)."} + (-> Ident (Meta Type)) + (do Monad + [[def-type def-data def-value] (find-def name)] + (wrap (:! Type def-value)))) + +(def: #export (defs module-name) + {#;doc "The entire list of definitions in a module (including the unexported/private ones)."} + (-> Text (Meta (List [Text Def]))) + (function [state] + (case (get module-name (get@ #;modules state)) + #;None (#e;Error ($_ text/compose "Unknown module: " module-name)) + (#;Some module) (#e;Success [state (get@ #;defs module)]) + ))) + +(def: #export (exports module-name) + {#;doc "All the exported definitions in a module."} + (-> Text (Meta (List [Text Def]))) + (do Monad + [defs (defs module-name)] + (wrap (list;filter (function [[name [def-type def-anns def-value]]] + (and (export? def-anns) + (not (hidden? def-anns)))) + defs)))) + +(def: #export modules + {#;doc "All the available modules (including the current one)."} + (Meta (List [Text Module])) + (function [state] + (|> state + (get@ #;modules) + [state] + #e;Success))) + +(def: #export (tags-of type-name) + {#;doc "All the tags associated with a type definition."} + (-> Ident (Meta (List Ident))) + (do Monad + [#let [[module name] type-name] + module (find-module module)] + (case (get name (get@ #;types module)) + (#;Some [tags _]) + (wrap tags) + + _ + (wrap (list))))) + +(def: #export cursor + {#;doc "The cursor of the current expression being analyzed."} + (Meta Cursor) + (function [state] + (#e;Success [state (get@ #;cursor state)]))) + +(def: #export expected-type + {#;doc "The expected type of the current expression being analyzed."} + (Meta Type) + (function [state] + (case (get@ #;expected state) + (#;Some type) + (#e;Success [state type]) + + #;None + (#e;Error "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 (resolve-tag tag) + {#;doc "Given a tag, finds out what is its index, its related tag-list and it's associated type."} + (-> Ident (Meta [Nat (List Ident) Type])) + (do Monad + [#let [[module name] tag] + =module (find-module module) + this-module-name current-module-name] + (case (get name (get@ #;tags =module)) + (#;Some [idx tag-list exported? type]) + (if (or exported? + (text/= this-module-name module)) + (wrap [idx tag-list type]) + (fail ($_ text/compose "Cannot access tag: " (ident/encode tag) " from module " this-module-name))) + + _ + (fail ($_ text/compose "Unknown tag: " (ident/encode tag)))))) + +(def: #export (tag-lists module) + {#;doc "All the tag-lists defined in a module, with their associated types."} + (-> Text (Meta (List [(List Ident) 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 [state] + (case (list;inits (get@ #;scopes state)) + #;None + (#e;Error "No local environment") + + (#;Some scopes) + (#e;Success [state + (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."} + (-> Ident (Meta Ident)) + (do Monad + [def-name (normalize def-name) + [_ def-anns _] (find-def def-name)] + (case (get-symbol-ann (ident-for #;alias) def-anns) + (#;Some real-def-name) + (wrap real-def-name) + + _ + (wrap def-name)))) + +(def: #export get-compiler + {#;doc "Obtains the current state of the compiler."} + (Meta Compiler) + (function [compiler] + (#e;Success [compiler compiler]))) + +(def: #export type-context + (Meta Type-Context) + (function [compiler] + (#e;Success [compiler (get@ #;type-context compiler)]))) + +(do-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 tokens + (^ (list [_ (#;Tag ["" "omit"])] + token)) + (do Monad + [output ( token) + #let [_ (list/map (. log! code;to-text) + output)]] + (wrap (list))) + + (^ (list token)) + (do Monad + [output ( token) + #let [_ (list/map (. log! code;to-text) + output)]] + (wrap output)) + + _ + (fail ($_ text/compose "Wrong syntax for " "."))))] + + [log-expand expand "log-expand"] + [log-expand-all expand-all "log-expand-all"] + [log-expand-once expand-once "log-expand-once"] + ) diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux new file mode 100644 index 000000000..d41dbe240 --- /dev/null +++ b/stdlib/source/lux/macro/code.lux @@ -0,0 +1,143 @@ +(;module: + lux + (lux (control [eq #+ Eq]) + (data bool + number + [text #+ Eq "Text/" Monoid] + ident + (coll [list #* "" Functor Fold]) + ))) + +## [Types] +## (type: (Code' w) +## (#;Bool Bool) +## (#;Nat Nat) +## (#;Int Int) +## (#;Frac Frac) +## (#;Text Text) +## (#;Symbol Text Text) +## (#;Tag Text Text) +## (#;Form (List (w (Code' w)))) +## (#;Tuple (List (w (Code' w)))) +## (#;Record (List [(w (Code' w)) (w (Code' w))]))) + +## (type: Code +## (Ann Cursor (Code' (Ann Cursor)))) + +## [Utils] +(def: _cursor Cursor ["" +0 +0]) + +## [Functions] +(do-template [ ] + [(def: #export ( x) + (-> Code) + [_cursor ( x)])] + + [bool Bool #;Bool] + [nat Nat #;Nat] + [int Int #;Int] + [deg Deg #;Deg] + [frac Frac #;Frac] + [text Text #;Text] + [symbol Ident #;Symbol] + [tag Ident #;Tag] + [form (List Code) #;Form] + [tuple (List Code) #;Tuple] + [record (List [Code Code]) #;Record] + ) + +(do-template [ ] + [(def: #export ( name) + {#;doc } + (-> Text Code) + [_cursor ( ["" name])])] + + [local-symbol #;Symbol "Produces a local symbol (a symbol with no module prefix)."] + [local-tag #;Tag "Produces a local tag (a tag with no module prefix)."]) + +## [Structures] +(struct: #export _ (Eq Code) + (def: (= x y) + (case [x y] + (^template [ ] + [[_ ( x')] [_ ( y')]] + (:: = x' y')) + ([#;Bool Eq] + [#;Nat Eq] + [#;Int Eq] + [#;Deg Eq] + [#;Frac Eq] + [#;Text Eq] + [#;Symbol Eq] + [#;Tag Eq]) + + (^template [] + [[_ ( xs')] [_ ( ys')]] + (and (:: Eq = (size xs') (size ys')) + (fold (function [[x' y'] old] + (and old (= x' y'))) + true + (zip2 xs' ys')))) + ([#;Form] + [#;Tuple]) + + [[_ (#;Record xs')] [_ (#;Record ys')]] + (and (:: Eq = (size xs') (size ys')) + (fold (function [[[xl' xr'] [yl' yr']] old] + (and old (= xl' yl') (= xr' yr'))) + true + (zip2 xs' ys'))) + + _ + false))) + +## [Values] +(def: #export (to-text ast) + (-> Code Text) + (case ast + (^template [ ] + [_ ( value)] + (:: encode value)) + ([#;Bool Codec] + [#;Nat Codec] + [#;Int Codec] + [#;Deg Codec] + [#;Frac Codec] + [#;Symbol Codec]) + + [_ (#;Text value)] + (text;encode value) + + [_ (#;Tag ident)] + (Text/compose "#" (:: Codec encode ident)) + + (^template [ ] + [_ ( members)] + ($_ Text/compose (|> members (map to-text) (interpose " ") (text;join-with "")) )) + ([#;Form "(" ")"] + [#;Tuple "[" "]"]) + + [_ (#;Record pairs)] + ($_ Text/compose "{" (|> pairs (map (function [[left right]] ($_ Text/compose (to-text left) " " (to-text right)))) (interpose " ") (text;join-with "")) "}") + )) + +(def: #export (replace original substitute ast) + {#;doc "Replaces all code that looks like the 'original' with the 'substitute'."} + (-> Code Code Code Code) + (if (:: Eq = original ast) + substitute + (case ast + (^template [] + [cursor ( parts)] + [cursor ( (map (replace original substitute) parts))]) + ([#;Form] + [#;Tuple]) + + [cursor (#;Record parts)] + [cursor (#;Record (map (function [[left right]] + [(replace original substitute left) + (replace original substitute right)]) + parts))] + + _ + ast))) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux new file mode 100644 index 000000000..7ed7fb2ee --- /dev/null +++ b/stdlib/source/lux/macro/poly.lux @@ -0,0 +1,448 @@ +(;module: + [lux #- function] + (lux (control [monad #+ do Monad] + [eq] + ["p" parser]) + [function] + (data [text "text/" Monoid] + (coll [list "list/" Fold Monad Monoid] + [dict #+ Dict]) + [number "nat/" Codec] + [product] + [bool] + [maybe] + [ident "ident/" Eq Codec] + ["e" error]) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax: Syntax] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))) + (lang [type] + (type [check])) + )) + +(type: #export Env (Dict Nat [Type Code])) + +(type: #export (Poly a) + (p;Parser [Env (List Type)] a)) + +(def: #export fresh Env (dict;new number;Hash)) + +(def: (run' env types poly) + (All [a] (-> Env (List Type) (Poly a) (e;Error a))) + (case (p;run [env types] poly) + (#e;Error error) + (#e;Error error) + + (#e;Success [[env' remaining] output]) + (case remaining + #;Nil + (#e;Success output) + + _ + (#e;Error (|> remaining + (list/map type;to-text) + (text;join-with ", ") + (text/compose "Unconsumed types: ")))))) + +(def: #export (run type poly) + (All [a] (-> Type (Poly a) (e;Error a))) + (run' fresh (list type) poly)) + +(def: #export env + (Poly Env) + (;function [[env inputs]] + (#e;Success [[env inputs] env]))) + +(def: (with-env temp poly) + (All [a] (-> Env (Poly a) (Poly a))) + (;function [[env inputs]] + (case (p;run [temp inputs] poly) + (#e;Error error) + (#e;Error error) + + (#e;Success [[_ remaining] output]) + (#e;Success [[env remaining] output])))) + +(def: #export peek + (Poly Type) + (;function [[env inputs]] + (case inputs + #;Nil + (#e;Error "Empty stream of types.") + + (#;Cons headT tail) + (#e;Success [[env inputs] headT])))) + +(def: #export any + (Poly Type) + (;function [[env inputs]] + (case inputs + #;Nil + (#e;Error "Empty stream of types.") + + (#;Cons headT tail) + (#e;Success [[env tail] headT])))) + +(def: #export (local types poly) + (All [a] (-> (List Type) (Poly a) (Poly a))) + (;function [[env pass-through]] + (case (run' env types poly) + (#e;Error error) + (#e;Error error) + + (#e;Success output) + (#e;Success [[env pass-through] output])))) + +(def: (label idx) + (-> Nat Code) + (code;local-symbol (text/compose "label\u0000" (nat/encode idx)))) + +(def: #export (with-extension type poly) + (All [a] (-> Type (Poly a) (Poly [Code a]))) + (;function [[env inputs]] + (let [current-id (dict;size env) + g!var (label current-id)] + (case (p;run [(dict;put current-id [type g!var] env) + inputs] + poly) + (#e;Error error) + (#e;Error error) + + (#e;Success [[_ inputs'] output]) + (#e;Success [[env inputs'] [g!var output]]))))) + +(do-template [ ] + [(def: #export + (Poly Unit) + (do p;Monad + [headT any] + (case (type;un-name headT) + + (wrap []) + + _ + (p;fail ($_ text/compose "Not " " type: " (type;to-text headT))))))] + + [void "Void" #;Void] + [unit "Unit" #;Unit] + [bool "Bool" (#;Primitive "#Bool" #;Nil)] + [nat "Nat" (#;Primitive "#Nat" #;Nil)] + [int "Int" (#;Primitive "#Int" #;Nil)] + [deg "Deg" (#;Primitive "#Deg" #;Nil)] + [frac "Frac" (#;Primitive "#Frac" #;Nil)] + [text "Text" (#;Primitive "#Text" #;Nil)] + ) + +(def: #export basic + (Poly Type) + (do p;Monad + [headT any] + (case (run headT ($_ p;either + void + unit + bool + nat + int + deg + frac + text)) + (#e;Error error) + (p;fail error) + + (#e;Success _) + (wrap headT)))) + +(do-template [ ] + [(def: #export ( poly) + (All [a] (-> (Poly a) (Poly a))) + (do p;Monad + [headT any] + (let [members ( (type;un-name headT))] + (if (n.> +1 (list;size members)) + (local members poly) + (p;fail ($_ text/compose "Not a " (ident/encode (ident-for )) " type: " (type;to-text headT)))))))] + + [variant type;flatten-variant #;Sum] + [tuple type;flatten-tuple #;Product] + ) + +(def: polymorphic' + (Poly [Nat Type]) + (do p;Monad + [headT any + #let [[num-arg bodyT] (type;flatten-univ-q (type;un-name headT))]] + (if (n.= +0 num-arg) + (p;fail ($_ text/compose "Non-polymorphic type: " (type;to-text headT))) + (wrap [num-arg bodyT])))) + +(def: #export (polymorphic poly) + (All [a] (-> (Poly a) (Poly [Code (List Code) a]))) + (do p;Monad + [headT any + funcI (:: @ map dict;size ;;env) + [num-args non-poly] (local (list headT) polymorphic') + env ;;env + #let [funcL (label funcI) + [all-varsL env'] (loop [current-arg +0 + env' env + all-varsL (: (List Code) (list))] + (if (n.< num-args current-arg) + (if (n.= +0 current-arg) + (let [varL (label (n.inc funcI))] + (recur (n.inc current-arg) + (|> env' + (dict;put funcI [headT funcL]) + (dict;put (n.inc funcI) [(#;Bound (n.inc funcI)) varL])) + (#;Cons varL all-varsL))) + (let [partialI (|> current-arg (n.* +2) (n.+ funcI)) + partial-varI (n.inc partialI) + partial-varL (label partial-varI) + partialC (` ((~ funcL) (~@ (|> (list;n.range +0 (n.dec num-args)) + (list/map (|>. (n.* +2) n.inc (n.+ funcI) label)) + list;reverse))))] + (recur (n.inc current-arg) + (|> env' + (dict;put partialI [;Void partialC]) + (dict;put partial-varI [(#;Bound partial-varI) partial-varL])) + (#;Cons partial-varL all-varsL)))) + [all-varsL env']))]] + (|> (do @ + [output poly] + (wrap [funcL all-varsL output])) + (local (list non-poly)) + (with-env env')))) + +(def: #export (function in-poly out-poly) + (All [i o] (-> (Poly i) (Poly o) (Poly [i o]))) + (do p;Monad + [headT any + #let [[inputsT outputT] (type;flatten-function (type;un-name headT))]] + (if (n.> +0 (list;size inputsT)) + (p;seq (local inputsT in-poly) + (local (list outputT) out-poly)) + (p;fail ($_ text/compose "Non-function type: " (type;to-text headT)))))) + +(def: #export (apply poly) + (All [a] (-> (Poly a) (Poly a))) + (do p;Monad + [headT any + #let [[funcT paramsT] (type;flatten-application (type;un-name headT))]] + (if (n.= +0 (list;size paramsT)) + (p;fail ($_ text/compose "Non-application type: " (type;to-text headT))) + (local (#;Cons funcT paramsT) poly)))) + +(def: #export (this expected) + (-> Type (Poly Unit)) + (do p;Monad + [actual any] + (if (check;checks? expected actual) + (wrap []) + (p;fail ($_ text/compose + "Types do not match." "\n" + "Expected: " (type;to-text expected) "\n" + " Actual: " (type;to-text actual)))))) + +(def: (adjusted-idx env idx) + (-> Env Nat Nat) + (let [env-level (n./ +2 (dict;size env)) + bound-level (n./ +2 idx) + bound-idx (n.% +2 idx)] + (|> env-level n.dec (n.- bound-level) (n.* +2) (n.+ bound-idx)))) + +(def: #export bound + (Poly Code) + (do p;Monad + [env ;;env + headT any] + (case headT + (#;Bound idx) + (case (dict;get (adjusted-idx env idx) env) + (#;Some [poly-type poly-ast]) + (wrap poly-ast) + + #;None + (p;fail ($_ text/compose "Unknown bound type: " (type;to-text headT)))) + + _ + (p;fail ($_ text/compose "Not a bound type: " (type;to-text headT)))))) + +(def: #export (var id) + (-> Nat (Poly Unit)) + (do p;Monad + [env ;;env + headT any] + (case headT + (#;Bound idx) + (if (n.= id (adjusted-idx env idx)) + (wrap []) + (p;fail ($_ text/compose "Wrong bound type.\n" + "Expected: " (nat/encode id) "\n" + " Actual: " (nat/encode idx)))) + + _ + (p;fail ($_ text/compose "Not a bound type: " (type;to-text headT)))))) + +(def: #export (recursive poly) + (All [a] (-> (Poly a) (Poly [Code a]))) + (do p;Monad + [headT any] + (case (type;un-name headT) + (#;Apply #;Void (#;UnivQ _ headT')) + (do @ + [[recT _ output] (|> poly + (with-extension #;Void) + (with-extension headT) + (local (list headT')))] + (wrap [recT output])) + + _ + (p;fail ($_ text/compose "Not a recursive type: " (type;to-text headT)))))) + +(def: #export recursive-self + (Poly Code) + (do p;Monad + [env ;;env + headT any] + (case (type;un-name headT) + (^multi (#;Apply #;Void (#;Bound funcT-idx)) + (n.= +0 (adjusted-idx env funcT-idx)) + [(dict;get +0 env) (#;Some [self-type self-call])]) + (wrap self-call) + + _ + (p;fail ($_ text/compose "Not a recursive type: " (type;to-text headT)))))) + +(def: #export recursive-call + (Poly Code) + (do p;Monad + [env ;;env + [funcT argsT] (apply (p;seq any (p;many any))) + _ (local (list funcT) (var +0)) + allC (let [allT (list& funcT argsT)] + (|> allT + (monad;map @ (function;const bound)) + (local allT)))] + (wrap (` ((~@ allC)))))) + +(def: #export log + (All [a] (Poly a)) + (do p;Monad + [current any + #let [_ (log! ($_ text/compose + "{" (ident/encode (ident-for ;;log)) "} " + (type;to-text current)))]] + (p;fail "LOGGING"))) + +## [Syntax] +(syntax: #export (poly: [export csr;export] + [name s;local-symbol] + body) + (with-gensyms [g!type g!output] + (let [g!name (code;symbol ["" name])] + (wrap (;list (` (syntax: (~@ (csw;export export)) ((~ g!name) [(~ g!type) s;symbol]) + (do macro;Monad + [(~ g!type) (macro;find-type-def (~ g!type))] + (case (|> (~ body) + (;function [(~ g!name)]) + p;rec + (do p;Monad []) + (;;run (~ g!type)) + (: (;Either ;Text ;Code))) + (#;Left (~ g!output)) + (macro;fail (~ g!output)) + + (#;Right (~ g!output)) + ((~' wrap) (;list (~ g!output)))))))))))) + +(def: (common-poly-name? poly-func) + (-> Text Bool) + (text;contains? "?" poly-func)) + +(def: (derivation-name poly args) + (-> Text (List Text) (Maybe Text)) + (if (common-poly-name? poly) + (#;Some (list/fold (text;replace-once "?") poly args)) + #;None)) + +(syntax: #export (derived: [export csr;export] + [?name (p;maybe s;local-symbol)] + [[poly-func poly-args] (s;form (p;seq s;symbol (p;many s;symbol)))] + [?custom-impl (p;maybe s;any)]) + (do @ + [poly-args (monad;map @ macro;normalize poly-args) + name (case ?name + (#;Some name) + (wrap name) + + (^multi #;None + [(derivation-name (product;right poly-func) (list/map product;right poly-args)) + (#;Some derived-name)]) + (wrap derived-name) + + _ + (p;fail "derived: was given no explicit name, and cannot generate one from given information.")) + #let [impl (case ?custom-impl + (#;Some custom-impl) + custom-impl + + #;None + (` ((~ (code;symbol poly-func)) (~@ (list/map code;symbol poly-args)))))]] + (wrap (;list (` (def: (~@ (csw;export export)) + (~ (code;symbol ["" name])) + {#;struct? true} + (~ impl))))))) + +## [Derivers] +(def: #export (to-ast env type) + (-> Env Type Code) + (case type + (#;Primitive name params) + (` (#;Primitive (~ (code;text name)) + (list (~@ (list/map (to-ast env) params))))) + + (^template [] + + (` )) + ([#;Void] [#;Unit]) + + (^template [] + ( idx) + (` ( (~ (code;nat idx))))) + ([#;Var] [#;Ex]) + + (#;Bound idx) + (let [idx (adjusted-idx env idx)] + (if (n.= +0 idx) + (|> (dict;get idx env) maybe;assume product;left (to-ast env)) + (` (;$ (~ (code;nat (n.dec idx))))))) + + (#;Apply #;Void (#;Bound idx)) + (let [idx (adjusted-idx env idx)] + (if (n.= +0 idx) + (|> (dict;get idx env) maybe;assume product;left (to-ast env)) + (undefined))) + + (^template [] + ( left right) + (` ( (~ (to-ast env left)) + (~ (to-ast env right))))) + ([#;Function] [#;Apply]) + + (^template [ ] + ( left right) + (` ( (~@ (list/map (to-ast env) ( type)))))) + ([#;Sum | type;flatten-variant] + [#;Product & type;flatten-tuple]) + + (#;Named name sub-type) + (code;symbol name) + + (^template [] + ( scope body) + (` ( (list (~@ (list/map (to-ast env) scope))) + (~ (to-ast env body))))) + ([#;UnivQ] [#;ExQ]) + )) diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux new file mode 100644 index 000000000..099febb24 --- /dev/null +++ b/stdlib/source/lux/macro/poly/eq.lux @@ -0,0 +1,147 @@ +(;module: + lux + (lux (control [monad #+ do Monad] + [eq] + ["p" parser]) + (data [text "text/" Monoid] + text/format + (coll [list "list/" Monad] + [sequence] + [array] + [queue] + [set] + [dict #+ Dict] + (tree [rose])) + [number "nat/" Codec] + [product] + [bool] + [maybe]) + (time ["du" duration] + ["da" date] + ["i" instant]) + [macro] + (macro [code] + [syntax #+ syntax: Syntax] + (syntax [common]) + [poly #+ poly:]) + (type [unit]) + (lang [type]) + )) + +## [Derivers] +(poly: #export Eq + (`` (do @ + [#let [g!_ (code;local-symbol "\u0000_")] + *env* poly;env + inputT poly;peek + #let [@Eq (: (-> Type Code) + (function [type] + (` (eq;Eq (~ (poly;to-ast *env* type))))))]] + ($_ p;either + ## Basic types + (~~ (do-template [ ] + [(do @ + [_ ] + (wrap (` (: (~ (@Eq inputT)) + ))))] + + [poly;unit (function [(~ g!_) (~ g!_)] true)] + [poly;bool bool;Eq] + [poly;nat number;Eq] + [poly;int number;Eq] + [poly;deg number;Eq] + [poly;frac number;Eq] + [poly;text text;Eq])) + ## Composite types + (~~ (do-template [ ] + [(do @ + [[_ argC] (poly;apply (p;seq (poly;this ) + Eq))] + (wrap (` (: (~ (@Eq inputT)) + ( (~ argC))))))] + + [;Maybe maybe;Eq] + [;List list;Eq] + [sequence;Sequence sequence;Eq] + [;Array array;Eq] + [queue;Queue queue;Eq] + [set;Set set;Eq] + [rose;Tree rose;Eq] + )) + (do @ + [[_ _ valC] (poly;apply ($_ p;seq + (poly;this dict;Dict) + poly;any + Eq))] + (wrap (` (: (~ (@Eq inputT)) + (dict;Eq (~ valC)))))) + ## Models + (~~ (do-template [ ] + [(do @ + [_ (poly;this )] + (wrap (` (: (~ (@Eq inputT)) + ))))] + + [du;Duration du;Eq] + [i;Instant i;Eq] + [da;Date da;Eq] + [da;Day da;Eq] + [da;Month da;Eq])) + (do @ + [_ (poly;apply (p;seq (poly;this unit;Qty) + poly;any))] + (wrap (` (: (~ (@Eq inputT)) + unit;Eq)))) + ## Variants + (do @ + [members (poly;variant (p;many Eq)) + #let [g!left (code;local-symbol "\u0000left") + g!right (code;local-symbol "\u0000right")]] + (wrap (` (: (~ (@Eq inputT)) + (function [(~ g!left) (~ g!right)] + (case [(~ g!left) (~ g!right)] + (~@ (list/join (list/map (function [[tag g!eq]] + (list (` [((~ (code;nat tag)) (~ g!left)) + ((~ (code;nat tag)) (~ g!right))]) + (` ((~ g!eq) (~ g!left) (~ g!right))))) + (list;enumerate members)))) + (~ g!_) + false)))))) + ## Tuples + (do @ + [g!eqs (poly;tuple (p;many Eq)) + #let [indices (|> (list;size g!eqs) n.dec (list;n.range +0)) + g!lefts (list/map (|>. nat/encode (text/compose "left") code;local-symbol) indices) + g!rights (list/map (|>. nat/encode (text/compose "right") code;local-symbol) indices)]] + (wrap (` (: (~ (@Eq inputT)) + (function [[(~@ g!lefts)] [(~@ g!rights)]] + (and (~@ (|> (list;zip3 g!eqs g!lefts g!rights) + (list/map (function [[g!eq g!left g!right]] + (` ((~ g!eq) (~ g!left) (~ g!right))))))))))))) + ## Type recursion + (do @ + [[g!self bodyC] (poly;recursive Eq)] + (wrap (` (: (~ (@Eq inputT)) + (eq;rec (;function [(~ g!self)] + (~ bodyC))))))) + poly;recursive-self + ## Type applications + (do @ + [[funcC argsC] (poly;apply (p;seq Eq (p;many Eq)))] + (wrap (` ((~ funcC) (~@ argsC))))) + ## Bound type-vars + poly;bound + ## Polymorphism + (do @ + [[funcC varsC bodyC] (poly;polymorphic Eq)] + (wrap (` (: (All [(~@ varsC)] + (-> (~@ (list/map (|>. (~) eq;Eq (`)) varsC)) + (eq;Eq ((~ (poly;to-ast *env* inputT)) (~@ varsC))))) + (function (~ funcC) [(~@ varsC)] + (~ bodyC)))))) + poly;recursive-call + ## If all else fails... + (|> poly;any + (:: @ map (|>. %type (format "Cannot create Eq for: ") p;fail)) + (:: @ join)) + )))) diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux new file mode 100644 index 000000000..ba847d35b --- /dev/null +++ b/stdlib/source/lux/macro/poly/functor.lux @@ -0,0 +1,95 @@ +(;module: + lux + (lux (control [monad #+ do Monad] + [functor] + ["p" parser]) + (data [text] + text/format + (coll [list "L/" Monad Monoid]) + [product]) + [macro] + (macro [code] + [syntax #+ syntax: Syntax] + (syntax [common]) + [poly #+ poly:]) + (lang [type]) + )) + +(poly: #export Functor + (do @ + [#let [type-funcC (code;local-symbol "\u0000type-funcC") + funcC (code;local-symbol "\u0000funcC") + inputC (code;local-symbol "\u0000inputC")] + *env* poly;env + inputT poly;peek + [polyC varsC non-functorT] (poly;local (list inputT) + (poly;polymorphic poly;any)) + #let [num-vars (list;size varsC)] + #let [@Functor (: (-> Type Code) + (function [unwrappedT] + (if (n.= +1 num-vars) + (` (functor;Functor (~ (poly;to-ast *env* unwrappedT)))) + (let [paramsC (|> num-vars n.dec list;indices (L/map (|>. %n code;local-symbol)))] + (` (All [(~@ paramsC)] + (functor;Functor ((~ (poly;to-ast *env* unwrappedT)) (~@ paramsC))))))))) + Arg (: (-> Code (poly;Poly Code)) + (function Arg [valueC] + ($_ p;either + ## Type-var + (do p;Monad + [#let [varI (|> num-vars (n.* +2) n.dec)] + _ (poly;var varI)] + (wrap (` ((~ funcC) (~ valueC))))) + ## Variants + (do @ + [_ (wrap []) + membersC (poly;variant (p;many (Arg valueC)))] + (wrap (` (case (~ valueC) + (~@ (L/join (L/map (function [[tag memberC]] + (list (` ((~ (code;nat tag)) (~ valueC))) + (` ((~ (code;nat tag)) (~ memberC))))) + (list;enumerate membersC)))))))) + ## Tuples + (do p;Monad + [pairsCC (: (poly;Poly (List [Code Code])) + (poly;tuple (loop [idx +0 + pairsCC (: (List [Code Code]) + (list))] + (p;either (let [slotC (|> idx %n (format "\u0000slot") code;local-symbol)] + (do @ + [_ (wrap []) + memberC (Arg slotC)] + (recur (n.inc idx) + (L/compose pairsCC (list [slotC memberC]))))) + (wrap pairsCC)))))] + (wrap (` (case (~ valueC) + [(~@ (L/map product;left pairsCC))] + [(~@ (L/map product;right pairsCC))])))) + ## Functions + (do @ + [_ (wrap []) + #let [outL (code;local-symbol "\u0000outL")] + [inT+ outC] (poly;function (p;many poly;any) + (Arg outL)) + #let [inC+ (|> (list;size inT+) n.dec + (list;n.range +0) + (L/map (|>. %n (format "\u0000inC") code;local-symbol)))]] + (wrap (` (function [(~@ inC+)] + (let [(~ outL) ((~ valueC) (~@ inC+))] + (~ outC)))))) + ## Recursion + (do p;Monad + [_ poly;recursive-call] + (wrap (` ((~' map) (~ funcC) (~ valueC))))) + ## Bound type-variables + (do p;Monad + [_ poly;any] + (wrap valueC)) + )))] + [_ _ outputC] (: (poly;Poly [Code (List Code) Code]) + (p;either (poly;polymorphic + (Arg inputC)) + (p;fail (format "Cannot create Functor for: " (%type inputT)))))] + (wrap (` (: (~ (@Functor inputT)) + (struct (def: ((~' map) (~ funcC) (~ inputC)) + (~ outputC)))))))) diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux new file mode 100644 index 000000000..5c3a645ee --- /dev/null +++ b/stdlib/source/lux/macro/poly/json.lux @@ -0,0 +1,312 @@ +(;module: {#;doc "Codecs for values in the JSON format."} + lux + (lux (control [monad #+ do Monad] + [eq #+ Eq] + codec + ["p" parser "p/" Monad]) + (data [bool] + [bit] + [text "text/" Eq Monoid] + (text ["l" lexer]) + [number "frac/" Codec "nat/" Codec] + maybe + ["e" error] + [sum] + [product] + (coll [list "list/" Fold Monad] + [sequence #+ Sequence sequence "sequence/" Monad] + ["d" dict]) + (format [".." json #+ JSON])) + (time ["i" instant] + ["du" duration] + ["da" date]) + [macro #+ with-gensyms] + (macro ["s" syntax #+ syntax:] + [code] + [poly #+ poly:]) + (type [unit]) + (lang [type]) + )) + +(def: #hidden _map_ + (All [a b] (-> (-> a b) (List a) (List b))) + list/map) + +(def: tag + (-> Nat Frac) + (|>. nat-to-int int-to-frac)) + +(def: #hidden (rec-encode non-rec) + (All [a] (-> (-> (-> a JSON) + (-> a JSON)) + (-> a JSON))) + (function [input] + (non-rec (rec-encode non-rec) input))) + +(def: low-mask Nat (|> +1 (bit;shift-left +32) n.dec)) +(def: high-mask Nat (|> low-mask (bit;shift-left +32))) + +(struct: #hidden _ (Codec JSON Nat) + (def: (encode input) + (let [high (|> input (bit;and high-mask) (bit;shift-right +32)) + low (bit;and low-mask input)] + (#..;Array (sequence (|> high nat-to-int int-to-frac #..;Number) + (|> low nat-to-int int-to-frac #..;Number))))) + (def: (decode input) + (<| (..;run input) + (do p;Monad + [high ..;number + low ..;number]) + (wrap (n.+ (|> high frac-to-int int-to-nat (bit;shift-left +32)) + (|> low frac-to-int int-to-nat)))))) + +(struct: #hidden _ (Codec JSON Int) + (def: encode (|>. int-to-nat (:: Codec encode))) + (def: decode + (|>. (:: Codec decode) (:: e;Functor map nat-to-int)))) + +(def: #hidden (nullable writer) + {#;doc "Builds a JSON generator for potentially inexistent values."} + (All [a] (-> (-> a JSON) (-> (Maybe a) JSON))) + (function [elem] + (case elem + #;None #..;Null + (#;Some value) (writer value)))) + +(struct: #hidden (Codec carrier) + (All [unit] (-> unit (Codec JSON (unit;Qty unit)))) + (def: encode + (|>. unit;out (:: Codec encode))) + (def: decode + (|>. (:: Codec decode) (:: e;Functor map (unit;in carrier))))) + +(poly: #hidden Codec//encode + (with-expansions + [ (do-template [ ] + [(do @ + [_ ] + (wrap (` (: (~ (@JSON//encode inputT)) + ))))] + + [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)] + [Bool poly;bool (|>. #..;Boolean)] + [Nat poly;nat (:: ;;Codec (~' encode))] + [Int poly;int (:: ;;Codec (~' encode))] + [Frac poly;frac (|>. #..;Number)] + [Text poly;text (|>. #..;String)]) +