diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux.lux | 428 |
1 files changed, 199 insertions, 229 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index b7de70c5d..334632272 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1635,7 +1635,7 @@ ($' m a) ($' m b))))))) -(def:''' Monad<Maybe> +(def:''' maybe-monad #Nil ($' Monad Maybe) {#wrap @@ -1647,7 +1647,7 @@ (#Some a) (f a)} ma))}) -(def:''' Monad<Meta> +(def:''' meta-monad #Nil ($' Monad Meta) {#wrap @@ -1852,17 +1852,17 @@ (return (tag$ ["lux" "Nil"])) (#Cons lastI inits) - (do Monad<Meta> + (do meta-monad [lastO ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] (let' [[[_module-name _ _] _] spliced] (wrap spliced)) _ - (do Monad<Meta> + (do meta-monad [lastO (untemplate lastI)] (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list lastO (tag$ ["lux" "Nil"])))))))} lastI)] - (monad/fold Monad<Meta> + (monad/fold meta-monad (function' [leftI rightO] ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] (let' [[[_module-name _ _] _] spliced] @@ -1871,7 +1871,7 @@ rightO)))) _ - (do Monad<Meta> + (do meta-monad [leftO (untemplate leftI)] (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list leftO rightO))))))} leftI)) @@ -1879,8 +1879,8 @@ inits))} (list/reverse elems)) #0 - (do Monad<Meta> - [=elems (monad/map Monad<Meta> untemplate elems)] + (do meta-monad + [=elems (monad/map meta-monad untemplate elems)] (wrap (untemplate-list =elems)))} replace?)) @@ -1923,7 +1923,7 @@ (return (wrap-meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module') (text$ name)))))))) [#1 [_ (#Identifier [module name])]] - (do Monad<Meta> + (do meta-monad [real-name ({"" (if (text/= "" subst) (wrap [module name]) @@ -1942,7 +1942,7 @@ (return unquoted) [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~!"])] (#Cons [dependent #Nil])]))]] - (do Monad<Meta> + (do meta-monad [independent (untemplate replace? subst dependent)] (wrap (wrap-meta (form$ (list (tag$ ["lux" "Form"]) (untemplate-list (list (untemplate-text "lux in-module") @@ -1953,24 +1953,24 @@ (untemplate #0 subst keep-quoted) [_ [meta (#Form elems)]] - (do Monad<Meta> + (do meta-monad [output (splice replace? (untemplate replace? subst) elems) #let [[_ output'] (wrap-meta (form$ (list (tag$ ["lux" "Form"]) output)))]] (wrap [meta output'])) [_ [meta (#Tuple elems)]] - (do Monad<Meta> + (do meta-monad [output (splice replace? (untemplate replace? subst) elems) #let [[_ output'] (wrap-meta (form$ (list (tag$ ["lux" "Tuple"]) output)))]] (wrap [meta output'])) [_ [_ (#Record fields)]] - (do Monad<Meta> - [=fields (monad/map Monad<Meta> + (do meta-monad + [=fields (monad/map meta-monad ("lux check" (-> (& Code Code) ($' Meta Code)) (function' [kv] (let' [[k v] kv] - (do Monad<Meta> + (do meta-monad [=k (untemplate replace? subst k) =v (untemplate replace? subst v)] (wrap (tuple$ (list =k =v))))))) @@ -2016,7 +2016,7 @@ "## 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." __paragraph "(` (def: (~ name) (function ((~' _) (~+ args)) (~ body))))"))]) ({(#Cons template #Nil) - (do Monad<Meta> + (do meta-monad [current-module current-module-name =template (untemplate #1 current-module template)] (wrap (list (form$ (list (text$ "lux check") @@ -2033,7 +2033,7 @@ "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph "(`' (def: (~ name) (function (_ (~+ args)) (~ body))))"))]) ({(#Cons template #Nil) - (do Monad<Meta> + (do meta-monad [=template (untemplate #1 "" template)] (wrap (list (form$ (list (text$ "lux check") (identifier$ ["lux" "Code"]) =template))))) @@ -2047,7 +2047,7 @@ "## Quotation as a macro." __paragraph "(' YOLO)"))]) ({(#Cons template #Nil) - (do Monad<Meta> + (do meta-monad [=template (untemplate #0 "" template)] (wrap (list (form$ (list (text$ "lux check") (identifier$ ["lux" "Code"]) =template))))) @@ -2278,8 +2278,8 @@ _ (fail "Wrong syntax for do-template")} - [(monad/map Monad<Maybe> get-short bindings) - (monad/map Monad<Maybe> tuple->list data)]) + [(monad/map maybe-monad get-short bindings) + (monad/map maybe-monad tuple->list data)]) _ (fail "Wrong syntax for do-template")} @@ -2621,7 +2621,7 @@ (-> ($' List (& Text Module)) Text Text Text ($' Maybe Macro)) - (do Monad<Maybe> + (do maybe-monad [$module (get module modules) gdef (let' [{#module-hash _ #module-aliases _ #definitions bindings #imports _ #tags tags #types types #module-annotations _ #module-state _} ("lux check" Module $module)] (get name bindings))] @@ -2650,7 +2650,7 @@ #Nil (-> Name ($' Meta Name)) ({["" name] - (do Monad<Meta> + (do meta-monad [module-name current-module-name] (wrap [module-name name])) @@ -2661,7 +2661,7 @@ (def:''' (find-macro full-name) #Nil (-> Name ($' Meta ($' Maybe Macro))) - (do Monad<Meta> + (do meta-monad [current-module current-module-name] (let' [[module name] full-name] (function' [state] @@ -2676,7 +2676,7 @@ (def:''' (macro? name) #Nil (-> Name ($' Meta Bit)) - (do Monad<Meta> + (do meta-monad [name (normalize name) output (find-macro name)] (wrap ({(#Some _) #1 @@ -2707,7 +2707,7 @@ #Nil (-> Code ($' Meta ($' List Code))) ({[_ (#Form (#Cons [_ (#Identifier macro-name)] args))] - (do Monad<Meta> + (do meta-monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ({(#Some macro) @@ -2725,13 +2725,13 @@ #Nil (-> Code ($' Meta ($' List Code))) ({[_ (#Form (#Cons [_ (#Identifier macro-name)] args))] - (do Monad<Meta> + (do meta-monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ({(#Some macro) - (do Monad<Meta> + (do meta-monad [expansion (macro args) - expansion' (monad/map Monad<Meta> macro-expand expansion)] + expansion' (monad/map meta-monad macro-expand expansion)] (wrap (list/join expansion'))) #None @@ -2746,37 +2746,37 @@ #Nil (-> Code ($' Meta ($' List Code))) ({[_ (#Form (#Cons [_ (#Identifier macro-name)] args))] - (do Monad<Meta> + (do meta-monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ({(#Some macro) - (do Monad<Meta> + (do meta-monad [expansion (macro args) - expansion' (monad/map Monad<Meta> macro-expand-all expansion)] + expansion' (monad/map meta-monad macro-expand-all expansion)] (wrap (list/join expansion'))) #None - (do Monad<Meta> - [args' (monad/map Monad<Meta> macro-expand-all args)] + (do meta-monad + [args' (monad/map meta-monad macro-expand-all args)] (wrap (list (form$ (#Cons (identifier$ macro-name) (list/join args'))))))} ?macro)) [_ (#Form members)] - (do Monad<Meta> - [members' (monad/map Monad<Meta> macro-expand-all members)] + (do meta-monad + [members' (monad/map meta-monad macro-expand-all members)] (wrap (list (form$ (list/join members'))))) [_ (#Tuple members)] - (do Monad<Meta> - [members' (monad/map Monad<Meta> macro-expand-all members)] + (do meta-monad + [members' (monad/map meta-monad macro-expand-all members)] (wrap (list (tuple$ (list/join members'))))) [_ (#Record pairs)] - (do Monad<Meta> - [pairs' (monad/map Monad<Meta> + (do meta-monad + [pairs' (monad/map meta-monad (function' [kv] (let' [[key val] kv] - (do Monad<Meta> + (do meta-monad [val' (macro-expand-all val)] ({(#Cons val'' #Nil) (return [key val'']) @@ -2825,7 +2825,7 @@ "## Takes a type expression and returns it's representation as data-structure." __paragraph "(type (All [a] (Maybe (List a))))"))]) ({(#Cons type #Nil) - (do Monad<Meta> + (do meta-monad [type+ (macro-expand-all type)] ({(#Cons type' #Nil) (wrap (list (walk-type type'))) @@ -2882,8 +2882,8 @@ #Nil (-> ($' List Code) ($' Meta (& Code ($' Maybe ($' List Text))))) ({(#Cons [_ (#Record pairs)] #Nil) - (do Monad<Meta> - [members (monad/map Monad<Meta> + (do meta-monad + [members (monad/map meta-monad (: (-> [Code Code] (Meta [Text Code])) (function' [pair] ({[[_ (#Tag "" member-name)] member-type] @@ -2908,8 +2908,8 @@ type) (#Cons case cases) - (do Monad<Meta> - [members (monad/map Monad<Meta> + (do meta-monad + [members (monad/map meta-monad (: (-> Code (Meta [Text Code])) (function' [case] ({[_ (#Tag "" member-name)] @@ -3093,25 +3093,25 @@ ({(#Cons [_ (#Form (#Cons [_ (#Identifier macro-name)] macro-args))] (#Cons body branches')) - (do Monad<Meta> + (do meta-monad [??? (macro? macro-name)] (if ??? - (do Monad<Meta> + (do meta-monad [init-expansion (macro-expand-once (form$ (list& (identifier$ macro-name) (form$ macro-args) body branches')))] (expander init-expansion)) - (do Monad<Meta> + (do meta-monad [sub-expansion (expander branches')] (wrap (list& (form$ (list& (identifier$ macro-name) macro-args)) body sub-expansion))))) (#Cons pattern (#Cons body branches')) - (do Monad<Meta> + (do meta-monad [sub-expansion (expander branches')] (wrap (list& pattern body sub-expansion))) #Nil - (do Monad<Meta> [] (wrap (list))) + (do meta-monad [] (wrap (list))) _ (fail ($_ text/compose "'lux.case' expects an even number of tokens: " (|> branches @@ -3132,7 +3132,7 @@ " " "_" ..new-line " " "#None)"))]) ({(#Cons value branches) - (do Monad<Meta> + (do meta-monad [expansion (expander branches)] (wrap (list (` ((~ (record$ (as-pairs expansion))) (~ value)))))) @@ -3153,7 +3153,7 @@ " #None)"))]) (case tokens (#Cons [_ (#Form (#Cons pattern #Nil))] (#Cons body branches)) - (do Monad<Meta> + (do meta-monad [pattern+ (macro-expand-all pattern)] (case pattern+ (#Cons pattern' #Nil) @@ -3514,11 +3514,11 @@ #None))] (case ?parts (#Some name args meta sigs) - (do Monad<Meta> + (do meta-monad [name+ (normalize name) - sigs' (monad/map Monad<Meta> macro-expand sigs) + sigs' (monad/map meta-monad macro-expand sigs) members (: (Meta (List [Text Code])) - (monad/map Monad<Meta> + (monad/map meta-monad (: (-> Code (Meta [Text Code])) (function (_ token) (case token @@ -3723,7 +3723,7 @@ (#Some (beta-reduce (list& type-fn param env) body)) (#Apply A F) - (do Monad<Maybe> + (do maybe-monad [type-fn* (apply-type F A)] (apply-type type-fn* param)) @@ -3765,7 +3765,7 @@ (#Some (flatten-tuple type)) (#Apply arg func) - (do Monad<Maybe> + (do maybe-monad [output (apply-type func arg)] (resolve-struct-type output)) @@ -3800,13 +3800,13 @@ (def: get-current-module (Meta Module) - (do Monad<Meta> + (do meta-monad [module-name current-module-name] (find-module module-name))) (def: (resolve-tag [module name]) (-> Name (Meta [Nat (List Name) Bit Type])) - (do Monad<Meta> + (do meta-monad [=module (find-module module) #let [{#module-hash _ #module-aliases _ #definitions bindings #imports _ #tags tags-table #types types #module-annotations _ #module-state _} =module]] (case (get name tags-table) @@ -3829,7 +3829,7 @@ (resolve-type-tags body) (#Named [module name] unnamed) - (do Monad<Meta> + (do meta-monad [=module (find-module module) #let [{#module-hash _ #module-aliases _ #definitions bindings #imports _ #tags tags #types types #module-annotations _ #module-state _} =module]] (case (get name types) @@ -3863,8 +3863,8 @@ (macro: #export (structure tokens) {#.doc "Not meant to be used directly. Prefer 'structure:'."} - (do Monad<Meta> - [tokens' (monad/map Monad<Meta> macro-expand tokens) + (do meta-monad + [tokens' (monad/map meta-monad macro-expand tokens) struct-type get-expected-type tags+type (resolve-type-tags struct-type) tags (: (Meta (List Name)) @@ -3877,7 +3877,7 @@ #let [tag-mappings (: (List [Text Code]) (list/map (function (_ tag) [(second tag) (tag$ tag)]) tags))] - members (monad/map Monad<Meta> + members (monad/map meta-monad (: (-> Code (Meta [Code Code])) (function (_ token) (case token @@ -3909,8 +3909,8 @@ (macro: #export (structure: tokens) {#.doc (text$ ($_ "lux text concat" "## Definition of structures ala ML." ..new-line - "(structure: #export Ord<Int> (Ord Int)" ..new-line - " (def: eq Equivalence<Int>)" ..new-line + "(structure: #export order (Order Int)" ..new-line + " (def: &equivalence equivalence)" ..new-line " (def: (< test subject)" ..new-line " (lux.i/< test subject))" ..new-line " (def: (<= test subject)" ..new-line @@ -3940,47 +3940,17 @@ #None))] (case ?parts (#Some [name args type meta definitions]) - (case (case name - [_ (#Identifier ["" "_"])] - (case type - (^ [_ (#Form (list& [_ (#Identifier [_ sig-name])] sig-args))]) - (case (: (Maybe (List Text)) - (monad/map Monad<Maybe> - (function (_ sa) - (case sa - [_ (#Identifier [_ arg-name])] - (#Some arg-name) + (let [usage (case args + #Nil + name - _ - #None)) - sig-args)) - (^ (#Some params)) - (#Some (identifier$ ["" ($_ text/compose sig-name "<" (|> params (interpose ",") (text/join-with "")) ">")])) - - _ - #None) - - _ - #None) - - _ - (#Some name) - ) - (#Some name) - (let [usage (case args - #Nil - name - - _ - (` ((~ name) (~+ args))))] - (return (list (` (..def: (~+ (export exported?)) (~ usage) - (~ (meta-code-merge (` {#.struct? #1}) - meta)) - (~ type) - (structure (~+ definitions))))))) - - #None - (fail "Cannot infer name, so struct must have a name other than '_'!")) + _ + (` ((~ name) (~+ args))))] + (return (list (` (..def: (~+ (export exported?)) (~ usage) + (~ (meta-code-merge (` {#.struct? #1}) + meta)) + (~ type) + (structure (~+ definitions))))))) #None (fail "Wrong syntax for structure:")))) @@ -4022,7 +3992,7 @@ #None))] (case parts (#Some name args meta type-codes) - (do Monad<Meta> + (do meta-monad [type+tags?? (unfold-type-def type-codes) module-name current-module-name] (let [type-name (identifier$ ["" name]) @@ -4100,7 +4070,7 @@ (def: (extract-defs defs) (-> (List Code) (Meta (List Text))) - (monad/map Monad<Meta> + (monad/map meta-monad (: (-> Code (Meta Text)) (function (_ def) (case def @@ -4116,13 +4086,13 @@ (case tokens (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "+"])] defs))] tokens')) (^ (list& [_ (#Form (list& [_ (#Tag ["" "only"])] defs))] tokens'))) - (do Monad<Meta> + (do meta-monad [defs' (extract-defs defs)] (return [(#Only defs') tokens'])) (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "-"])] defs))] tokens')) (^ (list& [_ (#Form (list& [_ (#Tag ["" "exclude"])] defs))] tokens'))) - (do Monad<Meta> + (do meta-monad [defs' (extract-defs defs)] (return [(#Exclude defs') tokens'])) @@ -4140,8 +4110,8 @@ (return [#.Nil #.Nil]) (^ (list& [_ (#Form (list& [_ (#Text prefix)] structs))] parts')) - (do Monad<Meta> - [structs' (monad/map Monad<Meta> + (do meta-monad + [structs' (monad/map meta-monad (function (_ struct) (case struct [_ (#Identifier ["" struct-name])] @@ -4165,7 +4135,7 @@ (def: (split-with token sample) (-> Text Text (Maybe [Text Text])) - (do ..Monad<Maybe> + (do ..maybe-monad [index (..index-of token sample) #let [[pre post'] (split! index sample) [_ post] (split! ("lux text size" token) post')]] @@ -4259,14 +4229,14 @@ (def: (parse-imports nested? relative-root imports) (-> Bit Text (List Code) (Meta (List Importation))) - (do Monad<Meta> - [imports' (monad/map Monad<Meta> + (do meta-monad + [imports' (monad/map meta-monad (: (-> Code (Meta (List Importation))) (function (_ token) (case token ## Simple [_ (#Identifier ["" m-name])] - (do Monad<Meta> + (do meta-monad [m-name (clean-module nested? relative-root m-name)] (wrap (list {#import-name m-name #import-alias #None @@ -4275,7 +4245,7 @@ ## Nested (^ [_ (#Tuple (list& [_ (#Identifier ["" m-name])] extra))]) - (do Monad<Meta> + (do meta-monad [import-name (clean-module nested? relative-root m-name) referral+extra (parse-referrals extra) #let [[referral extra] referral+extra] @@ -4291,7 +4261,7 @@ sub-imports)))) (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Identifier ["" m-name])] extra))]) - (do Monad<Meta> + (do meta-monad [import-name (clean-module nested? relative-root m-name) referral+extra (parse-referrals extra) #let [[referral extra] referral+extra] @@ -4308,25 +4278,25 @@ (^ [_ (#Record (list [[_ (#Tuple (list [_ (#Nat alteration)] [_ (#Tag ["" domain])]))] parallel-tree]))]) - (do Monad<Meta> + (do meta-monad [parallel-imports (parse-imports nested? relative-root (list parallel-tree))] (wrap (list/map (alter-domain alteration domain) parallel-imports))) (^ [_ (#Record (list [[_ (#Nat alteration)] parallel-tree]))]) - (do Monad<Meta> + (do meta-monad [parallel-imports (parse-imports nested? relative-root (list parallel-tree))] (wrap (list/map (alter-domain alteration "") parallel-imports))) (^ [_ (#Record (list [[_ (#Tag ["" domain])] parallel-tree]))]) - (do Monad<Meta> + (do meta-monad [parallel-imports (parse-imports nested? relative-root (list parallel-tree)) #let [alteration (list/size (text/split-all-with ..module-separator domain))]] (wrap (list/map (alter-domain alteration domain) parallel-imports))) _ - (do Monad<Meta> + (do meta-monad [current-module current-module-name] (fail (text/compose "Wrong syntax for import @ " current-module)))))) imports)] @@ -4460,7 +4430,7 @@ (def: (find-type full-name) (-> Name (Meta Type)) - (do Monad<Meta> + (do meta-monad [#let [[module name] full-name] current-module current-module-name] (function (_ compiler) @@ -4569,12 +4539,12 @@ " (range' <= succ from to))"))} (case tokens (^ (list& [_ (#Form (list [_ (#Text alias)]))] body branches)) - (do Monad<Meta> + (do meta-monad [g!temp (gensym "temp")] (wrap (list& g!temp (` (..^open (~ g!temp) (~ (text$ alias)) (~ body))) branches))) (^ (list [_ (#Identifier name)] [_ (#Text alias)] body)) - (do Monad<Meta> + (do meta-monad [init-type (find-type name) struct-evidence (resolve-type-tags init-type)] (case struct-evidence @@ -4582,17 +4552,17 @@ (fail (text/compose "Can only 'open' structs: " (type/encode init-type))) (#Some tags&members) - (do Monad<Meta> + (do meta-monad [full-body ((: (-> Name [(List Name) (List Type)] Code (Meta Code)) (function (recur source [tags members] target) (let [pattern (record$ (list/map (function (_ [t-module t-name]) [(tag$ [t-module t-name]) (identifier$ ["" (de-alias t-name alias)])]) tags))] - (do Monad<Meta> - [enhanced-target (monad/fold Monad<Meta> + (do meta-monad + [enhanced-target (monad/fold meta-monad (function (_ [[_ m-name] m-type] enhanced-target) - (do Monad<Meta> + (do meta-monad [m-structure (resolve-type-tags m-type)] (case m-structure (#Some m-tags&members) @@ -4659,7 +4629,7 @@ " (getter my-record))"))} (case tokens (^ (list [_ (#Tag slot')] record)) - (do Monad<Meta> + (do meta-monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output] @@ -4687,7 +4657,7 @@ slots))) (^ (list selector)) - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!record)) (..get@ (~ selector) (~ g!record))))))) @@ -4697,13 +4667,13 @@ (def: (open-field alias [module name] source type) (-> Text Name Code Type (Meta (List Code))) - (do Monad<Meta> + (do meta-monad [output (resolve-type-tags type) #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] (case output (#Some [tags members]) - (do Monad<Meta> - [decls' (monad/map Monad<Meta> + (do meta-monad + [decls' (monad/map meta-monad (: (-> [Name Type] (Meta (List Code))) (function (_ [sname stype]) (open-field alias sname source+ stype))) (zip2 tags members))] @@ -4719,27 +4689,27 @@ "## Opens a structure and generates a definition for each of its members (including nested members)." __paragraph "## For example:" ..new-line - "(open: ''i:.'' Number<Int>)" + "(open: ''i:.'' number)" __paragraph "## Will generate:" ..new-line - "(def: i:+ (:: Number<Int> +))" ..new-line - "(def: i:- (:: Number<Int> -))" ..new-line - "(def: i:* (:: Number<Int> *))" ..new-line + "(def: i:+ (:: number +))" ..new-line + "(def: i:- (:: number -))" ..new-line + "(def: i:* (:: number *))" ..new-line "..."))} (case tokens (^ (list [_ (#Text alias)] struct)) (case struct [_ (#Identifier struct-name)] - (do Monad<Meta> + (do meta-monad [struct-type (find-type struct-name) output (resolve-type-tags struct-type) #let [source (identifier$ struct-name)]] (case output (#Some [tags members]) - (do Monad<Meta> - [decls' (monad/map Monad<Meta> (: (-> [Name Type] (Meta (List Code))) - (function (_ [sname stype]) - (open-field alias sname source stype))) + (do meta-monad + [decls' (monad/map meta-monad (: (-> [Name Type] (Meta (List Code))) + (function (_ [sname stype]) + (open-field alias sname source stype))) (zip2 tags members))] (return (list/join decls'))) @@ -4747,7 +4717,7 @@ (fail (text/compose "Can only 'open:' structs: " (type/encode struct-type))))) _ - (do Monad<Meta> + (do meta-monad [g!struct (gensym "struct")] (return (list (` ("lux def" (~ g!struct) (~ struct) [(~ cursor-code) (#.Record #Nil)])) @@ -4762,7 +4732,7 @@ "(|>> (list/map int/encode) (interpose '' '') (fold text/compose ''''))" ..new-line "## =>" ..new-line "(function (_ <arg>) (fold text/compose '''' (interpose '' '' (list/map int/encode <arg>))))"))} - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!arg (gensym "arg")] (return (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens)))))))) @@ -4773,21 +4743,21 @@ "(<<| (fold text/compose '''') (interpose '' '') (list/map int/encode))" ..new-line "## =>" ..new-line "(function (_ <arg>) (fold text/compose '''' (interpose '' '' (list/map int/encode <arg>))))"))} - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!arg (gensym "arg")] (return (list (` (function ((~ g!_) (~ g!arg)) (<| (~+ tokens) (~ g!arg)))))))) (def: (imported-by? import-name module-name) (-> Text Text (Meta Bit)) - (do Monad<Meta> + (do meta-monad [module (find-module module-name) #let [{#module-hash _ #module-aliases _ #definitions _ #imports imports #tags _ #types _ #module-annotations _ #module-state _} module]] (wrap (is-member? imports import-name)))) (def: (read-refer module-name options) (-> Text (List Code) (Meta Refer)) - (do Monad<Meta> + (do meta-monad [referral+options (parse-referrals options) #let [[referral options] referral+options] openings+options (parse-openings options) @@ -4795,7 +4765,7 @@ current-module current-module-name #let [test-referrals (: (-> Text (List Text) (List Text) (Meta (List Any))) (function (_ module-name all-defs referred-defs) - (monad/map Monad<Meta> + (monad/map meta-monad (: (-> Text (Meta Any)) (function (_ _def) (if (is-member? all-defs _def) @@ -4816,11 +4786,11 @@ (def: (write-refer module-name [r-defs r-opens]) (-> Text Refer (Meta (List Code))) - (do Monad<Meta> + (do meta-monad [current-module current-module-name #let [test-referrals (: (-> Text (List Text) (List Text) (Meta (List Any))) (function (_ module-name all-defs referred-defs) - (monad/map Monad<Meta> + (monad/map meta-monad (: (-> Text (Meta Any)) (function (_ _def) (if (is-member? all-defs _def) @@ -4832,13 +4802,13 @@ (exported-definitions module-name) (#Only +defs) - (do Monad<Meta> + (do meta-monad [*defs (exported-definitions module-name) _ (test-referrals module-name *defs +defs)] (wrap +defs)) (#Exclude -defs) - (do Monad<Meta> + (do meta-monad [*defs (exported-definitions module-name) _ (test-referrals module-name *defs -defs)] (wrap (filter (|>> (is-member? -defs) not) *defs))) @@ -4866,7 +4836,7 @@ (macro: #export (refer tokens) (case tokens (^ (list& [_ (#Text module-name)] options)) - (do Monad<Meta> + (do meta-monad [=refer (read-refer module-name options)] (write-refer module-name =refer)) @@ -4908,12 +4878,12 @@ " [''M'' monad #*]]" ..new-line " [data" ..new-line " maybe" ..new-line - " [''.'' name (''name/.'' Codec<Text,Name>)]]" ..new-line + " [''.'' name (''name/.'' codec)]]" ..new-line " [macro" ..new-line " code]]" ..new-line " [//" ..new-line - " [type (''.'' Equivalence<Type>)]])"))} - (do Monad<Meta> + " [type (''.'' equivalence)]])"))} + (do meta-monad [#let [[_meta _imports] (: [(List [Code Code]) (List Code)] (case tokens (^ (list& [_ (#Record _meta)] _imports)) @@ -4940,10 +4910,10 @@ (macro: #export (:: tokens) {#.doc (text$ ($_ "lux text concat" "## Allows accessing the value of a structure's member." ..new-line - "(:: Codec<Text,Int> encode)" + "(:: codec encode)" __paragraph "## Also allows using that value as a function." ..new-line - "(:: Codec<Text,Int> encode +123)"))} + "(:: codec encode +123)"))} (case tokens (^ (list struct [_ (#Identifier member)])) (return (list (` (let [(^open ".") (~ struct)] (~ (identifier$ member)))))) @@ -4967,17 +4937,17 @@ "(let [setter (set@ [#foo #bar #baz])] (setter value my-record))"))} (case tokens (^ (list [_ (#Tag slot')] value record)) - (do Monad<Meta> + (do meta-monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output]] (case (resolve-struct-type type) (#Some members) - (do Monad<Meta> - [pattern' (monad/map Monad<Meta> + (do meta-monad + [pattern' (monad/map meta-monad (: (-> [Name [Nat Type]] (Meta [Name Nat Code])) (function (_ [r-slot-name [r-idx r-type]]) - (do Monad<Meta> + (do meta-monad [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] @@ -5004,8 +4974,8 @@ (fail "Wrong syntax for set@") _ - (do Monad<Meta> - [bindings (monad/map Monad<Meta> + (do meta-monad + [bindings (monad/map meta-monad (: (-> Code (Meta Code)) (function (_ _) (gensym "temp"))) slots) @@ -5026,13 +4996,13 @@ (~ update-expr))))))) (^ (list selector value)) - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!record)) (..set@ (~ selector) (~ value) (~ g!record))))))) (^ (list selector)) - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!value (gensym "value") g!record (gensym "record")] @@ -5054,17 +5024,17 @@ "(let [updater (update@ [#foo #bar #baz])] (updater func my-record))"))} (case tokens (^ (list [_ (#Tag slot')] fun record)) - (do Monad<Meta> + (do meta-monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output]] (case (resolve-struct-type type) (#Some members) - (do Monad<Meta> - [pattern' (monad/map Monad<Meta> + (do meta-monad + [pattern' (monad/map meta-monad (: (-> [Name [Nat Type]] (Meta [Name Nat Code])) (function (_ [r-slot-name [r-idx r-type]]) - (do Monad<Meta> + (do meta-monad [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] @@ -5091,7 +5061,7 @@ (fail "Wrong syntax for update@") _ - (do Monad<Meta> + (do meta-monad [g!record (gensym "record") g!temp (gensym "temp")] (wrap (list (` (let [(~ g!record) (~ record) @@ -5099,13 +5069,13 @@ (set@ [(~+ slots)] ((~ fun) (~ g!temp)) (~ g!record)))))))) (^ (list selector fun)) - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!record)) (..update@ (~ selector) (~ fun) (~ g!record))))))) (^ (list selector)) - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!fun (gensym "fun") g!record (gensym "record")] @@ -5154,9 +5124,9 @@ [_ (#Form data)] branches)) (case (: (Maybe (List Code)) - (do Monad<Maybe> - [bindings' (monad/map Monad<Maybe> get-short bindings) - data' (monad/map Monad<Maybe> tuple->list data)] + (do maybe-monad + [bindings' (monad/map maybe-monad get-short bindings) + data' (monad/map maybe-monad tuple->list data)] (if (every? (n/= (list/size bindings')) (list/map list/size data')) (let [apply (: (-> RepEnv (List Code)) (function (_ env) (list/map (apply-template env) templates)))] @@ -5426,20 +5396,20 @@ vars (list/map first pairs) inits (list/map second pairs)] (if (every? identifier? inits) - (do Monad<Meta> + (do meta-monad [inits' (: (Meta (List Name)) - (case (monad/map Monad<Maybe> get-name inits) + (case (monad/map maybe-monad get-name inits) (#Some inits') (return inits') #None (fail "Wrong syntax for loop"))) - init-types (monad/map Monad<Meta> find-type inits') + init-types (monad/map meta-monad find-type inits') expected get-expected-type] (return (list (` (("lux check" (-> (~+ (list/map type-to-code init-types)) (~ (type-to-code expected))) (function ((~ name) (~+ vars)) (~ body))) (~+ inits)))))) - (do Monad<Meta> - [aliases (monad/map Monad<Meta> + (do meta-monad + [aliases (monad/map meta-monad (: (-> Code (Meta Code)) (function (_ _) (gensym ""))) inits)] @@ -5457,12 +5427,12 @@ (f foo bar baz)))} (case tokens (^ (list& [_ (#Form (list [_ (#Tuple (list& hslot' tslots'))]))] body branches)) - (do Monad<Meta> + (do meta-monad [slots (: (Meta [Name (List Name)]) (case (: (Maybe [Name (List Name)]) - (do Monad<Maybe> + (do maybe-monad [hslot (get-tag hslot') - tslots (monad/map Monad<Maybe> get-tag tslots')] + tslots (monad/map maybe-monad get-tag tslots')] (wrap [hslot tslots]))) (#Some slots) (return slots) @@ -5471,7 +5441,7 @@ (fail "Wrong syntax for ^slots"))) #let [[hslot tslots] slots] hslot (normalize hslot) - tslots (monad/map Monad<Meta> normalize tslots) + tslots (monad/map meta-monad normalize tslots) output (resolve-tag hslot) g!_ (gensym "_") #let [[idx tags exported? type] output @@ -5504,18 +5474,18 @@ (^template [<tag> <ctor>] [_ (<tag> elems)] - (do Monad<Maybe> - [placements (monad/map Monad<Maybe> (place-tokens label tokens) elems)] + (do maybe-monad + [placements (monad/map maybe-monad (place-tokens label tokens) elems)] (wrap (list (<ctor> (list/join placements)))))) ([#Tuple tuple$] [#Form form$]) [_ (#Record pairs)] - (do Monad<Maybe> - [=pairs (monad/map Monad<Maybe> + (do maybe-monad + [=pairs (monad/map maybe-monad (: (-> [Code Code] (Maybe [Code Code])) (function (_ [slot value]) - (do Monad<Maybe> + (do maybe-monad [slot' (place-tokens label tokens slot) value' (place-tokens label tokens value)] (case [slot' value'] @@ -5537,7 +5507,7 @@ [<tests> (do-template [<expr> <text> <pattern>] [(compare <pattern> <expr>) (compare <text> (:: Code/encode encode <expr>)) - (compare #1 (:: Equivalence<Code> = <expr> <expr>))] + (compare #1 (:: equivalence = <expr> <expr>))] [(bit #1) "#1" [_ (#.Bit #1)]] [(bit #0) "#0" [_ (#.Bit #0)]] @@ -5557,7 +5527,7 @@ (^ (list& [_ (#Tuple bindings)] bodies)) (case bindings (^ (list& [_ (#Identifier ["" var-name])] macro-expr bindings')) - (do Monad<Meta> + (do meta-monad [expansion (macro-expand-once macro-expr)] (case (place-tokens var-name expansion (` (.with-expansions [(~+ bindings')] @@ -5598,7 +5568,7 @@ (def: (anti-quote-def name) (-> Name (Meta Code)) - (do Monad<Meta> + (do meta-monad [type+value (find-def-value name) #let [[type value] type+value]] (case (flatten-alias type) @@ -5620,38 +5590,38 @@ (case token [_ (#Identifier [def-prefix def-name])] (if (text/= "" def-prefix) - (do Monad<Meta> + (do meta-monad [current-module current-module-name] (anti-quote-def [current-module def-name])) (anti-quote-def [def-prefix def-name])) (^template [<tag>] [meta (<tag> parts)] - (do Monad<Meta> - [=parts (monad/map Monad<Meta> anti-quote parts)] + (do meta-monad + [=parts (monad/map meta-monad anti-quote parts)] (wrap [meta (<tag> =parts)]))) ([#Form] [#Tuple]) [meta (#Record pairs)] - (do Monad<Meta> - [=pairs (monad/map Monad<Meta> + (do meta-monad + [=pairs (monad/map meta-monad (: (-> [Code Code] (Meta [Code Code])) (function (_ [slot value]) - (do Monad<Meta> + (do meta-monad [=value (anti-quote value)] (wrap [slot =value])))) pairs)] (wrap [meta (#Record =pairs)])) _ - (:: Monad<Meta> return token) + (:: meta-monad return token) )) (macro: #export (static tokens) (case tokens (^ (list pattern)) - (do Monad<Meta> + (do meta-monad [pattern' (anti-quote pattern)] (wrap (list pattern'))) @@ -5678,8 +5648,8 @@ (fail "Multi-level patterns cannot be empty.") (#Cons init extras) - (do Monad<Meta> - [extras' (monad/map Monad<Meta> case-level^ extras)] + (do meta-monad + [extras' (monad/map meta-monad case-level^ extras)] (wrap [init extras'])))) (def: (multi-level-case$ g!_ [[init-pattern levels] body]) @@ -5716,7 +5686,7 @@ (#.Left (format "Static part " (%t static) " does not match URI: " uri))))} (case tokens (^ (list& [_meta (#Form levels)] body next-branches)) - (do Monad<Meta> + (do meta-monad [mlc (multi-level-case^ levels) expected get-expected-type g!temp (gensym "temp")] @@ -5804,7 +5774,7 @@ list)))} (case tokens (^ (list [_ (#Nat idx)])) - (do Monad<Meta> + (do meta-monad [stvs get-scope-type-vars] (case (list-at idx (list/reverse stvs)) (#Some var-id) @@ -5864,7 +5834,7 @@ (: Dinosaur (:assume (list +1 +2 +3))))} (case tokens (^ (list expr)) - (do Monad<Meta> + (do meta-monad [type get-expected-type] (wrap (list (` ("lux coerce" (~ (type-to-code type)) (~ expr)))))) @@ -5899,12 +5869,12 @@ Int)} (case tokens (^ (list [_ (#Identifier var-name)])) - (do Monad<Meta> + (do meta-monad [var-type (find-type var-name)] (wrap (list (type-to-code var-type)))) (^ (list expression)) - (do Monad<Meta> + (do meta-monad [g!temp (gensym "g!temp")] (wrap (list (` (let [(~ g!temp) (~ expression)] (..:of (~ g!temp))))))) @@ -5916,8 +5886,8 @@ (-> (List Code) (Meta [[Text (List Text)] (List Code)])) (case tokens (^ (list& [_ (#Form (list& [_ (#Identifier ["" name])] args'))] tokens')) - (do Monad<Meta> - [args (monad/map Monad<Meta> + (do meta-monad + [args (monad/map meta-monad (function (_ arg') (case arg' [_ (#Identifier ["" arg-name])] @@ -5977,7 +5947,7 @@ "For simple macros that do not need any fancy features." (template: (square x) (i/* x x)))} - (do Monad<Meta> + (do meta-monad [#let [[export? tokens] (export^ tokens)] name+args|tokens (parse-complex-declaration tokens) #let [[[name args] tokens] name+args|tokens] @@ -6051,7 +6021,7 @@ )) (macro: #export (for tokens) - (do Monad<Meta> + (do meta-monad [target target] (case tokens (^ (list [_ (#Record options)])) @@ -6081,23 +6051,23 @@ (-> Code (Meta [(List [Code Code]) Code])) (case code (^ [ann (#Form (list [_ (#Identifier ["" "~~"])] expansion))]) - (do Monad<Meta> + (do meta-monad [g!expansion (gensym "g!expansion")] (wrap [(list [g!expansion expansion]) g!expansion])) (^template [<tag>] [ann (<tag> parts)] - (do Monad<Meta> - [=parts (monad/map Monad<Meta> label-code parts)] + (do meta-monad + [=parts (monad/map meta-monad label-code parts)] (wrap [(list/fold list/compose (list) (list/map left =parts)) [ann (<tag> (list/map right =parts))]]))) ([#Form] [#Tuple]) [ann (#Record kvs)] - (do Monad<Meta> - [=kvs (monad/map Monad<Meta> + (do meta-monad + [=kvs (monad/map meta-monad (function (_ [key val]) - (do Monad<Meta> + (do meta-monad [=key (label-code key) =val (label-code val) #let [[key-labels key-labelled] =key @@ -6113,7 +6083,7 @@ (macro: #export (`` tokens) (case tokens (^ (list raw)) - (do Monad<Meta> + (do meta-monad [=raw (label-code raw) #let [[labels labelled] =raw]] (wrap (list (` (with-expansions [(~+ (|> labels @@ -6143,7 +6113,7 @@ (case pattern (^template [<tag> <name> <gen>] [_ (<tag> value)] - (do Monad<Meta> + (do meta-monad [g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) (<tag> (~ (<gen> value)))])))) ([#Bit "Bit" bit$] @@ -6156,10 +6126,10 @@ [#Identifier "Identifier" name$]) [_ (#Record fields)] - (do Monad<Meta> - [=fields (monad/map Monad<Meta> + (do meta-monad + [=fields (monad/map meta-monad (function (_ [key value]) - (do Monad<Meta> + (do meta-monad [=key (untemplate-pattern key) =value (untemplate-pattern value)] (wrap (` [(~ =key) (~ =value)])))) @@ -6178,14 +6148,14 @@ (case (list/reverse elems) (#Cons [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] inits) - (do Monad<Meta> - [=inits (monad/map Monad<Meta> untemplate-pattern (list/reverse inits)) + (do meta-monad + [=inits (monad/map meta-monad untemplate-pattern (list/reverse inits)) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) (<tag> (~ (untemplate-list& spliced =inits)))]))) _ - (do Monad<Meta> - [=elems (monad/map Monad<Meta> untemplate-pattern elems) + (do meta-monad + [=elems (monad/map meta-monad untemplate-pattern elems) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) (<tag> (~ (untemplate-list =elems)))]))))) ([#Tuple] [#Form]) @@ -6194,12 +6164,12 @@ (macro: #export (^code tokens) (case tokens (^ (list& [_meta (#Form (list template))] body branches)) - (do Monad<Meta> + (do meta-monad [pattern (untemplate-pattern template)] (wrap (list& pattern body branches))) (^ (list template)) - (do Monad<Meta> + (do meta-monad [pattern (untemplate-pattern template)] (wrap (list pattern))) |