diff options
| -rw-r--r-- | stdlib/source/lux/paradigm/concatenative.lux | 333 |
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) |