diff options
| -rw-r--r-- | lux-mode/lux-mode.el | 12 | ||||
| -rw-r--r-- | stdlib/source/lux/control/concatenative.lux | 151 | ||||
| -rw-r--r-- | stdlib/source/lux/data/product.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/data/sum.lux | 19 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/syntax.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/concatenative.lux | 235 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/continuation.lux | 14 |
8 files changed, 340 insertions, 97 deletions
diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el index 47a90d0bb..e3dfd46f6 100644 --- a/lux-mode/lux-mode.el +++ b/lux-mode/lux-mode.el @@ -267,7 +267,8 @@ Called by `imenu--generic-function'." (jvm-host (altRE "class:" "interface:" "import:" "object" "do-to" "synchronized" "class-for")) (alternative-format (altRE "char" "bin" "oct" "hex")) (documentation (altRE "doc" "comment")) - (function-application (altRE "|>" "|>>" "<|" "<<|" "_\\$" "\\$_")) + (function-application (altRE "|>" "<|" "_\\$" "\\$_")) + (function-definition (altRE "function" "|>>" "<<|" "||>")) (remember (altRE "remember" "to-do" "fix-me")) (definition (altRE "\\.module:" "def:" "type:" "program:" @@ -307,11 +308,12 @@ Called by `imenu--generic-function'." alternative-format documentation function-application + function-definition remember definition ;;;;;;;;;;;;;;;;;;;;;;;; "with-expansions" - "function" "undefined" "name-of" "static" + "undefined" "name-of" "static" "for" "io" "infix" @@ -361,7 +363,7 @@ highlighted region)." (font-lock-syntactic-face-function . lux-font-lock-syntactic-face-function)))) -(defvar withRE (concat "with" (altRE "-" "\\'"))) +(defvar withRE (concat "\\`" "with" (altRE "-" "\\'"))) (defvar definitionRE ":\\'") (defun lux-indent-function (indent-point state) @@ -419,8 +421,8 @@ This function also returns nil meaning don't specify the indentation." ((or (eq method 'defun) (and (null method) (> (length function) 2) - (or (string-match withRE function) - (string-match definitionRE function)))) + (or (string-match withRE function-tail) + (string-match definitionRE function-tail)))) (lisp-indent-defform state indent-point)) ((integerp method) (lisp-indent-specform method state diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux index a0152830d..0b6786c23 100644 --- a/stdlib/source/lux/control/concatenative.lux +++ b/stdlib/source/lux/control/concatenative.lux @@ -1,13 +1,13 @@ (.module: - [lux (#- if loop when) + [lux (#- Alias if loop) [abstract ["." monad]] [data - ["." maybe ("#;." monad)] + ["." maybe ("#@." monad)] ["." text ["%" format (#+ format)]] [collection - ["." list ("#;." fold functor)]] + ["." list ("#@." fold functor)]] [number ["n" nat] ["i" int] @@ -20,10 +20,9 @@ ["csr" reader] ["csw" writer]]]]] [// - ["p" parser ("#;." monad) - ["s" code (#+ Parser)]]]) + ["<>" parser ("#@." monad) + ["<c>" code (#+ Parser)]]]) -## [Syntax] (type: Alias [Text Code]) (type: Stack @@ -32,32 +31,32 @@ (def: aliases^ (Parser (List Alias)) - (|> (p.and s.local-identifier s.any) - p.some - s.record - (p.default (list)))) + (|> (<>.and <c>.local-identifier <c>.any) + <>.some + <c>.record + (<>.default (list)))) (def: bottom^ (Parser Nat) - (s.form (p.after (s.this (` #.Parameter)) s.nat))) + (<c>.form (<>.after (<c>.this! (` #.Parameter)) <c>.nat))) (def: stack^ (Parser Stack) - (p.either (p.and (p.maybe bottom^) - (s.tuple (p.some s.any))) - (p.and (|> bottom^ (p;map (|>> #.Some))) - (p;wrap (list))))) + (<>.either (<>.and (<>.maybe bottom^) + (<c>.tuple (<>.some <c>.any))) + (<>.and (|> bottom^ (<>@map (|>> #.Some))) + (<>@wrap (list))))) (def: (stack-fold tops bottom) (-> (List Code) Code Code) - (list;fold (function (_ top bottom) + (list@fold (function (_ top bottom) (` [(~ bottom) (~ top)])) bottom tops)) (def: (singleton expander) (-> (Meta (List Code)) (Meta Code)) - (monad.do ..monad + (monad.do macro.monad [expansion expander] (case expansion (#.Cons singleton #.Nil) @@ -65,18 +64,18 @@ _ (macro.fail (format "Cannot expand to more than a single AST/Code node:" text.new-line - (|> expansion (list;map %code) (text.join-with " "))))))) + (|> expansion (list@map %.code) (text.join-with " "))))))) (syntax: #export (=> {aliases aliases^} {inputs stack^} {outputs stack^}) (let [de-alias (function (_ aliased) - (list;fold (function (_ [from to] pre) + (list@fold (function (_ [from to] pre) (code.replace (code.local-identifier from) to pre)) aliased aliases))] - (case [(|> inputs (get@ #bottom) (maybe;map (|>> code.nat (~) #.Parameter (`)))) - (|> outputs (get@ #bottom) (maybe;map (|>> code.nat (~) #.Parameter (`))))] + (case [(|> inputs (get@ #bottom) (maybe@map (|>> code.nat (~) #.Parameter (`)))) + (|> outputs (get@ #bottom) (maybe@map (|>> code.nat (~) #.Parameter (`))))] [(#.Some bottomI) (#.Some bottomO)] (monad.do @ [inputC (singleton (macro.expand-all (stack-fold (get@ #top inputs) bottomI))) @@ -100,37 +99,21 @@ (function (_ [_ top]) top)) -(def: (prepare command) - (-> Code Code) - (case command - (^or [_ (#.Bit _)] - [_ (#.Nat _)] [_ (#.Int _)] - [_ (#.Rev _)] [_ (#.Frac _)] - [_ (#.Text _)] - [_ (#.Tag _)] (^ [_ (#.Form (list [_ (#.Tag _)]))])) - (` (..push (~ command))) - - [_ (#.Tuple block)] - (` (..push (|>> (~+ (list;map prepare block))))) - - _ - command)) - -(syntax: #export (||> {commands (p.some s.any)}) - (wrap (list (` (|> (~! ..begin!) (~+ (list;map prepare commands)) (~! ..end!)))))) +(syntax: #export (||> {commands (<>.some <c>.any)}) + (wrap (list (` (|> (~! ..begin!) (~+ commands) ((~! ..end!))))))) (syntax: #export (word: {export csr.export} - {name s.local-identifier} - {annotations (p.default cs.empty-annotations csr.annotations)} + {name <c>.local-identifier} + {annotations (<>.default cs.empty-annotations csr.annotations)} type - {commands (p.some s.any)}) + {commands (<>.some <c>.any)}) (wrap (list (` (def: (~+ (csw.export export)) (~ (code.local-identifier name)) (~ (csw.annotations annotations)) (~ type) - (|>> (~+ (list;map prepare commands)))))))) + (|>> (~+ commands))))))) -(syntax: #export (apply {arity (|> s.nat (p.filter (n.> 0)))}) +(syntax: #export (apply {arity (|> <c>.nat (<>.filter (n.> 0)))}) (with-gensyms [g! g!func g!stack g!output] (monad.do @ [g!inputs (|> (macro.gensym "input") (list.repeat arity) (monad.seq @))] @@ -141,15 +124,14 @@ (function ((~ g!) (~ (stack-fold g!inputs g!stack))) [(~ g!stack) ((~ g!func) (~+ g!inputs))]))))))))) -## [Primitives] -(def: #export apply1 (apply 1)) -(def: #export apply2 (apply 2)) -(def: #export apply3 (apply 3)) -(def: #export apply4 (apply 4)) -(def: #export apply5 (apply 5)) -(def: #export apply6 (apply 6)) -(def: #export apply7 (apply 7)) -(def: #export apply8 (apply 8)) +(def: #export apply/1 (apply 1)) +(def: #export apply/2 (apply 2)) +(def: #export apply/3 (apply 3)) +(def: #export apply/4 (apply 4)) +(def: #export apply/5 (apply 5)) +(def: #export apply/6 (apply 6)) +(def: #export apply/7 (apply 7)) +(def: #export apply/8 (apply 8)) (def: #export (push x) (All [a] (-> a (=> [] [a]))) @@ -253,21 +235,21 @@ ) (def: #export if - (All [__a __b] - (=> {then (=> __a __b) - else (=> __a __b)} - __a [Bit then else] __b)) + (All [___a ___z] + (=> {then (=> ___a ___z) + else (=> ___a ___z)} + ___a [Bit then else] ___z)) (function (_ [[[stack test] then] else]) (.if test (then stack) (else stack)))) (def: #export call - (All [__a __b] - (=> {quote (=> __a __b)} - __a [quote] __b)) - (function (_ [stack block]) - (block stack))) + (All [___a ___z] + (=> {quote (=> ___a ___z)} + ___a [quote] ___z)) + (function (_ [stack quote]) + (quote stack))) (def: #export loop (All [___] @@ -286,7 +268,7 @@ (function (_ [[stack a] quote]) [(quote stack) a])) -(def: #export dip2 +(def: #export dip/2 (All [___ a b] (=> ___ [a b (=> ___ ___)] ___ [a b])) @@ -294,20 +276,20 @@ [[(quote stack) a] b])) (def: #export do - (All [__a __b] - (=> {pred (=> __a __b [Bit]) - body (=> __b __a)} - __b [pred body] - __a [pred body])) + (All [___a ___z] + (=> {body (=> ___a ___z) + pred (=> ___z ___a [Bit])} + ___a [pred body] + ___z [pred body])) (function (_ [[stack pred] body]) [[(body stack) pred] body])) (def: #export while - (All [__a __b] - (=> {pred (=> __a __b [Bit]) - body (=> __b __a)} - __a [pred body] - __b)) + (All [___a ___z] + (=> {body (=> ___z ___a) + pred (=> ___a ___z [Bit])} + ___a [pred body] + ___z)) (function (while [[stack pred] body]) (let [[stack' verdict] (pred stack)] (.if verdict @@ -315,28 +297,33 @@ stack')))) (def: #export compose - (All [__a __b __c] - (=> [(=> __a __b) (=> __b __c)] - [(=> __a __c)])) + (All [___a ___ ___z] + (=> [(=> ___a ___) (=> ___ ___z)] + [(=> ___a ___z)])) (function (_ [[stack f] g]) [stack (|>> f g)])) (def: #export curry - (All [__a __b a] - (=> __a [a (=> __a [a] __b)] - __a [(=> __a __b)])) + (All [___a ___z a] + (=> ___a [a (=> ___a [a] ___z)] + ___a [(=> ___a ___z)])) (function (_ [[stack arg] quote]) [stack (|>> (push arg) quote)])) -## [Words] (word: #export when (All [___] (=> {body (=> ___ ___)} ___ [Bit body] ___)) - swap [call] [drop] if) + swap + (push (|>> call)) + (push (|>> drop)) + if) (word: #export ? (All [a] (=> [Bit a a] [a])) - rotL [drop] [nip] if) + rotL + (push (|>> drop)) + (push (|>> nip)) + if) diff --git a/stdlib/source/lux/data/product.lux b/stdlib/source/lux/data/product.lux index 64b84cb3e..416aa4673 100644 --- a/stdlib/source/lux/data/product.lux +++ b/stdlib/source/lux/data/product.lux @@ -49,7 +49,7 @@ (structure: #export (equivalence l@= r@=) (All [l r] (-> (Equivalence l) (Equivalence r) - (Equivalence [l r]))) + (Equivalence (& l r)))) (def: (= [lP rP] [lS rS]) (and (l@= lP lS) (r@= rP rS)))) diff --git a/stdlib/source/lux/data/sum.lux b/stdlib/source/lux/data/sum.lux index 2f7624113..5b7dc5a61 100644 --- a/stdlib/source/lux/data/sum.lux +++ b/stdlib/source/lux/data/sum.lux @@ -1,6 +1,8 @@ (.module: {#.doc "Functionality for working with variants (particularly 2-variants)."} - lux) + [lux #* + [abstract + [equivalence (#+ Equivalence)]]]) (template [<name> <type> <index>] [(def: #export (<name> value) @@ -51,3 +53,18 @@ (case x (0 x') [(#.Cons x' lefts) rights] (1 x') [lefts (#.Cons x' rights)])))) + +(structure: #export (equivalence l@= r@=) + (All [l r] + (-> (Equivalence l) (Equivalence r) + (Equivalence (| l r)))) + (def: (= reference sample) + (case [reference sample] + [(#.Left reference) (#.Left sample)] + (l@= reference sample) + + [(#.Right reference) (#.Right sample)] + (r@= reference sample) + + _ + false))) diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index c634e010c..007694978 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -91,7 +91,7 @@ ((~ g!body) (~ g!state)) (#.Left (~ g!error)) - (#.Left ((~! text.join-with) ": " (list (~ error-msg) (~ g!error))))} + (#.Left ((~! text.join-with) (~! text.new-line) (list (~ error-msg) (~ g!error))))} ((~! </>.run) (: ((~! </>.Parser) (Meta (List Code))) ((~! do) (~! <>.monad) diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index ace450eba..169332b30 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -2,6 +2,7 @@ [lux (#- function) ["_" test (#+ Test)]] ["." / #_ + ["#." concatenative] ["#." continuation] ["#." try] ["#." exception] @@ -60,6 +61,7 @@ (def: #export test Test ($_ _.and + /concatenative.test /continuation.test /try.test /exception.test diff --git a/stdlib/source/test/lux/control/concatenative.lux b/stdlib/source/test/lux/control/concatenative.lux new file mode 100644 index 000000000..c649128b0 --- /dev/null +++ b/stdlib/source/test/lux/control/concatenative.lux @@ -0,0 +1,235 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [data + ["." sum] + ["." name] + ["." bit ("#@." equivalence)] + [number + ["n" nat] + ["i" int] + ["r" rev] + ["f" frac]] + [text + ["%" format (#+ format)]]] + [math + ["." random]] + [macro + ["." template]]] + {1 + ["." / (#+ word: => ||>)]}) + +(def: stack-shuffling + Test + (do random.monad + [sample random.nat + dummy random.nat] + (`` ($_ _.and + (_.test (%.name (name-of /.push)) + (n.= sample + (||> (/.push sample)))) + (_.test (%.name (name-of /.drop)) + (n.= sample + (||> (/.push sample) + (/.push dummy) + /.drop))) + (_.test (%.name (name-of /.nip)) + (n.= sample + (||> (/.push dummy) + (/.push sample) + /.nip))) + (_.test (%.name (name-of /.dup)) + (||> (/.push sample) + /.dup + /.n/=)) + (_.test (%.name (name-of /.swap)) + (n.= sample + (||> (/.push sample) + (/.push dummy) + /.swap))) + (_.test (%.name (name-of /.rotL)) + (n.= sample + (||> (/.push sample) + (/.push dummy) + (/.push dummy) + /.rotL))) + (_.test (%.name (name-of /.rotR)) + (n.= sample + (||> (/.push dummy) + (/.push sample) + (/.push dummy) + /.rotR))) + (_.test (%.name (name-of /.&&)) + (let [[left right] (||> (/.push sample) + (/.push dummy) + /.&&)] + (and (n.= sample left) + (n.= dummy right)))) + (~~ (template [<function> <tag>] + [(_.test (%.name (name-of <function>)) + ((sum.equivalence n.= n.=) + (<tag> sample) + (||> (/.push sample) + <function>)))] + + [/.||L #.Left] + [/.||R #.Right])) + (_.test (%.name (name-of /.dip)) + (n.= (inc sample) + (||> (/.push sample) + (/.push dummy) + (/.push (/.apply/1 inc)) + /.dip + /.drop))) + (_.test (%.name (name-of /.dip/2)) + (n.= (inc sample) + (||> (/.push sample) + (/.push dummy) + (/.push dummy) + (/.push (/.apply/1 inc)) + /.dip/2 + /.drop /.drop))) + )))) + +(template: (!numerical <=> <generator> <filter> <arithmetic> <order>) + (: Test + (with-expansions [<arithmetic>' (template.splice <arithmetic>) + <order>' (template.splice <order>)] + (do random.monad + [parameter (|> <generator> (random.filter <filter>)) + subject <generator>] + (`` ($_ _.and + (~~ (template [<concatenative> <functional>] + [(_.test (%.name (name-of <concatenative>)) + (<=> (<functional> parameter subject) + (||> (/.push subject) + (/.push parameter) + <concatenative>)))] + + <arithmetic>')) + (~~ (template [<concatenative> <functional>] + [(_.test (%.name (name-of <concatenative>)) + (bit@= (<functional> parameter subject) + (||> (/.push subject) + (/.push parameter) + <concatenative>)))] + + <order>')) + )))))) + +(def: numerical + Test + ($_ _.and + (!numerical n.= random.nat (|>> (n.= 0) not) + [[/.n/+ n.+] [/.n/- n.-] [/.n/* n.*] [/.n// n./] [/.n/% n.%]] + [[/.n/= n.=] [/.n/< n.<] [/.n/<= n.<=] [/.n/> n.>] [/.n/>= n.>=]]) + (!numerical i.= random.int (|>> (i.= +0) not) + [[/.i/+ i.+] [/.i/- i.-] [/.i/* i.*] [/.i// i./] [/.i/% i.%]] + [[/.i/= i.=] [/.i/< i.<] [/.i/<= i.<=] [/.i/> i.>] [/.i/>= i.>=]]) + (!numerical r.= random.rev (|>> (r.= .0) not) + [[/.r/+ r.+] [/.r/- r.-] [/.r/* r.*] [/.r// r./] [/.r/% r.%]] + [[/.r/= r.=] [/.r/< r.<] [/.r/<= r.<=] [/.r/> r.>] [/.r/>= r.>=]]) + (!numerical f.= random.frac (|>> (f.= +0.0) not) + [[/.f/+ f.+] [/.f/- f.-] [/.f/* f.*] [/.f// f./] [/.f/% f.%]] + [[/.f/= f.=] [/.f/< f.<] [/.f/<= f.<=] [/.f/> f.>] [/.f/>= f.>=]]) + )) + +(def: control-flow + Test + (do random.monad + [choice random.bit + sample random.nat + start random.nat + #let [distance 10 + |inc| (/.apply/1 inc) + |test| (/.apply/1 (|>> (n.- start) (n.< distance)))]] + ($_ _.and + (_.test (%.name (name-of /.call)) + (n.= (inc sample) + (||> (/.push sample) + (/.push (/.apply/1 inc)) + /.call))) + (_.test (%.name (name-of /.if)) + (n.= (if choice + (inc sample) + (dec sample)) + (||> (/.push sample) + (/.push choice) + (/.push (/.apply/1 inc)) + (/.push (/.apply/1 dec)) + /.if))) + (_.test (%.name (name-of /.loop)) + (n.= (n.+ distance start) + (||> (/.push start) + (/.push (|>> |inc| /.dup |test|)) + /.loop))) + (_.test (%.name (name-of /.while)) + (n.= (n.+ distance start) + (||> (/.push start) + (/.push (|>> /.dup |test|)) + (/.push |inc|) + /.while))) + (_.test (%.name (name-of /.do)) + (n.= (inc sample) + (||> (/.push sample) + (/.push (|>> (/.push false))) + (/.push |inc|) + /.do /.while))) + (_.test (%.name (name-of /.compose)) + (n.= (inc (inc sample)) + (||> (/.push sample) + (/.push |inc|) + (/.push |inc|) + /.compose + /.call))) + (_.test (%.name (name-of /.curry)) + (n.= (n.+ sample sample) + (||> (/.push sample) + (/.push sample) + (/.push (/.apply/2 n.+)) + /.curry + /.call))) + (_.test (%.name (name-of /.when)) + (n.= (if choice + (inc sample) + sample) + (||> (/.push sample) + (/.push choice) + (/.push (/.apply/1 inc)) + /.when))) + (_.test (%.name (name-of /.?)) + (n.= (if choice + (inc sample) + (dec sample)) + (||> (/.push choice) + (/.push (inc sample)) + (/.push (dec sample)) + /.?))) + ))) + +(word: square + (=> [Nat] [Nat]) + + /.dup + (/.apply/2 n.*)) + +(def: definition + Test + (do random.monad + [sample random.nat] + (_.test (%.name (name-of /.word:)) + (n.= (n.* sample sample) + (||> (/.push sample) + ..square))))) + +(def: #export test + Test + (<| (_.context (name.module (name-of /._))) + ($_ _.and + ..stack-shuffling + ..numerical + ..control-flow + ..definition + ))) diff --git a/stdlib/source/test/lux/control/continuation.lux b/stdlib/source/test/lux/control/continuation.lux index 105dccd3f..8d6724614 100644 --- a/stdlib/source/test/lux/control/continuation.lux +++ b/stdlib/source/test/lux/control/continuation.lux @@ -34,8 +34,8 @@ (<| (_.context (%.name (name-of /.Cont))) (do r.monad [sample r.nat - #let [(^open "_;.") /.apply - (^open "_;.") /.monad] + #let [(^open "_@.") /.apply + (^open "_@.") /.monad] elems (r.list 3 r.nat)] ($_ _.and ($functor.spec ..injection ..comparison /.functor) @@ -43,7 +43,7 @@ ($monad.spec ..injection ..comparison /.monad) (_.test "Can run continuations to compute their values." - (n.= sample (/.run (_;wrap sample)))) + (n.= sample (/.run (_@wrap sample)))) (_.test "Can use the current-continuation as a escape hatch." (n.= (n.* 2 sample) @@ -67,14 +67,14 @@ (wrap output)))))) (_.test "Can use delimited continuations with shifting." - (let [(^open "_;.") /.monad - (^open "list;.") (list.equivalence n.equivalence) + (let [(^open "_@.") /.monad + (^open "list@.") (list.equivalence n.equivalence) visit (: (-> (List Nat) (Cont (List Nat) (List Nat))) (function (visit xs) (case xs #.Nil - (_;wrap #.Nil) + (_@wrap #.Nil) (#.Cons x xs') (do /.monad @@ -83,6 +83,6 @@ [tail (k xs')] (wrap (#.Cons x tail)))))] (visit output)))))] - (list;= elems + (list@= elems (/.run (/.reset (visit elems)))))) )))) |