- Added module for concatenative (stack-based) programming.

1 files changed, 333 insertions, 0 deletions

diff --git a/stdlib/source/lux/paradigm/concatenative.lux b/stdlib/source/lux/paradigm/concatenative.lux
new file mode 100644
index 000000000..0a149ec3b
--- /dev/null
+++ b/stdlib/source/lux/paradigm/concatenative.lux
@@ -0,0 +1,333 @@
+(;module: [lux #- if loop
+           n.+ n.- n.* n./ n.% n.= n.< n.<= n.> n.>=
+           i.+ i.- i.* i./ i.% i.= i.< i.<= i.> i.>=
+           d.+ d.- d.* d./ d.% d.= d.< d.<= d.> d.>=
+           r.+ r.- r.* r./ r.% r.= r.< r.<= r.> r.>=]
+  (lux (control ["p" parser "p/" Monad<Parser>]
+                ["M" monad])
+       (data [text]
+             text/format
+             [maybe "m/" Monad<Maybe>]
+             (coll [list "L/" Fold<List> Functor<List>]))
+       [macro #+ with-gensyms Monad<Lux>]
+       (macro [code]
+              ["s" syntax #+ syntax:]
+              (syntax ["cs" common]
+                      (common ["csr" reader]
+                              ["csw" writer])))))
+
+## [Syntax]
+(type: Alias [Text Code])
+
+(type: Stack
+  {#bottom (Maybe Nat)
+   #top (List Code)})
+
+(def: aliases^
+  (s;Syntax (List Alias))
+  (|> (p;seq s;local-symbol s;any)
+      p;some
+      s;record
+      (p;default (list))))
+
+(def: bottom^
+  (s;Syntax Nat)
+  (s;form (p;after (s;this (` #;Bound)) s;nat)))
+
+(def: stack^
+  (s;Syntax Stack)
+  (p;either (p;seq (p;opt bottom^)
+                   (s;tuple (p;some s;any)))
+            (p;seq (|> bottom^ (p/map (|>. #;Some)))
+                   (p/wrap (list)))))
+
+(def: (stack-fold tops bottom)
+  (-> (List Code) Code Code)
+  (L/fold (function [top bottom]
+            (` [(~ bottom) (~ top)]))
+          bottom
+          tops))
+
+(def: (singleton expander)
+  (-> (Lux (List Code)) (Lux Code))
+  (M;do Monad<Lux>
+    [expansion expander]
+    (case expansion
+      (#;Cons singleton #;Nil)
+      (wrap singleton)
+
+      _
+      (macro;fail (format "Cannot expand to more than a single AST/Code node:\n"
+                          (|> expansion (L/map %code) (text;join-with " ")))))))
+
+(syntax: #export (=> [aliases aliases^]
+                     [inputs stack^]
+                     [outputs stack^])
+  (let [de-alias (function [aliased]
+                   (L/fold (function [[from to] pre]
+                             (code;replace (code;local-symbol from) to pre))
+                           aliased
+                           aliases))]
+    (case [(|> inputs (get@ #bottom) (m/map (|>. code;nat (~) #;Bound (`))))
+           (|> outputs (get@ #bottom) (m/map (|>. code;nat (~) #;Bound (`))))]
+      [(#;Some bottomI) (#;Some bottomO)]
+      (M;do @
+        [inputC (singleton (macro;expand-all (stack-fold (get@ #top inputs) bottomI)))
+         outputC (singleton (macro;expand-all (stack-fold (get@ #top outputs) bottomO)))]
+        (wrap (list (` (-> (~ (de-alias inputC))
+                           (~ (de-alias outputC)))))))
+
+      [?bottomI ?bottomO]
+      (with-gensyms [g!stack]
+        (M;do @
+          [inputC (singleton (macro;expand-all (stack-fold (get@ #top inputs) (default g!stack ?bottomI))))
+           outputC (singleton (macro;expand-all (stack-fold (get@ #top outputs) (default g!stack ?bottomO))))]
+          (wrap (list (` (All [(~ g!stack)]
+                           (-> (~ (de-alias inputC))
+                               (~ (de-alias outputC))))))))))))
+
+(def: #hidden begin! Unit [])
+
+(def: #hidden end!
+  (All [a] (-> [Unit a] a))
+  (function [[_ top]]
+    top))
+
+(def: (prepare command)
+  (-> Code Code)
+  (case command
+    (^or [_ (#;Bool _)]
+         [_ (#;Nat _)]  [_ (#;Int _)]
+         [_ (#;Deg _)]  [_ (#;Real _)]
+         [_ (#;Char _)] [_ (#;Text _)]
+         [_ (#;Tag _)]  (^ [_ (#;Form (list [_ (#;Tag _)]))]))
+    (` (;;push (~ command)))
+
+    [_ (#;Tuple block)]
+    (` (;;push (|>. (~@ (L/map prepare block)))))
+
+    _
+    command))
+
+(syntax: #export (||> [commands (p;some s;any)])
+  (wrap (list (` (|> ;;begin! (~@ (L/map prepare commands)) ;;end!)))))
+
+(syntax: #export (word: [export csr;export] [name s;local-symbol]
+                   [annotations (p;default cs;empty-annotations csr;annotations)]
+                   type
+                   [commands (p;some s;any)])
+  (wrap (list (` (def: (~@ (csw;export export)) (~ (code;local-symbol name))
+                   (~ (csw;annotations annotations))
+                   (~ type)
+                   (|>. (~@ (L/map prepare commands))))))))
+
+(syntax: #export (apply [arity (|> s;nat (p;filter (;n.> +0)))])
+  (with-gensyms [g!func g!stack g!output]
+    (M;do @
+      [g!inputs (|> (macro;gensym "input") (list;repeat arity) (M;seqM @))]
+      (wrap (list (` (: (All [(~@ g!inputs) (~ g!output)]
+                          (-> (-> (~@ g!inputs) (~ g!output))
+                              (=> [(~@ g!inputs)] [(~ g!output)])))
+                        (function [(~ g!func)]
+                          (function [(~ (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 (push x)
+  (All [a] (-> a (=> [] [a])))
+  (function [stack]
+    [stack x]))
+
+(def: #export drop
+  (All [t] (=> [t] []))
+  (function [[stack top]]
+    stack))
+
+(def: #export nip
+  (All [_ a] (=> [_ a] [a]))
+  (function [[[stack _] top]]
+    [stack top]))
+
+(def: #export dup
+  (All [a] (=> [a] [a a]))
+  (function [[stack top]]
+    [[stack top] top]))
+
+(def: #export swap
+  (All [a b] (=> [a b] [b a]))
+  (function [[[stack l] r]]
+    [[stack r] l]))
+
+(def: #export rotL
+  (All [a b c] (=> [a b c] [b c a]))
+  (function [[[[stack a] b] c]]
+    [[[stack b] c] a]))
+
+(def: #export rotR
+  (All [a b c] (=> [a b c] [c a b]))
+  (function [[[[stack a] b] c]]
+    [[[stack c] a] b]))
+
+(def: #export &&
+  (All [a b] (=> [a b] [(& a b)]))
+  (function [[[stack l] r]]
+    [stack [l r]]))
+
+(def: #export ||L
+  (All [a b] (=> [a] [(| a b)]))
+  (function [[stack l]]
+    [stack (+0 l)]))
+
+(def: #export ||R
+  (All [a b] (=> [b] [(| a b)]))
+  (function [[stack r]]
+    [stack (+1 r)]))
+
+(do-template [<input> <output> <word> <func>]
+  [(def: #export <word>
+     (=> [<input> <input>] [<output>])
+     (function [[[stack subject] param]]
+       [stack (<func> param subject)]))]
+
+  [Nat Nat  n.+  ;n.+]
+  [Nat Nat  n.-  ;n.-]
+  [Nat Nat  n.*  ;n.*]
+  [Nat Nat  n./  ;n./]
+  [Nat Nat  n.%  ;n.%]
+  [Nat Bool n.=  ;n.=]
+  [Nat Bool n.<  ;n.<]
+  [Nat Bool n.<= ;n.<=]
+  [Nat Bool n.>  ;n.>]
+  [Nat Bool n.>= ;n.>=]
+
+  [Int Int  i.+  ;i.+]
+  [Int Int  i.-  ;i.-]
+  [Int Int  i.*  ;i.*]
+  [Int Int  i./  ;i./]
+  [Int Int  i.%  ;i.%]
+  [Int Bool i.=  ;i.=]
+  [Int Bool i.<  ;i.<]
+  [Int Bool i.<= ;i.<=]
+  [Int Bool i.>  ;i.>]
+  [Int Bool i.>= ;i.>=]
+
+  [Deg Deg  d.+  ;d.+]
+  [Deg Deg  d.-  ;d.-]
+  [Deg Deg  d.*  ;d.*]
+  [Deg Deg  d./  ;d./]
+  [Deg Deg  d.%  ;d.%]
+  [Deg Bool d.=  ;d.=]
+  [Deg Bool d.<  ;d.<]
+  [Deg Bool d.<= ;d.<=]
+  [Deg Bool d.>  ;d.>]
+  [Deg Bool d.>= ;d.>=]
+
+  [Real Real r.+  ;r.+]
+  [Real Real r.-  ;r.-]
+  [Real Real r.*  ;r.*]
+  [Real Real r./  ;r./]
+  [Real Real r.%  ;r.%]
+  [Real Bool r.=  ;r.=]
+  [Real Bool r.<  ;r.<]
+  [Real Bool r.<= ;r.<=]
+  [Real Bool r.>  ;r.>]
+  [Real Bool r.>= ;r.>=]
+  )
+
+(def: #export if
+  (All [..a ..b]
+    (=> {then (=> ..a ..b)
+         else (=> ..a ..b)}
+        ..a [Bool then else] ..b))
+  (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)))
+
+(def: #export loop
+  (All [...]
+    (=> {test (=> ... ... [Bool])}
+        ... [test] ...))
+  (function loop [[stack pred]]
+    (let [[stack' verdict] (pred stack)]
+      (;if verdict
+        (loop [stack' pred])
+        stack'))))
+
+(def: #export dip
+  (All [... a]
+    (=> ... [a (=> ... ...)]
+        ... [a]))
+  (function [[[stack a] quote]]
+    [(quote stack) a]))
+
+(def: #export dip2
+  (All [... a b]
+    (=> ... [a b (=> ... ...)]
+        ... [a b]))
+  (function [[[[stack a] b] quote]]
+    [[(quote stack) a] b]))
+
+(def: #export do
+  (All [..a ..b]
+    (=> {pred (=> ..a ..b [Bool])
+         body (=> ..b ..a)}
+        ..b [pred body]
+        ..a [pred body]))
+  (function [[[stack pred] body]]
+    [[(body stack) pred] body]))
+
+(def: #export while
+  (All [..a ..b]
+    (=> {pred (=> ..a ..b [Bool])
+         body (=> ..b ..a)}
+        ..a [pred body]
+        ..b))
+  (function while [[[stack pred] body]]
+    (let [[stack' verdict] (pred stack)]
+      (;if verdict
+        (while [[(body stack') pred] body])
+        stack'))))
+
+(def: #export compose
+  (All [..a ..b ..c]
+    (=> [(=> ..a ..b) (=> ..b ..c)]
+        [(=> ..a ..c)]))
+  (function [[[stack f] g]]
+    [stack (|>. f g)]))
+
+(def: #export curry
+  (All [..a ..b a]
+    (=> ..a [a (=> ..a [a] ..b)]
+        ..a [(=> ..a ..b)]))
+  (function [[[stack arg] quote]]
+    [stack (|>. (push arg) quote)]))
+
+## [Words]
+(word: #export when
+  (All [...]
+    (=> {body (=> ... ...)}
+        ... [Bool body]
+        ...))
+  swap [call] [drop] if)
+
+(word: #export ?
+  (All [a]
+    (=> [Bool a a] [a]))
+  rotL [drop] [nip] if)