Test for concatenative programming.

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))))))
             ))))