aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/control/concatenative.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux/control/concatenative.lux')
-rw-r--r--stdlib/source/lux/control/concatenative.lux330
1 files changed, 0 insertions, 330 deletions
diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux
deleted file mode 100644
index 51c2604b6..000000000
--- a/stdlib/source/lux/control/concatenative.lux
+++ /dev/null
@@ -1,330 +0,0 @@
-(.module:
- [lux (#- Alias if loop)
- ["." meta]
- [abstract
- ["." monad]]
- [data
- ["." maybe ("#\." monad)]
- ["." text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#\." fold functor)]]]
- ["." macro (#+ with_gensyms)
- ["." code]
- [syntax (#+ syntax:)
- ["|.|" export]
- ["|.|" annotations]]]
- [math
- [number
- ["n" nat]
- ["i" int]
- ["r" rev]
- ["f" frac]]]]
- [//
- ["<>" parser ("#\." monad)
- ["<c>" code (#+ Parser)]]])
-
-(type: Alias [Text Code])
-
-(type: Stack
- {#bottom (Maybe Nat)
- #top (List Code)})
-
-(def: aliases^
- (Parser (List Alias))
- (|> (<>.and <c>.local_identifier <c>.any)
- <>.some
- <c>.record
- (<>.default (list))))
-
-(def: bottom^
- (Parser Nat)
- (<c>.form (<>.after (<c>.this! (` #.Parameter)) <c>.nat)))
-
-(def: stack^
- (Parser Stack)
- (<>.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)
- (` [(~ bottom) (~ top)]))
- bottom
- tops))
-
-(def: (singleton expander)
- (-> (Meta (List Code)) (Meta Code))
- (monad.do meta.monad
- [expansion expander]
- (case expansion
- (#.Cons singleton #.Nil)
- (wrap singleton)
-
- _
- (meta.fail (format "Cannot expand to more than a single AST/Code node:" text.new_line
- (|> 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)
- (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 (`))))]
- [(#.Some bottomI) (#.Some bottomO)]
- (monad.do meta.monad
- [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]
- (monad.do meta.monad
- [inputC (singleton (macro.expand_all (stack_fold (get@ #top inputs) (maybe.default g!stack ?bottomI))))
- outputC (singleton (macro.expand_all (stack_fold (get@ #top outputs) (maybe.default g!stack ?bottomO))))]
- (wrap (list (` (All [(~ g!stack)]
- (-> (~ (de_alias inputC))
- (~ (de_alias outputC))))))))))))
-
-(def: begin! Any [])
-
-(def: end!
- (All [a] (-> [Any a] a))
- (function (_ [_ top])
- top))
-
-(syntax: #export (||> {commands (<>.some <c>.any)})
- (wrap (list (` (|> (~! ..begin!) (~+ commands) ((~! ..end!)))))))
-
-(syntax: #export (word:
- {export |export|.parser}
- {name <c>.local_identifier}
- {annotations (<>.default |annotations|.empty |annotations|.parser)}
- type
- {commands (<>.some <c>.any)})
- (wrap (list (` (def: (~+ (|export|.format export)) (~ (code.local_identifier name))
- (~ (|annotations|.format annotations))
- (~ type)
- (|>> (~+ commands)))))))
-
-(syntax: #export (apply {arity (|> <c>.nat (<>.filter (n.> 0)))})
- (with_gensyms [g! g!func g!stack g!output]
- (monad.do {! meta.monad}
- [g!inputs (|> (macro.gensym "input") (list.repeat arity) (monad.seq !))]
- (wrap (list (` (: (All [(~+ g!inputs) (~ g!output)]
- (-> (-> (~+ g!inputs) (~ g!output))
- (=> [(~+ g!inputs)] [(~ g!output)])))
- (function ((~ g!) (~ g!func))
- (function ((~ g!) (~ (stack_fold g!inputs g!stack)))
- [(~ g!stack) ((~ g!func) (~+ g!inputs))])))))))))
-
-(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])))
- (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 #0 l)]))
-
-(def: #export ||R
- (All [a b] (=> [b] [(| a b)]))
- (function (_ [stack r])
- [stack (0 #1 r)]))
-
-(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 Bit n/= n.=]
- [Nat Bit n/< n.<]
- [Nat Bit n/<= n.<=]
- [Nat Bit n/> n.>]
- [Nat Bit n/>= n.>=]
-
- [Int Int i/+ i.+]
- [Int Int i/- i.-]
- [Int Int i/* i.*]
- [Int Int i// i./]
- [Int Int i/% i.%]
- [Int Bit i/= i.=]
- [Int Bit i/< i.<]
- [Int Bit i/<= i.<=]
- [Int Bit i/> i.>]
- [Int Bit i/>= i.>=]
-
- [Rev Rev r/+ r.+]
- [Rev Rev r/- r.-]
- [Rev Rev r/* r.*]
- [Rev Rev r// r./]
- [Rev Rev r/% r.%]
- [Rev Bit r/= r.=]
- [Rev Bit r/< r.<]
- [Rev Bit r/<= r.<=]
- [Rev Bit r/> r.>]
- [Rev Bit r/>= r.>=]
-
- [Frac Frac f/+ f.+]
- [Frac Frac f/- f.-]
- [Frac Frac f/* f.*]
- [Frac Frac f// f./]
- [Frac Frac f/% f.%]
- [Frac Bit f/= f.=]
- [Frac Bit f/< f.<]
- [Frac Bit f/<= f.<=]
- [Frac Bit f/> f.>]
- [Frac Bit f/>= f.>=]
- )
-
-(def: #export if
- (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 ___z]
- (=> {quote (=> ___a ___z)}
- ___a [quote] ___z))
- (function (_ [stack quote])
- (quote stack)))
-
-(def: #export loop
- (All [___]
- (=> {test (=> ___ ___ [Bit])}
- ___ [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 dip/2
- (All [___ a b]
- (=> ___ [a b (=> ___ ___)]
- ___ [a b]))
- (function (_ [[[stack a] b] quote])
- [[(quote stack) a] b]))
-
-(def: #export do
- (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 ___z]
- (=> {body (=> ___z ___a)
- pred (=> ___a ___z [Bit])}
- ___a [pred body]
- ___z))
- (function (while [[stack pred] body])
- (let [[stack' verdict] (pred stack)]
- (.if verdict
- (while [[(body stack') pred] body])
- stack'))))
-
-(def: #export compose
- (All [___a ___ ___z]
- (=> [(=> ___a ___) (=> ___ ___z)]
- [(=> ___a ___z)]))
- (function (_ [[stack f] g])
- [stack (|>> f g)]))
-
-(def: #export curry
- (All [___a ___z a]
- (=> ___a [a (=> ___a [a] ___z)]
- ___a [(=> ___a ___z)]))
- (function (_ [[stack arg] quote])
- [stack (|>> (push arg) quote)]))
-
-(word: #export when
- (All [___]
- (=> {body (=> ___ ___)}
- ___ [Bit body]
- ___))
- swap
- (push (|>> call))
- (push (|>> drop))
- if)
-
-(word: #export ?
- (All [a]
- (=> [Bit a a] [a]))
- rotL
- (push (|>> drop))
- (push (|>> nip))
- if)
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-24 10:52:20 +0000