From e37e3713e080606930a5f8442f03dabc4c26a7f9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 21 Nov 2017 16:09:07 -0400 Subject: - Fixed some bugs. - Some small refactoring. --- stdlib/source/lux.lux | 609 +++++++++++++------------ stdlib/source/lux/concurrency/promise.lux | 42 +- stdlib/source/lux/concurrency/stm.lux | 9 +- stdlib/source/lux/control/eq.lux | 4 +- stdlib/source/lux/data/coll/priority-queue.lux | 4 +- stdlib/source/lux/data/number.lux | 21 +- stdlib/source/lux/data/text.lux | 4 +- stdlib/source/lux/lang/syntax.lux | 36 +- stdlib/source/lux/macro.lux | 23 +- stdlib/test/test/lux.lux | 8 +- stdlib/test/test/lux/data/coll/dict.lux | 2 +- stdlib/test/test/lux/lang/syntax.lux | 61 ++- 12 files changed, 404 insertions(+), 419 deletions(-) (limited to 'stdlib') 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 - [elems' ("lux check" ($' Meta ($' List Code)) - (monad/map Monad - ("lux check" (-> Code ($' Meta Code)) - (function' [elem] - ("lux case" elem - {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] - (wrap spliced) - - _ - (do Monad - [=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 + [lastO (untemplate lastI)] + (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list lastO (tag$ ["lux" "Nil"])))))))})] + (monad/fold Monad + (function' [leftI rightO] + ("lux case" leftI + {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] + (wrap (form$ (list (symbol$ ["lux" "splice-helper"]) + spliced + rightO))) - false - (do Monad - [=elems (monad/map Monad untemplate elems)] - (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))}) + _ + (do Monad + [leftO (untemplate leftI)] + (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list leftO rightO))))))})) + lastO + inits))}) false (do Monad [=elems (monad/map Monad 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 - [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 + [output (splice replace? (untemplate replace? subst) elems) + #let [[_ output'] (wrap-meta (form$ (list (tag$ ["lux" "Tuple"]) output)))]] + (wrap [meta output'])) [_ [_ (#Record fields)]] (do Monad @@ -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 } (case (reverse tokens) (^ (list& last init)) - (return (list (fold (: (-> Code Code Code) - (function [pre post] (`
))) - last - init))) + (return (list (list/fold (: (-> Code Code Code) + (function [pre post] (` ))) + last + init))) _ (fail )))] @@ -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 f init inputs) - (All [m o i] - (-> (Monad m) (-> i o (m o)) o (List i) (m o))) - (case inputs - #;Nil - (do Monad - [] - (wrap init)) - - (#;Cons input inputs') - (do Monad - [output (f input init)] - (foldM Monad 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 - [enhanced-target (foldM Monad - (function [[[_ m-name] m-type] enhanced-target] - (do Monad - [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 + (function [[[_ m-name] m-type] enhanced-target] + (do Monad + [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 @@ -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 [] [[_ _ column] ( 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 [ ] [group-cursor ( 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) ""] - ( 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) ""] + ( parts))] [(delim-update-cursor group-cursor') ($_ text/compose (cursor-padding baseline prev-cursor group-cursor) @@ -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 ( parts)] (do Monad [=parts (monad/map Monad label-code parts)] - (wrap [(fold list/compose (list) (map left =parts)) + (wrap [(list/fold list/compose (list) (map left =parts)) [ann ( (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))]])) _ diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux index 78cdbecce..75bcc52fd 100644 --- a/stdlib/source/lux/concurrency/promise.lux +++ b/stdlib/source/lux/concurrency/promise.lux @@ -20,7 +20,7 @@ (type: (Promise-State a) {#value (Maybe a) - #observers (List (-> a (IO Unit)))}) + #observers (List (-> a (IO Top)))}) (type: #export (Promise a) {#;doc "Represents values produced by asynchronous computations (unlike IO, which is synchronous)."} @@ -74,8 +74,8 @@ (wrap true)) (resolve value promise)))))) -(def: (await f promise) - (All [a] (-> (-> a (IO Unit)) (Promise a) Unit)) +(def: #export (await f promise) + (All [a] (-> (-> a (IO Top)) (Promise a) Top)) (let [old (io;run (atom;read promise))] (case (get@ #value old) (#;Some value) @@ -90,9 +90,7 @@ (struct: #export _ (F;Functor Promise) (def: (map f fa) (let [fb (promise ($ +1))] - (exec (await (function [a] (do Monad - [_ (resolve (f a) fb)] - (wrap []))) + (exec (await (function [a] (resolve (f a) fb)) fa) fb)))) @@ -106,9 +104,7 @@ (def: (apply ff fa) (let [fb (promise ($ +1))] (exec (await (function [f] - (io (await (function [a] (do Monad - [_ (resolve (f a) fb)] - (wrap []))) + (io (await (function [a] (resolve (f a) fb)) fa))) ff) fb)) @@ -120,10 +116,7 @@ (def: (join mma) (let [ma (promise ($ +0))] (exec (await (function [ma'] - (io (await (function [a'] - (do Monad - [_ (resolve a' ma)] - (wrap []))) + (io (await (function [a'] (resolve a' ma)) ma'))) mma) ma)))) @@ -142,10 +135,7 @@ (let [a|b (promise (Either ($ +0) ($ +1)))] (with-expansions [ (do-template [ ] - [(await (function [value] - (do Monad - [_ (resolve ( value) a|b)] - (wrap []))) + [(await (function [value] (resolve ( value) a|b)) )] [left #;Left] @@ -158,19 +148,13 @@ {#;doc "Homogeneous alternative combinator."} (All [a] (-> (Promise a) (Promise a) (Promise a))) (let [left||right (promise ($ +0))] - (with-expansions - [ (do-template [] - [(await [(function [value] - (do Monad - [_ (resolve value left||right)] - (wrap [])))] - )] + (`` (exec (~~ (do-template [] + [(await (function [value] (resolve value left||right)) + )] - [left] - [right] - )] - (exec - left||right)))) + [left] + [right])) + left||right)))) (def: #export (future computation) {#;doc "Runs an I/O computation on its own process and returns an Promise that will eventually host its result."} diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux index 1fee00b7e..e29edc9a2 100644 --- a/stdlib/source/lux/concurrency/stm.lux +++ b/stdlib/source/lux/concurrency/stm.lux @@ -245,7 +245,14 @@ [inputs (follow pending-commits)] (exec (|> inputs (:! (frp;Channel [(STM Unit) (P;Promise Unit)])) - (frp/map process-commit)) + (P;await (function recur [?inputs] + (io (case ?inputs + #;Nil + [] + + (#;Cons head tail) + (exec (process-commit head) + (P;await recur tail))))))) (wrap []))) (wrap []))) ))) diff --git a/stdlib/source/lux/control/eq.lux b/stdlib/source/lux/control/eq.lux index 9e372bd58..d0f64e908 100644 --- a/stdlib/source/lux/control/eq.lux +++ b/stdlib/source/lux/control/eq.lux @@ -5,13 +5,13 @@ (: (-> a a Bool) =)) -(def: #export (pair left right) +(def: #export (product left right) (All [l r] (-> (Eq l) (Eq r) (Eq [l r]))) (struct (def: (= [a b] [x y]) (and (:: left = a x) (:: right = b y))))) -(def: #export (either left right) +(def: #export (sum left right) (All [l r] (-> (Eq l) (Eq r) (Eq (| l r)))) (struct (def: (= a|b x|y) (case [a|b x|y] diff --git a/stdlib/source/lux/data/coll/priority-queue.lux b/stdlib/source/lux/data/coll/priority-queue.lux index 879ace1e6..96ad71a6b 100644 --- a/stdlib/source/lux/data/coll/priority-queue.lux +++ b/stdlib/source/lux/data/coll/priority-queue.lux @@ -11,8 +11,8 @@ (type: #export (Queue a) (Maybe (F;Fingers Priority a))) -(def: max-priority Priority ("lux nat max-value")) -(def: min-priority Priority ("lux nat min-value")) +(def: max-priority Priority ("lux nat max")) +(def: min-priority Priority ("lux nat min")) (def: #export empty Queue diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index e9009102b..5b8e1946d 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -80,11 +80,10 @@ (def: * d.*) (def: / d./) (def: % d.%) - (def: (negate x) (d.- x ("lux deg max-value"))) + (def: (negate x) (d.- x ("lux deg max"))) (def: abs id) (def: (signum x) - ("lux deg max-value")) - ) + ("lux deg max"))) (do-template [ ] [(struct: #export _ (Enum ) @@ -94,8 +93,8 @@ [Nat Order n.inc n.dec] [Int Order i.inc i.dec] - [Frac Order (f.+ ("lux frac smallest-value")) (f.- ("lux frac smallest-value"))] - [Deg Order (d.+ ("lux deg min-value")) (d.- ("lux deg min-value"))] + [Frac Order (f.+ ("lux frac smallest")) (f.- ("lux frac smallest"))] + [Deg Order (d.+ ("lux deg min")) (d.- ("lux deg min"))] ) (do-template [ ] @@ -104,10 +103,10 @@ (def: top ) (def: bottom ))] - [ Nat Enum ("lux nat max-value") ("lux nat min-value")] - [ Int Enum ("lux int max-value") ("lux int min-value")] - [Frac Enum ("lux frac max-value") ("lux frac min-value")] - [ Deg Enum ("lux deg max-value") ("lux deg min-value")] + [ Nat Enum ("lux nat max") ("lux nat min")] + [ Int Enum ("lux int max") ("lux int min")] + [Frac Enum ("lux frac max") ("lux frac min")] + [ Deg Enum ("lux deg max") ("lux deg min")] ) (do-template [ ] @@ -193,7 +192,7 @@ (if (n.>= +2 input-size) (case ("lux text char" repr +0) (^ (#;Some (char "+"))) - (let [input ("lux text upper-case" repr)] + (let [input ("lux text upper" repr)] (loop [idx +1 output +0] (if (n.< input-size idx) @@ -244,7 +243,7 @@ _ 1) - input ("lux text upper-case" repr)] + input ("lux text upper" repr)] (loop [idx (if (i.= -1 sign) +1 +0) output 0] (if (n.< input-size idx) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index d0f1e6f15..0611e6e79 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -27,8 +27,8 @@ (-> Text Text) ( input))] - [lower-case "lux text lower-case"] - [upper-case "lux text upper-case"] + [lower-case "lux text lower"] + [upper-case "lux text upper"] ) (def: #export (clip from to input) diff --git a/stdlib/source/lux/lang/syntax.lux b/stdlib/source/lux/lang/syntax.lux index 7bc8e8cca..ae20fd9b6 100644 --- a/stdlib/source/lux/lang/syntax.lux +++ b/stdlib/source/lux/lang/syntax.lux @@ -30,14 +30,17 @@ ["p" parser "p/" Monad] ["ex" exception #+ exception:]) (data [bool] - [text] ["e" error] [number] [product] [maybe] + [text] (text ["l" lexer] format) - (coll [sequence #+ Sequence])))) + (coll [sequence #+ Sequence] + [dict #+ Dict])))) + +(type: #export Aliases (Dict Text Text)) (def: white-space Text "\t\v \r\f") (def: new-line Text "\n") @@ -521,8 +524,8 @@ (def: current-module-mark Text (format identifier-separator identifier-separator)) -(def: (ident^ current-module) - (-> Text (l;Lexer [Ident Nat])) +(def: (ident^ current-module aliases) + (-> Text Aliases (l;Lexer [Ident Nat])) ($_ p;either ## When an identifier starts with 2 marks, its module is ## taken to be the current-module being compiled at the moment. @@ -558,7 +561,8 @@ (p;either (do @ [_ (l;this identifier-separator) second-part ident-part^] - (wrap [[first-part second-part] + (wrap [[(|> aliases (dict;get first-part) (maybe;default first-part)) + second-part] ($_ n.+ (text;size first-part) +1 @@ -574,22 +578,22 @@ ## provide the compiler with information related to data-structure ## construction and de-structuring (during pattern-matching). (do-template [ ] - [(def: #export ( current-module where) - (-> Text Cursor (l;Lexer [Cursor Code])) + [(def: #export ( current-module aliases where) + (-> Text Aliases Cursor (l;Lexer [Cursor Code])) (do p;Monad [[value length] ] (wrap [(update@ #;column (|>. ($_ n.+ length)) where) [where ( value)]])))] - [symbol #;Symbol (ident^ current-module) +0] - [tag #;Tag (p;after (l;this "#") (ident^ current-module)) +1] + [symbol #;Symbol (ident^ current-module aliases) +0] + [tag #;Tag (p;after (l;this "#") (ident^ current-module aliases)) +1] ) (exception: #export End-Of-File) (exception: #export Unrecognized-Input) -(def: (ast current-module) - (-> Text Cursor (l;Lexer [Cursor Code])) +(def: (ast current-module aliases) + (-> Text Aliases Cursor (l;Lexer [Cursor Code])) (: (-> Cursor (l;Lexer [Cursor Code])) (function ast' [where] (do p;Monad @@ -603,8 +607,8 @@ (frac where) (int where) (deg where) - (symbol current-module where) - (tag current-module where) + (symbol current-module aliases where) + (tag current-module aliases where) (text where) (do @ [end? l;end?] @@ -613,9 +617,9 @@ (p;fail (Unrecognized-Input current-module)))) ))))) -(def: #export (read current-module [where offset source]) - (-> Text Source (e;Error [Source Code])) - (case (p;run [offset source] (ast current-module where)) +(def: #export (read current-module aliases [where offset source]) + (-> Text Aliases Source (e;Error [Source Code])) + (case (p;run [offset source] (ast current-module aliases where)) (#e;Error error) (#e;Error error) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index e3cba7a31..fc392d49c 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -453,32 +453,11 @@ #;None (#e;Error ($_ text/compose "Unknown variable: " name)))))) -(def: #export (canonical name) - (-> Ident (Meta Ident)) - (case name - ["" _name] - (do Monad - [this-module current-module-name] - (wrap [this-module _name])) - - [_module _name] - (do Monad - [this-module-name current-module-name - this-module (find-module this-module-name)] - (case (list;find (|>. product;left (text/= _module)) - (get@ #;module-aliases this-module)) - (#;Some [alias real]) - (wrap [real _name]) - - _ - (wrap name))) - )) - (def: #export (find-def name) {#;doc "Looks-up a definition's whole data in the available modules (including the current one)."} (-> Ident (Meta Def)) (do Monad - [name (canonical name)] + [name (normalize name)] (function [compiler] (case (: (Maybe Def) (do maybe;Monad diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux index 22190bd93..addc7a33a 100644 --- a/stdlib/test/test/lux.lux +++ b/stdlib/test/test/lux.lux @@ -136,10 +136,10 @@ (|> x' (/ y) (* y) (= x')))) ))))] - ["Nat" r;nat n.= n.+ n.- n.* n./ n.% n.> +0 +1 +1000000 %n (n.% +1000) id] - ["Int" r;int i.= i.+ i.- i.* i./ i.% i.> 0 1 1000000 %i (i.% 1000) id] - ["Frac" r;frac f.= f.+ f.- f.* f./ f.% f.> 0.0 1.0 1000000.0 %r id math;floor] - ["Deg" r;deg d.= d.+ d.- d.* d./ d.% d.> .0 ("lux deg max-value") ("lux deg max-value") %f id id] + ["Nat" r;nat n.= n.+ n.- n.* n./ n.% n.> +0 +1 +1000000 %n (n.% +1000) id] + ["Int" r;int i.= i.+ i.- i.* i./ i.% i.> 0 1 1000000 %i (i.% 1000) id] + ["Frac" r;frac f.= f.+ f.- f.* f./ f.% f.> 0.0 1.0 1000000.0 %r id math;floor] + ["Deg" r;deg d.= d.+ d.- d.* d./ d.% d.> .0 ("lux deg max") ("lux deg max") %f id id] ) (do-template [category rand-gen -> <- = %a %z] diff --git a/stdlib/test/test/lux/data/coll/dict.lux b/stdlib/test/test/lux/data/coll/dict.lux index 536ad8450..ddc1ddd2d 100644 --- a/stdlib/test/test/lux/data/coll/dict.lux +++ b/stdlib/test/test/lux/data/coll/dict.lux @@ -30,7 +30,7 @@ (not (&;empty? dict)))) (test "The functions 'entries', 'keys' and 'values' should be synchronized." - (:: (list;Eq (eq;pair number;Eq number;Eq)) = + (:: (list;Eq (eq;product number;Eq number;Eq)) = (&;entries dict) (list;zip2 (&;keys dict) (&;values dict)))) diff --git a/stdlib/test/test/lux/lang/syntax.lux b/stdlib/test/test/lux/lang/syntax.lux index 3eb9bfc02..4a7c16807 100644 --- a/stdlib/test/test/lux/lang/syntax.lux +++ b/stdlib/test/test/lux/lang/syntax.lux @@ -7,7 +7,8 @@ [text] (text format ["l" lexer]) - (coll [list])) + (coll [list] + [dict #+ Dict])) ["r" math/random "r/" Monad] (macro [code]) (lang ["&" syntax]) @@ -80,20 +81,23 @@ other code^] ($_ seq (test "Can parse Lux code." - (case (&;read "" [default-cursor +0 (code;to-text sample)]) + (case (&;read "" (dict;new text;Hash) + [default-cursor +0 (code;to-text sample)]) (#e;Error error) false (#e;Success [_ parsed]) (:: code;Eq = parsed sample))) (test "Can parse Lux multiple code nodes." - (case (&;read "" [default-cursor +0 (format (code;to-text sample) " " - (code;to-text other))]) + (case (&;read "" (dict;new text;Hash) + [default-cursor +0 (format (code;to-text sample) " " + (code;to-text other))]) (#e;Error error) false (#e;Success [remaining =sample]) - (case (&;read "" remaining) + (case (&;read "" (dict;new text;Hash) + remaining) (#e;Error error) false @@ -114,11 +118,12 @@ signed? r;bool #let [expected (|> numerator (f./ denominator) (f.* (if signed? -1.0 1.0)))]] (test "Can parse frac ratio syntax." - (case (&;read "" [default-cursor +0 - (format (if signed? "-" "") - (%i (frac-to-int numerator)) - "/" - (%i (frac-to-int denominator)))]) + (case (&;read "" (dict;new text;Hash) + [default-cursor +0 + (format (if signed? "-" "") + (%i (frac-to-int numerator)) + "/" + (%i (frac-to-int denominator)))]) (#e;Success [_ [_ (#;Frac actual)]]) (f.= expected actual) @@ -131,8 +136,9 @@ (do @ [expected (|> r;nat (:: @ map (n.% +1_000)))] (test "Can parse nat char syntax." - (case (&;read "" [default-cursor +0 - (format "#" (%t (text;from-code expected)) "")]) + (case (&;read "" (dict;new text;Hash) + [default-cursor +0 + (format "#" (%t (text;from-code expected)) "")]) (#e;Success [_ [_ (#;Nat actual)]]) (n.= expected actual) @@ -181,8 +187,9 @@ (let [bad-match (format (text;from-code x) "\n" (text;from-code y) "\n" (text;from-code z))] - (case (&;read "" [default-cursor +0 - (format "\"" bad-match "\"")]) + (case (&;read "" (dict;new text;Hash) + [default-cursor +0 + (format "\"" bad-match "\"")]) (#e;Error error) true @@ -195,9 +202,10 @@ good-output (format (text;from-code x) "\n" (text;from-code y) "\n" (text;from-code z))] - (case (&;read "" [(|> default-cursor (update@ #;column (n.+ (n.dec offset-size)))) - +0 - (format "\"" good-input "\"")]) + (case (&;read "" (dict;new text;Hash) + [(|> default-cursor (update@ #;column (n.+ (n.dec offset-size)))) + +0 + (format "\"" good-input "\"")]) (#e;Error error) false @@ -206,25 +214,28 @@ parsed (code;text good-output))))) (test "Can handle comments." - (case (&;read "" [default-cursor +0 - (format comment (code;to-text sample))]) + (case (&;read "" (dict;new text;Hash) + [default-cursor +0 + (format comment (code;to-text sample))]) (#e;Error error) false (#e;Success [_ parsed]) (:: code;Eq = parsed sample))) (test "Will reject unbalanced multi-line comments." - (and (case (&;read "" [default-cursor +0 - (format "#(" "#(" unbalanced-comment ")#" - (code;to-text sample))]) + (and (case (&;read "" (dict;new text;Hash) + [default-cursor +0 + (format "#(" "#(" unbalanced-comment ")#" + (code;to-text sample))]) (#e;Error error) true (#e;Success [_ parsed]) false) - (case (&;read "" [default-cursor +0 - (format "#(" unbalanced-comment ")#" ")#" - (code;to-text sample))]) + (case (&;read "" (dict;new text;Hash) + [default-cursor +0 + (format "#(" unbalanced-comment ")#" ")#" + (code;to-text sample))]) (#e;Error error) true -- cgit v1.2.3