aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/paradigm/concatenative.lux333
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 05:23:23 +0000