aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/control/concatenative.lux151
-rw-r--r--stdlib/source/lux/data/product.lux2
-rw-r--r--stdlib/source/lux/data/sum.lux19
-rw-r--r--stdlib/source/lux/macro/syntax.lux2
-rw-r--r--stdlib/source/test/lux/control.lux2
-rw-r--r--stdlib/source/test/lux/control/concatenative.lux235
-rw-r--r--stdlib/source/test/lux/control/continuation.lux14
7 files changed, 333 insertions, 92 deletions
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))))))
))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 15:58:42 +0000