diff options
| author | The Lux Programming Language | 2017-12-02 14:33:40 -0400 |
|---|---|---|
| committer | GitHub | 2017-12-02 14:33:40 -0400 |
| commit | a3687e36a71ebbc3069260e904e47272933a48a1 (patch) | |
| tree | 0783fac3f94ea4765dfc91b0fe85b9b1a37cb5d8 /stdlib/source | |
| parent | 0ea9403e482b7f01df9e634ae2533b20ef56a9ab (diff) | |
| parent | c72e120e8c2c300411c0cb07ecb3b6bc32e0cb24 (diff) | |
Merge pull request #42 from LuxLang/context_sensitive_macro_expansion
Context sensitive macro expansion
Diffstat (limited to '')
39 files changed, 801 insertions, 904 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 4ec6e1ea1..ebac83f40 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -898,11 +898,6 @@ (flag-meta "export?")) (record$ #Nil)) -("lux def" hidden?-meta - ("lux check" Code - (flag-meta "hidden?")) - (record$ #Nil)) - ("lux def" macro?-meta ("lux check" Code (flag-meta "macro?")) @@ -916,14 +911,6 @@ (#Cons tail #Nil)))))) (record$ #Nil)) -("lux def" with-hidden-meta - ("lux check" (#Function Code Code) - (function'' [tail] - (form$ (#Cons (tag$ ["lux" "Cons"]) - (#Cons hidden?-meta - (#Cons tail #Nil)))))) - (record$ #Nil)) - ("lux def" with-macro-meta ("lux check" (#Function Code Code) (function'' [tail] @@ -1064,7 +1051,7 @@ _ (fail "Wrong syntax for $'")})) -(def:'' (map f xs) +(def:'' (list/map f xs) #Nil (#UnivQ #Nil (#UnivQ #Nil @@ -1076,7 +1063,7 @@ #Nil (#Cons x xs') - (#Cons (f x) (map f xs'))})) + (#Cons (f x) (list/map f xs'))})) (def:'' RepEnv #Nil @@ -1126,18 +1113,18 @@ syntax}) [meta (#Form parts)] - [meta (#Form (map (replace-syntax reps) parts))] + [meta (#Form (list/map (replace-syntax reps) parts))] [meta (#Tuple members)] - [meta (#Tuple (map (replace-syntax reps) members))] + [meta (#Tuple (list/map (replace-syntax reps) members))] [meta (#Record slots)] - [meta (#Record (map ("lux check" (#Function (#Product Code Code) (#Product Code Code)) - (function'' [slot] - ("lux case" slot - {[k v] - [(replace-syntax reps k) (replace-syntax reps v)]}))) - slots))] + [meta (#Record (list/map ("lux check" (#Function (#Product Code Code) (#Product Code Code)) + (function'' [slot] + ("lux case" slot + {[k v] + [(replace-syntax reps k) (replace-syntax reps v)]}))) + slots))] _ syntax}) @@ -1148,20 +1135,20 @@ (#Function Code Code) ("lux case" code {[_ (#Tuple members)] - (tuple$ (map update-bounds members)) + (tuple$ (list/map update-bounds members)) [_ (#Record pairs)] - (record$ (map ("lux check" (#Function (#Product Code Code) (#Product Code Code)) - (function'' [pair] - (let'' [name val] pair - [name (update-bounds val)]))) - pairs)) + (record$ (list/map ("lux check" (#Function (#Product Code Code) (#Product Code Code)) + (function'' [pair] + (let'' [name val] pair + [name (update-bounds val)]))) + pairs)) [_ (#Form (#Cons [_ (#Tag "lux" "Bound")] (#Cons [_ (#Nat idx)] #Nil)))] (form$ (#Cons (tag$ ["lux" "Bound"]) (#Cons (nat$ ("lux nat +" +2 idx)) #Nil))) [_ (#Form members)] - (form$ (map update-bounds members)) + (form$ (list/map update-bounds members)) _ code})) @@ -1549,9 +1536,7 @@ ys})) (def:''' #export (splice-helper xs ys) - (#Cons [(tag$ ["lux" "hidden?"]) - (bool$ true)] - #Nil) + #Nil (-> ($' List Code) ($' List Code) ($' List Code)) ("lux case" xs {(#Cons x xs') @@ -1854,8 +1839,9 @@ (#Cons lastI inits) (do Monad<Meta> [lastO ("lux case" lastI - {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] - (wrap spliced) + {[_ (#Form (#Cons [[_ (#Symbol ["" "~+"])] (#Cons [spliced #Nil])]))] + (let' [[[_module-name _ _] _] spliced] + (wrap spliced)) _ (do Monad<Meta> @@ -1864,10 +1850,11 @@ (monad/fold Monad<Meta> (function' [leftI rightO] ("lux case" leftI - {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] - (wrap (form$ (list (symbol$ ["lux" "splice-helper"]) - spliced - rightO))) + {[_ (#Form (#Cons [[_ (#Symbol ["" "~+"])] (#Cons [spliced #Nil])]))] + (let' [[[_module-name _ _] _] spliced] + (wrap (form$ (list (symbol$ ["lux" "splice-helper"]) + spliced + rightO)))) _ (do Monad<Meta> @@ -1880,6 +1867,11 @@ [=elems (monad/map Monad<Meta> untemplate elems)] (wrap (untemplate-list =elems)))})) +(def:''' (untemplate-text value) + #Nil + (-> Text Code) + (wrap-meta (form$ (list (tag$ ["lux" "Text"]) (text$ value))))) + (def:''' (untemplate replace? subst token) #Nil (-> Bool Text Code ($' Meta Code)) @@ -1933,6 +1925,14 @@ [true [_ (#Form (#Cons [[_ (#Symbol ["" "~"])] (#Cons [unquoted #Nil])]))]] (return unquoted) + [true [_ (#Form (#Cons [[_ (#Symbol ["" "~!"])] (#Cons [dependent #Nil])]))]] + (do Monad<Meta> + [independent (untemplate replace? subst dependent)] + (wrap (wrap-meta (form$ (list (tag$ ["lux" "Form"]) + (untemplate-list (list (untemplate-text "lux in-module") + (untemplate-text subst) + independent))))))) + [true [_ (#Form (#Cons [[_ (#Symbol ["" "~'"])] (#Cons [keep-quoted #Nil])]))]] (untemplate false subst keep-quoted) @@ -1996,26 +1996,28 @@ (macro:' #export (` tokens) (list [(tag$ ["lux" "doc"]) - (text$ "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms. + (text$ "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms. ## All unprefixed macros will receive their parent module's prefix if imported; otherwise will receive the prefix of the module on which the quasi-quote is being used. (` (def: (~ name) - (function [(~@ args)] + (function [(~+ args)] (~ body))))")]) ("lux case" tokens {(#Cons template #Nil) (do Monad<Meta> [current-module current-module-name =template (untemplate true current-module template)] - (wrap (list (form$ (list (text$ "lux check") (symbol$ ["lux" "Code"]) =template))))) + (wrap (list (form$ (list (text$ "lux check") + (symbol$ ["lux" "Code"]) + =template))))) _ (fail "Wrong syntax for `")})) (macro:' #export (`' tokens) (list [(tag$ ["lux" "doc"]) - (text$ "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms. + (text$ "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms. (`' (def: (~ name) - (function [(~@ args)] + (function [(~+ args)] (~ body))))")]) ("lux case" tokens {(#Cons template #Nil) @@ -2042,12 +2044,12 @@ (macro:' #export (|> tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Piping macro. - (|> elems (map int/encode) (interpose \" \") (fold text/compose \"\")) + (|> elems (list/map int/encode) (interpose \" \") (fold text/compose \"\")) ## => (fold text/compose \"\" (interpose \" \" - (map int/encode elems)))")]) + (list/map int/encode elems)))")]) ("lux case" tokens {(#Cons [init apps]) (return (list (list/fold ("lux check" (-> Code Code Code) @@ -2070,12 +2072,12 @@ (macro:' #export (<| tokens) (list [(tag$ ["lux" "doc"]) (text$ "## Reverse piping macro. - (<| (fold text/compose \"\") (interpose \" \") (map int/encode) elems) + (<| (fold text/compose \"\") (interpose \" \") (list/map int/encode) elems) ## => (fold text/compose \"\" (interpose \" \" - (map int/encode elems)))")]) + (list/map int/encode elems)))")]) ("lux case" (list/reverse tokens) {(#Cons [init apps]) (return (list (list/fold ("lux check" (-> Code Code Code) @@ -2155,17 +2157,17 @@ template}) [meta (#Tuple elems)] - [meta (#Tuple (map (apply-template env) elems))] + [meta (#Tuple (list/map (apply-template env) elems))] [meta (#Form elems)] - [meta (#Form (map (apply-template env) elems))] + [meta (#Form (list/map (apply-template env) elems))] [meta (#Record members)] - [meta (#Record (map ("lux check" (-> (& Code Code) (& Code Code)) - (function' [kv] - (let' [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members))] + [meta (#Record (list/map ("lux check" (-> (& Code Code) (& Code Code)) + (function' [kv] + (let' [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) + members))] _ template})) @@ -2203,10 +2205,10 @@ (monad/map Monad<Maybe> tuple->list data)] {[(#Some bindings') (#Some data')] (let' [apply ("lux check" (-> RepEnv ($' List Code)) - (function' [env] (map (apply-template env) templates))) + (function' [env] (list/map (apply-template env) templates))) num-bindings (list/size bindings')] (if (every? (function' [sample] ("lux nat =" num-bindings sample)) - (map list/size data')) + (list/map list/size data')) (|> data' (join-map (compose apply (make-env bindings'))) return) @@ -2591,16 +2593,22 @@ (-> Code Code) ("lux case" type {[_ (#Form (#Cons [_ (#Tag tag)] parts))] - (form$ (#Cons [(tag$ tag) (map walk-type parts)])) + (form$ (#Cons [(tag$ tag) (list/map walk-type parts)])) [_ (#Tuple members)] - (` (& (~@ (map walk-type members)))) + (` (& (~+ (list/map walk-type members)))) + + [_ (#Form (#Cons [_ (#Text "lux in-module")] + (#Cons [_ (#Text module)] + (#Cons type' + #Nil))))] + (` ("lux in-module" (~ (text$ module)) (~ (walk-type type')))) [_ (#Form (#Cons type-fn args))] (list/fold ("lux check" (-> Code Code Code) (function' [arg type-fn] (` (#.Apply (~ arg) (~ type-fn))))) (walk-type type-fn) - (map walk-type args)) + (list/map walk-type args)) _ type})) @@ -2677,8 +2685,8 @@ _ (fail "Wrong syntax for variant case.")}))) pairs)] - (return [(` (& (~@ (map second members)))) - (#Some (map first members))])) + (return [(` (& (~+ (list/map second members)))) + (#Some (list/map first members))])) (#Cons type #Nil) ("lux case" type @@ -2686,7 +2694,7 @@ (return [(` #.Unit) (#Some (list member-name))]) [_ (#Form (#Cons [_ (#Tag "" member-name)] member-types))] - (return [(` (& (~@ member-types))) (#Some (list member-name))]) + (return [(` (& (~+ member-types))) (#Some (list member-name))]) _ (return [type #None])}) @@ -2704,13 +2712,13 @@ (return [member-name member-type]) [_ (#Form (#Cons [_ (#Tag "" member-name)] member-types))] - (return [member-name (` (& (~@ member-types)))]) + (return [member-name (` (& (~+ member-types)))]) _ (fail "Wrong syntax for variant case.")}))) (list& case cases))] - (return [(` (| (~@ (map second members)))) - (#Some (map first members))])) + (return [(` (| (~+ (list/map second members)))) + (#Some (list/map first members))])) _ (fail "Improper type-definition syntax")})) @@ -2795,7 +2803,7 @@ body _ - (` (function' (~ name) [(~@ args)] (~ body)))}) + (` (function' (~ name) [(~+ args)] (~ body)))}) body'' ("lux case" ?type {(#Some type) (` (: (~ type) (~ body'))) @@ -2849,21 +2857,21 @@ [_ (#Form xs)] ($_ text/compose "(" (|> xs - (map code-to-text) + (list/map code-to-text) (interpose " ") list/reverse (list/fold text/compose "")) ")") [_ (#Tuple xs)] ($_ text/compose "[" (|> xs - (map code-to-text) + (list/map code-to-text) (interpose " ") list/reverse (list/fold text/compose "")) "]") [_ (#Record kvs)] ($_ text/compose "{" (|> kvs - (map (function' [kv] ("lux case" kv {[k v] ($_ text/compose (code-to-text k) " " (code-to-text v))}))) + (list/map (function' [kv] ("lux case" kv {[k v] ($_ text/compose (code-to-text k) " " (code-to-text v))}))) (interpose " ") list/reverse (list/fold text/compose "")) "}")} @@ -2897,7 +2905,7 @@ _ (fail ($_ text/compose "\"lux.case\" expects an even number of tokens: " (|> branches - (map code-to-text) + (list/map code-to-text) (interpose " ") list/reverse (list/fold text/compose ""))))})) @@ -2974,7 +2982,7 @@ _ (let' [pairs (|> patterns - (map (function' [pattern] (list pattern body))) + (list/map (function' [pattern] (list pattern body))) (list/join))] (return (list/compose pairs branches)))) _ @@ -3033,9 +3041,9 @@ _ #None)) - (#Some ident head tail body) + (#Some g!name head tail body) (let [g!blank (symbol$ ["" ""]) - g!name (symbol$ ident) + g!name (symbol$ g!name) body+ (list/fold (: (-> Code Code Code) (function' [arg body'] (if (symbol? arg) @@ -3080,27 +3088,27 @@ [_ (#Tuple xs)] (|> xs - (map process-def-meta-value) + (list/map process-def-meta-value) untemplate-list (meta-code ["lux" "Tuple"])) [_ (#Record kvs)] (|> kvs - (map (: (-> [Code Code] Code) - (function [[k v]] - (` [(~ (process-def-meta-value k)) - (~ (process-def-meta-value v))])))) + (list/map (: (-> [Code Code] Code) + (function [[k v]] + (` [(~ (process-def-meta-value k)) + (~ (process-def-meta-value v))])))) untemplate-list (meta-code ["lux" "Record"])) )) (def:' (process-def-meta kvs) (-> (List [Code Code]) Code) - (untemplate-list (map (: (-> [Code Code] Code) - (function [[k v]] - (` [(~ (process-def-meta-value k)) - (~ (process-def-meta-value v))]))) - kvs))) + (untemplate-list (list/map (: (-> [Code Code] Code) + (function [[k v]] + (` [(~ (process-def-meta-value k)) + (~ (process-def-meta-value v))]))) + kvs))) (def:' (with-func-args args meta) (-> (List Code) Code Code) @@ -3110,46 +3118,30 @@ _ (` (#.Cons [[(~ cursor-code) (#.Tag ["lux" "func-args"])] - [(~ cursor-code) (#.Tuple (.list (~@ (map (function [arg] - (` [(~ cursor-code) (#.Text (~ (text$ (code-to-text arg))))])) - args))))]] + [(~ cursor-code) (#.Tuple (.list (~+ (list/map (function [arg] + (` [(~ cursor-code) (#.Text (~ (text$ (code-to-text arg))))])) + args))))]] (~ meta))))) (def:' (with-type-args args) (-> (List Code) Code) - (` {#.type-args [(~@ (map (function [arg] (text$ (code-to-text arg))) - args))]})) - -(def:' Export-Level - Type - ($' Either - Unit ## Exported - Unit ## Hidden - )) + (` {#.type-args [(~+ (list/map (function [arg] (text$ (code-to-text arg))) + args))]})) -(def:' (export-level^ tokens) - (-> (List Code) [(Maybe Export-Level) (List Code)]) +(def:' (export^ tokens) + (-> (List Code) [Bool (List Code)]) (case tokens (#Cons [_ (#Tag [_ "export"])] tokens') - [(#Some (#Left [])) tokens'] - - (#Cons [_ (#Tag [_ "hidden"])] tokens') - [(#Some (#Right [])) tokens'] + [true tokens'] _ - [#None tokens])) - -(def:' (export-level ?el) - (-> (Maybe Export-Level) (List Code)) - (case ?el - #None - (list) + [false tokens])) - (#Some (#Left [])) +(def:' (export ?) + (-> Bool (List Code)) + (if ? (list (' #export)) - - (#Some (#Right [])) - (list (' #hidden)))) + (list))) (macro:' #export (def: tokens) (list [(tag$ ["lux" "doc"]) @@ -3162,7 +3154,7 @@ (def: branching-exponent Int 5)")]) - (let [[export? tokens'] (export-level^ tokens) + (let [[export? tokens'] (export^ tokens) parts (: (Maybe [Code (List Code) (Maybe Code) Code (List [Code Code])]) (case tokens' (^ (list [_ (#Form (#Cons name args))] [_ (#Record meta-kvs)] type body)) @@ -3198,7 +3190,7 @@ body _ - (` (function (~ name) [(~@ args)] (~ body)))) + (` (function (~ name) [(~+ args)] (~ body)))) body (case ?type (#Some type) (` (: (~ type) (~ body))) @@ -3210,18 +3202,9 @@ (~ body) [(~ cursor-code) (#Record (~ (with-func-args args - (case export? - #None - =meta - - (#Some (#Left [])) + (if export? (with-export-meta =meta) - - (#Some (#Right [])) - (|> =meta - with-export-meta - with-hidden-meta) - ))))]))))) + =meta))))]))))) #None (fail "Wrong syntax for def:")))) @@ -3257,7 +3240,7 @@ _ (fail \"Wrong syntax for ident-for\")))")]) - (let [[exported? tokens] (export-level^ tokens) + (let [[exported? tokens] (export^ tokens) name+args+meta+body?? (: (Maybe [Ident (List Code) Code Code]) (case tokens (^ (list [_ (#Form (list& [_ (#Symbol name)] args))] body)) @@ -3279,8 +3262,8 @@ (let [name (symbol$ name) def-sig (case args #Nil name - _ (` ((~ name) (~@ args))))] - (return (list (` (..def: (~@ (export-level exported?)) + _ (` ((~ name) (~+ args))))] + (return (list (` (..def: (~+ (export exported?)) (~ def-sig) (~ (meta-code-merge (` {#.macro? true}) meta)) @@ -3305,7 +3288,7 @@ >) (: (-> a a Bool) >=))"} - (let [[exported? tokens'] (export-level^ tokens) + (let [[exported? tokens'] (export^ tokens) ?parts (: (Maybe [Ident (List Code) Code (List Code)]) (case tokens' (^ (list& [_ (#Form (list& [_ (#Symbol name)] args))] [meta-rec-cursor (#Record meta-rec-parts)] sigs)) @@ -3340,10 +3323,10 @@ (list/join sigs'))) #let [[_module _name] name+ def-name (symbol$ name) - sig-type (record$ (map (: (-> [Text Code] [Code Code]) - (function [[m-name m-type]] - [(tag$ ["" m-name]) m-type])) - members)) + sig-type (record$ (list/map (: (-> [Text Code] [Code Code]) + (function [[m-name m-type]] + [(tag$ ["" m-name]) m-type])) + members)) sig-meta (meta-code-merge (` {#.sig? true}) meta) usage (case args @@ -3351,8 +3334,8 @@ def-name _ - (` ((~ def-name) (~@ args))))]] - (return (list (` (..type: (~@ (export-level exported?)) (~ usage) (~ sig-meta) (~ sig-type)))))) + (` ((~ def-name) (~+ args))))]] + (return (list (` (..type: (~+ (export exported?)) (~ usage) (~ sig-meta) (~ sig-type)))))) #None (fail "Wrong syntax for sig:")))) @@ -3678,8 +3661,8 @@ _ (fail "No tags available for type."))) #let [tag-mappings (: (List [Text Code]) - (map (function [tag] [(second tag) (tag$ tag)]) - tags))] + (list/map (function [tag] [(second tag) (tag$ tag)]) + tags))] members (monad/map Monad<Meta> (: (-> Code (Meta [Code Code])) (function [token] @@ -3715,7 +3698,7 @@ (def: (lux.>= test subject) (or (lux.> test subject) (lux.= test subject))))"} - (let [[exported? tokens'] (export-level^ tokens) + (let [[exported? tokens'] (export^ tokens) ?parts (: (Maybe [Code (List Code) Code Code (List Code)]) (case tokens' (^ (list& [_ (#Form (list& name args))] [meta-rec-cursor (#Record meta-rec-parts)] type defs)) @@ -3766,12 +3749,12 @@ name _ - (` ((~ name) (~@ args))))] - (return (list (` (..def: (~@ (export-level exported?)) (~ usage) + (` ((~ name) (~+ args))))] + (return (list (` (..def: (~+ (export exported?)) (~ usage) (~ (meta-code-merge (` {#.struct? true}) meta)) (~ type) - (struct (~@ defs))))))) + (struct (~+ defs))))))) #None (fail "Cannot infer name, so struct must have a name other than \"_\"!")) @@ -3791,7 +3774,7 @@ (type: (List a) #Nil (#Cons a (List a)))"} - (let [[exported? tokens'] (export-level^ tokens) + (let [[exported? tokens'] (export^ tokens) [rec? tokens'] (case tokens' (#Cons [_ (#Tag [_ "rec"])] tokens') [true tokens'] @@ -3830,7 +3813,7 @@ type-meta (: Code (case tags?? (#Some tags) - (` {#.tags [(~@ (map text$ tags))] + (` {#.tags [(~+ (list/map text$ tags))] #.type? true}) _ @@ -3849,10 +3832,10 @@ (#Some type) _ - (#Some (` (All (~ type-name) [(~@ args)] (~ type)))))))] + (#Some (` (All (~ type-name) [(~+ args)] (~ type)))))))] (case type' (#Some type'') - (return (list (` (..def: (~@ (export-level exported?)) (~ type-name) + (return (list (` (..def: (~+ (export exported?)) (~ type-name) (~ ($_ meta-code-merge (with-type-args args) (if rec? (' {#.type-rec? true}) (' {})) type-meta @@ -3986,14 +3969,14 @@ (case tokens (^ (list& [_ (#Tag "" "open")] [_ (#Form parts)] tokens')) (if (|> parts - (map (: (-> Code Bool) - (function [part] - (case part - (^or [_ (#Text _)] [_ (#Symbol _)]) - true + (list/map (: (-> Code Bool) + (function [part] + (case part + (^or [_ (#Text _)] [_ (#Symbol _)]) + true - _ - false)))) + _ + false)))) (list/fold (function [r l] (and l r)) true)) (let [openings (list/fold (: (-> Code (List Openings) (List Openings)) (function [part openings] @@ -4022,14 +4005,14 @@ (def: (parse-short-openings parts) (-> (List Code) (Meta [(List Openings) (List Code)])) (if (|> parts - (map (: (-> Code Bool) - (function [part] - (case part - (^or [_ (#Text _)] [_ (#Symbol _)]) - true + (list/map (: (-> Code Bool) + (function [part] + (case part + (^or [_ (#Text _)] [_ (#Symbol _)]) + true - _ - false)))) + _ + false)))) (list/fold (function [r l] (and l r)) true)) (let [openings (list/fold (: (-> Code (List Openings) (List Openings)) (function [part openings] @@ -4054,16 +4037,16 @@ (def: (decorate-sub-importations super-name) (-> Text (List Importation) (List Importation)) - (map (: (-> Importation Importation) - (function [importation] - (let [{#import-name _name - #import-alias _alias - #import-refer {#refer-defs _referrals - #refer-open _openings}} importation] - {#import-name ($_ text/compose super-name "/" _name) - #import-alias _alias - #import-refer {#refer-defs _referrals - #refer-open _openings}}))))) + (list/map (: (-> Importation Importation) + (function [importation] + (let [{#import-name _name + #import-alias _alias + #import-refer {#refer-defs _referrals + #refer-open _openings}} importation] + {#import-name ($_ text/compose super-name "/" _name) + #import-alias _alias + #import-refer {#refer-defs _referrals + #refer-open _openings}}))))) (def: (replace-all pattern value template) (-> Text Text Text Text) @@ -4187,18 +4170,17 @@ modules)] (case (get module modules) (#Some =module) - (let [to-alias (map (: (-> [Text Def] - (List Text)) - (function [[name [def-type def-meta def-value]]] - (case [(get-meta ["lux" "export?"] def-meta) - (get-meta ["lux" "hidden?"] def-meta)] - [(#Some [_ (#Bool true)]) #None] - (list name) + (let [to-alias (list/map (: (-> [Text Def] + (List Text)) + (function [[name [def-type def-meta def-value]]] + (case (get-meta ["lux" "export?"] def-meta) + (#Some [_ (#Bool true)]) + (list name) - _ - (list)))) - (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-annotations _ #module-state _} =module] - defs))] + _ + (list)))) + (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-annotations _ #module-state _} =module] + defs))] (#Right state (list/join to-alias))) #None @@ -4369,7 +4351,7 @@ name _ - ($_ text/compose "(" name " " (|> params (map type/show) (interpose " ") list/reverse (list/fold text/compose "")) ")")) + ($_ text/compose "(" name " " (|> params (list/map type/show) (interpose " ") list/reverse (list/fold text/compose "")) ")")) #Void "Void" @@ -4378,13 +4360,13 @@ "Unit" (#Sum _) - ($_ text/compose "(| " (|> (flatten-variant type) (map type/show) (interpose " ") list/reverse (list/fold text/compose "")) ")") + ($_ text/compose "(| " (|> (flatten-variant type) (list/map type/show) (interpose " ") list/reverse (list/fold text/compose "")) ")") (#Product _) - ($_ text/compose "[" (|> (flatten-tuple type) (map type/show) (interpose " ") list/reverse (list/fold text/compose "")) "]") + ($_ text/compose "[" (|> (flatten-tuple type) (list/map type/show) (interpose " ") list/reverse (list/fold text/compose "")) "]") (#Function _) - ($_ text/compose "(-> " (|> (flatten-lambda type) (map type/show) (interpose " ") list/reverse (list/fold text/compose "")) ")") + ($_ text/compose "(-> " (|> (flatten-lambda type) (list/map type/show) (interpose " ") list/reverse (list/fold text/compose "")) ")") (#Bound id) (nat/encode id) @@ -4405,15 +4387,30 @@ (let [[func args] (flatten-app type)] ($_ text/compose "(" (type/show func) " " - (|> args (map type/show) (interpose " ") list/reverse (list/fold text/compose "")) + (|> args (list/map type/show) (interpose " ") list/reverse (list/fold text/compose "")) ")")) (#Named [prefix name] _) ($_ text/compose prefix "." name) )) -(macro: #hidden (^open' tokens) +(macro: #export (^open tokens) + {#.doc "## Same as the \"open\" macro, but meant to be used as a pattern-matching macro for generating local bindings. + ## Can optionally take a \"prefix\" text for the generated local bindings. + (def: #export (range (^open) from to) + (All [a] (-> (Enum a) a a (List a))) + (range' <= succ from to))"} (case tokens + (^ (list& [_ (#Form (list))] body branches)) + (do Monad<Meta> + [g!temp (gensym "temp")] + (wrap (list& g!temp (` (..^open (~ g!temp) "" (~ body))) branches))) + + (^ (list& [_ (#Form (list [_ (#Text prefix)]))] body branches)) + (do Monad<Meta> + [g!temp (gensym "temp")] + (wrap (list& g!temp (` (..^open (~ g!temp) (~ (text$ prefix)) (~ body))) branches))) + (^ (list [_ (#Symbol name)] [_ (#Text prefix)] body)) (do Monad<Meta> [init-type (find-type name) @@ -4426,10 +4423,10 @@ (do Monad<Meta> [full-body ((: (-> Ident [(List Ident) (List Type)] Code (Meta Code)) (function recur [source [tags members] target] - (let [pattern (record$ (map (function [[t-module t-name]] - [(tag$ [t-module t-name]) - (symbol$ ["" (text/compose prefix t-name)])]) - tags))] + (let [pattern (record$ (list/map (function [[t-module t-name]] + [(tag$ [t-module t-name]) + (symbol$ ["" (text/compose prefix t-name)])]) + tags))] (do Monad<Meta> [enhanced-target (monad/fold Monad<Meta> (function [[[_ m-name] m-type] enhanced-target] @@ -4452,24 +4449,6 @@ _ (fail "Wrong syntax for ^open"))) -(macro: #export (^open tokens) - {#.doc "## Same as the \"open\" macro, but meant to be used as a pattern-matching macro for generating local bindings. - ## Can optionally take a \"prefix\" text for the generated local bindings. - (def: #export (range (^open) from to) - (All [a] (-> (Enum a) a a (List a))) - (range' <= succ from to))"} - (case tokens - (^ (list& [_ (#Form (list [_ (#Text prefix)]))] body branches)) - (do Monad<Meta> - [g!temp (gensym "temp")] - (return (list& g!temp (` (^open' (~ g!temp) (~ (text$ prefix)) (~ body))) branches))) - - (^ (list& [_ (#Form (list))] body branches)) - (return (list& (` (..^open "")) body branches)) - - _ - (fail "Wrong syntax for ^open"))) - (macro: #export (cond tokens) {#.doc "## Branching structures with multiple test conditions. (cond (n/even? num) \"even\" @@ -4524,12 +4503,13 @@ g!output (gensym "")] (case (resolve-struct-type type) (#Some members) - (let [pattern (record$ (map (: (-> [Ident [Nat Type]] [Code Code]) - (function [[[r-prefix r-name] [r-idx r-type]]] - [(tag$ [r-prefix r-name]) (if (n/= idx r-idx) - g!output - g!_)])) - (zip2 tags (enumerate members))))] + (let [pattern (record$ (list/map (: (-> [Ident [Nat Type]] [Code Code]) + (function [[[r-prefix r-name] [r-idx r-type]]] + [(tag$ [r-prefix r-name]) + (if (n/= idx r-idx) + g!output + g!_)])) + (zip2 tags (enumerate members))))] (return (list (` ("lux case" (~ record) {(~ pattern) (~ g!output)}))))) _ @@ -4606,27 +4586,27 @@ (macro: #export (|>> tokens) {#.doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it. - (|>> (map int/encode) (interpose \" \") (fold text/compose \"\")) + (|>> (list/map int/encode) (interpose \" \") (fold text/compose \"\")) ## => (function [<arg>] (fold text/compose \"\" (interpose \" \" - (map int/encode <arg>))))"} + (list/map int/encode <arg>))))"} (do Monad<Meta> [g!arg (gensym "arg")] - (return (list (` (function [(~ g!arg)] (|> (~ g!arg) (~@ tokens)))))))) + (return (list (` (function [(~ g!arg)] (|> (~ g!arg) (~+ tokens)))))))) (macro: #export (<<| tokens) {#.doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it. - (<<| (fold text/compose \"\") (interpose \" \") (map int/encode)) + (<<| (fold text/compose \"\") (interpose \" \") (list/map int/encode)) ## => (function [<arg>] (fold text/compose \"\" (interpose \" \" - (map int/encode <arg>))))"} + (list/map int/encode <arg>))))"} (do Monad<Meta> [g!arg (gensym "arg")] - (return (list (` (function [(~ g!arg)] (<| (~@ tokens) (~ g!arg)))))))) + (return (list (` (function [(~ g!arg)] (<| (~+ tokens) (~ g!arg)))))))) (def: (imported-by? import-name module-name) (-> Text Text (Meta Bool)) @@ -4660,7 +4640,7 @@ _ (fail ($_ text/compose "Wrong syntax for refer @ " current-module "\n" (|> options - (map code-to-text) + (list/map code-to-text) (interpose " ") (list/fold text/compose ""))))))) @@ -4695,24 +4675,24 @@ #Nothing (wrap (list))) - #let [defs (map (: (-> Text Code) - (function [def] - (` ("lux def" (~ (symbol$ ["" def])) - (~ (symbol$ [module-name def])) - [(~ cursor-code) - (#.Record (#Cons [[(~ cursor-code) (#.Tag ["lux" "alias"])] - [(~ cursor-code) (#.Symbol [(~ (text$ module-name)) (~ (text$ def))])]] - #Nil))])))) - defs') + #let [defs (list/map (: (-> Text Code) + (function [def] + (` ("lux def" (~ (symbol$ ["" def])) + (~ (symbol$ [module-name def])) + [(~ cursor-code) + (#.Record (#Cons [[(~ cursor-code) (#.Tag ["lux" "alias"])] + [(~ cursor-code) (#.Symbol [(~ (text$ module-name)) (~ (text$ def))])]] + #Nil))])))) + defs') openings (join-map (: (-> Openings (List Code)) (function [[prefix structs]] - (map (function [[_ name]] (` (open (~ (symbol$ [module-name name])) (~ (text$ prefix))))) - structs))) + (list/map (function [[_ name]] (` (open (~ (symbol$ [module-name name])) (~ (text$ prefix))))) + structs))) r-opens)]] (wrap (list/compose defs openings)) )) -(macro: #hidden (refer tokens) +(macro: #export (refer tokens) (case tokens (^ (list& [_ (#Text module-name)] options)) (do Monad<Meta> @@ -4730,21 +4710,21 @@ (list (' #refer) (' #all)) (#Only defs) - (list (' #refer) (`' (#only (~@ (map (|>> [""] symbol$) - defs))))) + (list (' #refer) (`' (#only (~+ (list/map (|>> [""] symbol$) + defs))))) (#Exclude defs) - (list (' #refer) (`' (#exclude (~@ (map (|>> [""] symbol$) - defs))))) + (list (' #refer) (`' (#exclude (~+ (list/map (|>> [""] symbol$) + defs))))) #Nothing (list))) =opens (join-map (function [[prefix structs]] - (list& (text$ prefix) (map symbol$ structs))) + (list& (text$ prefix) (list/map symbol$ structs))) r-opens)] (` (..refer (~ (text$ module-name)) - (~@ =defs) - (~' #open) ((~@ =opens)))))) + (~+ =defs) + (~' #open) ((~+ =opens)))))) (macro: #export (module: tokens) {#.doc "Module-definition macro. @@ -4783,15 +4763,15 @@ [(list) tokens]))] current-module current-module-name imports (parse-imports current-module _imports) - #let [=imports (map (: (-> Importation Code) - (function [[m-name m-alias =refer]] - (` [(~ (text$ m-name)) (~ (text$ (default "" m-alias)))]))) - imports) - =refers (map (: (-> Importation Code) - (function [[m-name m-alias =refer]] - (refer-to-code m-name =refer))) - imports) - =meta (process-def-meta (list& [(` #.imports) (` [(~@ =imports)])] + #let [=imports (list/map (: (-> Importation Code) + (function [[m-name m-alias =refer]] + (` [(~ (text$ m-name)) (~ (text$ (default "" m-alias)))]))) + imports) + =refers (list/map (: (-> Importation Code) + (function [[m-name m-alias =refer]] + (refer-to-code m-name =refer))) + imports) + =meta (process-def-meta (list& [(` #.imports) (` [(~+ =imports)])] _meta)) =module (` ("lux module" [(~ cursor-code) (#.Record (~ =meta))]))]] @@ -4808,7 +4788,7 @@ (return (list (` (let [(^open) (~ struct)] (~ (symbol$ member)))))) (^ (list& struct [_ (#Symbol member)] args)) - (return (list (` ((let [(^open) (~ struct)] (~ (symbol$ member))) (~@ args))))) + (return (list (` ((let [(^open) (~ struct)] (~ (symbol$ member))) (~+ args))))) _ (fail "Wrong syntax for ::"))) @@ -4843,16 +4823,18 @@ [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] - (let [pattern (record$ (map (: (-> [Ident Nat Code] [Code Code]) - (function [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) r-var])) - pattern')) - output (record$ (map (: (-> [Ident Nat Code] [Code Code]) - (function [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) (if (n/= idx r-idx) - value - r-var)])) - pattern'))] + (let [pattern (record$ (list/map (: (-> [Ident Nat Code] [Code Code]) + (function [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) + r-var])) + pattern')) + output (record$ (list/map (: (-> [Ident Nat Code] [Code Code]) + (function [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) + (if (n/= idx r-idx) + value + r-var)])) + pattern'))] (return (list (` ("lux case" (~ record) {(~ pattern) (~ output)})))))) _ @@ -4882,7 +4864,7 @@ [record (: (List (List Code)) #Nil)] pairs) accesses (list/join (list/reverse accesses'))]] - (wrap (list (` (let [(~@ accesses)] + (wrap (list (` (let [(~+ accesses)] (~ update-expr))))))) (^ (list selector value)) @@ -4929,16 +4911,18 @@ [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] - (let [pattern (record$ (map (: (-> [Ident Nat Code] [Code Code]) - (function [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) r-var])) - pattern')) - output (record$ (map (: (-> [Ident Nat Code] [Code Code]) - (function [[r-slot-name r-idx r-var]] - [(tag$ r-slot-name) (if (n/= idx r-idx) - (` ((~ fun) (~ r-var))) - r-var)])) - pattern'))] + (let [pattern (record$ (list/map (: (-> [Ident Nat Code] [Code Code]) + (function [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) + r-var])) + pattern')) + output (record$ (list/map (: (-> [Ident Nat Code] [Code Code]) + (function [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) + (if (n/= idx r-idx) + (` ((~ fun) (~ r-var))) + r-var)])) + pattern'))] (return (list (` ("lux case" (~ record) {(~ pattern) (~ output)})))))) _ @@ -4954,8 +4938,8 @@ [g!record (gensym "record") g!temp (gensym "temp")] (wrap (list (` (let [(~ g!record) (~ record) - (~ g!temp) (get@ [(~@ slots)] (~ g!record))] - (set@ [(~@ slots)] ((~ fun) (~ g!temp)) (~ g!record)))))))) + (~ g!temp) (get@ [(~+ slots)] (~ g!record))] + (set@ [(~+ slots)] ((~ fun) (~ g!temp)) (~ g!record)))))))) (^ (list selector fun)) (do Monad<Meta> @@ -5015,9 +4999,9 @@ (do Monad<Maybe> [bindings' (monad/map Monad<Maybe> get-name bindings) data' (monad/map Monad<Maybe> tuple->list data)] - (if (every? (n/= (list/size bindings')) (map list/size data')) + (if (every? (n/= (list/size bindings')) (list/map list/size data')) (let [apply (: (-> RepEnv (List Code)) - (function [env] (map (apply-template env) templates)))] + (function [env] (list/map (apply-template env) templates)))] (|> data' (join-map (compose apply (make-env bindings'))) wrap)) @@ -5057,14 +5041,14 @@ (^template [<tag>] [[_ _ column] (<tag> parts)] - (list/fold n/min column (map find-baseline-column parts))) + (list/fold n/min column (list/map find-baseline-column parts))) ([#Form] [#Tuple]) [[_ _ column] (#Record pairs)] (list/fold n/min column - (list/compose (map (|>> first find-baseline-column) pairs) - (map (|>> second find-baseline-column) pairs))) + (list/compose (list/map (|>> first find-baseline-column) pairs) + (list/map (|>> second find-baseline-column) pairs))) )) (type: Doc-Fragment @@ -5149,7 +5133,7 @@ (def: rejoin-all-pairs (-> (List [Code Code]) (List Code)) - (|>> (map rejoin-pair) list/join)) + (|>> (list/map rejoin-pair) list/join)) (def: (doc-example->Text prev-cursor baseline example) (-> Cursor Nat Code [Cursor Text]) @@ -5198,7 +5182,7 @@ (#Doc-Comment comment) (|> comment (text/split "\n") - (map (function [line] ($_ text/compose "## " line "\n"))) + (list/map (function [line] ($_ text/compose "## " line "\n"))) text/join) (#Doc-Example example) @@ -5220,7 +5204,7 @@ x)))"} (return (list (` [(~ cursor-code) (#.Text (~ (|> tokens - (map (|>> identify-doc-fragment doc-fragment->Text)) + (list/map (|>> identify-doc-fragment doc-fragment->Text)) text/join text$)))])))) @@ -5242,7 +5226,7 @@ (-> Type Code) (case type (#Primitive name params) - (` (#Primitive (~ (text$ name)) (~ (untemplate-list (map type-to-code params))))) + (` (#Primitive (~ (text$ name)) (~ (untemplate-list (list/map type-to-code params))))) #Void (` #Void) @@ -5268,11 +5252,11 @@ (` (#Ex (~ (nat$ id)))) (#UnivQ env type) - (let [env' (untemplate-list (map type-to-code env))] + (let [env' (untemplate-list (list/map type-to-code env))] (` (#UnivQ (~ env') (~ (type-to-code type))))) (#ExQ env type) - (let [env' (untemplate-list (map type-to-code env))] + (let [env' (untemplate-list (list/map type-to-code env))] (` (#ExQ (~ env') (~ (type-to-code type))))) (#Apply arg fun) @@ -5293,8 +5277,8 @@ (case tokens (^ (list [_ (#Tuple bindings)] body)) (let [pairs (as-pairs bindings) - vars (map first pairs) - inits (map second pairs)] + vars (list/map first pairs) + inits (list/map second pairs)] (if (every? symbol? inits) (do Monad<Meta> [inits' (: (Meta (List Ident)) @@ -5303,18 +5287,18 @@ #None (fail "Wrong syntax for loop"))) init-types (monad/map Monad<Meta> find-type inits') expected get-expected-type] - (return (list (` (("lux check" (-> (~@ (map type-to-code init-types)) + (return (list (` (("lux check" (-> (~+ (list/map type-to-code init-types)) (~ (type-to-code expected))) - (function (~ (symbol$ ["" "recur"])) [(~@ vars)] + (function (~ (symbol$ ["" "recur"])) [(~+ vars)] (~ body))) - (~@ inits)))))) + (~+ inits)))))) (do Monad<Meta> [aliases (monad/map Monad<Meta> (: (-> Code (Meta Code)) (function [_] (gensym ""))) inits)] - (return (list (` (let [(~@ (interleave aliases inits))] - (.loop [(~@ (interleave vars aliases))] + (return (list (` (let [(~+ (interleave aliases inits))] + (.loop [(~+ (interleave vars aliases))] (~ body))))))))) _ @@ -5345,16 +5329,16 @@ output (resolve-tag hslot) g!_ (gensym "_") #let [[idx tags exported? type] output - slot-pairings (map (: (-> Ident [Text Code]) - (function [[module name]] [name (symbol$ ["" name])])) - (list& hslot tslots)) - pattern (record$ (map (: (-> Ident [Code Code]) - (function [[module name]] - (let [tag (tag$ [module name])] - (case (get name slot-pairings) - (#Some binding) [tag binding] - #None [tag g!_])))) - tags))]] + slot-pairings (list/map (: (-> Ident [Text Code]) + (function [[module name]] [name (symbol$ ["" name])])) + (list& hslot tslots)) + pattern (record$ (list/map (: (-> Ident [Code Code]) + (function [[module name]] + (let [tag (tag$ [module name])] + (case (get name slot-pairings) + (#Some binding) [tag binding] + #None [tag g!_])))) + tags))]] (return (list& pattern body branches))) _ @@ -5430,8 +5414,8 @@ (do Monad<Meta> [expansion (macro-expand-once macro-expr)] (case (place-tokens var-name expansion (` (.with-expansions - [(~@ bindings')] - (~@ bodies)))) + [(~+ bindings')] + (~+ bodies)))) (#Some output) (wrap output) @@ -5609,7 +5593,7 @@ (let [output (list g!temp (` ("lux case" ("lux check" (#.Apply (~ (type-to-code expected)) Maybe) (case (~ g!temp) - (~@ (multi-level-case$ g!temp [mlc body])) + (~+ (multi-level-case$ g!temp [mlc body])) (~ g!temp) #.None)) @@ -5618,7 +5602,7 @@ #None (case (~ g!temp) - (~@ next-branches))})))] + (~+ next-branches))})))] (wrap output))) _ @@ -5730,7 +5714,7 @@ (^ (list& [_meta (#Form (list [_ (#Symbol ["" name])] [_ (#Tuple steps)]))] body branches)) (let [g!name (symbol$ ["" name])] (return (list& g!name - (` (let [(~ g!name) (|> (~ g!name) (~@ steps))] + (` (let [(~ g!name) (|> (~ g!name) (~+ steps))] (~ body))) branches))) @@ -5778,36 +5762,6 @@ _ (fail "Wrong syntax for type-of"))) -(type: #hidden Export-Level' - #Export - #Hidden) - -(def: (parse-export-level tokens) - (-> (List Code) (Meta [(Maybe Export-Level') (List Code)])) - (case tokens - (^ (list& [_ (#Tag ["" "export"])] tokens')) - (return [(#Some #Export) tokens']) - - (^ (list& [_ (#Tag ["" "hidden"])] tokens')) - (return [(#Some #Hidden) tokens']) - - _ - (return [#None tokens]) - )) - -(def: (gen-export-level ?export-level) - (-> (Maybe Export-Level') (List Code)) - (case ?export-level - #None - (list) - - (#Some #Export) - (list (' #export)) - - (#Some #Hidden) - (list (' #hidden)) - )) - (def: (parse-complex-declaration tokens) (-> (List Code) (Meta [[Text (List Text)] (List Code)])) (case tokens @@ -5864,8 +5818,7 @@ (template: (square x) (i/* x x)))} (do Monad<Meta> - [?export-level|tokens (parse-export-level tokens) - #let [[?export-level tokens] ?export-level|tokens] + [#let [[export? tokens] (export^ tokens)] name+args|tokens (parse-complex-declaration tokens) #let [[[name args] tokens] name+args|tokens] anns|tokens (parse-anns tokens) @@ -5876,14 +5829,14 @@ g!tokens (gensym "tokens") g!compiler (gensym "compiler") g!_ (gensym "_") - #let [rep-env (map (function [arg] - [arg (` ((~' ~) (~ (symbol$ ["" arg]))))]) - args)]] - (wrap (list (` (macro: (~@ (gen-export-level ?export-level)) + #let [rep-env (list/map (function [arg] + [arg (` ((~' ~) (~ (symbol$ ["" arg]))))]) + args)]] + (wrap (list (` (macro: (~+ (export export?)) ((~ (symbol$ ["" name])) (~ g!tokens) (~ g!compiler)) (~ anns) (case (~ g!tokens) - (^ (list (~@ (map (|>> [""] symbol$) args)))) + (^ (list (~+ (list/map (|>> [""] symbol$) args)))) (#.Right [(~ g!compiler) (list (` (~ (replace-syntax rep-env input-template))))]) @@ -5978,8 +5931,8 @@ [ann (<tag> parts)] (do Monad<Meta> [=parts (monad/map Monad<Meta> label-code parts)] - (wrap [(list/fold list/compose (list) (map left =parts)) - [ann (<tag> (map right =parts))]]))) + (wrap [(list/fold list/compose (list) (list/map left =parts)) + [ann (<tag> (list/map right =parts))]]))) ([#Form] [#Tuple]) [ann (#Record kvs)] @@ -5993,8 +5946,8 @@ [val-labels val-labelled] =val]] (wrap [(list/compose key-labels val-labels) [key-labelled val-labelled]]))) kvs)] - (wrap [(list/fold list/compose (list) (map left =kvs)) - [ann (#Record (map right =kvs))]])) + (wrap [(list/fold list/compose (list) (list/map left =kvs)) + [ann (#Record (list/map right =kvs))]])) _ (return [(list) code]))) @@ -6005,8 +5958,8 @@ (do Monad<Meta> [=raw (label-code raw) #let [[labels labelled] =raw]] - (wrap (list (` (with-expansions [(~@ (|> labels - (map (function [[label expansion]] (list label expansion))) + (wrap (list (` (with-expansions [(~+ (|> labels + (list/map (function [[label expansion]] (list label expansion))) list/join))] (~ labelled)))))) @@ -6059,13 +6012,13 @@ [_ (#Form (#Cons [[_ (#Symbol ["" "~"])] (#Cons [unquoted #Nil])]))] (return unquoted) - [_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] - (fail "Cannot use (~@) inside of ^code unless it is the last element in a form or a tuple.") + [_ (#Form (#Cons [[_ (#Symbol ["" "~+"])] (#Cons [spliced #Nil])]))] + (fail "Cannot use (~+) inside of ^code unless it is the last element in a form or a tuple.") (^template [<tag>] [_ (<tag> elems)] (case (list/reverse elems) - (#Cons [_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] + (#Cons [_ (#Form (#Cons [[_ (#Symbol ["" "~+"])] (#Cons [spliced #Nil])]))] inits) (do Monad<Meta> [=inits (monad/map Monad<Meta> untemplate-pattern (list/reverse inits)) diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux index 328d717ce..b0f1285fa 100644 --- a/stdlib/source/lux/cli.lux +++ b/stdlib/source/lux/cli.lux @@ -102,8 +102,6 @@ (wrap [(code.symbol ["" name]) (` any)])) (s.tuple (p.seq s.any s.any))))))) -(def: #hidden _Monad<CLI>_ p.Monad<Parser>) - (syntax: #export (program: [args program-args^] body) {#.doc (doc "Defines the entry-point to a program (similar to the \"main\" function/method in other programming languages)." "Can take a list of all the input parameters to the program, or can destructure them using CLI-option combinators from the lux/cli module." @@ -123,23 +121,23 @@ (case args (#Raw args) (wrap (list (` ("lux program" (~ (code.symbol ["" args])) - (do io.Monad<IO> - [] - (~ body)))))) + ((~! do) (~! io.Monad<IO>) + [] + (~ body)))))) (#Parsed args) (with-gensyms [g!args g!_ g!output g!message] (wrap (list (` ("lux program" (~ g!args) - (case ((: (..CLI (io.IO Unit)) - (do .._Monad<CLI>_ - [(~@ (|> args - (list/map (function [[binding parser]] - (list binding parser))) - list/join)) - (~ g!_) ..end] - ((~' wrap) (do io.Monad<IO> - [] - (~ body))))) + (case ((: (~! (..CLI (io.IO Unit))) + ((~! do) (~! p.Monad<Parser>) + [(~+ (|> args + (list/map (function [[binding parser]] + (list binding parser))) + list/join)) + (~ g!_) ..end] + ((~' wrap) ((~! do) (~! io.Monad<IO>) + [] + (~ body))))) (~ g!args)) (#E.Success [(~ g!_) (~ g!output)]) (~ g!output) diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index a079d2d28..b326d0028 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -52,8 +52,10 @@ (io (let [[handle end] behavior self (: (Actor ($ +0)) (@abstract {#mailbox (stm.var (:! (Message ($ +0)) [])) - #kill-switch (P.promise Unit) - #obituary (P.promise (Obituary ($ +0)))})) + #kill-switch (: (P.Promise Unit) + (P.promise #.None)) + #obituary (: (P.Promise (Obituary ($ +0))) + (P.promise #.None))})) mailbox-channel (io.run (stm.follow (get@ #mailbox (@repr self)))) |mailbox| (stm.var mailbox-channel) _ (P/map (function [_] @@ -144,12 +146,12 @@ ## [Syntax] (do-template [<with> <resolve> <tag> <desc>] - [(def: #hidden (<with> name) + [(def: #export (<with> name) (-> Ident cs.Annotations cs.Annotations) (|>> (#.Cons [(ident-for <tag>) (code.tag name)]))) - (def: #hidden (<resolve> name) + (def: #export (<resolve> name) (-> Ident (Meta Ident)) (do Monad<Meta> [[_ annotations _] (macro.find-def name)] @@ -170,7 +172,7 @@ (p.seq s.local-symbol (:: p.Monad<Parser> wrap (list))))) (do-template [<name> <desc>] - [(def: #hidden <name> + [(def: #export <name> (-> Text Text) (|>> (format <desc> "@")))] @@ -221,7 +223,7 @@ output (message state self) #let [_ (log! "AFTER")]] (wrap output)))))} - (with-gensyms [g!message g!self g!state g!init g!error g!return g!output] + (with-gensyms [g!init] (do @ [module macro.current-module-name #let [g!type (code.local-symbol (state-name _name)) @@ -229,16 +231,16 @@ g!actor (code.local-symbol _name) g!new (code.local-symbol (new-name _name)) g!vars (list/map code.local-symbol _vars)]] - (wrap (list (` (type: (~@ (csw.export export)) ((~ g!type) (~@ g!vars)) + (wrap (list (` (type: (~+ (csw.export export)) ((~ g!type) (~+ g!vars)) (~ state-type))) - (` (type: (~@ (csw.export export)) ((~ g!actor) (~@ g!vars)) + (` (type: (~+ (csw.export export)) ((~ g!actor) (~+ g!vars)) (~ (|> annotations (with-actor [module _name]) csw.annotations)) - (..Actor ((~ g!type) (~@ g!vars))))) - (` (def: (~@ (csw.export export)) (~ g!behavior) - (All [(~@ g!vars)] - (..Behavior ((~ g!type) (~@ g!vars)))) + (..Actor ((~ g!type) (~+ g!vars))))) + (` (def: (~+ (csw.export export)) (~ g!behavior) + (All [(~+ g!vars)] + (..Behavior ((~ g!type) (~+ g!vars)))) {#..handle (~ (case ?handle #.None (` ..default-handle) @@ -260,9 +262,9 @@ (do P.Monad<Promise> [] (~ bodyC))))))})) - (` (def: (~@ (csw.export export)) ((~ g!new) (~ g!init)) - (All [(~@ g!vars)] - (-> ((~ g!type) (~@ g!vars)) (io.IO ((~ g!actor) (~@ g!vars))))) + (` (def: (~+ (csw.export export)) ((~ g!new) (~ g!init)) + (All [(~+ g!vars)] + (-> ((~ g!type) (~+ g!vars)) (io.IO ((~ g!actor) (~+ g!vars))))) (..spawn (~ g!behavior) (~ g!init)))))) ))) @@ -313,7 +315,7 @@ #let [g!type (code.symbol (product.both id state-name actor-name)) g!message (code.local-symbol (get@ #name signature)) g!actor-vars (list/map code.local-symbol actor-vars) - g!actor (` ((~ (code.symbol actor-name)) (~@ g!actor-vars))) + actorC (` ((~ (code.symbol actor-name)) (~+ g!actor-vars))) g!all-vars (|> (get@ #vars signature) (list/map code.local-symbol) (list/compose g!actor-vars)) g!inputsC (|> (get@ #inputs signature) (list/map (|>> product.left code.local-symbol))) g!inputsT (|> (get@ #inputs signature) (list/map product.right)) @@ -335,16 +337,16 @@ (code.replace g!var g!ref outputT)) (get@ #output signature) ref-replacements)]] - (wrap (list (` (def: (~@ (csw.export export)) ((~ g!message) (~@ g!inputsC) (~ g!self)) + (wrap (list (` (def: (~+ (csw.export export)) ((~ g!message) (~+ g!inputsC) (~ g!self)) (~ (|> annotations (with-message actor-name) csw.annotations)) - (All [(~@ g!all-vars)] (-> (~@ g!inputsT) (~ g!actor) (T.Task (~ (get@ #output signature))))) + (All [(~+ g!all-vars)] (-> (~+ g!inputsT) (~ actorC) (T.Task (~ (get@ #output signature))))) (let [(~ g!task) (T.task (~ g!outputT))] (io.run (do io.Monad<IO> [(~ g!sent?) (..send (function [(~ g!state) (~ g!self)] (do P.Monad<Promise> - [(~ g!return) (: (T.Task [((~ g!type) (~@ g!actor-refs)) + [(~ g!return) (: (T.Task [((~ g!type) (~+ g!actor-refs)) (~ g!outputT)]) (do T.Monad<Task> [] diff --git a/stdlib/source/lux/concurrency/frp.lux b/stdlib/source/lux/concurrency/frp.lux index 541b6530a..230eca335 100644 --- a/stdlib/source/lux/concurrency/frp.lux +++ b/stdlib/source/lux/concurrency/frp.lux @@ -24,7 +24,7 @@ {#.doc (doc "Makes an uninitialized Channel (in this case, of Nat)." (channel Nat))} (wrap (list (` (: (Channel (~ type)) - (&.promise' #.None)))))) + (&.promise #.None)))))) ## [Values] (def: #export (filter p xs) diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux index 0762694f9..2de5fa2c8 100644 --- a/stdlib/source/lux/concurrency/promise.lux +++ b/stdlib/source/lux/concurrency/promise.lux @@ -25,17 +25,11 @@ {#.doc "Represents values produced by asynchronous computations (unlike IO, which is synchronous)."} (Atom (Promise-State a))) -(def: #hidden (promise' ?value) +(def: #export (promise ?value) (All [a] (-> (Maybe a) (Promise a))) (atom {#value ?value #observers (list)})) -(syntax: #export (promise [type s.any]) - {#.doc (doc "Makes an uninitialized Promise (in this example, of Unit)." - (promise Unit))} - (wrap (list (` (: (Promise (~ type)) - (promise' #.None)))))) - (def: #export (poll promise) {#.doc "Polls a Promise's value."} (All [a] (-> (Promise a) (Maybe a))) @@ -88,7 +82,7 @@ (struct: #export _ (F.Functor Promise) (def: (map f fa) - (let [fb (promise ($ +1)) + (let [fb (: (Promise ($ +1)) (promise #.None)) ## fb (promise' #.None) ] (exec (await (function [a] (resolve (f a) fb)) @@ -103,7 +97,7 @@ #observers (list)})) (def: (apply ff fa) - (let [fb (promise ($ +1)) + (let [fb (: (Promise ($ +1)) (promise #.None)) ## fb (promise' #.None) ] (exec (await (function [f] @@ -117,7 +111,7 @@ (def: applicative Applicative<Promise>) (def: (join mma) - (let [ma (promise ($ +0)) + (let [ma (: (Promise ($ +0)) (promise #.None)) ## ma (promise' #.None) ] (exec (await (function [ma'] @@ -137,7 +131,7 @@ (def: #export (alt left right) {#.doc "Heterogeneous alternative combinator."} (All [a b] (-> (Promise a) (Promise b) (Promise (| a b)))) - (let [a|b (promise (| ($ +0) ($ +1))) + (let [a|b (: (Promise (| ($ +0) ($ +1))) (promise #.None)) ## a|b (promise' #.None) ] (with-expansions @@ -154,7 +148,7 @@ (def: #export (either left right) {#.doc "Homogeneous alternative combinator."} (All [a] (-> (Promise a) (Promise a) (Promise a))) - (let [left||right (promise ($ +0)) + (let [left||right (: (Promise ($ +0)) (promise #.None)) ## left||right (promise' #.None) ] (`` (exec (~~ (do-template [<promise>] @@ -168,7 +162,7 @@ (def: #export (future computation) {#.doc "Runs an I/O computation on its own process and returns an Promise that will eventually host its result."} (All [a] (-> (IO a) (Promise a))) - (let [!out (promise ($ +0)) + (let [!out (: (Promise ($ +0)) (promise #.None)) ## !out (promise' #.None) ] (exec ("lux process future" (io (io.run (resolve (io.run computation) @@ -178,7 +172,7 @@ (def: #export (wait time) {#.doc "Returns a Promise that will be resolved after the specified amount of milliseconds."} (-> Nat (Promise Unit)) - (let [!out (promise Unit)] + (let [!out (: (Promise Unit) (promise #.None))] (exec ("lux process schedule" time (resolve [] !out)) !out))) diff --git a/stdlib/source/lux/concurrency/space.lux b/stdlib/source/lux/concurrency/space.lux index 1ba795b24..fb7f199f8 100644 --- a/stdlib/source/lux/concurrency/space.lux +++ b/stdlib/source/lux/concurrency/space.lux @@ -105,8 +105,6 @@ (p.either (s.tuple (p.some s.local-symbol)) (:: p.Monad<Parser> wrap (list)))) -(def: #hidden _future P.future) - (syntax: #export (on: [export csr.export] [t-vars type-vars^] [[actor-name actor-params] reference^] @@ -133,19 +131,19 @@ (do @ [actor-name (A.resolve-actor actor-name) #let [stateT (` ((~ (code.symbol (product.both id A.state-name actor-name))) - (~@ actor-params))) + (~+ actor-params))) g!actionL (code.local-symbol (get@ #action-name declaration)) g!senderL (code.local-symbol (get@ #sender-name declaration)) g!spaceL (code.local-symbol (get@ #space-name declaration)) g!receiverL (code.local-symbol (get@ #receiver-name declaration)) g!event (get@ #event declaration) g!state (get@ #state declaration)]] - (wrap (list (` (def: (~@ (csw.export export)) ((~ g!actionL) [(~ g!event) (~ g!senderL) (~ g!spaceL)] (~ g!receiverL)) + (wrap (list (` (def: (~+ (csw.export export)) ((~ g!actionL) [(~ g!event) (~ g!senderL) (~ g!spaceL)] (~ g!receiverL)) (~ (csw.annotations annotations)) - (All [(~@ (L/map code.local-symbol t-vars))] + (All [(~+ (L/map code.local-symbol t-vars))] (..Action (~ eventT) (~ stateT))) (T.from-promise - (_future + ((~! P.future) (A.send (function [(~ g!state) (~ g!receiverL)] (: (T.Task (~ stateT)) (monad.do T.Monad<Task> diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux index f7c7664f1..cc39ae0c3 100644 --- a/stdlib/source/lux/concurrency/stm.lux +++ b/stdlib/source/lux/concurrency/stm.lux @@ -264,7 +264,7 @@ For this reason, it's important to note that transactions must be free from side-effects, such as I/O."} (All [a] (-> (STM a) (P.Promise a))) - (let [output (P.promise ($ +0))] + (let [output (: (P.Promise ($ +0)) (P.promise #.None))] (exec (io.run init-processor!) (io.run (write! [stm-proc output] pending-commits)) output))) diff --git a/stdlib/source/lux/concurrency/task.lux b/stdlib/source/lux/concurrency/task.lux index 7f1322bf4..a740d7398 100644 --- a/stdlib/source/lux/concurrency/task.lux +++ b/stdlib/source/lux/concurrency/task.lux @@ -72,7 +72,7 @@ {#.doc (doc "Makes an uninitialized Task (in this example, of Unit)." (task Unit))} (wrap (list (` (: (..Task (~ type)) - (P.promise' #.None)))))) + (P.promise #.None)))))) (def: #export (from-promise promise) (All [a] (-> (P.Promise a) (Task a))) diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux index 104dcf593..bfc51550b 100644 --- a/stdlib/source/lux/control/concatenative.lux +++ b/stdlib/source/lux/control/concatenative.lux @@ -7,8 +7,8 @@ [monad]) (data [text] text/format - [maybe "m/" Monad<Maybe>] - (coll [list "L/" Fold<List> Functor<List>])) + [maybe "maybe/" Monad<Maybe>] + (coll [list "list/" Fold<List> Functor<List>])) [macro #+ with-gensyms Monad<Meta>] (macro [code] ["s" syntax #+ syntax:] @@ -43,10 +43,10 @@ (def: (stack-fold tops bottom) (-> (List Code) Code Code) - (L/fold (function [top bottom] - (` [(~ bottom) (~ top)])) - bottom - tops)) + (list/fold (function [top bottom] + (` [(~ bottom) (~ top)])) + bottom + tops)) (def: (singleton expander) (-> (Meta (List Code)) (Meta Code)) @@ -58,18 +58,18 @@ _ (macro.fail (format "Cannot expand to more than a single AST/Code node:\n" - (|> expansion (L/map %code) (text.join-with " "))))))) + (|> expansion (list/map %code) (text.join-with " "))))))) (syntax: #export (=> [aliases aliases^] [inputs stack^] [outputs stack^]) (let [de-alias (function [aliased] - (L/fold (function [[from to] pre] - (code.replace (code.local-symbol from) to pre)) - aliased - aliases))] - (case [(|> inputs (get@ #bottom) (m/map (|>> code.nat (~) #.Bound (`)))) - (|> outputs (get@ #bottom) (m/map (|>> code.nat (~) #.Bound (`))))] + (list/fold (function [[from to] pre] + (code.replace (code.local-symbol from) to pre)) + aliased + aliases))] + (case [(|> inputs (get@ #bottom) (maybe/map (|>> code.nat (~) #.Bound (`)))) + (|> outputs (get@ #bottom) (maybe/map (|>> code.nat (~) #.Bound (`))))] [(#.Some bottomI) (#.Some bottomO)] (monad.do @ [inputC (singleton (macro.expand-all (stack-fold (get@ #top inputs) bottomI))) @@ -86,9 +86,9 @@ (-> (~ (de-alias inputC)) (~ (de-alias outputC)))))))))))) -(def: #hidden begin! Unit []) +(def: begin! Unit []) -(def: #hidden end! +(def: end! (All [a] (-> [Unit a] a)) (function [[_ top]] top)) @@ -104,33 +104,33 @@ (` (..push (~ command))) [_ (#.Tuple block)] - (` (..push (|>> (~@ (L/map prepare block))))) + (` (..push (|>> (~+ (list/map prepare block))))) _ command)) (syntax: #export (||> [commands (p.some s.any)]) - (wrap (list (` (|> ..begin! (~@ (L/map prepare commands)) ..end!))))) + (wrap (list (` (|> (~! ..begin!) (~+ (list/map prepare commands)) (~! ..end!)))))) (syntax: #export (word: [export csr.export] [name s.local-symbol] [annotations (p.default cs.empty-annotations csr.annotations)] type [commands (p.some s.any)]) - (wrap (list (` (def: (~@ (csw.export export)) (~ (code.local-symbol name)) + (wrap (list (` (def: (~+ (csw.export export)) (~ (code.local-symbol name)) (~ (csw.annotations annotations)) (~ type) - (|>> (~@ (L/map prepare commands)))))))) + (|>> (~+ (list/map prepare commands)))))))) (syntax: #export (apply [arity (|> s.nat (p.filter (.n/> +0)))]) (with-gensyms [g!func g!stack g!output] (monad.do @ [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)]))) + (wrap (list (` (: (All [(~+ g!inputs) (~ g!output)] + (-> (-> (~+ g!inputs) (~ g!output)) + (=> [(~+ g!inputs)] [(~ g!output)]))) (function [(~ g!func)] (function [(~ (stack-fold g!inputs g!stack))] - [(~ g!stack) ((~ g!func) (~@ g!inputs))]))))))))) + [(~ g!stack) ((~ g!func) (~+ g!inputs))]))))))))) ## [Primitives] (def: #export apply1 (apply +1)) diff --git a/stdlib/source/lux/control/cont.lux b/stdlib/source/lux/control/cont.lux index db0202e40..c3be37b73 100644 --- a/stdlib/source/lux/control/cont.lux +++ b/stdlib/source/lux/control/cont.lux @@ -57,7 +57,7 @@ (syntax: #export (pending expr) {#.doc (doc "Turns any expression into a function that is pending a continuation." - (pending (some-computation some-input)))} + (pending (some-function some-input)))} (with-gensyms [g!k] (wrap (list (` (.function [(~ g!k)] ((~ g!k) (~ expr)))))))) diff --git a/stdlib/source/lux/control/contract.lux b/stdlib/source/lux/control/contract.lux index ac0ae5432..72b4c0770 100644 --- a/stdlib/source/lux/control/contract.lux +++ b/stdlib/source/lux/control/contract.lux @@ -29,8 +29,7 @@ "Otherwise, an error is raised." (post i/even? (i/+ 2 2)))} - (do @ - [g!output (macro.gensym "")] + (macro.with-gensyms [g!output] (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 d14158590..fcee396e1 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -17,10 +17,6 @@ (-> Text Text)) ## [Values] -(def: #hidden _text/compose_ - (-> Text Text Text) - text/compose) - (def: #export (match? exception error) (-> Exception Text Bool) (text.starts-with? (exception "") error)) @@ -74,6 +70,6 @@ [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)) + (wrap (list (` (def: (~+ (csw.export _ex-lev)) ((~ (code.symbol ["" name])) (~ g!message)) Exception - (_text/compose_ (~ (code.text descriptor)) (~ g!message)))))))) + ((~! text/compose) (~ (code.text descriptor)) (~ g!message)))))))) diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux index f8208fee6..a5ba038f5 100644 --- a/stdlib/source/lux/control/pipe.lux +++ b/stdlib/source/lux/control/pipe.lux @@ -21,7 +21,7 @@ (new> 0 i/inc)))} (case (list.reverse tokens) (^ (list& _ r-body)) - (wrap (list (` (|> (~@ (list.reverse r-body)))))) + (wrap (list (` (|> (~+ (list.reverse r-body)))))) _ (undefined))) @@ -46,13 +46,13 @@ (with-gensyms [g!temp] (wrap (list (` (with-expansions [(~ g!temp) (~ prev)] - (cond (~@ (do Monad<List> + (cond (~+ (do Monad<List> [[test then] branches] - (list (` (|> (~ g!temp) (~@ test))) - (` (|> (~ g!temp) (~@ then)))))) + (list (` (|> (~ g!temp) (~+ test))) + (` (|> (~ g!temp) (~+ then)))))) (~ (case ?else (#.Some else) - (` (|> (~ g!temp) (~@ else))) + (` (|> (~ g!temp) (~+ else))) _ g!temp))))))))) @@ -65,8 +65,8 @@ [i/inc])))} (with-gensyms [g!temp] (wrap (list (` (loop [(~ g!temp) (~ prev)] - (if (|> (~ g!temp) (~@ test)) - ((~' recur) (|> (~ g!temp) (~@ then))) + (if (|> (~ g!temp) (~+ test)) + ((~' recur) (|> (~ g!temp) (~+ then))) (~ g!temp)))))))) (syntax: #export (do> monad [steps (p.some body^)] prev) @@ -82,11 +82,11 @@ (^ (list& last-step prev-steps)) (let [step-bindings (do Monad<List> [step (list.reverse prev-steps)] - (list g!temp (` (|> (~ g!temp) (~@ step)))))] + (list g!temp (` (|> (~ g!temp) (~+ step)))))] (wrap (list (` (do (~ monad) [(~ g!temp) (~ prev) - (~@ step-bindings)] - (|> (~ g!temp) (~@ last-step))))))) + (~+ step-bindings)] + (|> (~ g!temp) (~+ last-step))))))) _ (wrap (list prev))))) @@ -97,10 +97,9 @@ (|> 5 (exec> [int-to-nat %n log!]) (i/* 10)))} - (do @ - [g!temp (macro.gensym "")] + (with-gensyms [g!temp] (wrap (list (` (let [(~ g!temp) (~ prev)] - (exec (|> (~ g!temp) (~@ body)) + (exec (|> (~ g!temp) (~+ body)) (~ g!temp)))))))) (syntax: #export (tuple> [paths (p.many body^)] prev) @@ -111,10 +110,9 @@ [i/dec (i// 2)] [Int/encode])) "Will become: [50 2 \"5\"]")} - (do @ - [g!temp (macro.gensym "")] + (with-gensyms [g!temp] (wrap (list (` (let [(~ g!temp) (~ prev)] - [(~@ (L/map (function [body] (` (|> (~ g!temp) (~@ body)))) + [(~+ (L/map (function [body] (` (|> (~ g!temp) (~+ body)))) paths))])))))) (syntax: #export (case> [branches (p.many (p.seq s.any s.any))] prev) @@ -133,5 +131,5 @@ 9 "nine" _ "???")))} (wrap (list (` (case (~ prev) - (~@ (L/join (L/map (function [[pattern body]] (list pattern body)) + (~+ (L/join (L/map (function [[pattern body]] (list pattern body)) branches)))))))) diff --git a/stdlib/source/lux/data/coll/list.lux b/stdlib/source/lux/data/coll/list.lux index 27f4e8bad..9709db465 100644 --- a/stdlib/source/lux/data/coll/list.lux +++ b/stdlib/source/lux/data/coll/list.lux @@ -359,27 +359,27 @@ (let [(^open) Functor<List> indices (n/range +0 (n/dec num-lists)) type-vars (: (List Code) (map (|>> nat/encode symbol$) indices)) - zip-type (` (All [(~@ type-vars)] - (-> (~@ (map (: (-> Code Code) (function [var] (` (List (~ var))))) + zip-type (` (All [(~+ type-vars)] + (-> (~+ (map (: (-> Code Code) (function [var] (` (List (~ var))))) type-vars)) - (List [(~@ type-vars)])))) + (List [(~+ type-vars)])))) vars+lists (|> indices (map n/inc) (map (function [idx] (let [base (nat/encode idx)] [(symbol$ base) (symbol$ ("lux text concat" base "'"))])))) - pattern (` [(~@ (map (function [[v vs]] (` (#.Cons (~ v) (~ vs)))) + pattern (` [(~+ (map (function [[v vs]] (` (#.Cons (~ v) (~ vs)))) vars+lists))]) g!step (symbol$ "\tstep\t") g!blank (symbol$ "\t_\t") list-vars (map product.right vars+lists) code (` (: (~ zip-type) - (function (~ g!step) [(~@ list-vars)] - (case [(~@ list-vars)] + (function (~ g!step) [(~+ list-vars)] + (case [(~+ list-vars)] (~ pattern) - (#.Cons [(~@ (map product.left vars+lists))] - ((~ g!step) (~@ list-vars))) + (#.Cons [(~+ (map product.left vars+lists))] + ((~ g!step) (~+ list-vars))) (~ g!blank) #.Nil))))] @@ -405,9 +405,9 @@ g!return-type (symbol$ "\treturn-type\t") g!func (symbol$ "\tfunc\t") type-vars (: (List Code) (map (|>> nat/encode symbol$) indices)) - zip-type (` (All [(~@ type-vars) (~ g!return-type)] - (-> (-> (~@ type-vars) (~ g!return-type)) - (~@ (map (: (-> Code Code) (function [var] (` (List (~ var))))) + zip-type (` (All [(~+ type-vars) (~ g!return-type)] + (-> (-> (~+ type-vars) (~ g!return-type)) + (~+ (map (: (-> Code Code) (function [var] (` (List (~ var))))) type-vars)) (List (~ g!return-type))))) vars+lists (|> indices @@ -416,17 +416,17 @@ (let [base (nat/encode idx)] [(symbol$ base) (symbol$ ("lux text concat" base "'"))])))) - pattern (` [(~@ (map (function [[v vs]] (` (#.Cons (~ v) (~ vs)))) + pattern (` [(~+ (map (function [[v vs]] (` (#.Cons (~ v) (~ vs)))) vars+lists))]) g!step (symbol$ "\tstep\t") g!blank (symbol$ "\t_\t") list-vars (map product.right vars+lists) code (` (: (~ zip-type) - (function (~ g!step) [(~ g!func) (~@ list-vars)] - (case [(~@ list-vars)] + (function (~ g!step) [(~ g!func) (~+ list-vars)] + (case [(~+ list-vars)] (~ pattern) - (#.Cons ((~ g!func) (~@ (map product.left vars+lists))) - ((~ g!step) (~ g!func) (~@ list-vars))) + (#.Cons ((~ g!func) (~+ (map product.left vars+lists))) + ((~ g!step) (~ g!func) (~+ list-vars))) (~ g!blank) #.Nil))))] diff --git a/stdlib/source/lux/data/coll/sequence.lux b/stdlib/source/lux/data/coll/sequence.lux index e5d2717fc..bc9787adf 100644 --- a/stdlib/source/lux/data/coll/sequence.lux +++ b/stdlib/source/lux/data/coll/sequence.lux @@ -369,7 +369,7 @@ (syntax: #export (sequence [elems (p.some s.any)]) {#.doc (doc "Sequence literals." (sequence 10 20 30 40))} - (wrap (list (` (from-list (list (~@ elems))))))) + (wrap (list (` (from-list (list (~+ elems))))))) ## [Structures] (struct: #export (Eq<Node> Eq<a>) (All [a] (-> (Eq a) (Eq (Node a)))) diff --git a/stdlib/source/lux/data/coll/stream.lux b/stdlib/source/lux/data/coll/stream.lux index 0cfa549bb..4bce6dd6b 100644 --- a/stdlib/source/lux/data/coll/stream.lux +++ b/stdlib/source/lux/data/coll/stream.lux @@ -6,7 +6,8 @@ [cont #+ pending Cont] ["p" parser]) [macro #+ with-gensyms] - (macro ["s" syntax #+ syntax: Syntax]) + (macro [code] + ["s" syntax #+ syntax: Syntax]) (data (coll [list "List/" Monad<List>]) bool))) @@ -134,10 +135,10 @@ "Caveat emptor: Only use it for destructuring, and not for testing values within the streams." (let [(^stream& x y z _tail) (some-stream-func 1 2 3)] (func x y z)))} - (with-gensyms [g!s] - (let [body+ (` (let [(~@ (List/join (List/map (function [pattern] - (list (` [(~ pattern) (~ g!s)]) - (` (cont.run (~ g!s))))) + (with-gensyms [g!stream] + (let [body+ (` (let [(~+ (List/join (List/map (function [pattern] + (list (` [(~ pattern) (~ g!stream)]) + (` ((~! cont.run) (~ g!stream))))) patterns)))] (~ body)))] - (wrap (list& g!s body+ branches))))) + (wrap (list& g!stream body+ branches))))) diff --git a/stdlib/source/lux/data/coll/tree/rose.lux b/stdlib/source/lux/data/coll/tree/rose.lux index 077f68191..76f4f1894 100644 --- a/stdlib/source/lux/data/coll/tree/rose.lux +++ b/stdlib/source/lux/data/coll/tree/rose.lux @@ -51,7 +51,7 @@ 40 {}}]))} (wrap (list (` (~ (loop [[value children] root] (` {#value (~ value) - #children (list (~@ (L/map recur children)))}))))))) + #children (list (~+ (L/map recur children)))}))))))) ## [Structs] (struct: #export (Eq<Tree> Eq<a>) (All [a] (-> (Eq a) (Eq (Tree a)))) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 37d6f954f..49a739b4f 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -75,7 +75,7 @@ (wrap (list (` (: JSON #Null)))) [_ (#.Tuple members)] - (wrap (list (` (: JSON (#Array (sequence (~@ (list/map wrapper members)))))))) + (wrap (list (` (: JSON (#Array (sequence (~+ (list/map wrapper members)))))))) [_ (#.Record pairs)] (do Monad<Meta> @@ -88,7 +88,7 @@ _ (macro.fail "Wrong syntax for JSON object."))) pairs)] - (wrap (list (` (: JSON (#Object (dict.from-list text.Hash<Text> (list (~@ pairs'))))))))) + (wrap (list (` (: JSON (#Object (dict.from-list text.Hash<Text> (list (~+ pairs'))))))))) _ (wrap (list token)) @@ -356,7 +356,7 @@ ############################################################ ############################################################ -(def: #hidden (show-null _) (-> Null Text) "null") +(def: (show-null _) (-> Null Text) "null") (do-template [<name> <type> <codec>] [(def: <name> (-> <type> Text) <codec>)] diff --git a/stdlib/source/lux/data/lazy.lux b/stdlib/source/lux/data/lazy.lux index 27c60afa9..69f50b5f0 100644 --- a/stdlib/source/lux/data/lazy.lux +++ b/stdlib/source/lux/data/lazy.lux @@ -5,14 +5,14 @@ [applicative #+ Applicative] [monad #+ Monad do]) (concurrency [atom]) - [macro] + [macro #+ with-gensyms] (macro ["s" syntax #+ syntax:]) (type abstract))) (abstract: #export (Lazy a) (-> [] a) - (def: #hidden (freeze' generator) + (def: (freeze' generator) (All [a] (-> (-> [] a) (Lazy a))) (let [cache (atom.atom (: (Maybe ($ +0)) #.None))] (@abstract (function [_] @@ -30,9 +30,8 @@ ((@repr l-value) []))) (syntax: #export (freeze expr) - (do @ - [g!_ (macro.gensym "_")] - (wrap (list (` (freeze' (function [(~ g!_)] (~ expr)))))))) + (with-gensyms [g!_] + (wrap (list (` ((~! freeze') (function [(~ g!_)] (~ expr)))))))) (struct: #export _ (Functor Lazy) (def: (map f fa) diff --git a/stdlib/source/lux/data/number/ratio.lux b/stdlib/source/lux/data/number/ratio.lux index 6f5b64f5e..8342c9d28 100644 --- a/stdlib/source/lux/data/number/ratio.lux +++ b/stdlib/source/lux/data/number/ratio.lux @@ -21,7 +21,7 @@ {#numerator Nat #denominator Nat}) -(def: #hidden (normalize (^slots [#numerator #denominator])) +(def: (normalize (^slots [#numerator #denominator])) (-> Ratio Ratio) (let [common (math.gcd numerator denominator)] {#numerator (n// common numerator) @@ -155,6 +155,6 @@ (ratio numerator denominator) "The denominator can be omitted if it's 1." (ratio numerator))} - (wrap (list (` (normalize {#..numerator (~ numerator) - #..denominator (~ (maybe.default (' +1) - ?denominator))}))))) + (wrap (list (` ((~! normalize) {#..numerator (~ numerator) + #..denominator (~ (maybe.default (' +1) + ?denominator))}))))) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index e1c93bc5f..1c56f1cb9 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -19,14 +19,12 @@ )) ## [Syntax] -(def: #hidden _compose_ - (-> Text Text Text) - (:: text.Monoid<Text> compose)) - (syntax: #export (format [fragments (p.many s.any)]) {#.doc (doc "Text interpolation." (format "Static part " (%t static) " does not match URI: " uri))} - (wrap (list (` ($_ _compose_ (~@ fragments)))))) + (macro.with-gensyms [g!compose] + (wrap (list (` (let [(~ g!compose) (:: (~! text.Monoid<Text>) (~' compose))] + ($_ (~ g!compose) (~+ fragments)))))))) ## [Formatters] (type: #export (Formatter a) diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux index 1f1a0a3c0..ab85158cf 100644 --- a/stdlib/source/lux/data/text/regex.lux +++ b/stdlib/source/lux/data/text/regex.lux @@ -10,7 +10,7 @@ ["e" error] [maybe] (coll [list "list/" Fold<List> Monad<List>])) - [macro #- run] + [macro #+ with-gensyms] (macro [code] ["s" syntax #+ syntax:]))) @@ -27,23 +27,23 @@ l.any regex-char^))) -(def: #hidden (refine^ refinement^ base^) +(def: (refine^ refinement^ base^) (All [a] (-> (l.Lexer a) (l.Lexer Text) (l.Lexer Text))) (do p.Monad<Parser> [output base^ _ (l.local output refinement^)] (wrap output))) -(def: #hidden word^ +(def: word^ (l.Lexer Text) (p.either l.alpha-num (l.one-of "_"))) -(def: #hidden (copy reference) +(def: (copy reference) (-> Text (l.Lexer Text)) (p.after (l.this reference) (p/wrap reference))) -(def: #hidden (join-text^ part^) +(def: (join-text^ part^) (-> (l.Lexer (List Text)) (l.Lexer Text)) (do p.Monad<Parser> [parts part^] @@ -87,7 +87,7 @@ (l.Lexer Code) (do p.Monad<Parser> [char escaped-char^] - (wrap (` (..copy (~ (code.text char))))))) + (wrap (` ((~! ..copy) (~ (code.text char))))))) (def: re-options^ (l.Lexer Code) @@ -103,8 +103,8 @@ re-range^ re-options^))] (wrap (case negate? - (#.Some _) (` (l.not ($_ p.either (~@ parts)))) - #.None (` ($_ p.either (~@ parts))))))) + (#.Some _) (` (l.not ($_ p.either (~+ parts)))) + #.None (` ($_ p.either (~+ parts))))))) (def: re-user-class^ (l.Lexer Code) @@ -113,32 +113,32 @@ init re-user-class^' rest (p.some (p.after (l.this "&&") (l.enclosed ["[" "]"] re-user-class^')))] (wrap (list/fold (function [refinement base] - (` (refine^ (~ refinement) (~ base)))) + (` ((~! refine^) (~ refinement) (~ base)))) init rest)))) -(def: #hidden blank^ +(def: blank^ (l.Lexer Text) (l.one-of " \t")) -(def: #hidden ascii^ +(def: ascii^ (l.Lexer Text) (l.range (char "\u0000") (char "\u007F"))) -(def: #hidden control^ +(def: control^ (l.Lexer Text) (p.either (l.range (char "\u0000") (char "\u001F")) (l.one-of "\u007F"))) -(def: #hidden punct^ +(def: punct^ (l.Lexer Text) (l.one-of "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~")) -(def: #hidden graph^ +(def: graph^ (l.Lexer Text) (p.either punct^ l.alpha-num)) -(def: #hidden print^ +(def: print^ (l.Lexer Text) (p.either graph^ (l.one-of "\u0020"))) @@ -153,8 +153,8 @@ (p.after (l.this "\\D") (wrap (` (l.not l.decimal)))) (p.after (l.this "\\s") (wrap (` l.space))) (p.after (l.this "\\S") (wrap (` (l.not l.space)))) - (p.after (l.this "\\w") (wrap (` word^))) - (p.after (l.this "\\W") (wrap (` (l.not word^)))) + (p.after (l.this "\\w") (wrap (` (~! word^)))) + (p.after (l.this "\\W") (wrap (` (l.not (~! word^))))) (p.after (l.this "\\p{Lower}") (wrap (` l.lower))) (p.after (l.this "\\p{Upper}") (wrap (` l.upper))) @@ -164,12 +164,12 @@ (p.after (l.this "\\p{Space}") (wrap (` l.space))) (p.after (l.this "\\p{HexDigit}") (wrap (` l.hexadecimal))) (p.after (l.this "\\p{OctDigit}") (wrap (` l.octal))) - (p.after (l.this "\\p{Blank}") (wrap (` blank^))) - (p.after (l.this "\\p{ASCII}") (wrap (` ascii^))) - (p.after (l.this "\\p{Contrl}") (wrap (` control^))) - (p.after (l.this "\\p{Punct}") (wrap (` punct^))) - (p.after (l.this "\\p{Graph}") (wrap (` graph^))) - (p.after (l.this "\\p{Print}") (wrap (` print^))) + (p.after (l.this "\\p{Blank}") (wrap (` (~! blank^)))) + (p.after (l.this "\\p{ASCII}") (wrap (` (~! ascii^)))) + (p.after (l.this "\\p{Contrl}") (wrap (` (~! control^)))) + (p.after (l.this "\\p{Punct}") (wrap (` (~! punct^)))) + (p.after (l.this "\\p{Graph}") (wrap (` (~! graph^)))) + (p.after (l.this "\\p{Print}") (wrap (` (~! print^)))) ))) (def: re-class^ @@ -188,12 +188,12 @@ (p.either (do p.Monad<Parser> [_ (l.this "\\") id number^] - (wrap (` (..copy (~ (code.symbol ["" (int/encode (nat-to-int id))])))))) + (wrap (` ((~! ..copy) (~ (code.symbol ["" (int/encode (nat-to-int id))])))))) (do p.Monad<Parser> [_ (l.this "\\k<") captured-name identifier-part^ _ (l.this ">")] - (wrap (` (..copy (~ (code.symbol ["" captured-name])))))))) + (wrap (` ((~! ..copy) (~ (code.symbol ["" captured-name])))))))) (def: (re-simple^ current-module) (-> Text (l.Lexer Code)) @@ -214,11 +214,11 @@ (wrap (` (p.default "" (~ base)))) "*" - (wrap (` (join-text^ (p.some (~ base))))) + (wrap (` ((~! join-text^) (p.some (~ base))))) ## "+" _ - (wrap (` (join-text^ (p.many (~ base))))) + (wrap (` ((~! join-text^) (p.many (~ base))))) ))) (def: (re-counted-quantified^ current-module) @@ -229,18 +229,18 @@ ($_ p.either (do @ [[from to] (p.seq number^ (p.after (l.this ",") number^))] - (wrap (` (join-text^ (p.between (~ (code.nat from)) - (~ (code.nat to)) - (~ base)))))) + (wrap (` ((~! join-text^) (p.between (~ (code.nat from)) + (~ (code.nat to)) + (~ base)))))) (do @ [limit (p.after (l.this ",") number^)] - (wrap (` (join-text^ (p.at-most (~ (code.nat limit)) (~ base)))))) + (wrap (` ((~! join-text^) (p.at-most (~ (code.nat limit)) (~ base)))))) (do @ [limit (p.before (l.this ",") number^)] - (wrap (` (join-text^ (p.at-least (~ (code.nat limit)) (~ base)))))) + (wrap (` ((~! join-text^) (p.at-least (~ (code.nat limit)) (~ base)))))) (do @ [limit number^] - (wrap (` (join-text^ (p.exactly (~ (code.nat limit)) (~ base)))))))))) + (wrap (` ((~! join-text^) (p.exactly (~ (code.nat limit)) (~ base)))))))))) (def: (re-quantified^ current-module) (-> Text (l.Lexer Code)) @@ -253,10 +253,6 @@ (re-quantified^ current-module) (re-simple^ current-module))) -(def: #hidden _text/compose_ - (-> Text Text Text) - (:: text.Monoid<Text> compose)) - (type: Re-Group #Non-Capturing (#Capturing [(Maybe Text) Nat])) @@ -280,7 +276,7 @@ [idx names (list& (list g!temp complex - (' #let) (` [(~ g!total) (_text/compose_ (~ g!total) (~ g!temp))])) + (' #let) (` [(~ g!total) (:: (~! text.Monoid<Text>) (~' compose) (~ g!total) (~ g!temp))])) steps)] (#e.Success [(#Capturing [?name num-captures]) scoped]) @@ -296,7 +292,7 @@ [idx! (list& name! names) (list& (list name! scoped - (' #let) (` [(~ g!total) (_text/compose_ (~ g!total) (~ access))])) + (' #let) (` [(~ g!total) (:: (~! text.Monoid<Text>) (~' compose) (~ g!total) (~ access))])) steps)]) ))) [0 @@ -308,15 +304,15 @@ +0) (` (do p.Monad<Parser> [(~ (' #let)) [(~ g!total) ""] - (~@ (|> steps list.reverse list/join))] - ((~ (' wrap)) [(~ g!total) (~@ (list.reverse names))])))]) + (~+ (|> steps list.reverse list/join))] + ((~ (' wrap)) [(~ g!total) (~+ (list.reverse names))])))]) )) -(def: #hidden (unflatten^ lexer) +(def: (unflatten^ lexer) (-> (l.Lexer Text) (l.Lexer [Text Unit])) (p.seq lexer (:: p.Monad<Parser> wrap []))) -(def: #hidden (|||^ left right) +(def: (|||^ left right) (All [l r] (-> (l.Lexer [Text l]) (l.Lexer [Text r]) (l.Lexer [Text (| l r)]))) (function [input] (case (left input) @@ -331,7 +327,7 @@ (#e.Error error) (#e.Error error))))) -(def: #hidden (|||_^ left right) +(def: (|||_^ left right) (All [l r] (-> (l.Lexer [Text l]) (l.Lexer [Text r]) (l.Lexer Text))) (function [input] (case (left input) @@ -350,7 +346,7 @@ (-> [Nat Code] Code) (if (n/> +0 num-captures) alt - (` (unflatten^ (~ alt))))) + (` ((~! unflatten^) (~ alt))))) (def: (re-alternative^ capturing? re-scoped^ current-module) (-> Bool @@ -361,13 +357,16 @@ [#let [sub^ (re-sequential^ capturing? re-scoped^ current-module)] head sub^ tail (p.some (p.after (l.this "|") sub^)) - #let [g!op (if capturing? - (` |||^) - (` |||_^))]] + #let [g!op (code.symbol ["" " alt "])]] (if (list.empty? tail) (wrap head) (wrap [(list/fold n/max (product.left head) (list/map product.left tail)) - (` ($_ (~ g!op) (~ (prep-alternative head)) (~@ (list/map prep-alternative tail))))])))) + (` (let [(~ g!op) (~ (if capturing? + (` (~! |||^)) + (` (~! |||_^))))] + ($_ (~ g!op) + (~ (prep-alternative head)) + (~+ (list/map prep-alternative tail)))))])))) (def: (re-scoped^ current-module) (-> Text (l.Lexer [Re-Group Code])) @@ -484,11 +483,9 @@ _ do-something-else))} - (do @ - [g!temp (macro.gensym "temp")] + (with-gensyms [g!temp] (wrap (list& (` (^multi (~ g!temp) - [(l.run (~ g!temp) (regex (~ (code.text pattern)))) - (#e.Success (~ (maybe.default g!temp - bindings)))])) + [((~! l.run) (~ g!temp) (regex (~ (code.text pattern)))) + (#e.Success (~ (maybe.default g!temp bindings)))])) body branches)))) diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux index 5e52cc283..fafaa81c7 100644 --- a/stdlib/source/lux/host.js.lux +++ b/stdlib/source/lux/host.js.lux @@ -77,8 +77,8 @@ (case shape (#.Left [function args ?type]) (wrap (list (` (:! (~ (default (' ..Object) ?type)) - ("js call" (~ function) (~@ args)))))) + ("js call" (~ function) (~+ args)))))) (#.Right [object field args ?type]) (wrap (list (` (:! (~ (default (' ..Object) ?type)) - ("js object-call" (~ object) (~ (code.text field)) (~@ args)))))))) + ("js object-call" (~ object) (~ (code.text field)) (~+ args)))))))) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index a53ec1a5f..dbbc26fb8 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -290,7 +290,7 @@ [[name params] _ _] (let [name (sanitize name) =params (list/map (class->type' mode type-params in-array?) params)] - (` (primitive (~ (code.text name)) [(~@ =params)]))))) + (` (primitive (~ (code.text name)) [(~+ =params)]))))) (def: (class->type' mode type-params in-array? class) (-> Primitive-Mode (List TypeParam) Bool GenericType Code) @@ -341,7 +341,7 @@ (class->type #ManualPrM class-params bound1)))) class-params)] (` (primitive (~ (code.text (sanitize class-name))) - [(~@ =params)])))) + [(~+ =params)])))) (def: empty-imports Class-Imports @@ -579,7 +579,7 @@ (s.form ($_ p.seq (s.this (' ::new!)) (s.tuple (p.exactly (list.size arg-decls) s.any))))) #let [arg-decls' (: (List Text) (list/map (|>> product.right (simple-class$ params)) arg-decls))]] (wrap (` ((~ (code.text (format "jvm new" ":" class-name ":" (text.join-with "," arg-decls')))) - (~@ args)))))) + (~+ args)))))) (def: (make-static-method-parser params class-name method-name arg-decls) (-> (List TypeParam) Text Text (List ArgDecl) (Syntax Code)) @@ -589,7 +589,7 @@ (s.form ($_ p.seq (s.this (code.symbol ["" dotted-name])) (s.tuple (p.exactly (list.size arg-decls) s.any))))) #let [arg-decls' (: (List Text) (list/map (|>> product.right (simple-class$ params)) arg-decls))]] (wrap (`' ((~ (code.text (format "jvm invokestatic" ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) - (~@ args)))))) + (~+ args)))))) (do-template [<name> <jvm-op>] [(def: (<name> params class-name method-name arg-decls) @@ -600,7 +600,7 @@ (s.form ($_ p.seq (s.this (code.symbol ["" dotted-name])) (s.tuple (p.exactly (list.size arg-decls) s.any))))) #let [arg-decls' (: (List Text) (list/map (|>> product.right (simple-class$ params)) arg-decls))]] (wrap (`' ((~ (code.text (format <jvm-op> ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) - (~' _jvm_this) (~@ args))))))] + (~' _jvm_this) (~+ args))))))] [make-special-method-parser "jvm invokespecial"] [make-virtual-method-parser "jvm invokevirtual"] @@ -1206,7 +1206,7 @@ #let [arg-decls' (: (List Text) (list/map (|>> product.right (simple-class$ (list))) arg-decls))]] (wrap (`' ((~ (code.text (format "jvm invokespecial" ":" (get@ #super-class-name super-class) ":" name ":" (text.join-with "," arg-decls')))) - (~' _jvm_this) (~@ args)))))))] + (~' _jvm_this) (~+ args)))))))] (with-parens (spaced (list "override" (class-decl$ class-decl) @@ -1259,9 +1259,9 @@ (generic-type$ return-type)))) )) -(def: (complete-call$ obj [method args]) +(def: (complete-call$ g!obj [method args]) (-> Code Partial-Call Code) - (` ((~ method) (~ args) (~ obj)))) + (` ((~ method) (~ args) (~ g!obj)))) ## [Syntax] (def: object-super-class @@ -1465,7 +1465,7 @@ (ClassName::method2 [arg3 arg4 arg5])))} (with-gensyms [g!obj] (wrap (list (` (let [(~ g!obj) (~ obj)] - (exec (~@ (list/map (complete-call$ g!obj) methods)) + (exec (~+ (list/map (complete-call$ g!obj) methods)) (~ g!obj)))))))) (def: (class-import$ long-name? [full-name params]) @@ -1478,9 +1478,9 @@ {#.type? true #..jvm-class (~ (code.text full-name))} Type - (All [(~@ params')] + (All [(~+ params')] (primitive (~ (code.text (sanitize full-name))) - [(~@ params')])))))) + [(~+ params')])))))) (def: (member-type-vars class-tvars member) (-> (List TypeParam) ImportMemberDecl (List TypeParam)) @@ -1550,7 +1550,7 @@ [(` (Maybe (~ return-type))) (` (??? (~ return-term)))] [return-type - (let [g!temp (code.symbol ["" "Ω"])] + (let [g!temp (code.symbol ["" " Ω "])] (` (let [(~ g!temp) (~ return-term)] (if (not (null? (:! (primitive "java.lang.Object") (~ g!temp)))) @@ -1634,7 +1634,7 @@ body #AutoPrM - (` (let [(~@ (|> inputs + (` (let [(~+ (|> inputs (list/map auto-conv) list/join))] (~ body))))) @@ -1653,19 +1653,19 @@ "float" (` (f2d (~ output))) _ output))) -(def: (with-mode-field-set mode class input) +(def: (with-mode-field-set mode class g!input) (-> Primitive-Mode GenericType Code Code) (case mode #ManualPrM - input + g!input #AutoPrM (case (simple-class$ (list) class) - "byte" (` (l2b (~ input))) - "short" (` (l2s (~ input))) - "int" (` (l2i (~ input))) - "float" (` (d2f (~ input))) - _ input))) + "byte" (` (l2b (~ g!input))) + "short" (` (l2s (~ g!input))) + "int" (` (l2i (~ g!input))) + "float" (` (d2f (~ g!input))) + _ g!input))) (def: (member-def-interop type-params kind class [arg-function-inputs arg-method-inputs arg-classes arg-types] member method-prefix) (-> (List TypeParam) ClassKind ClassDecl [(List Code) (List Code) (List Text) (List Code)] ImportMemberDecl Text (Meta (List Code))) @@ -1686,7 +1686,7 @@ (let [=class-tvars (|> class-tvars (list.filter free-type-param?) (list/map type-param->type-arg))] - (` (All [(~@ =class-tvars)] (primitive (~ (code.text full-name)) [(~@ =class-tvars)])))))) + (` (All [(~+ =class-tvars)] (primitive (~ (code.text full-name)) [(~+ =class-tvars)])))))) getter-interop (: (-> Text Code) (function [name] (let [getter-name (code.symbol ["" (format method-prefix member-separator name)])] @@ -1701,15 +1701,15 @@ #let [def-name (code.symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) def-params (list (code.tuple arg-function-inputs)) jvm-interop (|> (` ((~ (code.text (format "jvm new" ":" full-name ":" (text.join-with "," arg-classes)))) - (~@ arg-method-inputs))) + (~+ arg-method-inputs))) (with-mode-inputs (get@ #import-member-mode commons) (list.zip2 arg-classes arg-function-inputs))) [return-type jvm-interop] (|> [return-type jvm-interop] (decorate-return-maybe member) (decorate-return-try member) (decorate-return-io member))]] - (wrap (list (` (def: ((~ def-name) (~@ def-params)) - (All [(~@ all-params)] (-> [(~@ arg-types)] (~ return-type))) + (wrap (list (` (def: ((~ def-name) (~+ def-params)) + (All [(~+ all-params)] (-> [(~+ arg-types)] (~ return-type))) (~ jvm-interop)))))) (#MethodDecl [commons method]) @@ -1739,10 +1739,10 @@ (list (class-decl-type$ class))] ))) def-params (#.Cons (code.tuple arg-function-inputs) obj-ast) - def-param-types (#.Cons (` [(~@ arg-types)]) class-ast) + def-param-types (#.Cons (` [(~+ arg-types)]) class-ast) jvm-interop (|> (` ((~ (code.text (format "jvm " jvm-op ":" full-name ":" import-method-name ":" (text.join-with "," arg-classes)))) - (~@ obj-ast) (~@ arg-method-inputs))) + (~+ obj-ast) (~+ arg-method-inputs))) (with-mode-output (get@ #import-member-mode commons) (get@ #import-method-return method)) (with-mode-inputs (get@ #import-member-mode commons) @@ -1751,18 +1751,18 @@ (decorate-return-maybe member) (decorate-return-try member) (decorate-return-io member))]] - (wrap (list (` (def: ((~ def-name) (~@ def-params)) - (All [(~@ all-params)] (-> (~@ def-param-types) (~ return-type))) + (wrap (list (` (def: ((~ def-name) (~+ def-params)) + (All [(~+ all-params)] (-> (~+ def-param-types) (~ return-type))) (~ jvm-interop))))))) (#FieldAccessDecl fad) (do Monad<Meta> [#let [(^open) fad base-gtype (class->type import-field-mode type-params import-field-type) - g!class (class-decl-type$ class) - g!type (if import-field-maybe? - (` (Maybe (~ base-gtype))) - base-gtype) + classC (class-decl-type$ class) + typeC (if import-field-maybe? + (` (Maybe (~ base-gtype))) + base-gtype) tvar-asts (: (List Code) (|> class-tvars (list.filter free-type-param?) @@ -1774,12 +1774,12 @@ getter-name (` ((~ getter-name) (~ g!obj)))) getter-type (if import-field-setter? - (` (IO (~ g!type))) - g!type) + (` (IO (~ typeC))) + typeC) getter-type (if import-field-static? getter-type - (` (-> (~ g!class) (~ getter-type)))) - getter-type (` (All [(~@ tvar-asts)] (~ getter-type))) + (` (-> (~ classC) (~ getter-type)))) + getter-type (` (All [(~+ tvar-asts)] (~ getter-type))) getter-body (if import-field-static? (with-mode-field-get import-field-mode import-field-type (` ((~ (code.text (format "jvm getstatic" ":" full-name ":" import-field-name)))))) @@ -1800,8 +1800,8 @@ (` ((~ setter-name) (~ g!value))) (` ((~ setter-name) (~ g!value) (~ g!obj)))) setter-type (if import-field-static? - (` (All [(~@ tvar-asts)] (-> (~ g!type) (IO Unit)))) - (` (All [(~@ tvar-asts)] (-> (~ g!type) (~ g!class) (IO Unit))))) + (` (All [(~+ tvar-asts)] (-> (~ typeC) (IO Unit)))) + (` (All [(~+ tvar-asts)] (-> (~ typeC) (~ classC) (IO Unit))))) setter-value (with-mode-field-set import-field-mode import-field-type g!value) setter-value (if import-field-maybe? (` (!!! (~ setter-value))) @@ -2033,9 +2033,9 @@ (` (try ("jvm invokevirtual:java.io.Closeable:close:" (~ (code.symbol ["" (product.left res)])))))) bindings)] (wrap (list (` (do Monad<IO> - [(~@ inits) + [(~+ inits) (~ g!output) (~ body) - (~' #let) [(~ g!_) (exec (~@ (list.reverse closes)) [])]] + (~' #let) [(~ g!_) (exec (~+ (list.reverse closes)) [])]] ((~' wrap) (~ g!output))))))))) (syntax: #export (class-for [#let [imports (class-imports *compiler*)]] diff --git a/stdlib/source/lux/lang/type.lux b/stdlib/source/lux/lang/type.lux index ab680cb6c..43febdb8c 100644 --- a/stdlib/source/lux/lang/type.lux +++ b/stdlib/source/lux/lang/type.lux @@ -169,7 +169,7 @@ (case type (#.Primitive name params) (` (#.Primitive (~ (code.text name)) - (list (~@ (list/map to-ast params))))) + (list (~+ (list/map to-ast params))))) (^template [<tag>] <tag> @@ -189,7 +189,7 @@ (^template [<tag> <macro> <flattener>] (<tag> left right) - (` (<macro> (~@ (list/map to-ast (<flattener> type)))))) + (` (<macro> (~+ (list/map to-ast (<flattener> type)))))) ([#.Sum | flatten-variant] [#.Product & flatten-tuple]) @@ -198,7 +198,7 @@ (^template [<tag>] (<tag> env body) - (` (<tag> (list (~@ (list/map to-ast env))) + (` (<tag> (list (~+ (list/map to-ast env))) (~ (to-ast body))))) ([#.UnivQ] [#.ExQ]) )) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index 0b28598c8..aa2429ae7 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -197,7 +197,6 @@ (flag-set? (ident-for <tag>)))] [export? #.export? "exported"] - [hidden? #.hidden? "hidden"] [macro? #.macro? "a macro"] [type? #.type? "a type"] [struct? #.struct? "a structure"] @@ -393,7 +392,7 @@ (function [name] (list (code.symbol ["" name]) (` (gensym (~ (code.text name))))))) symbol-names))]] (wrap (list (` (do Monad<Meta> - [(~@ symbol-defs)] + [(~+ symbol-defs)] (~ body)))))) _ @@ -524,8 +523,7 @@ (do Monad<Meta> [defs (defs module-name)] (wrap (list.filter (function [[name [def-type def-anns def-value]]] - (and (export? def-anns) - (not (hidden? def-anns)))) + (export? def-anns)) defs)))) (def: #export modules diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index 05a609e1b..a14e415b4 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -200,7 +200,7 @@ (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)) + 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) @@ -336,7 +336,7 @@ (|> allT (monad.map @ (function.const bound)) (local allT)))] - (wrap (` ((~@ allC)))))) + (wrap (` ((~+ allC)))))) (def: #export log (All [a] (Poly a)) @@ -353,7 +353,7 @@ 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]) + (wrap (.list (` (syntax: (~+ (csw.export export)) ((~ g!name) [(~ g!type) s.symbol]) (do macro.Monad<Meta> [(~ g!type) (macro.find-type-def (~ g!type))] (case (|> (~ body) @@ -400,8 +400,8 @@ custom-impl #.None - (` ((~ (code.symbol poly-func)) (~@ (list/map code.symbol poly-args)))))]] - (wrap (.list (` (def: (~@ (csw.export export)) + (` ((~ (code.symbol poly-func)) (~+ (list/map code.symbol poly-args)))))]] + (wrap (.list (` (def: (~+ (csw.export export)) (~ (code.symbol ["" name])) {#.struct? true} (~ impl))))))) @@ -412,7 +412,7 @@ (case type (#.Primitive name params) (` (#.Primitive (~ (code.text name)) - (list (~@ (list/map (to-ast env) params))))) + (list (~+ (list/map (to-ast env) params))))) (^template [<tag>] <tag> @@ -444,7 +444,7 @@ (^template [<tag> <macro> <flattener>] (<tag> left right) - (` (<macro> (~@ (list/map (to-ast env) (<flattener> type)))))) + (` (<macro> (~+ (list/map (to-ast env) (<flattener> type)))))) ([#.Sum | type.flatten-variant] [#.Product & type.flatten-tuple]) @@ -453,7 +453,7 @@ (^template [<tag>] (<tag> scope body) - (` (<tag> (list (~@ (list/map (to-ast env) scope))) + (` (<tag> (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 index 46feab967..3550df0c0 100644 --- a/stdlib/source/lux/macro/poly/eq.lux +++ b/stdlib/source/lux/macro/poly/eq.lux @@ -100,7 +100,7 @@ (wrap (` (: (~ (@Eq inputT)) (function [(~ g!left) (~ g!right)] (case [(~ g!left) (~ g!right)] - (~@ (list/join (list/map (function [[tag g!eq]] + (~+ (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))))) @@ -114,8 +114,8 @@ 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) + (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 @@ -128,16 +128,16 @@ ## Type applications (do @ [[funcC argsC] (poly.apply (p.seq Eq<?> (p.many Eq<?>)))] - (wrap (` ((~ funcC) (~@ argsC))))) + (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)] + (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... diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux index fbd8dcd03..79740c32c 100644 --- a/stdlib/source/lux/macro/poly/functor.lux +++ b/stdlib/source/lux/macro/poly/functor.lux @@ -30,8 +30,8 @@ (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))))))))) + (` (All [(~+ paramsC)] + (functor.Functor ((~ (poly.to-ast *env* unwrappedT)) (~+ paramsC))))))))) Arg<?> (: (-> Code (poly.Poly Code)) (function Arg<?> [valueC] ($_ p.either @@ -45,7 +45,7 @@ [_ (wrap []) membersC (poly.variant (p.many (Arg<?> valueC)))] (wrap (` (case (~ valueC) - (~@ (L/join (L/map (function [[tag memberC]] + (~+ (L/join (L/map (function [[tag memberC]] (list (` ((~ (code.nat tag)) (~ valueC))) (` ((~ (code.nat tag)) (~ memberC))))) (list.enumerate membersC)))))))) @@ -63,8 +63,8 @@ (L/compose pairsCC (list [slotC memberC]))))) (wrap pairsCC)))))] (wrap (` (case (~ valueC) - [(~@ (L/map product.left pairsCC))] - [(~@ (L/map product.right pairsCC))])))) + [(~+ (L/map product.left pairsCC))] + [(~+ (L/map product.right pairsCC))])))) ## Functions (do @ [_ (wrap []) @@ -74,8 +74,8 @@ #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+))] + (wrap (` (function [(~+ inC+)] + (let [(~ outL) ((~ valueC) (~+ inC+))] (~ outC)))))) ## Recursion (do p.Monad<Parser> diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux index 3a5148377..3cb1fac1a 100644 --- a/stdlib/source/lux/macro/poly/json.lux +++ b/stdlib/source/lux/macro/poly/json.lux @@ -28,15 +28,11 @@ (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) +(def: (rec-encode non-rec) (All [a] (-> (-> (-> a JSON) (-> a JSON)) (-> a JSON))) @@ -46,7 +42,7 @@ (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) +(struct: _ (Codec JSON Nat) (def: (encode input) (let [high (|> input (bit.and high-mask) (bit.shift-right +32)) low (bit.and low-mask input)] @@ -60,12 +56,12 @@ (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) +(struct: _ (Codec JSON Int) (def: encode (|>> int-to-nat (:: Codec<JSON,Nat> encode))) (def: decode (|>> (:: Codec<JSON,Nat> decode) (:: e.Functor<Error> map nat-to-int)))) -(def: #hidden (nullable writer) +(def: (nullable writer) {#.doc "Builds a JSON generator for potentially inexistent values."} (All [a] (-> (-> a JSON) (-> (Maybe a) JSON))) (function [elem] @@ -73,14 +69,14 @@ #.None #//.Null (#.Some value) (writer value)))) -(struct: #hidden (Codec<JSON,Qty> carrier) +(struct: (Codec<JSON,Qty> carrier) (All [unit] (-> unit (Codec JSON (unit.Qty unit)))) (def: encode (|>> unit.out (:: Codec<JSON,Int> encode))) (def: decode (|>> (:: Codec<JSON,Int> decode) (:: e.Functor<Error> map (unit.in carrier))))) -(poly: #hidden Codec<JSON,?>//encode +(poly: Codec<JSON,?>//encode (with-expansions [<basic> (do-template [<type> <matcher> <encoder>] [(do @ @@ -90,8 +86,8 @@ [Unit poly.unit (function [(~ (code.symbol ["" "0"]))] #//.Null)] [Bool poly.bool (|>> #//.Boolean)] - [Nat poly.nat (:: ..Codec<JSON,Nat> (~' encode))] - [Int poly.int (:: ..Codec<JSON,Int> (~' encode))] + [Nat poly.nat (:: (~! ..Codec<JSON,Nat>) (~' encode))] + [Int poly.int (:: (~! ..Codec<JSON,Int>) (~' encode))] [Frac poly.frac (|>> #//.Number)] [Text poly.text (|>> #//.String)]) <time> (do-template [<type> <codec>] @@ -118,7 +114,7 @@ [unitT (poly.apply (p.after (poly.this unit.Qty) poly.any))] (wrap (` (: (~ (@JSON//encode inputT)) - (:: (Codec<JSON,Qty> (:! (~ (poly.to-ast *env* unitT)) [])) (~' encode)))))) + (:: ((~! Codec<JSON,Qty>) (:! (~ (poly.to-ast *env* unitT)) [])) (~' encode)))))) (do @ [#let [g!key (code.local-symbol "\u0000key") g!val (code.local-symbol "\u0000val")] @@ -128,8 +124,8 @@ Codec<JSON,?>//encode))] (wrap (` (: (~ (@JSON//encode inputT)) (|>> d.entries - (.._map_ (function [[(~ g!key) (~ g!val)]] - [(~ g!key) ((~ =val=) (~ g!val))])) + ((~! list/map) (function [[(~ g!key) (~ g!val)]] + [(~ g!key) ((~ =val=) (~ g!val))])) (d.from-list text.Hash<Text>) #//.Object))))) (do @ @@ -137,20 +133,20 @@ (poly.this .Maybe) Codec<JSON,?>//encode))] (wrap (` (: (~ (@JSON//encode inputT)) - (..nullable (~ =sub=)))))) + ((~! ..nullable) (~ =sub=)))))) (do @ [[_ =sub=] (poly.apply ($_ p.seq (poly.this .List) Codec<JSON,?>//encode))] (wrap (` (: (~ (@JSON//encode inputT)) - (|>> (.._map_ (~ =sub=)) sequence.from-list #//.Array))))) + (|>> ((~! list/map) (~ =sub=)) sequence.from-list #//.Array))))) (do @ [#let [g!input (code.local-symbol "\u0000input")] members (poly.variant (p.many Codec<JSON,?>//encode))] (wrap (` (: (~ (@JSON//encode inputT)) (function [(~ g!input)] (case (~ g!input) - (~@ (list/join (list/map (function [[tag g!encode]] + (~+ (list/join (list/map (function [[tag g!encode]] (list (` ((~ (code.nat tag)) (~ g!input))) (` (//.json [(~ (code.frac (..tag tag))) ((~ g!encode) (~ g!input))])))) @@ -161,30 +157,30 @@ (list.n/range +0) (list/map (|>> nat/encode code.local-symbol)))]] (wrap (` (: (~ (@JSON//encode inputT)) - (function [[(~@ g!members)]] - (//.json [(~@ (list/map (function [[g!member g!encode]] + (function [[(~+ g!members)]] + (//.json [(~+ (list/map (function [[g!member g!encode]] (` ((~ g!encode) (~ g!member)))) (list.zip2 g!members g!encoders)))])))))) ## Type recursion (do @ [[selfC non-recC] (poly.recursive Codec<JSON,?>//encode)] (wrap (` (: (~ (@JSON//encode inputT)) - (..rec-encode (.function [(~ selfC)] - (~ non-recC))))))) + ((~! ..rec-encode) (.function [(~ selfC)] + (~ non-recC))))))) poly.recursive-self ## Type applications (do @ [partsC (poly.apply (p.many Codec<JSON,?>//encode))] - (wrap (` ((~@ partsC))))) + (wrap (` ((~+ partsC))))) ## Polymorphism (do @ [[funcC varsC bodyC] (poly.polymorphic Codec<JSON,?>//encode)] - (wrap (` (: (All [(~@ varsC)] - (-> (~@ (list/map (function [varC] (` (-> (~ varC) //.JSON))) + (wrap (` (: (All [(~+ varsC)] + (-> (~+ (list/map (function [varC] (` (-> (~ varC) //.JSON))) varsC)) - (-> ((~ (poly.to-ast *env* inputT)) (~@ varsC)) + (-> ((~ (poly.to-ast *env* inputT)) (~+ varsC)) //.JSON))) - (function (~ funcC) [(~@ varsC)] + (function (~ funcC) [(~+ varsC)] (~ bodyC)))))) poly.bound poly.recursive-call @@ -192,7 +188,7 @@ (p.fail (text/compose "Cannot create JSON encoder for: " (type.to-text inputT))) )))) -(poly: #hidden Codec<JSON,?>//decode +(poly: Codec<JSON,?>//decode (with-expansions [<basic> (do-template [<type> <matcher> <decoder>] [(do @ @@ -202,8 +198,8 @@ [Unit poly.unit //.null] [Bool poly.bool //.boolean] - [Nat poly.nat (p.codec ..Codec<JSON,Nat> //.any)] - [Int poly.int (p.codec ..Codec<JSON,Int> //.any)] + [Nat poly.nat (p.codec (~! ..Codec<JSON,Nat>) //.any)] + [Int poly.int (p.codec (~! ..Codec<JSON,Int>) //.any)] [Frac poly.frac //.number] [Text poly.text //.string]) <time> (do-template [<type> <codec>] @@ -230,7 +226,7 @@ [unitT (poly.apply (p.after (poly.this unit.Qty) poly.any))] (wrap (` (: (~ (@JSON//decode inputT)) - (p.codec (Codec<JSON,Qty> (:! (~ (poly.to-ast *env* unitT)) [])) //.any))))) + (p.codec ((~! Codec<JSON,Qty>) (:! (~ (poly.to-ast *env* unitT)) [])) //.any))))) (do @ [[_ _ valC] (poly.apply ($_ p.seq (poly.this d.Dict) @@ -252,7 +248,7 @@ [members (poly.variant (p.many Codec<JSON,?>//decode))] (wrap (` (: (~ (@JSON//decode inputT)) ($_ p.alt - (~@ (list/map (function [[tag memberC]] + (~+ (list/map (function [[tag memberC]] (` (|> (~ memberC) (p.after (//.number! (~ (code.frac (..tag tag))))) //.array))) @@ -260,7 +256,7 @@ (do @ [g!decoders (poly.tuple (p.many Codec<JSON,?>//decode))] (wrap (` (: (~ (@JSON//decode inputT)) - (//.array ($_ p.seq (~@ g!decoders))))))) + (//.array ($_ p.seq (~+ g!decoders))))))) ## Type recursion (do @ [[selfC bodyC] (poly.recursive Codec<JSON,?>//decode)] @@ -271,14 +267,14 @@ ## Type applications (do @ [[funcC argsC] (poly.apply (p.seq Codec<JSON,?>//decode (p.many Codec<JSON,?>//decode)))] - (wrap (` ((~ funcC) (~@ argsC))))) + (wrap (` ((~ funcC) (~+ argsC))))) ## Polymorphism (do @ [[funcC varsC bodyC] (poly.polymorphic Codec<JSON,?>//decode)] - (wrap (` (: (All [(~@ varsC)] - (-> (~@ (list/map (|>> (~) //.Reader (`)) varsC)) - (//.Reader ((~ (poly.to-ast *env* inputT)) (~@ varsC))))) - (function (~ funcC) [(~@ varsC)] + (wrap (` (: (All [(~+ varsC)] + (-> (~+ (list/map (|>> (~) //.Reader (`)) varsC)) + (//.Reader ((~ (poly.to-ast *env* inputT)) (~+ varsC))))) + (function (~ funcC) [(~+ varsC)] (~ bodyC)))))) poly.bound poly.recursive-call @@ -307,6 +303,6 @@ (derived: (Codec<JSON,?> Record)))} (with-gensyms [g!inputs] (wrap (list (` (: (Codec //.JSON (~ inputT)) - (struct (def: (~' encode) (Codec<JSON,?>//encode (~ inputT))) - (def: ((~' decode) (~ g!inputs)) (//.run (~ g!inputs) (Codec<JSON,?>//decode (~ inputT)))) + (struct (def: (~' encode) ((~! Codec<JSON,?>//encode) (~ inputT))) + (def: ((~' decode) (~ g!inputs)) (//.run (~ g!inputs) ((~! Codec<JSON,?>//decode) (~ inputT)))) ))))))) diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index b18e0763f..e31b8c876 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -194,13 +194,8 @@ (wrap [real value])))) ## [Syntax] -(def: #hidden text/join-with text.join-with) - -(def: #hidden _run_ p.run) -(def: #hidden _Monad<Parser>_ p.Monad<Parser>) - (macro: #export (syntax: tokens) - {#.doc (doc "A more advanced way to define macros than macro:." + {#.doc (doc "A more advanced way to define macros than \"macro:\"." "The inputs to the macro can be parsed in complex ways through the use of syntax parsers." "The macro body is also (implicitly) run in the Monad<Meta>, to save some typing." "Also, the compiler state can be accessed through the *compiler* binding." @@ -216,16 +211,13 @@ (with-brackets (spaced (list/map constructor-arg$ constructor-args))) (with-brackets (spaced (list/map (method-def$ id) methods))))))] (wrap (list (` ((~ (code.text def-code)))))))))} - (let [[exported? tokens] (: [(Maybe (Either Unit Unit)) (List Code)] + (let [[exported? tokens] (: [Bool (List Code)] (case tokens - (^ (list& [_ (#.Tag ["" "hidden"])] tokens')) - [(#.Some #.Left) tokens'] - (^ (list& [_ (#.Tag ["" "export"])] tokens')) - [(#.Some #.Right) tokens'] + [true tokens'] _ - [#.None tokens])) + [false tokens])) ?parts (: (Maybe [Text (List Code) Code Code]) (case tokens (^ (list [_ (#.Form (list& [_ (#.Symbol ["" name])] args))] @@ -241,7 +233,7 @@ #.None))] (case ?parts (#.Some [name args meta body]) - (with-gensyms [g!tokens g!body g!msg] + (with-gensyms [g!text/join-with g!tokens g!body g!error] (do macro.Monad<Meta> [vars+parsers (monad.map @ (: (-> Code (Meta [Code Code])) @@ -258,29 +250,25 @@ args) #let [g!state (code.symbol ["" "*compiler*"]) error-msg (code.text (text/compose "Wrong syntax for " name)) - export-ast (: (List Code) (case exported? - (#.Some #.Left) - (list (' #hidden)) - - (#.Some #.Right) - (list (' #export)) - - _ - (list)))]] - (wrap (list (` (macro: (~@ export-ast) ((~ (code.symbol ["" name])) (~ g!tokens) (~ g!state)) + export-ast (: (List Code) + (if exported? + (list (' #export)) + (list)))]] + (wrap (list (` (macro: (~+ export-ast) ((~ (code.symbol ["" name])) (~ g!tokens) (~ g!state)) (~ meta) ("lux case" (..run (~ g!tokens) (: (Syntax (Meta (List Code))) - (do .._Monad<Parser>_ - [(~@ (join-pairs vars+parsers))] - ((~' wrap) (do macro.Monad<Meta> + (do (~! p.Monad<Parser>) + [(~+ (join-pairs vars+parsers))] + ((~' wrap) (do (~! macro.Monad<Meta>) [] (~ body)))))) {(#E.Success (~ g!body)) ((~ g!body) (~ g!state)) - (#E.Error (~ g!msg)) - (#E.Error (text/join-with ": " (list (~ error-msg) (~ g!msg))))}))))))) + (#E.Error (~ g!error)) + (let [(~ g!text/join-with) (~! text.join-with)] + (#E.Error ((~ g!text/join-with) ": " (list (~ error-msg) (~ g!error)))))}))))))) _ (macro.fail "Wrong syntax for syntax:")))) diff --git a/stdlib/source/lux/macro/syntax/common.lux b/stdlib/source/lux/macro/syntax/common.lux index 8c684537e..9de36fe5d 100644 --- a/stdlib/source/lux/macro/syntax/common.lux +++ b/stdlib/source/lux/macro/syntax/common.lux @@ -3,10 +3,6 @@ The goal is to be able to reuse common syntax in macro definitions across libraries."} lux) -(type: #export Export - #Exported - #Hidden) - (type: #export Declaration {#declaration-name Text #declaration-args (List Text)}) diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux index ac6d876c3..0e8b5df9a 100644 --- a/stdlib/source/lux/macro/syntax/common/reader.lux +++ b/stdlib/source/lux/macro/syntax/common/reader.lux @@ -1,7 +1,7 @@ (.module: {#.doc "Commons syntax readers."} lux (lux (control monad - ["p" parser]) + ["p" parser "p/" Monad<Parser>]) (data (coll [list]) [ident "ident/" Eq<Ident>] [product] @@ -12,13 +12,9 @@ ## Exports (def: #export export - {#.doc (doc "A reader for export levels." - "Such as:" - #export - #hidden)} - (Syntax (Maybe Export)) - (p.maybe (p.alt (s.this (' #export)) - (s.this (' #hidden))))) + (Syntax Bool) + (p.either (p.after (s.this (' #export)) (p/wrap true)) + (p/wrap false))) ## Declarations (def: #export declaration @@ -28,7 +24,7 @@ (foo bar baz))} (Syntax Declaration) (p.either (p.seq s.local-symbol - (:: p.Monad<Parser> wrap (list))) + (p/wrap (list))) (s.form (p.seq s.local-symbol (p.many s.local-symbol))))) @@ -46,7 +42,7 @@ type s.any value s.any] (wrap [(#.Some type) value]))) - (p.seq (:: p.Monad<Parser> wrap #.None) + (p.seq (p/wrap #.None) s.any))) (def: _definition-anns-tag^ diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux index d5ad8cb61..5b5ab9ab5 100644 --- a/stdlib/source/lux/macro/syntax/common/writer.lux +++ b/stdlib/source/lux/macro/syntax/common/writer.lux @@ -1,24 +1,18 @@ (.module: {#.doc "Commons syntax writers."} lux - (lux (data (coll [list "L/" Functor<List>]) + (lux (data (coll [list "list/" Functor<List>]) [product]) (macro [code])) [// #*]) ## Exports -(def: #export (export ?el) - (-> (Maybe Export) (List Code)) - (case ?el - #.None - (list) - - (#.Some #//.Exported) +(def: #export (export exported?) + (-> Bool (List Code)) + (if exported? (list (' #export)) - - (#.Some #//.Hidden) - (list (' #hidden)))) + (list))) ## Annotations (def: #export (annotations anns) (-> Annotations Code) - (|> anns (L/map (product.both code.tag id)) code.record)) + (|> anns (list/map (product.both code.tag id)) code.record)) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index 66bec5d9b..b755299cd 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -5,7 +5,7 @@ [code]) (control [monad #+ do Monad] ["p" parser]) - (concurrency [promise #+ Promise Monad<Promise>]) + (concurrency [promise #+ Promise]) (data (coll [list "list/" Monad<List> Fold<List>]) [product] [maybe] @@ -19,7 +19,7 @@ ## [Host] (do-template [<name> <signal>] - [(def: #hidden <name> (IO Bottom) + [(def: <name> (IO Bottom) (io ("lux io exit" <signal>)))] [exit 0] @@ -39,8 +39,6 @@ (def: pcg-32-magic-inc Nat +12345) ## [Values] -(def: #hidden Monad<Random> (Monad r.Random) r.Monad<Random>) - (def: success Counters [+1 +0]) (def: failure Counters [+0 +1]) (def: start Counters [+0 +0]) @@ -52,24 +50,24 @@ (def: #export (fail message) (All [a] (-> Text Test)) (|> [failure (format " [Error] " message)] - (:: Monad<Promise> wrap) + (:: promise.Monad<Promise> wrap) (:: r.Monad<Random> wrap))) (def: #export (assert message condition) {#.doc "Check that a condition is true, and fail with the given message otherwise."} (-> Text Bool (Promise [Counters Text])) (if condition - (:: Monad<Promise> wrap [success (format "[Success] " message)]) - (:: Monad<Promise> wrap [failure (format " [Error] " message)]))) + (:: promise.Monad<Promise> wrap [success (format "[Success] " message)]) + (:: promise.Monad<Promise> wrap [failure (format " [Error] " message)]))) (def: #export (test message condition) {#.doc "Check that a condition is true, and fail with the given message otherwise."} (-> Text Bool Test) (:: r.Monad<Random> wrap (assert message condition))) -(def: #hidden (run' tests) +(def: (run' tests) (-> (List [Text (IO Test) Text]) (Promise Counters)) - (do Monad<Promise> + (do promise.Monad<Promise> [test-runs (|> tests (list/map (: (-> [Text (IO Test) Text] (Promise Counters)) (function [[module test description]] @@ -113,15 +111,13 @@ [seed r.nat] (function [prng] (let [[prng' instance] (r.run (r.pcg-32 [pcg-32-magic-inc seed]) test)] - [prng' (do Monad<Promise> + [prng' (do promise.Monad<Promise> [[counters documentation] instance] (if (failed? counters) (wrap [counters (format "Failed with this seed: " (%n seed) "\n" documentation)]) (product.right (r.run prng' (times (n/dec amount) test)))))]))))) ## [Syntax] -(def: #hidden _code/text_ code.text) - (syntax: #export (context: description test) {#.doc (doc "Macro for definint tests." (context: "Simple macros and constructs" @@ -188,14 +184,17 @@ )} (with-gensyms [g!context g!test g!error] (wrap (list (` (def: #export (~ g!context) - {#..test (.._code/text_ (~ description))} - (IO Test) - (io (case ("lux try" [(io (do ..Monad<Random> [] (~ test)))]) - (#.Right (~ g!test)) - (~ g!test) + {#..test ((~! code.text) (~ description))} + (~! (IO Test)) + ((~! io) (case ("lux try" ((~! io) ((~! do) + (~! r.Monad<Random>) + [] + (~ test)))) + (#.Right (~ g!test)) + (~ g!test) - (#.Left (~ g!error)) - (..fail (~ g!error)))))))))) + (#.Left (~ g!error)) + (..fail (~ g!error)))))))))) (def: (exported-tests module-name) (-> Text (Meta (List [Text Text Text]))) @@ -212,13 +211,10 @@ (list.filter product.left) (list/map product.right))))) -(def: #hidden _composeT_ (-> Text Text Text) (:: text.Monoid<Text> compose)) -(def: #hidden _%i_ (-> Int Text) %i) - (syntax: #export (run) {#.doc (doc "Runs all the tests defined on the current module, and in all imported modules." (run))} - (with-gensyms [g!successes g!failures g!total-successes g!total-failures] + (with-gensyms [g!successes g!failures g!total-successes g!total-failures g!text/compose] (do @ [current-module macro.current-module-name modules (macro.imported-modules current-module) @@ -232,29 +228,31 @@ tests) num-tests (list.size tests+) groups (list.split-all promise.concurrency-level tests+)]] - (wrap (list (` (: (IO Unit) - (io (exec (do Monad<Promise> - [(~' #let) [(~ g!total-successes) +0 - (~ g!total-failures) +0] - (~@ (list/join (list/map (function [group] - (list (` [(~ g!successes) (~ g!failures)]) (` (run' (list (~@ group)))) - (' #let) (` [(~ g!total-successes) (n/+ (~ g!successes) (~ g!total-successes)) - (~ g!total-failures) (n/+ (~ g!failures) (~ g!total-failures))]))) - groups)))] - (exec (log! ($_ _composeT_ - "Test-suite finished." - "\n" - (_%i_ (nat-to-int (~ g!total-successes))) - " out of " - (_%i_ (nat-to-int (n/+ (~ g!total-failures) - (~ g!total-successes)))) - " tests passed." - "\n" - (_%i_ (nat-to-int (~ g!total-failures))) " tests failed.")) - (promise.future (if (n/> +0 (~ g!total-failures)) - ..die - ..exit)))) - []))))))))) + (wrap (list (` (: (~! (IO Unit)) + ((~! io) (exec ((~! do) (~! promise.Monad<Promise>) + [(~' #let) [(~ g!total-successes) +0 + (~ g!total-failures) +0] + (~+ (list/join (list/map (function [group] + (list (` [(~ g!successes) (~ g!failures)]) (` ((~! run') (list (~+ group)))) + (' #let) (` [(~ g!total-successes) (n/+ (~ g!successes) (~ g!total-successes)) + (~ g!total-failures) (n/+ (~ g!failures) (~ g!total-failures))]))) + groups)))] + (exec (let [(~ g!text/compose) (:: (~! text.Monoid<Text>) (~' compose))] + (log! ($_ (~ g!text/compose) + "Test-suite finished." + "\n" + ((~! %i) (nat-to-int (~ g!total-successes))) + " out of " + ((~! %i) (nat-to-int (n/+ (~ g!total-failures) + (~ g!total-successes)))) + " tests passed." + "\n" + ((~! %i) (nat-to-int (~ g!total-failures))) " tests failed."))) + ((~! promise.future) + (if (n/> +0 (~ g!total-failures)) + (~! ..die) + (~! ..exit))))) + []))))))))) (def: #export (seq left right) {#.doc "Sequencing combinator."} @@ -262,7 +260,7 @@ (do r.Monad<Random> [left left right right] - (wrap (do Monad<Promise> + (wrap (do promise.Monad<Promise> [[l-counter l-documentation] left [r-counter r-documentation] right] (wrap [(add-counters l-counter r-counter) diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux index 8d20c25c5..cf6f1b4e4 100644 --- a/stdlib/source/lux/type/abstract.lux +++ b/stdlib/source/lux/type/abstract.lux @@ -63,8 +63,8 @@ (do macro.Monad<Meta> [this-module (macro.find-module this-module-name) #let [type-varsC (list/map code.local-symbol type-vars) - abstract-declaration (` ((~ (code.local-symbol name)) (~@ type-varsC))) - representation-declaration (` ((~ (code.local-symbol (representation-name name))) (~@ type-varsC))) + abstract-declaration (` ((~ (code.local-symbol name)) (~+ type-varsC))) + representation-declaration (` ((~ (code.local-symbol (representation-name name))) (~+ type-varsC))) this-module (|> this-module (update@ #.defs (put down-cast (: Def [Macro macro-anns @@ -72,7 +72,7 @@ (function [tokens] (case tokens (^ (list value)) - (wrap (list (` ((: (All [(~@ type-varsC)] + (wrap (list (` ((: (All [(~+ type-varsC)] (-> (~ representation-declaration) (~ abstract-declaration))) (|>> :!!)) (~ value))))) @@ -85,7 +85,7 @@ (function [tokens] (case tokens (^ (list value)) - (wrap (list (` ((: (All [(~@ type-varsC)] + (wrap (list (` ((: (All [(~+ type-varsC)] (-> (~ abstract-declaration) (~ representation-declaration))) (|>> :!!)) (~ value))))) @@ -107,8 +107,8 @@ (#E.Success [(update@ #.modules (put this-module-name this-module) compiler) []])))) -(syntax: #hidden (install-casts [name s.local-symbol] - [type-vars (s.tuple (p.some s.local-symbol))]) +(syntax: (install-casts [name s.local-symbol] + [type-vars (s.tuple (p.some s.local-symbol))]) (do @ [this-module-name macro.current-module-name ?down-cast (macro.find-macro [this-module-name down-cast]) @@ -125,7 +125,7 @@ down-cast " & " up-cast ") because definitions like that already exist."))))) -(syntax: #hidden (un-install-casts) +(syntax: (un-install-casts) (do macro.Monad<Meta> [this-module-name macro.current-module-name ?down-cast (macro.find-macro [this-module-name down-cast]) @@ -154,13 +154,13 @@ [primitives (p.some s.any)]) (let [hidden-name (representation-name name) type-varsC (list/map code.local-symbol type-vars) - abstract-declaration (` ((~ (code.local-symbol name)) (~@ type-varsC))) - representation-declaration (` ((~ (code.local-symbol hidden-name)) (~@ type-varsC)))] - (wrap (list& (` (type: (~@ (csw.export export)) (~ abstract-declaration) + abstract-declaration (` ((~ (code.local-symbol name)) (~+ type-varsC))) + representation-declaration (` ((~ (code.local-symbol hidden-name)) (~+ type-varsC)))] + (wrap (list& (` (type: (~+ (csw.export export)) (~ abstract-declaration) (~ (csw.annotations annotations)) - (primitive (~ (code.text hidden-name)) [(~@ type-varsC)]))) - (` (type: (~@ (csw.export export)) (~ representation-declaration) + (primitive (~ (code.text hidden-name)) [(~+ type-varsC)]))) + (` (type: (~+ (csw.export export)) (~ representation-declaration) (~ representation-type))) - (` (install-casts (~ (code.local-symbol name)) [(~@ type-varsC)])) + (` ((~! install-casts) (~ (code.local-symbol name)) [(~+ type-varsC)])) (list/compose primitives - (list (` (un-install-casts)))))))) + (list (` ((~! un-install-casts))))))))) diff --git a/stdlib/source/lux/type/implicit.lux b/stdlib/source/lux/type/implicit.lux index 39acf31ba..7fe8d02d9 100644 --- a/stdlib/source/lux/type/implicit.lux +++ b/stdlib/source/lux/type/implicit.lux @@ -302,7 +302,7 @@ (code.symbol constructor) _ - (` ((~ (code.symbol constructor)) (~@ (list/map instance$ dependencies)))))) + (` ((~ (code.symbol constructor)) (~+ (list/map instance$ dependencies)))))) (syntax: #export (::: [member s.symbol] [args (p.alt (p.seq (p.some s.symbol) s.end!) @@ -344,7 +344,7 @@ (#.Cons chosen #.Nil) (wrap (list (` (:: (~ (instance$ chosen)) (~ (code.local-symbol (product.right member))) - (~@ (list/map code.symbol args)))))) + (~+ (list/map code.symbol args)))))) _ (macro.fail (format "Too many options available: " @@ -355,9 +355,7 @@ (#.Right [args _]) (do @ - [labels (monad.seq @ (list.repeat (list.size args) - (macro.gensym ""))) - #let [retry (` (let [(~@ (|> (list.zip2 labels args) (list/map join-pair) list/join))] - (..::: (~ (code.symbol member)) (~@ labels))))]] - (wrap (list retry))) + [labels (|> (macro.gensym "") (list.repeat (list.size args)) (monad.seq @))] + (wrap (list (` (let [(~+ (|> (list.zip2 labels args) (list/map join-pair) list/join))] + (..::: (~ (code.symbol member)) (~+ labels))))))) )) diff --git a/stdlib/source/lux/type/object.lux b/stdlib/source/lux/type/object.lux index ba4b06384..d7ebb1e8c 100644 --- a/stdlib/source/lux/type/object.lux +++ b/stdlib/source/lux/type/object.lux @@ -1,15 +1,15 @@ (.module: lux - (lux (control ["M" monad #+ do Monad] + (lux (control [monad #+ do Monad] ["p" parser "p/" Monad<Parser>]) (data [text] text/format [product] [maybe] - [ident #+ "Ident/" Eq<Ident>] - (coll [list "L/" Functor<List> Fold<List> Monoid<List>] + [ident #+ "ident/" Eq<Ident>] + (coll [list "list/" Functor<List> Fold<List> Monoid<List>] [set #+ Set])) - [macro #+ Monad<Meta> "Macro/" Monad<Meta>] + [macro #+ Monad<Meta> "macro/" Monad<Meta>] (macro [code] ["s" syntax #+ syntax:] (syntax ["cs" common] @@ -66,7 +66,7 @@ (|> (list.size ancestors) n/dec (list.n/range +0) - (L/map (|>> %n (format "ancestor") code.local-symbol))))) + (list/map (|>> %n (format "ancestor") code.local-symbol))))) ## [Methods] (type: Method @@ -86,32 +86,32 @@ (def: (declarationM g!self (^open)) (-> Code Method Code) - (let [g!type-vars (L/map code.local-symbol type-vars) + (let [g!type-vars (list/map code.local-symbol type-vars) g!method (code.local-symbol name)] - (` (: (All [(~@ g!type-vars)] - (-> (~@ inputs) (~ g!self) (~ output))) + (` (: (All [(~+ g!type-vars)] + (-> (~+ inputs) (~ g!self) (~ output))) (~ g!method))))) (def: (definition export [interface parameters] g!self-object g!ext g!states (^open)) - (-> (Maybe cs.Export) Declaration Code Code (List Code) Method Code) + (-> Bool Declaration Code Code (List Code) Method Code) (let [g!method (code.local-symbol name) - g!parameters (L/map code.local-symbol parameters) - g!type-vars (L/map code.local-symbol type-vars) + g!parameters (list/map code.local-symbol parameters) + g!type-vars (list/map code.local-symbol type-vars) g!_temp (code.symbol ["" "_temp"]) g!_object (code.symbol ["" "_object"]) g!_behavior (code.symbol ["" "_behavior"]) g!_state (code.symbol ["" "_state"]) g!_extension (code.symbol ["" "_extension"]) - g!_args (L/map (|>> product.left nat-to-int %i (format "_") code.local-symbol) - (list.enumerate inputs)) - g!destructuring (L/fold (function [_ g!bottom] (` [(~ g!_temp) (~ g!_temp) (~ g!bottom)])) - (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]) - (maybe.default g!states (list.tail g!states)))] - (` (def: (~@ (csw.export export)) ((~ g!method) (~@ g!_args) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!states) (~@ g!type-vars)] - (-> (~@ inputs) (~ g!self-object) (~ output))) + g!_args (list/map (|>> product.left nat-to-int %i (format "_") code.local-symbol) + (list.enumerate inputs)) + g!destructuring (list/fold (function [_ g!bottom] (` [(~ g!_temp) (~ g!_temp) (~ g!bottom)])) + (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]) + (maybe.default g!states (list.tail g!states)))] + (` (def: (~+ (csw.export export)) ((~ g!method) (~+ g!_args) (~ g!_object)) + (All [(~+ g!parameters) (~ g!ext) (~+ g!states) (~+ g!type-vars)] + (-> (~+ inputs) (~ g!self-object) (~ output))) (let [(~ g!destructuring) (~ g!_object)] - (:: (~ g!_behavior) (~ g!method) (~@ g!_args) (~ g!_object))))))) + (:: (~ g!_behavior) (~ g!method) (~+ g!_args) (~ g!_object))))))) ## [Inheritance] (type: Reference @@ -121,7 +121,7 @@ (def: (no-parent? parent) (-> Ident Bool) - (Ident/= no-parent parent)) + (ident/= no-parent parent)) (def: (with-interface parent interface) (-> Ident Ident cs.Annotations cs.Annotations) @@ -147,7 +147,7 @@ (case [(macro.get-tag-ann (ident-for <name-tag>) annotations) (macro.get-tag-ann (ident-for <parent-tag>) annotations)] [(#.Some real-name) (#.Some parent)] - (if (Ident/= no-parent parent) + (if (ident/= no-parent parent) (wrap [real-name (list)]) (do @ [[_ ancestors] (<name> parent)] @@ -170,7 +170,7 @@ (#.Function inputT outputT) (let [[stateT+ objectT] (type.flatten-function currentT)] - (Macro/wrap [depth stateT+])) + (macro/wrap [depth stateT+])) _ (macro.fail (format "Cannot extract inheritance from type: " (type.to-text newT)))))) @@ -184,11 +184,11 @@ size (|> (n/dec size) (list.n/range +0) - (L/map (|>> (n/* +2) n/inc code.nat (~) #.Bound (`))) + (list/map (|>> (n/* +2) n/inc code.nat (~) #.Bound (`))) (list.zip2 (list.reverse mappings)) - (L/fold (function [[mappingC boundC] genericC] - (code.replace boundC mappingC genericC)) - typeC)))) + (list/fold (function [[mappingC boundC] genericC] + (code.replace boundC mappingC genericC)) + typeC)))) (def: referenceS (s.Syntax Reference) @@ -211,12 +211,12 @@ ## Utils (def: (nest ancestors bottom) (-> (List Code) Code Code) - (L/fold (function [[level _] g!bottom] - (let [g!_behavior' (code.local-symbol (format "_behavior" (%n level))) - g!_state' (code.local-symbol (format "_state" (%n level)))] - (` [(~ g!_behavior') (~ g!_state') (~ g!bottom)]))) - bottom - (list.enumerate ancestors))) + (list/fold (function [[level _] g!bottom] + (let [g!_behavior' (code.local-symbol (format "_behavior" (%n level))) + g!_state' (code.local-symbol (format "_state" (%n level)))] + (` [(~ g!_behavior') (~ g!_state') (~ g!bottom)]))) + bottom + (list.enumerate ancestors))) ## Names (do-template [<name> <category>] @@ -242,7 +242,7 @@ ) (def: (getterN export interface g!parameters g!ext g!child ancestors) - (-> (Maybe cs.Export) Text (List Code) Code Code (List Ident) + (-> Bool Text (List Code) Code Code (List Ident) Code) (let [g!get (code.local-symbol (getN interface)) g!interface (code.local-symbol interface) @@ -251,17 +251,17 @@ g!_state (' _state) g!_extension (' _extension) g!ancestors (ancestor-inputs ancestors) - g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + g!object (` ((~ g!interface) (~+ g!parameters) (~ g!ext) (~+ g!ancestors) (~ g!child))) g!tear-down (nest g!ancestors (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]))] - (` (def: (~@ (csw.export export)) ((~ g!get) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] + (` (def: (~+ (csw.export export)) ((~ g!get) (~ g!_object)) + (All [(~+ g!parameters) (~ g!ext) (~+ g!ancestors) (~ g!child)] (-> (~ g!object) (~ g!child))) (let [(~ g!tear-down) (~ g!_object)] (~ g!_state)))))) (def: (setterN export interface g!parameters g!ext g!child ancestors) - (-> (Maybe cs.Export) Text (List Code) Code Code (List Ident) + (-> Bool Text (List Code) Code Code (List Ident) Code) (let [g!set (code.local-symbol (setN interface)) g!interface (code.local-symbol interface) @@ -271,20 +271,20 @@ g!_extension (' _extension) g!_input (' _input) g!ancestors (ancestor-inputs ancestors) - g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + g!object (` ((~ g!interface) (~+ g!parameters) (~ g!ext) (~+ g!ancestors) (~ g!child))) g!tear-down (nest g!ancestors (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])) g!build-up (nest g!ancestors (` [(~ g!_behavior) (~ g!_input) (~ g!_extension)]))] - (` (def: (~@ (csw.export export)) + (` (def: (~+ (csw.export export)) ((~ g!set) (~ g!_input) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] + (All [(~+ g!parameters) (~ g!ext) (~+ g!ancestors) (~ g!child)] (-> (~ g!child) (~ g!object) (~ g!object))) (let [(~ g!tear-down) (~ g!_object)] (~ g!build-up)))))) (def: (updaterN export interface g!parameters g!ext g!child ancestors) - (-> (Maybe cs.Export) Text (List Code) Code Code (List Ident) + (-> Bool Text (List Code) Code Code (List Ident) Code) (let [g!update (code.local-symbol (updateN interface)) g!interface (code.local-symbol interface) @@ -294,14 +294,14 @@ g!_extension (' _extension) g!_change (' _change) g!ancestors (ancestor-inputs ancestors) - g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + g!object (` ((~ g!interface) (~+ g!parameters) (~ g!ext) (~+ g!ancestors) (~ g!child))) g!tear-down (nest g!ancestors (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])) g!build-up (nest g!ancestors (` [(~ g!_behavior) ((~ g!_change) (~ g!_state)) (~ g!_extension)]))] - (` (def: (~@ (csw.export export)) + (` (def: (~+ (csw.export export)) ((~ g!update) (~ g!_change) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] + (All [(~+ g!parameters) (~ g!ext) (~+ g!ancestors) (~ g!child)] (-> (-> (~ g!child) (~ g!child)) (-> (~ g!object) (~ g!object)))) (let [(~ g!tear-down) (~ g!_object)] @@ -313,34 +313,34 @@ (case type (#.Primitive name params) (do Monad<Meta> - [paramsC+ (M.map @ type-to-code params)] + [paramsC+ (monad.map @ type-to-code params)] (wrap (` (.primitive (~ (code.symbol ["" name])) - (~@ paramsC+))))) + (~+ paramsC+))))) #.Void - (Macro/wrap (` (.|))) + (macro/wrap (` (.|))) #.Unit - (Macro/wrap (` (.&))) + (macro/wrap (` (.&))) (^template [<tag> <macro> <flatten>] (<tag> _) (do Monad<Meta> - [partsC+ (M.map @ type-to-code (<flatten> type))] - (wrap (` (<macro> (~@ partsC+)))))) + [partsC+ (monad.map @ type-to-code (<flatten> type))] + (wrap (` (<macro> (~+ partsC+)))))) ([#.Sum .| type.flatten-variant] [#.Product .& type.flatten-tuple]) (#.Function input output) (do Monad<Meta> [#let [[insT+ outT] (type.flatten-function type)] - insC+ (M.map @ type-to-code insT+) + insC+ (monad.map @ type-to-code insT+) outC (type-to-code outT)] - (wrap (` (.-> (~@ insC+) (~ outC))))) + (wrap (` (.-> (~+ insC+) (~ outC))))) (^template [<tag>] (<tag> idx) - (Macro/wrap (` (<tag> (~ (code.nat idx)))))) + (macro/wrap (` (<tag> (~ (code.nat idx)))))) ([#.Bound] [#.Var] [#.Ex]) @@ -349,11 +349,11 @@ (do Monad<Meta> [#let [[funcT argsT+] (type.flatten-application type)] funcC (type-to-code funcT) - argsC+ (M.map @ type-to-code argsT+)] - (wrap (` ((~ funcC) (~@ argsC+))))) + argsC+ (monad.map @ type-to-code argsT+)] + (wrap (` ((~ funcC) (~+ argsC+))))) (#.Named name unnamedT) - (Macro/wrap (code.symbol name)) + (macro/wrap (code.symbol name)) _ (macro.fail (format "Cannot convert type to code: " (type.to-text type))))) @@ -378,34 +378,34 @@ (wrap [parent (list& parent ancestors) mappings])))) #let [g!signature (code.local-symbol (signatureN interface)) g!interface (code.local-symbol interface) - g!parameters (L/map code.local-symbol parameters) + g!parameters (list/map code.local-symbol parameters) g!self-ref (if (list.empty? g!parameters) (list g!interface) (list)) g!interface-def (if (no-parent? parent) - (let [g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~ g!child)))] - (` (Ex (~@ g!self-ref) [(~ g!ext) (~ g!child)] - [((~ g!signature) (~@ g!parameters) (~ g!recur)) + (let [g!recur (` ((~ g!interface) (~+ g!parameters) (~ g!ext) (~ g!child)))] + (` (Ex (~+ g!self-ref) [(~ g!ext) (~ g!child)] + [((~ g!signature) (~+ g!parameters) (~ g!recur)) (~ g!child) (~ g!ext)]))) (let [g!parent (code.symbol parent) g!ancestors (ancestor-inputs ancestors) - g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))] - (` (Ex (~@ g!self-ref) [(~ g!ext) (~@ g!ancestors) (~ g!child)] - ((~ g!parent) (~@ mappings) - [((~ g!signature) (~@ g!parameters) (~ g!recur)) + g!recur (` ((~ g!interface) (~+ g!parameters) (~ g!ext) (~+ g!ancestors) (~ g!child)))] + (` (Ex (~+ g!self-ref) [(~ g!ext) (~+ g!ancestors) (~ g!child)] + ((~ g!parent) (~+ mappings) + [((~ g!signature) (~+ g!parameters) (~ g!recur)) (~ g!child) (~ g!ext)] - (~@ g!ancestors))))))]] - (wrap (list& (` (sig: (~@ (csw.export export)) - ((~ g!signature) (~@ g!parameters) (~ g!self-class)) - (~@ (let [de-alias (code.replace (code.local-symbol alias) g!self-class)] - (L/map (|>> (update@ #inputs (L/map de-alias)) - (update@ #output de-alias) - (declarationM g!self-class)) - methods))))) + (~+ g!ancestors))))))]] + (wrap (list& (` (sig: (~+ (csw.export export)) + ((~ g!signature) (~+ g!parameters) (~ g!self-class)) + (~+ (let [de-alias (code.replace (code.local-symbol alias) g!self-class)] + (list/map (|>> (update@ #inputs (list/map de-alias)) + (update@ #output de-alias) + (declarationM g!self-class)) + methods))))) - (` (type: (~@ (csw.export export)) ((~ g!interface) (~@ g!parameters)) + (` (type: (~+ (csw.export export)) ((~ g!interface) (~+ g!parameters)) (~ (|> annotations (with-interface parent [module interface]) csw.annotations)) @@ -416,13 +416,13 @@ (updaterN export interface g!parameters g!ext g!child ancestors) (let [g!ancestors (ancestor-inputs ancestors) - g!states (L/compose g!ancestors (list g!child)) - g!self-object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + g!states (list/compose g!ancestors (list g!child)) + g!self-object (` ((~ g!interface) (~+ g!parameters) (~ g!ext) (~+ g!ancestors) (~ g!child))) de-alias (code.replace (code.symbol ["" alias]) g!self-object)] - (L/map (|>> (update@ #inputs (L/map de-alias)) - (update@ #output de-alias) - (definition export decl g!self-object g!ext g!states)) - methods)))) + (list/map (|>> (update@ #inputs (list/map de-alias)) + (update@ #output de-alias) + (definition export decl g!self-object g!ext g!states)) + methods)))) ))) (syntax: #export (class: [export csr.export] @@ -451,9 +451,9 @@ (do @ [newT (macro.find-def-type (product.both id newN parent)) [depth rawT+] (extract newT) - codeT+ (M.map @ type-to-code rawT+)] - (wrap (L/map (specialize parent-mappings) codeT+))))) - #let [g!parameters (L/map code.local-symbol parameters) + codeT+ (monad.map @ type-to-code rawT+)] + (wrap (list/map (specialize parent-mappings) codeT+))))) + #let [g!parameters (list/map code.local-symbol parameters) g!state (code.local-symbol (stateN instance)) g!struct (code.local-symbol (structN instance)) @@ -464,51 +464,51 @@ g!parent-structs (if (no-parent? parent) (list) - (L/map (|>> (product.both id structN) code.symbol) (list& parent ancestors)))] - g!parent-inits (M.map @ (function [_] (macro.gensym "parent-init")) - g!parent-structs) - #let [g!full-init (L/fold (function [[parent-struct parent-state] child] - (` [(~ parent-struct) (~ parent-state) (~ child)])) - (` [(~ g!struct) (~ g!init) []]) - (list.zip2 g!parent-structs g!parent-inits)) + (list/map (|>> (product.both id structN) code.symbol) (list& parent ancestors)))] + g!parent-inits (monad.map @ (function [_] (macro.gensym "parent-init")) + g!parent-structs) + #let [g!full-init (list/fold (function [[parent-struct parent-state] child] + (` [(~ parent-struct) (~ parent-state) (~ child)])) + (` [(~ g!struct) (~ g!init) []]) + (list.zip2 g!parent-structs g!parent-inits)) g!new (code.local-symbol (newN instance)) - g!recur (` ((~ g!class) (~@ g!parameters) (~ g!extension))) + g!recur (` ((~ g!class) (~+ g!parameters) (~ g!extension))) g!rec (if (list.empty? g!parameters) (list (' #rec)) (list))]] - (wrap (list (` (type: (~@ (csw.export export)) - ((~ g!state) (~@ g!parameters)) + (wrap (list (` (type: (~+ (csw.export export)) + ((~ g!state) (~+ g!parameters)) (~ state-type))) - (` (type: (~@ (csw.export export)) (~@ g!rec) ((~ g!class) (~@ g!parameters)) + (` (type: (~+ (csw.export export)) (~+ g!rec) ((~ g!class) (~+ g!parameters)) (~ (|> annotations (with-class interface parent [module instance]) csw.annotations)) (Ex [(~ g!extension)] (~ (if (no-parent? parent) - (` ((~ g!interface) (~@ interface-mappings) + (` ((~ g!interface) (~+ interface-mappings) (~ g!extension) - ((~ g!state) (~@ g!parameters)))) + ((~ g!state) (~+ g!parameters)))) (let [g!parent (code.symbol parent)] - (` ((~ g!parent) (~@ parent-mappings) - [((~ g!signature) (~@ interface-mappings) (~ g!recur)) - ((~ g!state) (~@ g!parameters)) + (` ((~ g!parent) (~+ parent-mappings) + [((~ g!signature) (~+ interface-mappings) (~ g!recur)) + ((~ g!state) (~+ g!parameters)) (~ g!extension)])))))))) - (` (struct: (~@ (csw.export export)) (~ g!struct) - (All [(~@ g!parameters) (~ g!extension)] - ((~ g!signature) (~@ interface-mappings) - ((~ g!interface) (~@ interface-mappings) + (` (struct: (~+ (csw.export export)) (~ g!struct) + (All [(~+ g!parameters) (~ g!extension)] + ((~ g!signature) (~+ interface-mappings) + ((~ g!interface) (~+ interface-mappings) (~ g!extension) - (~@ g!inheritance) - ((~ g!state) (~@ g!parameters))))) - (~@ impls))) - - (` (def: (~@ (csw.export export)) ((~ g!new) (~@ g!parent-inits) (~ g!init)) - (All [(~@ g!parameters)] - (-> (~@ g!inheritance) - ((~ g!state) (~@ g!parameters)) - ((~ g!class) (~@ g!parameters)))) + (~+ g!inheritance) + ((~ g!state) (~+ g!parameters))))) + (~+ impls))) + + (` (def: (~+ (csw.export export)) ((~ g!new) (~+ g!parent-inits) (~ g!init)) + (All [(~+ g!parameters)] + (-> (~+ g!inheritance) + ((~ g!state) (~+ g!parameters)) + ((~ g!class) (~+ g!parameters)))) (~ g!full-init))) )) ))) diff --git a/stdlib/source/lux/type/unit.lux b/stdlib/source/lux/type/unit.lux index 262ccf9e4..cf59e25d4 100644 --- a/stdlib/source/lux/type/unit.lux +++ b/stdlib/source/lux/type/unit.lux @@ -68,10 +68,10 @@ (syntax: #export (unit: [export csr.export] [name s.local-symbol] [annotations (p.default cs.empty-annotations csr.annotations)]) - (wrap (list (` (type: (~@ (csw.export export)) (~ (code.local-symbol name)) + (wrap (list (` (type: (~+ (csw.export export)) (~ (code.local-symbol name)) (~ (csw.annotations annotations)) (primitive (~ (code.text (unit-name name)))))) - (` (def: (~@ (csw.export export)) (~ (code.local-symbol (format "@" name))) + (` (def: (~+ (csw.export export)) (~ (code.local-symbol (format "@" name))) (~ (code.local-symbol name)) (:!! []))) ))) @@ -92,10 +92,10 @@ [(^slots [#r.numerator #r.denominator]) ratio^] [annotations (p.default cs.empty-annotations csr.annotations)]) (let [g!scale (code.local-symbol name)] - (wrap (list (` (type: (~@ (csw.export export)) ((~ g!scale) (~' u)) + (wrap (list (` (type: (~+ (csw.export export)) ((~ g!scale) (~' u)) (~ (csw.annotations annotations)) (primitive (~ (code.text (scale-name name))) [(~' u)]))) - (` (struct: (~@ (csw.export export)) (~ (code.local-symbol (format "@" name))) + (` (struct: (~+ (csw.export export)) (~ (code.local-symbol (format "@" name))) (..Scale (~ g!scale)) (def: (~' scale) (|>> ..out |