diff options
Diffstat (limited to '')
-rw-r--r-- | stdlib/source/lux.lux | 609 |
1 files changed, 305 insertions, 304 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 407e895a3..0dcc335a0 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1189,7 +1189,7 @@ (#Function Nat Code) (form$ (#Cons (tag$ ["lux" "Bound"]) (#Cons (nat$ idx) #Nil)))) -(def:'' (fold f init xs) +(def:'' (list/fold f init xs) #;Nil ## (All [a b] (-> (-> b a a) a (List b) a)) (#UnivQ #Nil (#UnivQ #Nil (#Function (#Function (#Bound +1) @@ -1203,13 +1203,13 @@ init (#Cons x xs') - (fold f (f x init) xs')})) + (list/fold f (f x init) xs')})) (def:'' (length list) #;Nil (#UnivQ #Nil (#Function ($' List (#Bound +1)) Nat)) - (fold (function'' [_ acc] ("lux nat +" +1 acc)) +0 list)) + (list/fold (function'' [_ acc] ("lux nat +" +1 acc)) +0 list)) (macro:' #export (All tokens) (#Cons [(tag$ ["lux" "doc"]) @@ -1232,14 +1232,14 @@ {(#Cons [_ (#Tuple args)] (#Cons body #Nil)) (parse-quantified-args args (function'' [names] - (let'' body' (fold ("lux check" (#Function Text (#Function Code Code)) - (function'' [name' body'] - (form$ (#Cons (tag$ ["lux" "UnivQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) - (update-bounds body')) #Nil)))))) - body - names) + (let'' body' (list/fold ("lux check" (#Function Text (#Function Code Code)) + (function'' [name' body'] + (form$ (#Cons (tag$ ["lux" "UnivQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) + (update-bounds body')) #Nil)))))) + body + names) (return (#Cons ("lux case" [(text/= "" self-name) names] {[true _] body' @@ -1283,14 +1283,14 @@ {(#Cons [_ (#Tuple args)] (#Cons body #Nil)) (parse-quantified-args args (function'' [names] - (let'' body' (fold ("lux check" (#Function Text (#Function Code Code)) - (function'' [name' body'] - (form$ (#Cons (tag$ ["lux" "ExQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) - (update-bounds body')) #Nil)))))) - body - names) + (let'' body' (list/fold ("lux check" (#Function Text (#Function Code Code)) + (function'' [name' body'] + (form$ (#Cons (tag$ ["lux" "ExQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) + (update-bounds body')) #Nil)))))) + body + names) (return (#Cons ("lux case" [(text/= "" self-name) names] {[true _] body' @@ -1314,10 +1314,10 @@ (def:'' (reverse list) #;Nil (All [a] (#Function ($' List a) ($' List a))) - (fold ("lux check" (All [a] (#Function a (#Function ($' List a) ($' List a)))) - (function'' [head tail] (#Cons head tail))) - #Nil - list)) + (list/fold ("lux check" (All [a] (#Function a (#Function ($' List a) ($' List a)))) + (function'' [head tail] (#Cons head tail))) + #Nil + list)) (macro:' #export (-> tokens) (#Cons [(tag$ ["lux" "doc"]) @@ -1328,10 +1328,10 @@ #;Nil) ("lux case" (reverse tokens) {(#Cons output inputs) - (return (#Cons (fold ("lux check" (#Function Code (#Function Code Code)) - (function'' [i o] (form$ (#Cons (tag$ ["lux" "Function"]) (#Cons i (#Cons o #Nil)))))) - output - inputs) + (return (#Cons (list/fold ("lux check" (#Function Code (#Function Code Code)) + (function'' [i o] (form$ (#Cons (tag$ ["lux" "Function"]) (#Cons i (#Cons o #Nil)))))) + output + inputs) #Nil)) _ @@ -1342,12 +1342,12 @@ (text$ "## List-construction macro. (list 1 2 3)")] #;Nil) - (return (#Cons (fold (function'' [head tail] - (form$ (#Cons (tag$ ["lux" "Cons"]) - (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) - #Nil)))) - (tag$ ["lux" "Nil"]) - (reverse xs)) + (return (#Cons (list/fold (function'' [head tail] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) + #Nil)))) + (tag$ ["lux" "Nil"]) + (reverse xs)) #Nil))) (macro:' #export (list& xs) @@ -1358,11 +1358,11 @@ #;Nil) ("lux case" (reverse xs) {(#Cons last init) - (return (list (fold (function'' [head tail] - (form$ (list (tag$ ["lux" "Cons"]) - (tuple$ (list head tail))))) - last - init))) + (return (list (list/fold (function'' [head tail] + (form$ (list (tag$ ["lux" "Cons"]) + (tuple$ (list head tail))))) + last + init))) _ (fail "Wrong syntax for list&")})) @@ -1380,9 +1380,9 @@ (return (list (tag$ ["lux" "Unit"]))) (#Cons last prevs) - (return (list (fold (function'' [left right] (form$ (list (tag$ ["lux" "Product"]) left right))) - last - prevs)))} + (return (list (list/fold (function'' [left right] (form$ (list (tag$ ["lux" "Product"]) left right))) + last + prevs)))} )) (macro:' #export (| tokens) @@ -1398,9 +1398,9 @@ (return (list (tag$ ["lux" "Void"]))) (#Cons last prevs) - (return (list (fold (function'' [left right] (form$ (list (tag$ ["lux" "Sum"]) left right))) - last - prevs)))} + (return (list (list/fold (function'' [left right] (form$ (list (tag$ ["lux" "Sum"]) left right))) + last + prevs)))} )) (macro:' (function' tokens) @@ -1420,13 +1420,13 @@ (return (list (form$ (list (text$ "lux function") (symbol$ ["" name]) harg - (fold (function'' [arg body'] - (form$ (list (text$ "lux function") - (symbol$ ["" ""]) - arg - body'))) - body - (reverse targs))))))}) + (list/fold (function'' [arg body'] + (form$ (list (text$ "lux function") + (symbol$ ["" ""]) + arg + body'))) + body + (reverse targs))))))}) _ (fail "Wrong syntax for function'")}))) @@ -1497,14 +1497,14 @@ (macro:' (let' tokens) ("lux case" tokens {(#Cons [[_ (#Tuple bindings)] (#Cons [body #Nil])]) - (return (list (fold ("lux check" (-> (& Code Code) Code - Code) - (function' [binding body] - ("lux case" binding - {[label value] - (form$ (list (text$ "lux case") value (record$ (list [label body]))))}))) - body - (reverse (as-pairs bindings))))) + (return (list (list/fold ("lux check" (-> (& Code Code) Code + Code) + (function' [binding body] + ("lux case" binding + {[label value] + (form$ (list (text$ "lux case") value (record$ (list [label body]))))}))) + body + (reverse (as-pairs bindings))))) _ (fail "Wrong syntax for let'")})) @@ -1522,16 +1522,6 @@ {true true false (any? p xs')})})) -(def:''' (spliced? token) - #;Nil - (-> Code Bool) - ("lux case" token - {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [_ #Nil])]))] - true - - _ - false})) - (def:''' (wrap-meta content) #;Nil (-> Code Code) @@ -1592,7 +1582,7 @@ {(#Cons op tokens') ("lux case" tokens' {(#Cons first nexts) - (return (list (fold (_$_joiner op) first nexts))) + (return (list (list/fold (_$_joiner op) first nexts))) _ (fail "Wrong syntax for _$")}) @@ -1612,7 +1602,7 @@ {(#Cons op tokens') ("lux case" (reverse tokens') {(#Cons last prevs) - (return (list (fold (_$_joiner op) last prevs))) + (return (list (list/fold (_$_joiner op) last prevs))) _ (fail "Wrong syntax for $_")}) @@ -1672,19 +1662,19 @@ {(#Cons monad (#Cons [_ (#Tuple bindings)] (#Cons body #Nil))) (let' [g!wrap (symbol$ ["" "wrap"]) g!bind (symbol$ ["" " bind "]) - body' (fold ("lux check" (-> (& Code Code) Code Code) - (function' [binding body'] - (let' [[var value] binding] - ("lux case" var - {[_ (#Tag "" "let")] - (form$ (list (symbol$ ["lux" "let'"]) value body')) - - _ - (form$ (list g!bind - (form$ (list (text$ "lux function") (symbol$ ["" ""]) var body')) - value))})))) - body - (reverse (as-pairs bindings)))] + body' (list/fold ("lux check" (-> (& Code Code) Code Code) + (function' [binding body'] + (let' [[var value] binding] + ("lux case" var + {[_ (#Tag "" "let")] + (form$ (list (symbol$ ["lux" "let'"]) value body')) + + _ + (form$ (list g!bind + (form$ (list (text$ "lux function") (symbol$ ["" ""]) var body')) + value))})))) + body + (reverse (as-pairs bindings)))] (return (list (form$ (list (text$ "lux case") monad (record$ (list [(record$ (list [(tag$ ["lux" "wrap"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) @@ -1714,6 +1704,27 @@ (wrap (#Cons y ys))) }))) +(def:''' (monad/fold m f y xs) + #Nil + ## (All [m a b] + ## (-> (Monad m) (-> a b (m b)) b (List a) (m b))) + (All [m a b] + (-> ($' Monad m) + (-> a b ($' m b)) + b + ($' List a) + ($' m b))) + (let' [{#;wrap wrap #;bind _} m] + ("lux case" xs + {#Nil + (wrap y) + + (#Cons x xs') + (do m + [y' (f x y)] + (monad/fold m f y' xs')) + }))) + (macro:' #export (if tokens) (list [(tag$ ["lux" "doc"]) (text$ "Picks which expression to evaluate based on a boolean test value. @@ -1831,42 +1842,43 @@ #None (#Left ($_ text/compose "Unknown module: " module " @ " (ident/encode ident)))}))) -(def:''' (splice replace? untemplate tag elems) +(def:''' (splice replace? untemplate elems) #Nil - (-> Bool (-> Code ($' Meta Code)) Code ($' List Code) ($' Meta Code)) + (-> Bool (-> Code ($' Meta Code)) ($' List Code) ($' Meta Code)) ("lux case" replace? {true - ("lux case" (any? spliced? elems) - {true + ("lux case" (reverse elems) + {#Nil + (return (tag$ ["lux" "Nil"])) + + (#Cons lastI inits) (do Monad<Meta> - [elems' ("lux check" ($' Meta ($' List Code)) - (monad/map Monad<Meta> - ("lux check" (-> Code ($' Meta Code)) - (function' [elem] - ("lux case" elem - {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] - (wrap spliced) - - _ - (do Monad<Meta> - [=elem (untemplate elem)] - (wrap (form$ (list (text$ "lux check") - (form$ (list (tag$ ["lux" "Apply"]) (tuple$ (list (symbol$ ["lux" "Code"]) (symbol$ ["lux" "List"]))))) - (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list =elem (tag$ ["lux" "Nil"])))))))))}))) - elems))] - (wrap (wrap-meta (form$ (list tag - (form$ (list& (symbol$ ["lux" "$_"]) - (symbol$ ["lux" "splice-helper"]) - elems'))))))) + [lastO ("lux case" lastI + {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] + (wrap spliced) + + _ + (do Monad<Meta> + [lastO (untemplate lastI)] + (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list lastO (tag$ ["lux" "Nil"])))))))})] + (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))) - false - (do Monad<Meta> - [=elems (monad/map Monad<Meta> untemplate elems)] - (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))}) + _ + (do Monad<Meta> + [leftO (untemplate leftI)] + (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list leftO rightO))))))})) + lastO + inits))}) false (do Monad<Meta> [=elems (monad/map Monad<Meta> untemplate elems)] - (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))})) + (wrap (untemplate-list =elems)))})) (def:''' (untemplate replace? subst token) #Nil @@ -1918,9 +1930,6 @@ [false [_ (#Symbol [module name])]] (return (wrap-meta (form$ (list (tag$ ["lux" "Symbol"]) (tuple$ (list (text$ module) (text$ name))))))) - [_ [_ (#Tuple elems)]] - (splice replace? (untemplate replace? subst) (tag$ ["lux" "Tuple"]) elems) - [true [_ (#Form (#Cons [[_ (#Symbol ["" "~"])] (#Cons [unquoted #Nil])]))]] (return unquoted) @@ -1929,9 +1938,15 @@ [_ [meta (#Form elems)]] (do Monad<Meta> - [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "Form"]) elems) - #let [[_ form'] output]] - (return [meta form'])) + [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> + [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> @@ -2041,19 +2056,19 @@ (map int/encode elems)))")]) ("lux case" tokens {(#Cons [init apps]) - (return (list (fold ("lux check" (-> Code Code Code) - (function' [app acc] - ("lux case" app - {[_ (#Tuple parts)] - (tuple$ (list/compose parts (list acc))) + (return (list (list/fold ("lux check" (-> Code Code Code) + (function' [app acc] + ("lux case" app + {[_ (#Tuple parts)] + (tuple$ (list/compose parts (list acc))) - [_ (#Form parts)] - (form$ (list/compose parts (list acc))) + [_ (#Form parts)] + (form$ (list/compose parts (list acc))) - _ - (` ((~ app) (~ acc)))}))) - init - apps))) + _ + (` ((~ app) (~ acc)))}))) + init + apps))) _ (fail "Wrong syntax for |>")})) @@ -2069,19 +2084,19 @@ (map int/encode elems)))")]) ("lux case" (reverse tokens) {(#Cons [init apps]) - (return (list (fold ("lux check" (-> Code Code Code) - (function' [app acc] - ("lux case" app - {[_ (#Tuple parts)] - (tuple$ (list/compose parts (list acc))) + (return (list (list/fold ("lux check" (-> Code Code Code) + (function' [app acc] + ("lux case" app + {[_ (#Tuple parts)] + (tuple$ (list/compose parts (list acc))) - [_ (#Form parts)] - (form$ (list/compose parts (list acc))) + [_ (#Form parts)] + (form$ (list/compose parts (list acc))) - _ - (` ((~ app) (~ acc)))}))) - init - apps))) + _ + (` ((~ app) (~ acc)))}))) + init + apps))) _ (fail "Wrong syntax for <|")})) @@ -2176,7 +2191,7 @@ #Nil (All [a] (-> (-> a Bool) ($' List a) Bool)) - (fold (function' [_2 _1] (if _1 (p _2) false)) true xs)) + (list/fold (function' [_2 _1] (if _1 (p _2) false)) true xs)) (macro:' #export (do-template tokens) (list [(tag$ ["lux" "doc"]) @@ -2341,11 +2356,11 @@ _ (let' [loop ("lux check" (-> Nat Text Text) (function' recur [input output] - (if ("lux nat =" input +0) - ("lux text concat" "+" output) - (recur ("lux nat /" input +10) - ("lux text concat" (digit-to-text ("lux nat %" input +10)) - output)))))] + (if (n.= +0 input) + (text/compose "+" output) + (recur (n./ +10 input) + (text/compose (|> input (n.% +10) digit-to-text) + output)))))] (loop value ""))})) (def:''' (int/abs value) @@ -2366,10 +2381,10 @@ (("lux check" (-> Int Text Text) (function' recur [input output] (if (i.= 0 input) - ("lux text concat" sign output) + (text/compose sign output) (recur (i./ 10 input) - ("lux text concat" (|> input (i.% 10) ("lux coerce" Nat) digit-to-text) - output))))) + (text/compose (|> input (i.% 10) ("lux coerce" Nat) digit-to-text) + output))))) (|> value (i./ 10) int/abs) (|> value (i.% 10) int/abs ("lux coerce" Nat) digit-to-text))))) @@ -2465,7 +2480,7 @@ #Nil (All [a] (-> ($' List ($' List a)) ($' List a))) - (fold list/compose #Nil (reverse xs))) + (list/fold list/compose #Nil (reverse xs))) (def:''' (interpose sep xs) #Nil @@ -2580,10 +2595,10 @@ (` (& (~@ (map walk-type members)))) [_ (#Form (#Cons type-fn args))] - (fold ("lux check" (-> Code Code Code) - (function' [arg type-fn] (` (#;Apply (~ arg) (~ type-fn))))) - (walk-type type-fn) - (map walk-type args)) + (list/fold ("lux check" (-> Code Code Code) + (function' [arg type-fn] (` (#;Apply (~ arg) (~ type-fn))))) + (walk-type type-fn) + (map walk-type args)) _ type})) @@ -2740,10 +2755,10 @@ ("lux case" (reverse tokens) {(#Cons value actions) (let' [dummy (symbol$ ["" ""])] - (return (list (fold ("lux check" (-> Code Code Code) - (function' [pre post] (` ("lux case" (~ pre) {(~ dummy) (~ post)})))) - value - actions)))) + (return (list (list/fold ("lux check" (-> Code Code Code) + (function' [pre post] (` ("lux case" (~ pre) {(~ dummy) (~ post)})))) + value + actions)))) _ (fail "Wrong syntax for exec")})) @@ -2835,21 +2850,21 @@ (map code-to-text) (interpose " ") reverse - (fold text/compose "")) ")") + (list/fold text/compose "")) ")") [_ (#Tuple xs)] ($_ text/compose "[" (|> xs (map code-to-text) (interpose " ") reverse - (fold text/compose "")) "]") + (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))}))) (interpose " ") reverse - (fold text/compose "")) "}")} + (list/fold text/compose "")) "}")} )) (def:' (expander branches) @@ -2883,7 +2898,7 @@ (map code-to-text) (interpose " ") reverse - (fold text/compose ""))))})) + (list/fold text/compose ""))))})) (macro:' #export (case tokens) (list [(tag$ ["lux" "doc"]) @@ -2983,13 +2998,13 @@ (^ (list [_ (#Tuple bindings)] body)) (if (multiple? +2 (length bindings)) (|> bindings as-pairs reverse - (fold (: (-> [Code Code] Code Code) - (function' [lr body'] - (let' [[l r] lr] - (if (symbol? l) - (` ("lux case" (~ r) {(~ l) (~ body')})) - (` (case (~ r) (~ l) (~ body'))))))) - body) + (list/fold (: (-> [Code Code] Code Code) + (function' [lr body'] + (let' [[l r] lr] + (if (symbol? l) + (` ("lux case" (~ r) {(~ l) (~ body')})) + (` (case (~ r) (~ l) (~ body'))))))) + body) list return) (fail "let requires an even number of parts")) @@ -3019,14 +3034,14 @@ (#Some ident head tail body) (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ident) - body+ (fold (: (-> Code Code Code) - (function' [arg body'] - (if (symbol? arg) - (` ("lux function" (~ g!blank) (~ arg) (~ body'))) - (` ("lux function" (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) - body - (reverse tail))] + body+ (list/fold (: (-> Code Code Code) + (function' [arg body'] + (if (symbol? arg) + (` ("lux function" (~ g!blank) (~ arg) (~ body'))) + (` ("lux function" (~ g!blank) (~ g!blank) + (case (~ g!blank) (~ arg) (~ body'))))))) + body + (reverse tail))] (return (list (if (symbol? head) (` ("lux function" (~ g!name) (~ head) (~ body+))) (` ("lux function" (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) @@ -3222,7 +3237,7 @@ (-> Code Code Code) (case addition [cursor (#;Record pairs)] - (fold meta-code-add base pairs) + (list/fold meta-code-add base pairs) _ base)) @@ -3360,10 +3375,10 @@ {#;doc <doc-msg>} (case (reverse tokens) (^ (list& last init)) - (return (list (fold (: (-> Code Code Code) - (function [pre post] (` <form>))) - last - init))) + (return (list (list/fold (: (-> Code Code Code) + (function [pre post] (` <form>))) + last + init))) _ (fail <message>)))] @@ -3704,7 +3719,7 @@ (def: (text/join parts) (-> (List Text) Text) - (|> parts reverse (fold text/compose ""))) + (|> parts reverse (list/fold text/compose ""))) (macro: #export (struct: tokens) {#;doc "## Definition of structures ala ML. @@ -3999,25 +4014,25 @@ _ false)))) - (fold (function [r l] (and l r)) true)) - (let [openings (fold (: (-> Code (List Openings) (List Openings)) - (function [part openings] - (case part - [_ (#Text prefix)] - (list& [prefix (list)] openings) - - [_ (#Symbol struct-name)] - (case openings - #Nil - (list ["" (list struct-name)]) - - (#Cons [prefix structs] openings') - (#Cons [prefix (#Cons struct-name structs)] openings')) - - _ - openings))) - (: (List Openings) (list)) - parts)] + (list/fold (function [r l] (and l r)) true)) + (let [openings (list/fold (: (-> Code (List Openings) (List Openings)) + (function [part openings] + (case part + [_ (#Text prefix)] + (list& [prefix (list)] openings) + + [_ (#Symbol struct-name)] + (case openings + #Nil + (list ["" (list struct-name)]) + + (#Cons [prefix structs] openings') + (#Cons [prefix (#Cons struct-name structs)] openings')) + + _ + openings))) + (: (List Openings) (list)) + parts)] (return [openings tokens'])) (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol).")) @@ -4035,25 +4050,25 @@ _ false)))) - (fold (function [r l] (and l r)) true)) - (let [openings (fold (: (-> Code (List Openings) (List Openings)) - (function [part openings] - (case part - [_ (#Text prefix)] - (list& [prefix (list)] openings) - - [_ (#Symbol struct-name)] - (case openings - #Nil - (list ["" (list struct-name)]) - - (#Cons [prefix structs] openings') - (#Cons [prefix (#Cons struct-name structs)] openings')) - - _ - openings))) - (: (List Openings) (list)) - parts)] + (list/fold (function [r l] (and l r)) true)) + (let [openings (list/fold (: (-> Code (List Openings) (List Openings)) + (function [part openings] + (case part + [_ (#Text prefix)] + (list& [prefix (list)] openings) + + [_ (#Symbol struct-name)] + (case openings + #Nil + (list ["" (list struct-name)]) + + (#Cons [prefix structs] openings') + (#Cons [prefix (#Cons struct-name structs)] openings')) + + _ + openings))) + (: (List Openings) (list)) + parts)] (return [openings (list)])) (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol)."))) @@ -4080,7 +4095,7 @@ [current-module current-module-name] (case (split-module module) (^ (list& "." parts)) - (return (|> (list& current-module parts) (interpose "/") reverse (fold text/compose ""))) + (return (|> (list& current-module parts) (interpose "/") reverse (list/fold text/compose ""))) parts (let [[ups parts'] (split-with (text/= "..") parts) @@ -4092,7 +4107,7 @@ (fail (text/compose "Cannot clean module: " module)) (#Some top-module) - (return (|> (list& top-module parts') (interpose "/") reverse (fold text/compose "")))) + (return (|> (list& top-module parts') (interpose "/") reverse (list/fold text/compose "")))) ))) )) @@ -4200,11 +4215,11 @@ (def: (is-member? cases name) (-> (List Text) Text Bool) - (let [output (fold (function [case prev] - (or prev - (text/= case name))) - false - cases)] + (let [output (list/fold (function [case prev] + (or prev + (text/= case name))) + false + cases)] output)) (def: (try-both f x1 x2) @@ -4351,7 +4366,7 @@ name _ - ($_ text/compose "(" name " " (|> params (map type/show) (interpose " ") reverse (fold text/compose "")) ")")) + ($_ text/compose "(" name " " (|> params (map type/show) (interpose " ") reverse (list/fold text/compose "")) ")")) #Void "Void" @@ -4360,13 +4375,13 @@ "Unit" (#Sum _) - ($_ text/compose "(| " (|> (flatten-variant type) (map type/show) (interpose " ") reverse (fold text/compose "")) ")") + ($_ text/compose "(| " (|> (flatten-variant type) (map type/show) (interpose " ") reverse (list/fold text/compose "")) ")") (#Product _) - ($_ text/compose "[" (|> (flatten-tuple type) (map type/show) (interpose " ") reverse (fold text/compose "")) "]") + ($_ text/compose "[" (|> (flatten-tuple type) (map type/show) (interpose " ") reverse (list/fold text/compose "")) "]") (#Function _) - ($_ text/compose "(-> " (|> (flatten-lambda type) (map type/show) (interpose " ") reverse (fold text/compose "")) ")") + ($_ text/compose "(-> " (|> (flatten-lambda type) (map type/show) (interpose " ") reverse (list/fold text/compose "")) ")") (#Bound id) (nat/encode id) @@ -4387,27 +4402,13 @@ (let [[func args] (flatten-app type)] ($_ text/compose "(" (type/show func) " " - (|> args (map type/show) (interpose " ") reverse (fold text/compose "")) + (|> args (map type/show) (interpose " ") reverse (list/fold text/compose "")) ")")) (#Named [prefix name] _) ($_ text/compose prefix ";" name) )) -(def: (foldM Monad<m> f init inputs) - (All [m o i] - (-> (Monad m) (-> i o (m o)) o (List i) (m o))) - (case inputs - #;Nil - (do Monad<m> - [] - (wrap init)) - - (#;Cons input inputs') - (do Monad<m> - [output (f input init)] - (foldM Monad<m> f output inputs')))) - (macro: #hidden (^open' tokens) (case tokens (^ (list [_ (#Symbol name)] [_ (#Text prefix)] body)) @@ -4427,20 +4428,20 @@ (symbol$ ["" (text/compose prefix t-name)])]) tags))] (do Monad<Meta> - [enhanced-target (foldM Monad<Meta> - (function [[[_ m-name] m-type] enhanced-target] - (do Monad<Meta> - [m-structure (resolve-type-tags m-type)] - (case m-structure - (#;Some m-tags&members) - (recur ["" (text/compose prefix m-name)] - m-tags&members - enhanced-target) - - #;None - (wrap enhanced-target)))) - target - (zip2 tags members))] + [enhanced-target (monad/fold Monad<Meta> + (function [[[_ m-name] m-type] enhanced-target] + (do Monad<Meta> + [m-structure (resolve-type-tags m-type)] + (case m-structure + (#;Some m-tags&members) + (recur ["" (text/compose prefix m-name)] + m-tags&members + enhanced-target) + + #;None + (wrap enhanced-target)))) + target + (zip2 tags members))] (wrap (` ("lux case" (~ (symbol$ source)) {(~ pattern) (~ enhanced-target)}))))))) name tags&members body)] (wrap (list full-body))))) @@ -4476,12 +4477,12 @@ (fail "cond requires an even number of arguments.") (case (reverse tokens) (^ (list& else branches')) - (return (list (fold (: (-> [Code Code] Code Code) - (function [branch else] - (let [[right left] branch] - (` (if (~ left) (~ right) (~ else)))))) - else - (as-pairs branches')))) + (return (list (list/fold (: (-> [Code Code] Code Code) + (function [branch else] + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as-pairs branches')))) _ (fail "Wrong syntax for cond")))) @@ -4532,11 +4533,11 @@ (fail "get@ can only use records."))) (^ (list [_ (#Tuple slots)] record)) - (return (list (fold (: (-> Code Code Code) - (function [slot inner] - (` (;;get@ (~ slot) (~ inner))))) - record - slots))) + (return (list (list/fold (: (-> Code Code Code) + (function [slot inner] + (` (;;get@ (~ slot) (~ inner))))) + record + slots))) (^ (list selector)) (do Monad<Meta> @@ -4658,7 +4659,7 @@ "\n" (|> options (map code-to-text) (interpose " ") - (fold text/compose ""))))))) + (list/fold text/compose ""))))))) (def: (write-refer module-name [r-defs r-opens]) (-> Text Refer (Meta (List Code))) @@ -4865,17 +4866,17 @@ (function [_] (gensym "temp"))) slots) #let [pairs (zip2 slots bindings) - update-expr (fold (: (-> [Code Code] Code Code) - (function [[s b] v] - (` (;;set@ (~ s) (~ v) (~ b))))) - value - (reverse pairs)) - [_ accesses'] (fold (: (-> [Code Code] [Code (List (List Code))] [Code (List (List Code))]) - (function [[new-slot new-binding] [old-record accesses']] - [(` (get@ (~ new-slot) (~ new-binding))) - (#;Cons (list new-binding old-record) accesses')])) - [record (: (List (List Code)) #;Nil)] - pairs) + update-expr (list/fold (: (-> [Code Code] Code Code) + (function [[s b] v] + (` (;;set@ (~ s) (~ v) (~ b))))) + value + (reverse pairs)) + [_ accesses'] (list/fold (: (-> [Code Code] [Code (List (List Code))] [Code (List (List Code))]) + (function [[new-slot new-binding] [old-record accesses']] + [(` (get@ (~ new-slot) (~ new-binding))) + (#;Cons (list new-binding old-record) accesses')])) + [record (: (List (List Code)) #;Nil)] + pairs) accesses (list/join (reverse accesses'))]] (wrap (list (` (let [(~@ accesses)] (~ update-expr))))))) @@ -5052,14 +5053,14 @@ (^template [<tag>] [[_ _ column] (<tag> parts)] - (fold n.min column (map find-baseline-column parts))) + (list/fold n.min column (map find-baseline-column parts))) ([#Form] [#Tuple]) [[_ _ column] (#Record pairs)] - (fold n.min column - (list/compose (map (. find-baseline-column first) pairs) - (map (. find-baseline-column second) pairs))) + (list/fold n.min column + (list/compose (map (. find-baseline-column first) pairs) + (map (. find-baseline-column second) pairs))) )) (type: Doc-Fragment @@ -5165,11 +5166,11 @@ (^template [<tag> <open> <close> <prep>] [group-cursor (<tag> parts)] - (let [[group-cursor' parts-text] (fold (function [part [last-cursor text-accum]] - (let [[part-cursor part-text] (doc-example->Text last-cursor baseline part)] - [part-cursor (text/compose text-accum part-text)])) - [(delim-update-cursor group-cursor) ""] - (<prep> parts))] + (let [[group-cursor' parts-text] (list/fold (function [part [last-cursor text-accum]] + (let [[part-cursor part-text] (doc-example->Text last-cursor baseline part)] + [part-cursor (text/compose text-accum part-text)])) + [(delim-update-cursor group-cursor) ""] + (<prep> parts))] [(delim-update-cursor group-cursor') ($_ text/compose (cursor-padding baseline prev-cursor group-cursor) <open> @@ -5565,15 +5566,15 @@ (def: (multi-level-case$ g!_ [[init-pattern levels] body]) (-> Code [Multi-Level-Case Code] (List Code)) - (let [inner-pattern-body (fold (function [[calculation pattern] success] - (` (case (~ calculation) - (~ pattern) - (~ success) - - (~ g!_) - #;None))) - (` (#;Some (~ body))) - (: (List [Code Code]) (reverse levels)))] + (let [inner-pattern-body (list/fold (function [[calculation pattern] success] + (` (case (~ calculation) + (~ pattern) + (~ success) + + (~ g!_) + #;None))) + (` (#;Some (~ body))) + (: (List [Code Code]) (reverse levels)))] (list init-pattern inner-pattern-body))) (macro: #export (^multi tokens) @@ -5973,7 +5974,7 @@ [ann (<tag> parts)] (do Monad<Meta> [=parts (monad/map Monad<Meta> label-code parts)] - (wrap [(fold list/compose (list) (map left =parts)) + (wrap [(list/fold list/compose (list) (map left =parts)) [ann (<tag> (map right =parts))]]))) ([#Form] [#Tuple]) @@ -5988,7 +5989,7 @@ [val-labels val-labelled] =val]] (wrap [(list/compose key-labels val-labels) [key-labelled val-labelled]]))) kvs)] - (wrap [(fold list/compose (list) (map left =kvs)) + (wrap [(list/fold list/compose (list) (map left =kvs)) [ann (#Record (map right =kvs))]])) _ |