aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2017-06-21 19:10:24 -0400
committerEduardo Julian2017-06-21 19:10:24 -0400
commitd0ec271e90a2be17d2ad5f5e23b0bb3006602bc8 (patch)
tree7dc817999ab1da7916d663838f574e670c8c1c15
parent4a94a3dab463857fb1e881d4ab835ef5351ba9ac (diff)
- CLI, Syntax and Lexer are now based upon a common Parser type.
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/cli.lux194
-rw-r--r--stdlib/source/lux/concurrency/actor.lux23
-rw-r--r--stdlib/source/lux/concurrency/frp.lux5
-rw-r--r--stdlib/source/lux/concurrency/promise.lux5
-rw-r--r--stdlib/source/lux/control/effect.lux31
-rw-r--r--stdlib/source/lux/control/parser.lux248
-rw-r--r--stdlib/source/lux/control/pipe.lux19
-rw-r--r--stdlib/source/lux/data/coll/seq.lux5
-rw-r--r--stdlib/source/lux/data/coll/stream.lux5
-rw-r--r--stdlib/source/lux/data/coll/tree/rose.lux11
-rw-r--r--stdlib/source/lux/data/coll/vector.lux5
-rw-r--r--stdlib/source/lux/data/format/json.lux207
-rw-r--r--stdlib/source/lux/data/format/xml.lux143
-rw-r--r--stdlib/source/lux/data/number/complex.lux5
-rw-r--r--stdlib/source/lux/data/number/ratio.lux5
-rw-r--r--stdlib/source/lux/data/text/format.lux5
-rw-r--r--stdlib/source/lux/data/text/lexer.lux323
-rw-r--r--stdlib/source/lux/data/text/regex.lux405
-rw-r--r--stdlib/source/lux/host.js.lux11
-rw-r--r--stdlib/source/lux/host.jvm.lux235
-rw-r--r--stdlib/source/lux/macro/poly.lux13
-rw-r--r--stdlib/source/lux/macro/syntax.lux254
-rw-r--r--stdlib/source/lux/macro/syntax/common/reader.lux51
-rw-r--r--stdlib/source/lux/math.lux37
-rw-r--r--stdlib/source/lux/math/simple.lux25
-rw-r--r--stdlib/source/lux/test.lux15
-rw-r--r--stdlib/source/lux/type/auto.lux7
-rw-r--r--stdlib/test/test/lux/cli.lux70
-rw-r--r--stdlib/test/test/lux/control/parser.lux183
-rw-r--r--stdlib/test/test/lux/data/text/lexer.lux161
-rw-r--r--stdlib/test/test/lux/data/text/regex.lux11
-rw-r--r--stdlib/test/test/lux/macro/syntax.lux153
-rw-r--r--stdlib/test/tests.lux9
33 files changed, 1252 insertions, 1627 deletions
diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux
index 6883811a6..0ea898ed8 100644
--- a/stdlib/source/lux/cli.lux
+++ b/stdlib/source/lux/cli.lux
@@ -1,63 +1,39 @@
(;module:
- [lux #- not]
+ lux
(lux (control functor
applicative
- monad)
- (data (coll (list #as list #open ("List/" Monoid<List> Monad<List>)))
- (text #as text #open ("Text/" Monoid<Text>))
+ monad
+ ["p" parser])
+ (data (coll [list "L/" Monoid<List> Monad<List>])
+ [text "T/" Monoid<Text>]
+ text/format
["R" result]
- (sum #as sum))
+ [sum])
[io]
[macro #+ with-gensyms Functor<Lux> Monad<Lux>]
(macro [code]
["s" syntax #+ syntax: Syntax])))
## [Types]
-(type: #export (CLI a)
+(type: #export CLI
{#;doc "A command-line interface parser."}
- (-> (List Text) (R;Result [(List Text) a])))
+ (p;Parser (List Text)))
-## [Utils]
-(def: (run' opt inputs)
- (All [a] (-> (CLI a) (List Text) (R;Result [(List Text) a])))
- (opt inputs))
-
-## [Structures]
-(struct: #export _ (Functor CLI)
- (def: (map f ma inputs)
- (case (ma inputs)
- (#R;Error msg) (#R;Error msg)
- (#R;Success [inputs' datum]) (#R;Success [inputs' (f datum)]))))
-
-(struct: #export _ (Applicative CLI)
- (def: functor Functor<CLI>)
-
- (def: (wrap a inputs)
- (#R;Success [inputs a]))
-
- (def: (apply ff fa inputs)
- (case (ff inputs)
- (#R;Success [inputs' f])
- (case (fa inputs')
- (#R;Success [inputs'' a])
- (#R;Success [inputs'' (f a)])
-
- (#R;Error msg)
- (#R;Error msg))
-
- (#R;Error msg)
- (#R;Error msg))
- ))
+## [Combinators]
+(def: #export (run inputs parser)
+ (All [a] (-> (List Text) (CLI a) (R;Result a)))
+ (case (p;run inputs parser)
+ (#R;Success [remaining output])
+ (case remaining
+ #;Nil
+ (#R;Success output)
-(struct: #export _ (Monad CLI)
- (def: applicative Applicative<CLI>)
+ _
+ (#R;Error (format "Remaining CLI inputs: " (text;join-with " " remaining))))
- (def: (join mma inputs)
- (case (mma inputs)
- (#R;Error msg) (#R;Error msg)
- (#R;Success [inputs' ma]) (ma inputs'))))
+ (#R;Error error)
+ (#R;Error error)))
-## [Combinators]
(def: #export any
{#;doc "Just returns the next input without applying any logic."}
(CLI Text)
@@ -92,13 +68,13 @@
(let [[pre post] (list;split-with (. ;not (list;member? text;Eq<Text> names)) inputs)]
(case post
#;Nil
- (#R;Error ($_ Text/append "Missing option (" (text;join-with " " names) ")"))
+ (#R;Error ($_ T/append "Missing option (" (text;join-with " " names) ")"))
(^ (list& _ value post'))
- (#R;Success [(List/append pre post') value])
+ (#R;Success [(L/append pre post') value])
_
- (#R;Error ($_ Text/append "Option lacks value (" (text;join-with " " names) ")"))
+ (#R;Error ($_ T/append "Option lacks value (" (text;join-with " " names) ")"))
))))
(def: #export (flag names)
@@ -111,7 +87,7 @@
(#R;Success [pre false])
(#;Cons _ post')
- (#R;Success [(List/append pre post') true])))))
+ (#R;Success [(L/append pre post') true])))))
(def: #export end
{#;doc "Ensures there are no more inputs."}
@@ -119,111 +95,7 @@
(function [inputs]
(case inputs
#;Nil (#R;Success [inputs []])
- _ (#R;Error (Text/append "Unknown parameters: " (text;join-with " " inputs))))))
-
-(def: #export (after param subject)
- (All [p s] (-> (CLI p) (CLI s) (CLI s)))
- (do Monad<CLI>
- [_ param]
- subject))
-
-(def: #export (before param subject)
- (All [p s] (-> (CLI p) (CLI s) (CLI s)))
- (do Monad<CLI>
- [output subject
- _ param]
- (wrap output)))
-
-(def: #export (assert message test)
- {#;doc "Fails with the given message if the test is false."}
- (-> Text Bool (CLI Unit))
- (function [inputs]
- (if test
- (#R;Success [inputs []])
- (#R;Error message))))
-
-(def: #export (opt opt)
- {#;doc "Optionality combinator."}
- (All [a]
- (-> (CLI a) (CLI (Maybe a))))
- (function [inputs]
- (case (opt inputs)
- (#R;Error _) (#R;Success [inputs #;None])
- (#R;Success [inputs' x]) (#R;Success [inputs' (#;Some x)]))))
-
-(def: #export (seq optL optR)
- {#;doc "Sequencing combinator."}
- (All [a b] (-> (CLI a) (CLI b) (CLI [a b])))
- (do Monad<CLI>
- [l optL
- r optR]
- (wrap [l r])))
-
-(def: #export (alt optL optR)
- {#;doc "Heterogeneous alternative combinator."}
- (All [a b] (-> (CLI a) (CLI b) (CLI (| a b))))
- (function [inputs]
- (case (optL inputs)
- (#R;Error msg)
- (case (optR inputs)
- (#R;Error _)
- (#R;Error msg)
-
- (#R;Success [inputs' r])
- (#R;Success [inputs' (sum;right r)]))
-
- (#R;Success [inputs' l])
- (#R;Success [inputs' (sum;left l)]))))
-
-(def: #export (not opt)
- {#;doc "The opposite of the given CLI."}
- (All [a] (-> (CLI a) (CLI Unit)))
- (function [inputs]
- (case (opt inputs)
- (#R;Error msg)
- (#R;Success [inputs []])
-
- _
- (#R;Error "Expected to fail; yet succeeded."))))
-
-(def: #export (some opt)
- {#;doc "0-or-more combinator."}
- (All [a]
- (-> (CLI a) (CLI (List a))))
- (function [inputs]
- (case (opt inputs)
- (#R;Error _) (#R;Success [inputs (list)])
- (#R;Success [inputs' x]) (run' (do Monad<CLI>
- [xs (some opt)]
- (wrap (list& x xs)))
- inputs'))))
-
-(def: #export (many opt)
- {#;doc "1-or-more combinator."}
- (All [a]
- (-> (CLI a) (CLI (List a))))
- (do Monad<CLI>
- [x opt
- xs (some opt)]
- (wrap (list& x xs))))
-
-(def: #export (either pl pr)
- {#;doc "Homogeneous alternative combinator."}
- (All [a]
- (-> (CLI a) (CLI a) (CLI a)))
- (function [inputs]
- (case (pl inputs)
- (#R;Error _) (pr inputs)
- output output)))
-
-(def: #export (run opt inputs)
- (All [a] (-> (CLI a) (List Text) (R;Result a)))
- (case (opt inputs)
- (#R;Error msg)
- (#R;Error msg)
-
- (#R;Success [_ value])
- (#R;Success value)))
+ _ (#R;Error (T/append "Unknown parameters: " (text;join-with " " inputs))))))
## [Syntax]
(type: Program-Args
@@ -232,11 +104,11 @@
(def: program-args^
(Syntax Program-Args)
- (s;alt s;local-symbol
- (s;form (s;some (s;either (do s;Monad<Syntax>
+ (p;alt s;local-symbol
+ (s;form (p;some (p;either (do p;Monad<Parser>
[name s;local-symbol]
(wrap [(code;symbol ["" name]) (` any)]))
- (s;tuple (s;seq s;any s;any)))))))
+ (s;tuple (p;seq s;any s;any)))))))
(syntax: #export (program: [args program-args^] body)
{#;doc (doc "Defines the entry-point to a program (similar to the \"main\" function/method in other programming languages)."
@@ -248,7 +120,7 @@
(wrap [])))
(program: (name)
- (io (log! (Text/append "Hello, " name))))
+ (io (log! (T/append "Hello, " name))))
(program: ([config config^])
(do Monad<IO>
@@ -265,9 +137,9 @@
(case ((: (;;CLI (io;IO Unit))
(do ;;Monad<CLI>
[(~@ (|> args
- (List/map (function [[binding parser]]
- (list binding parser)))
- List/join))
+ (L/map (function [[binding parser]]
+ (list binding parser)))
+ L/join))
(~ g!_) ;;end]
((~' wrap) (~ body))))
(~ g!args))
diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux
index 9062feb73..5f75dc912 100644
--- a/stdlib/source/lux/concurrency/actor.lux
+++ b/stdlib/source/lux/concurrency/actor.lux
@@ -1,6 +1,7 @@
(;module: {#;doc "The actor model of concurrency."}
lux
- (lux (control monad)
+ (lux (control monad
+ ["p" parser])
[io #- run]
function
(data ["R" result]
@@ -150,12 +151,12 @@
(def: method^
(Syntax Method)
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[_ (s;this (' method:))
- vars (s;default (list) (s;tuple (s;some s;local-symbol)))
- [name args] (s;form ($_ s;seq
+ vars (p;default (list) (s;tuple (p;some s;local-symbol)))
+ [name args] (s;form ($_ p;seq
s;local-symbol
- (s;many csr;typed-input)
+ (p;many csr;typed-input)
))
return s;any
body s;any]
@@ -167,15 +168,15 @@
(def: stop^
(Syntax Code)
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[_ (s;this (' stop:))]
s;any)))
(def: actor-decl^
(Syntax [(List Text) Text (List [Text Code])])
- (s;seq (s;default (list) (s;tuple (s;some s;local-symbol)))
- (s;either (s;form (s;seq s;local-symbol (s;many csr;typed-input)))
- (s;seq s;local-symbol (:: s;Monad<Syntax> wrap (list))))))
+ (p;seq (p;default (list) (s;tuple (p;some s;local-symbol)))
+ (p;either (s;form (p;seq s;local-symbol (p;many csr;typed-input)))
+ (p;seq s;local-symbol (:: p;Monad<Parser> wrap (list))))))
(def: (actor-def-decl [_vars _name _args] return-type)
(-> [(List Text) Text (List [Text Code])] Code (List Code))
@@ -195,8 +196,8 @@
(syntax: #export (actor: [_ex-lev csr;export]
[(^@ decl [_vars _name _args]) actor-decl^]
state-type
- [methods (s;many method^)]
- [?stop (s;opt stop^)])
+ [methods (p;many method^)]
+ [?stop (p;opt stop^)])
{#;doc (doc "Allows defining an actor, with a pice of state and a set of methods that can be called on it."
"A method can access the actor's state through the *state* variable."
"A method can also access the actor itself through the *self* variable."
diff --git a/stdlib/source/lux/concurrency/frp.lux b/stdlib/source/lux/concurrency/frp.lux
index 914351d22..f71cf1797 100644
--- a/stdlib/source/lux/concurrency/frp.lux
+++ b/stdlib/source/lux/concurrency/frp.lux
@@ -3,7 +3,8 @@
(lux (control functor
applicative
monad
- eq)
+ eq
+ ["p" parser])
[io #- run]
(data (coll [list "L/" Monoid<List>])
text/format)
@@ -19,7 +20,7 @@
(&;Promise (Maybe [a (Chan a)])))
## [Syntax]
-(syntax: #export (chan [?type (s;opt s;any)])
+(syntax: #export (chan [?type (p;opt s;any)])
{#;doc (doc "Makes an uninitialized Chan (in this case, of Unit)."
(chan Unit)
diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux
index a6c814c5a..f2a7ffc05 100644
--- a/stdlib/source/lux/concurrency/promise.lux
+++ b/stdlib/source/lux/concurrency/promise.lux
@@ -7,7 +7,8 @@
function
(control functor
applicative
- monad)
+ monad
+ ["p" parser])
[macro]
(macro ["s" syntax #+ syntax: Syntax])
(concurrency [atom #+ Atom atom])
@@ -30,7 +31,7 @@
(atom {#value ?value
#observers (list)}))
-(syntax: #export (promise [?type (s;opt s;any)])
+(syntax: #export (promise [?type (p;opt s;any)])
{#;doc (doc "Makes an uninitialized Promise (in this example, of Unit)."
(promise Unit)
diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux
index 939bd28f5..457519442 100644
--- a/stdlib/source/lux/control/effect.lux
+++ b/stdlib/source/lux/control/effect.lux
@@ -2,7 +2,8 @@
lux
(lux (control ["F" functor]
applicative
- ["M" monad #*])
+ ["M" monad #*]
+ ["p" parser])
[io #- run]
(data (coll [list "List/" Monad<List> Monoid<List>])
[number "Nat/" Codec<Text,Nat>]
@@ -55,19 +56,19 @@
))))
## [Syntax]
-(syntax: #export (|E [effects (s;many s;any)])
+(syntax: #export (|E [effects (p;many s;any)])
{#;doc (doc "A way to combine smaller effect into a larger effect."
(type: EffABC (|E EffA EffB EffC)))}
(wrap (list (` ($_ ;;|@ (~@ effects))))))
-(syntax: #export (|F [functors (s;many s;any)])
+(syntax: #export (|F [functors (p;many s;any)])
{#;doc (doc "A way to combine smaller effect functors into a larger functor."
(def: Functor<EffABC>
(Functor EffABC)
(|F Functor<EffA> Functor<EffB> Functor<EffC>)))}
(wrap (list (` ($_ ;;combine-functors (~@ functors))))))
-(syntax: #export (|H monad [handlers (s;many s;any)])
+(syntax: #export (|H monad [handlers (p;many s;any)])
{#;doc (doc "A way to combine smaller effect handlers into a larger handler."
(def: Handler<EffABC,IO>
(Handler EffABC io;IO)
@@ -85,18 +86,18 @@
(def: op^
(Syntax Op)
- (s;form (s;either ($_ s;seq
+ (s;form (p;either ($_ p;seq
s;local-symbol
- (s;tuple (s;some s;any))
+ (s;tuple (p;some s;any))
s;any)
- ($_ s;seq
+ ($_ p;seq
s;local-symbol
- (:: s;Monad<Syntax> wrap (list))
+ (:: p;Monad<Parser> wrap (list))
s;any))))
(syntax: #export (effect: [exp-lvl csr;export]
[name s;local-symbol]
- [ops (s;many op^)])
+ [ops (p;many op^)])
{#;doc (doc "Define effects by specifying which operations and constants a handler must provide."
(effect: #export EffA
(opA [Nat Text] Bool)
@@ -153,16 +154,16 @@
(def: translation^
(Syntax Translation)
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[_ (s;this (' =>))]
- (s;seq s;symbol
- (s;tuple (s;seq s;any
+ (p;seq s;symbol
+ (s;tuple (p;seq s;any
s;any))))))
(syntax: #export (handler: [exp-lvl csr;export]
[name s;local-symbol]
[[effect target-type target-monad] translation^]
- [defs (s;many (csr;definition *compiler*))])
+ [defs (p;many (csr;definition *compiler*))])
{#;doc (doc "Define effect handlers by implementing the operations and values of an effect."
(handler: _
(=> EffA [IO Monad<IO>])
@@ -245,7 +246,7 @@
(def: g!functor Code (code;symbol ["" "\t@E\t"]))
-(syntax: #export (doE functor [bindings (s;tuple (s;some s;any))] body)
+(syntax: #export (doE functor [bindings (s;tuple (p;some s;any))] body)
{#;doc (doc "An alternative to the 'do' macro for monads."
(with-handler Handler<EffABC,IO>
(doE Functor<EffABC>
@@ -305,7 +306,7 @@
(` (+1 (~ base)))
))
-(syntax: #export (lift [value (s;alt s;symbol
+(syntax: #export (lift [value (p;alt s;symbol
s;any)])
{#;doc (doc "A way to (automatically) lift effectful fields and operations from simple effects into the larger space of composite effects."
(with-handler Handler<EffABC,IO>
diff --git a/stdlib/source/lux/control/parser.lux b/stdlib/source/lux/control/parser.lux
new file mode 100644
index 000000000..71b4377d9
--- /dev/null
+++ b/stdlib/source/lux/control/parser.lux
@@ -0,0 +1,248 @@
+(;module:
+ [lux #- not default]
+ (lux (control functor
+ applicative
+ monad)
+ (data (coll [list "L/" Functor<List> Monoid<List>])
+ [product]
+ ["R" result])))
+
+(type: #export (Parser s a)
+ {#;doc "A generic parser."}
+ (-> s (R;Result [s a])))
+
+## [Structures]
+(struct: #export Functor<Parser> (All [s] (Functor (Parser s)))
+ (def: (map f ma)
+ (function [input]
+ (case (ma input)
+ (#R;Error msg)
+ (#R;Error msg)
+
+ (#R;Success [input' a])
+ (#R;Success [input' (f a)])))))
+
+(struct: #export Applicative<Parser> (All [s] (Applicative (Parser s)))
+ (def: functor Functor<Parser>)
+
+ (def: (wrap x)
+ (function [input]
+ (#R;Success [input x])))
+
+ (def: (apply ff fa)
+ (function [input]
+ (case (ff input)
+ (#R;Success [input' f])
+ (case (fa input')
+ (#R;Success [input'' a])
+ (#R;Success [input'' (f a)])
+
+ (#R;Error msg)
+ (#R;Error msg))
+
+ (#R;Error msg)
+ (#R;Error msg)))))
+
+(struct: #export Monad<Parser> (All [s] (Monad (Parser s)))
+ (def: applicative Applicative<Parser>)
+
+ (def: (join mma)
+ (function [input]
+ (case (mma input)
+ (#R;Error msg)
+ (#R;Error msg)
+
+ (#R;Success [input' ma])
+ (ma input')))))
+
+## [Parsers]
+(def: #export (assert message test)
+ {#;doc "Fails with the given message if the test is false."}
+ (All [s] (-> Text Bool (Parser s Unit)))
+ (function [input]
+ (if test
+ (#R;Success [input []])
+ (#R;Error message))))
+
+(def: #export (opt p)
+ {#;doc "Optionality combinator."}
+ (All [s a]
+ (-> (Parser s a) (Parser s (Maybe a))))
+ (function [input]
+ (case (p input)
+ (#R;Error _) (#R;Success [input #;None])
+ (#R;Success [input' x]) (#R;Success [input' (#;Some x)]))))
+
+(def: #export (run input p)
+ (All [s a]
+ (-> s (Parser s a) (R;Result [s a])))
+ (p input))
+
+(def: #export (some p)
+ {#;doc "0-or-more combinator."}
+ (All [s a]
+ (-> (Parser s a) (Parser s (List a))))
+ (function [input]
+ (case (p input)
+ (#R;Error _) (#R;Success [input (list)])
+ (#R;Success [input' x]) (run input'
+ (do Monad<Parser>
+ [xs (some p)]
+ (wrap (list& x xs)))
+ ))))
+
+(def: #export (many p)
+ {#;doc "1-or-more combinator."}
+ (All [s a]
+ (-> (Parser s a) (Parser s (List a))))
+ (do Monad<Parser>
+ [x p
+ xs (some p)]
+ (wrap (list& x xs))))
+
+(def: #export (seq p1 p2)
+ {#;doc "Sequencing combinator."}
+ (All [s a b]
+ (-> (Parser s a) (Parser s b) (Parser s [a b])))
+ (do Monad<Parser>
+ [x1 p1
+ x2 p2]
+ (wrap [x1 x2])))
+
+(def: #export (alt p1 p2)
+ {#;doc "Heterogeneous alternative combinator."}
+ (All [s a b]
+ (-> (Parser s a) (Parser s b) (Parser s (| a b))))
+ (function [tokens]
+ (case (p1 tokens)
+ (#R;Success [tokens' x1]) (#R;Success [tokens' (+0 x1)])
+ (#R;Error _) (run tokens
+ (do Monad<Parser>
+ [x2 p2]
+ (wrap (+1 x2))))
+ )))
+
+(def: #export (either pl pr)
+ {#;doc "Homogeneous alternative combinator."}
+ (All [s a]
+ (-> (Parser s a) (Parser s a) (Parser s a)))
+ (function [tokens]
+ (case (pl tokens)
+ (#R;Error _) (pr tokens)
+ output output
+ )))
+
+(def: #export (exactly n p)
+ {#;doc "Parse exactly N times."}
+ (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
+ (if (n.> +0 n)
+ (do Monad<Parser>
+ [x p
+ xs (exactly (n.dec n) p)]
+ (wrap (#;Cons x xs)))
+ (:: Monad<Parser> wrap (list))))
+
+(def: #export (at-least n p)
+ {#;doc "Parse at least N times."}
+ (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
+ (do Monad<Parser>
+ [min (exactly n p)
+ extra (some p)]
+ (wrap (L/append min extra))))
+
+(def: #export (at-most n p)
+ {#;doc "Parse at most N times."}
+ (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
+ (if (n.> +0 n)
+ (function [input]
+ (case (p input)
+ (#R;Error msg)
+ (#R;Success [input (list)])
+
+ (#R;Success [input' x])
+ (run input'
+ (do Monad<Parser>
+ [xs (at-most (n.dec n) p)]
+ (wrap (#;Cons x xs))))
+ ))
+ (:: Monad<Parser> wrap (list))))
+
+(def: #export (between from to p)
+ {#;doc "Parse between N and M times."}
+ (All [s a] (-> Nat Nat (Parser s a) (Parser s (List a))))
+ (do Monad<Parser>
+ [min-xs (exactly from p)
+ max-xs (at-most (n.- from to) p)]
+ (wrap (:: list;Monad<List> join (list min-xs max-xs)))))
+
+(def: #export (sep-by sep p)
+ {#;doc "Parsers instances of 'p' that are separated by instances of 'sep'."}
+ (All [s a b] (-> (Parser s b) (Parser s a) (Parser s (List a))))
+ (do Monad<Parser>
+ [?x (opt p)]
+ (case ?x
+ #;None
+ (wrap #;Nil)
+
+ (#;Some x)
+ (do @
+ [xs' (some (seq sep p))]
+ (wrap (#;Cons x (L/map product;right xs'))))
+ )))
+
+(def: #export (not p)
+ (All [s a] (-> (Parser s a) (Parser s Unit)))
+ (function [input]
+ (case (p input)
+ (#R;Error msg)
+ (#R;Success [input []])
+
+ _
+ (#R;Error "Expected to fail; yet succeeded."))))
+
+(def: #export (fail message)
+ (All [s a] (-> Text (Parser s a)))
+ (function [input]
+ (#R;Error message)))
+
+(def: #export (default value parser)
+ {#;doc "If the given parser fails, returns the default value."}
+ (All [s a] (-> a (Parser s a) (Parser s a)))
+ (function [input]
+ (case (parser input)
+ (#R;Error error)
+ (#R;Success [input value])
+
+ (#R;Success [input' output])
+ (#R;Success [input' output]))))
+
+(def: #export remaining
+ (All [s] (Parser s s))
+ (function [inputs]
+ (#R;Success [inputs inputs])))
+
+(def: #export (rec parser)
+ {#;doc "Combinator for recursive parser."}
+ (All [s a] (-> (-> (Parser s a) (Parser s a)) (Parser s a)))
+ (function [inputs]
+ (run inputs (parser (rec parser)))))
+
+(def: #export (after param subject)
+ (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a)))
+ (do Monad<Parser>
+ [_ param]
+ subject))
+
+(def: #export (before param subject)
+ (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a)))
+ (do Monad<Parser>
+ [output subject
+ _ param]
+ (wrap output)))
+
+(def: #export (constrain test parser)
+ (All [s a] (-> (-> a Bool) (Parser s a) (Parser s a)))
+ (do Monad<Parser>
+ [output parser
+ _ (assert "Constraint failed." (test output))]
+ (wrap output)))
diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux
index 67ef9da9c..3ed2bcbfc 100644
--- a/stdlib/source/lux/control/pipe.lux
+++ b/stdlib/source/lux/control/pipe.lux
@@ -1,6 +1,7 @@
(;module: {#;doc "Composable extensions to the piping macro |> that enhance it with various abilities."}
lux
- (lux (control monad)
+ (lux (control monad
+ ["p" parser])
(data (coll [list #+ Monad<List> "" Fold<List> "List/" Monad<List>])
maybe)
[macro #+ with-gensyms Monad<Lux>]
@@ -11,9 +12,9 @@
## [Syntax]
(def: body^
(Syntax (List Code))
- (s;tuple (s;many s;any)))
+ (s;tuple (p;many s;any)))
-(syntax: #export (_> [tokens (s;at-least +2 s;any)])
+(syntax: #export (_> [tokens (p;at-least +2 s;any)])
{#;doc (doc "Ignores the piped argument, and begins a new pipe."
(|> 20
(i.* 3)
@@ -26,7 +27,7 @@
_
(undefined)))
-(syntax: #export (@> [name (s;default "@" s;local-symbol)]
+(syntax: #export (@> [name (p;default "@" s;local-symbol)]
[body body^]
prev)
{#;doc (doc "Gives a name to the piped-argument, within the given expression."
@@ -43,8 +44,8 @@
prev
body))))
-(syntax: #export (?> [branches (s;many (s;seq body^ body^))]
- [?else (s;opt body^)]
+(syntax: #export (?> [branches (p;many (p;seq body^ body^))]
+ [?else (p;opt body^)]
prev)
{#;doc (doc "Branching for pipes."
"Both the tests and the bodies are piped-code, and must be given inside a tuple."
@@ -79,7 +80,7 @@
((~' recur) (|> (~ g!temp) (~@ then)))
(~ g!temp))))))))
-(syntax: #export (%> monad [steps (s;some body^)] prev)
+(syntax: #export (%> monad [steps (p;some body^)] prev)
{#;doc (doc "Monadic pipes."
"Each steps in the monadic computation is a pipe and must be given inside a tuple."
(|> 5
@@ -113,7 +114,7 @@
(exec (|> (~ g!temp) (~@ body))
(~ g!temp))))))))
-(syntax: #export (&> [paths (s;many body^)] prev)
+(syntax: #export (&> [paths (p;many body^)] prev)
{#;doc (doc "Parallel branching for pipes."
"Allows to run multiple pipelines for a value and gives you a tuple of the outputs."
(|> 5
@@ -127,7 +128,7 @@
[(~@ (List/map (function [body] (` (|> (~ g!temp) (~@ body))))
paths))]))))))
-(syntax: #export (case> [branches (s;many (s;seq s;any s;any))] prev)
+(syntax: #export (case> [branches (p;many (p;seq s;any s;any))] prev)
{#;doc (doc "Pattern-matching for pipes."
"The bodies of each branch are NOT pipes; just regular values."
(|> 5
diff --git a/stdlib/source/lux/data/coll/seq.lux b/stdlib/source/lux/data/coll/seq.lux
index 1b55e3c41..84795f91f 100644
--- a/stdlib/source/lux/data/coll/seq.lux
+++ b/stdlib/source/lux/data/coll/seq.lux
@@ -4,7 +4,8 @@
applicative
monad
eq
- fold)
+ fold
+ ["p" parser])
(data (coll ["L" list "L/" Monoid<List> Fold<List>]
(tree ["F" finger]))
[number]
@@ -275,5 +276,5 @@
right' (join (#;Some (set@ #F;tree right ffa')))]
(wrap (F;branch left' right')))))))
-(syntax: #export (seq [elems (s;some s;any)])
+(syntax: #export (seq [elems (p;some s;any)])
(wrap (list (` (;;from-list (list (~@ elems)))))))
diff --git a/stdlib/source/lux/data/coll/stream.lux b/stdlib/source/lux/data/coll/stream.lux
index 8babfee91..43ed0087c 100644
--- a/stdlib/source/lux/data/coll/stream.lux
+++ b/stdlib/source/lux/data/coll/stream.lux
@@ -3,7 +3,8 @@
(lux (control functor
monad
comonad
- [cont #+ pending Cont])
+ [cont #+ pending Cont]
+ ["p" parser])
[macro #+ with-gensyms]
(macro ["s" syntax #+ syntax: Syntax])
(data (coll [list "List/" Monad<List>])
@@ -128,7 +129,7 @@
(pending [wa (split tail)]))))
## [Pattern-matching]
-(syntax: #export (^stream& [patterns (s;form (s;many s;any))] body [branches (s;some s;any)])
+(syntax: #export (^stream& [patterns (s;form (p;many s;any))] body [branches (p;some s;any)])
{#;doc (doc "Allows destructuring of streams in pattern-matching expressions."
"Caveat emptor: Only use it for destructuring, and not for testing values within the streams."
(let [(^stream& x y z _tail) (some-stream-func 1 2 3)]
diff --git a/stdlib/source/lux/data/coll/tree/rose.lux b/stdlib/source/lux/data/coll/tree/rose.lux
index 979faa828..5493d6692 100644
--- a/stdlib/source/lux/data/coll/tree/rose.lux
+++ b/stdlib/source/lux/data/coll/tree/rose.lux
@@ -2,7 +2,8 @@
lux
(lux (control functor
monad
- eq)
+ eq
+ ["p" parser])
(data (coll [list "L/" Monad<List>]))
[macro]
(macro [code]
@@ -35,11 +36,11 @@
(def: tree^
(Syntax Tree-Code)
- (|> (|>. s;some s;record (s;seq s;any))
- s;rec
- s;some
+ (|> (|>. p;some s;record (p;seq s;any))
+ p;rec
+ p;some
s;record
- (s;seq s;any)
+ (p;seq s;any)
s;tuple))
(syntax: #export (tree [root tree^])
diff --git a/stdlib/source/lux/data/coll/vector.lux b/stdlib/source/lux/data/coll/vector.lux
index 999b2932d..69a7a9822 100644
--- a/stdlib/source/lux/data/coll/vector.lux
+++ b/stdlib/source/lux/data/coll/vector.lux
@@ -5,7 +5,8 @@
monad
eq
monoid
- fold)
+ fold
+ ["p" parser])
(data maybe
(coll [list "List/" Fold<List> Functor<List> Monoid<List>]
[array #+ Array "Array/" Functor<Array> Fold<Array>])
@@ -342,7 +343,7 @@
(|>. (get@ #size) (n.= +0)))
## [Syntax]
-(syntax: #export (vector [elems (s;some s;any)])
+(syntax: #export (vector [elems (p;some s;any)])
{#;doc (doc "Vector literals."
(vector 10 20 30 40))}
(wrap (list (` (from-list (list (~@ elems)))))))
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index 6cf45dfc9..573849b9e 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -6,22 +6,23 @@
applicative
monad
eq
- codec)
+ codec
+ ["p" parser "p/" Monad<Parser>])
(data [bool]
[text "Text/" Eq<Text> Monoid<Text>]
text/format
- (text ["l" lexer #+ Lexer Monad<Lexer> "Lexer/" Monad<Lexer>])
+ (text ["l" lexer])
[number "Real/" Codec<Text,Real>]
maybe
[char "Char/" Codec<Text,Char>]
["R" result]
[sum]
[product]
- (coll [list "" Fold<List> "List/" Monad<List>]
+ (coll [list "L/" Fold<List> Monad<List>]
[vector #+ Vector vector "Vector/" Monad<Vector>]
["d" dict]))
[macro #+ Monad<Lux> with-gensyms]
- (macro [syntax #+ syntax:]
+ (macro ["s" syntax #+ syntax:]
[code]
[poly #+ poly:])
[type]
@@ -86,7 +87,7 @@
(wrap (list (` (: JSON #Null))))
[_ (#;Tuple members)]
- (wrap (list (` (: JSON (#Array (vector (~@ (List/map wrapper members))))))))
+ (wrap (list (` (: JSON (#Array (vector (~@ (L/map wrapper members))))))))
[_ (#;Record pairs)]
(do Monad<Lux>
@@ -125,7 +126,7 @@
(format "{"
(|> object
d;entries
- (List/map (function [[key value]] (format (:: text;Codec<Text,Text> encode key) ":" (show-json value))))
+ (L/map (function [[key value]] (format (:: text;Codec<Text,Text> encode key) ":" (show-json value))))
(text;join-with ","))
"}"))
@@ -227,23 +228,23 @@
## Lexers
(def: space~
- (Lexer Text)
- (l;some' l;space))
+ (l;Lexer Text)
+ (l;some l;space))
(def: data-sep
- (Lexer [Text Unit Text])
- ($_ l;seq space~ (l;this ",") space~))
+ (l;Lexer [Text Unit Text])
+ ($_ p;seq space~ (l;this ",") space~))
(def: null~
- (Lexer Null)
- (do Monad<Lexer>
+ (l;Lexer Null)
+ (do p;Monad<Parser>
[_ (l;this "null")]
(wrap [])))
(do-template [<name> <token> <value>]
[(def: <name>
- (Lexer Boolean)
- (do Monad<Lexer>
+ (l;Lexer Boolean)
+ (do p;Monad<Parser>
[_ (l;this <token>)]
(wrap <value>)))]
@@ -252,52 +253,48 @@
)
(def: boolean~
- (Lexer Boolean)
- (l;either t~ f~))
+ (l;Lexer Boolean)
+ (p;either t~ f~))
(def: number~
- (Lexer Number)
- (do Monad<Lexer>
+ (l;Lexer Number)
+ (do p;Monad<Parser>
[signed? (l;this? "-")
- digits (: (Lexer Text)
- (l;many' l;digit))
- decimals (: (Lexer Text)
- (l;default "0"
- (do @
- [_ (l;this ".")]
- (l;many' l;digit))))
- exp (: (Lexer Text)
- (l;default ""
- (do @
- [mark (l;one-of "eE")
- signed?' (l;this? "-")
- offset (l;many' l;digit)]
- (wrap (format mark (if signed?' "-" "") offset)))))]
- (case (: (R;Result Real)
- (Real/decode (format (if signed? "-" "") digits "." decimals exp)))
+ digits (l;many l;digit)
+ decimals (p;default "0"
+ (do @
+ [_ (l;this ".")]
+ (l;many l;digit)))
+ exp (p;default ""
+ (do @
+ [mark (l;one-of "eE")
+ signed?' (l;this? "-")
+ offset (l;many l;digit)]
+ (wrap (format mark (if signed?' "-" "") offset))))]
+ (case (Real/decode (format (if signed? "-" "") digits "." decimals exp))
(#R;Error message)
- (l;fail message)
+ (p;fail message)
(#R;Success value)
(wrap value))))
(def: escaped~
- (Lexer Text)
- ($_ l;either
- (l;after (l;this "\\t") (Lexer/wrap "\t"))
- (l;after (l;this "\\b") (Lexer/wrap "\b"))
- (l;after (l;this "\\n") (Lexer/wrap "\n"))
- (l;after (l;this "\\r") (Lexer/wrap "\r"))
- (l;after (l;this "\\f") (Lexer/wrap "\f"))
- (l;after (l;this "\\\"") (Lexer/wrap "\""))
- (l;after (l;this "\\\\") (Lexer/wrap "\\"))))
+ (l;Lexer Text)
+ ($_ p;either
+ (p;after (l;this "\\t") (p/wrap "\t"))
+ (p;after (l;this "\\b") (p/wrap "\b"))
+ (p;after (l;this "\\n") (p/wrap "\n"))
+ (p;after (l;this "\\r") (p/wrap "\r"))
+ (p;after (l;this "\\f") (p/wrap "\f"))
+ (p;after (l;this "\\\"") (p/wrap "\""))
+ (p;after (l;this "\\\\") (p/wrap "\\"))))
(def: string~
- (Lexer String)
+ (l;Lexer String)
(<| (l;enclosed ["\"" "\""])
(loop [_ []]
- (do Monad<Lexer>
- [chars (l;some' (l;none-of "\\\""))
+ (do p;Monad<Parser>
+ [chars (l;some (l;none-of "\\\""))
stop l;peek]
(if (Text/= "\\" stop)
(do @
@@ -307,8 +304,8 @@
(wrap chars))))))
(def: (kv~ json~)
- (-> (-> Unit (Lexer JSON)) (Lexer [String JSON]))
- (do Monad<Lexer>
+ (-> (-> Unit (l;Lexer JSON)) (l;Lexer [String JSON]))
+ (do p;Monad<Parser>
[key string~
_ space~
_ (l;this ":")
@@ -318,11 +315,11 @@
(do-template [<name> <type> <open> <close> <elem-parser> <prep>]
[(def: (<name> json~)
- (-> (-> Unit (Lexer JSON)) (Lexer <type>))
- (do Monad<Lexer>
+ (-> (-> Unit (l;Lexer JSON)) (l;Lexer <type>))
+ (do p;Monad<Parser>
[_ (l;this <open>)
_ space~
- elems (l;sep-by data-sep <elem-parser>)
+ elems (p;sep-by data-sep <elem-parser>)
_ space~
_ (l;this <close>)]
(wrap (<prep> elems))))]
@@ -332,8 +329,8 @@
)
(def: (json~' _)
- (-> Unit (Lexer JSON))
- ($_ l;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
+ (-> Unit (l;Lexer JSON))
+ ($_ p;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
## [Structures]
(struct: #export _ (Functor Parser)
@@ -669,25 +666,25 @@
[(#Array xs) (#Array ys)]
(and (n.= (vector;size xs) (vector;size ys))
- (fold (function [idx prev]
- (and prev
- (default false
- (do Monad<Maybe>
- [x' (vector;nth idx xs)
- y' (vector;nth idx ys)]
- (wrap (= x' y'))))))
- true
- (list;indices (vector;size xs))))
+ (L/fold (function [idx prev]
+ (and prev
+ (default false
+ (do Monad<Maybe>
+ [x' (vector;nth idx xs)
+ y' (vector;nth idx ys)]
+ (wrap (= x' y'))))))
+ true
+ (list;indices (vector;size xs))))
[(#Object xs) (#Object ys)]
(and (n.= (d;size xs) (d;size ys))
- (fold (function [[xk xv] prev]
- (and prev
- (case (d;get xk ys)
- #;None false
- (#;Some yv) (= xv yv))))
- true
- (d;entries xs)))
+ (L/fold (function [[xk xv] prev]
+ (and prev
+ (case (d;get xk ys)
+ #;None false
+ (#;Some yv) (= xv yv))))
+ true
+ (d;entries xs)))
_
false)))
@@ -702,9 +699,9 @@
(#ObjectShape (List [Text Code])))
(def: _shape^
- (syntax;Syntax Shape)
- (syntax;alt (syntax;tuple (syntax;some syntax;any))
- (syntax;record (syntax;some (syntax;seq syntax;text syntax;any)))))
+ (s;Syntax Shape)
+ (p;alt (s;tuple (p;some s;any))
+ (s;record (p;some (p;seq s;text s;any)))))
(syntax: #export (shape [shape _shape^])
{#;doc (doc "Builds a parser that ensures the (inclusive) shape of an array or object."
@@ -717,15 +714,15 @@
(let [array-size (list;size parts)
parsers (|> parts
(list;zip2 (list;indices array-size))
- (List/map (function [[idx parser]]
- (` (nth (~ (code;nat idx)) (~ parser))))))]
+ (L/map (function [[idx parser]]
+ (` (nth (~ (code;nat idx)) (~ parser))))))]
(wrap (list (` ($_ seq (~@ parsers))))))
(#ObjectShape kvs)
- (let [fields (List/map product;left kvs)
- parsers (List/map (function [[field-name parser]]
- (` (field (~ (code;text field-name)) (~ parser))))
- kvs)]
+ (let [fields (L/map product;left kvs)
+ parsers (L/map (function [[field-name parser]]
+ (` (field (~ (code;text field-name)) (~ parser))))
+ kvs)]
(wrap (list (` ($_ seq (~@ parsers))))))
))
@@ -740,24 +737,24 @@
(let [array-size (list;size parts)
parsers (|> parts
(list;zip2 (list;indices array-size))
- (List/map (function [[idx parser]]
- (` (nth (~ (code;nat idx)) (~ parser))))))]
+ (L/map (function [[idx parser]]
+ (` (nth (~ (code;nat idx)) (~ parser))))))]
(wrap (list (` (ensure (array-size! (~ (code;nat array-size)))
($_ seq (~@ parsers)))))))
(#ObjectShape kvs)
- (let [fields (List/map product;left kvs)
- parsers (List/map (function [[field-name parser]]
- (` (field (~ (code;text field-name)) (~ parser))))
- kvs)]
- (wrap (list (` (ensure (object-fields! (list (~@ (List/map code;text fields))))
+ (let [fields (L/map product;left kvs)
+ parsers (L/map (function [[field-name parser]]
+ (` (field (~ (code;text field-name)) (~ parser))))
+ kvs)]
+ (wrap (list (` (ensure (object-fields! (list (~@ (L/map code;text fields))))
($_ seq (~@ parsers)))))))
))
## [Polytypism]
(def: #hidden _map_
(All [a b] (-> (-> a b) (List a) (List b)))
- List/map)
+ L/map)
(poly: #hidden (Codec<JSON,?>//encode *env* :x:)
(let [->Codec//encode (: (-> Code Code)
@@ -823,12 +820,12 @@
_
(` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (List/map ->Codec//encode g!vars))
+ (-> (~@ (L/map ->Codec//encode g!vars))
(~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
(wrap (` (: (~ :x:+)
(function [(~@ g!vars) (~ g!input)]
(case (~ g!input)
- (~@ (List/join pattern-matching))))
+ (~@ (L/join pattern-matching))))
)))))
(with-gensyms [g!type-fun g!case g!input]
(do @
@@ -849,7 +846,7 @@
_
(` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (List/map ->Codec//encode g!vars))
+ (-> (~@ (L/map ->Codec//encode g!vars))
(~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
(wrap (` (: (~ :x:+)
(function [(~@ g!vars) (~ g!input)]
@@ -874,14 +871,14 @@
_
(` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (List/map ->Codec//encode g!vars))
+ (-> (~@ (L/map ->Codec//encode g!vars))
(~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]
- #let [.tuple. (` [(~@ (List/map product;left pattern-matching))])]]
+ #let [.tuple. (` [(~@ (L/map product;left pattern-matching))])]]
(wrap (` (: (~ :x:+)
(function [(~@ g!vars) (~ .tuple.)]
- (;;json [(~@ (List/map (function [[g!member g!encoder]]
- (` ((~ g!encoder) (~ g!member))))
- pattern-matching))]))
+ (;;json [(~@ (L/map (function [[g!member g!encoder]]
+ (` ((~ g!encoder) (~ g!member))))
+ pattern-matching))]))
)))
))
(do @
@@ -960,10 +957,10 @@
_
(` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (List/map ->Codec//decode g!vars))
+ (-> (~@ (L/map ->Codec//decode g!vars))
(~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))
base-parser (` ($_ ;;either
- (~@ (List/join pattern-matching))))
+ (~@ (L/join pattern-matching))))
parser (case g!vars
#;Nil
base-parser
@@ -994,15 +991,15 @@
_
(` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (List/map ->Codec//decode g!vars))
+ (-> (~@ (L/map ->Codec//decode g!vars))
(~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
(wrap (` (: (~ :x:+)
(function [(~@ g!vars) (~ g!input)]
(do R;Monad<Result>
- [(~@ (List/join extraction))]
- ((~ (' wrap)) (~ (code;record (List/map (function [[name :slot:]]
- [(code;tag name) (code;symbol ["" (product;right name)])])
- members))))))
+ [(~@ (L/join extraction))]
+ ((~ (' wrap)) (~ (code;record (L/map (function [[name :slot:]]
+ [(code;tag name) (code;symbol ["" (product;right name)])])
+ members))))))
)))))
(with-gensyms [g!type-fun g!case g!input]
(do @
@@ -1023,15 +1020,15 @@
_
(` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (List/map ->Codec//decode g!vars))
+ (-> (~@ (L/map ->Codec//decode g!vars))
(~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]
#let [.decoder. (case g!vars
#;Nil
- (` (;;shape [(~@ (List/map product;right pattern-matching))]))
+ (` (;;shape [(~@ (L/map product;right pattern-matching))]))
_
(` (function [(~@ g!vars)]
- (;;shape [(~@ (List/map product;right pattern-matching))]))))]]
+ (;;shape [(~@ (L/map product;right pattern-matching))]))))]]
(wrap (` (: (~ :x:+) (~ .decoder.))))
))
(do @
diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux
index aaafcd3d0..ef2f5d44d 100644
--- a/stdlib/source/lux/data/format/xml.lux
+++ b/stdlib/source/lux/data/format/xml.lux
@@ -2,10 +2,11 @@
lux
(lux (control monad
eq
- codec)
- (data [text "text/" Eq<Text>]
+ codec
+ ["p" parser "p/" Monad<Parser>])
+ (data [text "t/" Eq<Text>]
text/format
- (text ["l" lexer "lex/" Monad<Lexer>])
+ (text ["l" lexer])
[number]
["R" result]
[char "c/" Eq<Char>]
@@ -13,14 +14,14 @@
[maybe "m/" Monad<Maybe>]
[ident "Ident/" Eq<Ident>]
(coll [list "L/" Monad<List>]
- ["D" dict]
+ ["d" dict]
(tree ["T" rose]
["Z" zipper])))
))
## [Types]
(type: #export Tag Ident)
-(type: #export Attrs (D;Dict Ident Text))
+(type: #export Attrs (d;Dict Ident Text))
(type: #export #rec XML
(#Text Text)
@@ -37,51 +38,51 @@
## [Parsing]
(def: xml-standard-escape-char^
(l;Lexer Text)
- ($_ l;either
- (l;after (l;this "&lt;") (lex/wrap "<"))
- (l;after (l;this "&gt;") (lex/wrap ">"))
- (l;after (l;this "&amp;") (lex/wrap "&"))
- (l;after (l;this "&apos;") (lex/wrap "'"))
- (l;after (l;this "&quot;") (lex/wrap "\""))))
+ ($_ p;either
+ (p;after (l;this "&lt;") (p/wrap "<"))
+ (p;after (l;this "&gt;") (p/wrap ">"))
+ (p;after (l;this "&amp;") (p/wrap "&"))
+ (p;after (l;this "&apos;") (p/wrap "'"))
+ (p;after (l;this "&quot;") (p/wrap "\""))))
(def: xml-unicode-escape-char^
(l;Lexer Text)
- (|> (do l;Monad<Lexer>
- [hex? (l;opt (l;this "x"))
+ (|> (do p;Monad<Parser>
+ [hex? (p;opt (l;this "x"))
code (case hex?
#;None
- (l;codec number;Codec<Text,Int> (l;many' l;digit))
+ (l;codec number;Codec<Text,Int> (l;many l;digit))
(#;Some _)
- (l;codec number;Hex@Codec<Text,Int> (l;many' l;hex-digit)))]
+ (l;codec number;Hex@Codec<Text,Int> (l;many l;hex-digit)))]
(wrap (|> code int-to-nat char;char char;as-text)))
- (l;before (l;this ";"))
- (l;after (l;this "&#"))))
+ (p;before (l;this ";"))
+ (p;after (l;this "&#"))))
(def: xml-escape-char^
(l;Lexer Text)
- (l;either xml-standard-escape-char^
+ (p;either xml-standard-escape-char^
xml-unicode-escape-char^))
(def: xml-char^
(l;Lexer Text)
- (l;either (l;none-of "<>&'\"")
+ (p;either (l;none-of "<>&'\"")
xml-escape-char^))
(def: xml-identifier
(l;Lexer Text)
- (do l;Monad<Lexer>
- [head (l;either (l;one-of "_")
+ (do p;Monad<Parser>
+ [head (p;either (l;one-of "_")
l;alpha)
- tail (l;some' (l;either (l;one-of "_.-")
- l;alpha-num))]
+ tail (l;some (p;either (l;one-of "_.-")
+ l;alpha-num))]
(wrap (format head tail))))
(def: namespaced-symbol^
(l;Lexer Ident)
- (do l;Monad<Lexer>
+ (do p;Monad<Parser>
[first-part xml-identifier
- ?second-part (<| l;opt (l;after (l;this ":")) xml-identifier)]
+ ?second-part (<| p;opt (p;after (l;this ":")) xml-identifier)]
(case ?second-part
#;None
(wrap ["" first-part])
@@ -94,102 +95,94 @@
(def: spaced^
(All [a] (-> (l;Lexer a) (l;Lexer a)))
- (let [white-space^ (l;some l;space)]
- (|>. (l;before white-space^)
- (l;after white-space^))))
+ (let [white-space^ (p;some l;space)]
+ (|>. (p;before white-space^)
+ (p;after white-space^))))
(def: attr-value^
(l;Lexer Text)
- (let [value^ (l;some' xml-char^)]
- (l;either (l;enclosed ["\"" "\""] value^)
+ (let [value^ (l;some xml-char^)]
+ (p;either (l;enclosed ["\"" "\""] value^)
(l;enclosed ["'" "'"] value^))))
(def: attrs^
(l;Lexer Attrs)
- (<| (:: l;Monad<Lexer> map (D;from-list ident;Hash<Ident>))
- l;some
- (l;seq (spaced^ attr-name^))
- (l;after (l;this "="))
+ (<| (:: p;Monad<Parser> map (d;from-list ident;Hash<Ident>))
+ p;some
+ (p;seq (spaced^ attr-name^))
+ (p;after (l;this "="))
(spaced^ attr-value^)))
(def: (close-tag^ expected)
(-> Tag (l;Lexer []))
- (do l;Monad<Lexer>
+ (do p;Monad<Parser>
[actual (|> tag^
spaced^
- (l;after (l;this "/"))
+ (p;after (l;this "/"))
(l;enclosed ["<" ">"]))]
- (l;assert (format "Close tag does not match open tag.\n"
+ (p;assert (format "Close tag does not match open tag.\n"
"Expected: " (%ident expected) "\n"
" Actual: " (%ident actual) "\n")
(Ident/= expected actual))))
(def: comment^
(l;Lexer Text)
- (|> (l;some' (l;not (l;this "--")))
- (l;after (l;this "-->"))
- (l;after (l;this "<--"))
+ (|> (l;not (l;this "--"))
+ l;some
+ (l;enclosed ["<--" "-->"])
spaced^))
(def: xml-header^
(l;Lexer Attrs)
(|> (spaced^ attrs^)
- (l;before (l;this "?>"))
- (l;after (l;this "<?xml"))
+ (p;before (l;this "?>"))
+ (p;after (l;this "<?xml"))
spaced^))
(def: cdata^
(l;Lexer Text)
(let [end (l;this "]]>")]
- (|> (l;some' (l;not end))
- (l;after end)
- (l;after (l;this "<![CDATA["))
+ (|> (l;some (l;not end))
+ (p;after end)
+ (p;after (l;this "<![CDATA["))
spaced^)))
(def: text^
(l;Lexer XML)
- (|> (l;either cdata^
- (l;many' xml-char^))
- (lex/map (|>. text;trim #Text))))
+ (|> (p;either cdata^
+ (l;many xml-char^))
+ (p/map (|>. text;trim #Text))))
(def: xml^
(l;Lexer XML)
- (|> (l;rec
+ (|> (p;rec
(function [node^]
- (l;either text^
+ (p;either text^
(spaced^
- (do l;Monad<Lexer>
+ (do p;Monad<Parser>
[_ (l;this "<")
tag (spaced^ tag^)
attrs (spaced^ attrs^)
- #let [no-children^ (do l;Monad<Lexer>
+ #let [no-children^ (do p;Monad<Parser>
[_ (l;this "/>")]
(wrap (node tag attrs (list))))
- with-children^ (do l;Monad<Lexer>
+ with-children^ (do p;Monad<Parser>
[_ (l;this ">")
- children (l;some node^)
+ children (p;some node^)
_ (close-tag^ tag)]
(wrap (node tag attrs children)))]]
- (l;either no-children^
+ (p;either no-children^
with-children^))))))
## This is put outside of the call to "rec" because comments
## cannot be located inside of XML nodes.
## This way, the comments can only be before or after the main document.
- (l;before (l;some comment^))
- (l;after (l;some comment^))
- (l;after (l;opt xml-header^))))
+ (p;before (p;some comment^))
+ (p;after (p;some comment^))
+ (p;after (p;opt xml-header^))))
-(def: #export (read-xml input)
+(def: #export (read input)
(-> Text (R;Result XML))
- (case (l;run' input xml^)
- (#R;Success ["" output])
- (#R;Success output)
-
- (#;Some [input-left output])
- (#R;Error (format "Unconsumed input: " (%t input-left)))
-
- (#R;Error error)
- (#R;Error error)))
+ (l;run input xml^))
## [Generation]
(def: (sanitize-value input)
@@ -210,7 +203,7 @@
(def: (write-attrs attrs)
(-> Attrs Text)
(|> attrs
- D;entries
+ d;entries
(L/map (function [[key value]]
(format (write-tag key) "=" "\""(sanitize-value value) "\"")))
(text;join-with " ")))
@@ -219,7 +212,7 @@
Text
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>")
-(def: #export (write-xml input)
+(def: #export (write input)
(-> XML Text)
(format xml-header
(loop [input input]
@@ -229,7 +222,7 @@
(#Node xml-tag xml-attrs xml-children)
(let [tag (write-tag xml-tag)
- attrs (if (D;empty? xml-attrs)
+ attrs (if (d;empty? xml-attrs)
""
(format " " (write-attrs xml-attrs)))]
(if (list;empty? xml-children)
@@ -242,19 +235,19 @@
## [Structs]
(struct: #export _ (Codec Text XML)
- (def: encode write-xml)
- (def: decode read-xml))
+ (def: encode write)
+ (def: decode read))
(struct: #export _ (Eq XML)
(def: (= reference sample)
(case [reference sample]
[(#Text reference/value) (#Text sample/value)]
- (text/= reference/value sample/value)
+ (t/= reference/value sample/value)
[(#Node reference/tag reference/attrs reference/children)
(#Node sample/tag sample/attrs sample/children)]
(and (Ident/= reference/tag sample/tag)
- (:: (D;Eq<Dict> text;Eq<Text>) = reference/attrs sample/attrs)
+ (:: (d;Eq<Dict> text;Eq<Text>) = reference/attrs sample/attrs)
(n.= (list;size reference/children)
(list;size sample/children))
(|> (list;zip2 reference/children sample/children)
diff --git a/stdlib/source/lux/data/number/complex.lux b/stdlib/source/lux/data/number/complex.lux
index 94276e5f8..852498e28 100644
--- a/stdlib/source/lux/data/number/complex.lux
+++ b/stdlib/source/lux/data/number/complex.lux
@@ -4,7 +4,8 @@
(control eq
number
codec
- monad)
+ monad
+ ["p" parser])
(data [number "r/" Number<Real> Codec<Text,Real>]
[text "Text/" Monoid<Text>]
text/format
@@ -22,7 +23,7 @@
{#real Real
#imaginary Real})
-(syntax: #export (complex real [?imaginary (s;opt s;any)])
+(syntax: #export (complex real [?imaginary (p;opt s;any)])
{#;doc (doc "Complex literals."
(complex real imaginary)
"The imaginary part can be omitted if it's 0."
diff --git a/stdlib/source/lux/data/number/ratio.lux b/stdlib/source/lux/data/number/ratio.lux
index 8497b3c5d..d9b20cb97 100644
--- a/stdlib/source/lux/data/number/ratio.lux
+++ b/stdlib/source/lux/data/number/ratio.lux
@@ -5,7 +5,8 @@
[order]
number
codec
- monad)
+ monad
+ ["p" parser])
(data [number "n/" Number<Nat> Codec<Text,Nat>]
[text "Text/" Monoid<Text>]
text/format
@@ -148,7 +149,7 @@
#;None
(#;Left (Text/append "Invalid syntax for ratio: " input)))))
-(syntax: #export (ratio numerator [?denominator (s;opt s;any)])
+(syntax: #export (ratio numerator [?denominator (p;opt s;any)])
{#;doc (doc "Rational literals."
(ratio numerator denominator)
"The denominator can be omitted if it's 1."
diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux
index 5c40a2514..127921e41 100644
--- a/stdlib/source/lux/data/text/format.lux
+++ b/stdlib/source/lux/data/text/format.lux
@@ -1,6 +1,7 @@
(;module:
lux
- (lux (control monad)
+ (lux (control monad
+ ["p" parser])
(data [bool]
[char]
[number]
@@ -17,7 +18,7 @@
(-> Text Text Text)
(:: text;Monoid<Text> append))
-(syntax: #export (format [fragments (s;many s;any)])
+(syntax: #export (format [fragments (p;many s;any)])
{#;doc (doc "Text interpolation as a macro."
(format "Static part " (%t static) " does not match URI: " uri))}
(wrap (list (` ($_ _append_ (~@ fragments))))))
diff --git a/stdlib/source/lux/data/text/lexer.lux b/stdlib/source/lux/data/text/lexer.lux
index 8475d91e2..8c40af821 100644
--- a/stdlib/source/lux/data/text/lexer.lux
+++ b/stdlib/source/lux/data/text/lexer.lux
@@ -1,65 +1,20 @@
(;module:
- [lux #- not default]
+ [lux #- not]
(lux (control functor
applicative
monad
- codec)
- (data [text "Text/" Eq<Text> Monoid<Text>]
- [number "Int/" Codec<Text,Int>]
+ codec
+ ["p" parser])
+ (data [text "T/" Eq<Text>]
+ text/format
[product]
- [char "Char/" Order<Char> Codec<Text,Char>]
+ [char "C/" Order<Char> Codec<Text,Char>]
maybe
["R" result]
- (coll [list "" Functor<List>]))))
-
-## [Types]
-(type: #export (Lexer a)
- (-> Text (R;Result [Text a])))
-
-## [Structures]
-(struct: #export _ (Functor Lexer)
- (def: (map f fa)
- (function [input]
- (case (fa input)
- (#R;Error msg) (#R;Error msg)
- (#R;Success [input' output]) (#R;Success [input' (f output)])))))
-
-(struct: #export _ (Applicative Lexer)
- (def: functor Functor<Lexer>)
-
- (def: (wrap a)
- (function [input]
- (#R;Success [input a])))
-
- (def: (apply ff fa)
- (function [input]
- (case (ff input)
- (#R;Success [input' f])
- (case (fa input')
- (#R;Success [input'' a])
- (#R;Success [input'' (f a)])
-
- (#R;Error msg)
- (#R;Error msg))
-
- (#R;Error msg)
- (#R;Error msg)))))
-
-(struct: #export _ (Monad Lexer)
- (def: applicative Applicative<Lexer>)
-
- (def: (join mma)
- (function [input]
- (case (mma input)
- (#R;Error msg) (#R;Error msg)
- (#R;Success [input' ma]) (ma input'))))
- )
+ (coll [list "L/" Functor<List>]))))
-## [Values]
-## Runner
-(def: #export (run' input lexer)
- (All [a] (-> Text (Lexer a) (R;Result [Text a])))
- (lexer input))
+(type: #export Lexer
+ (p;Parser Text))
(def: #export (run input lexer)
(All [a] (-> Text (Lexer a) (R;Result a)))
@@ -68,15 +23,11 @@
(#R;Error msg)
(#R;Success [input' output])
- (#R;Success output)
+ (if (T/= "" input')
+ (#R;Success output)
+ (#R;Error (format "Remaining lexer input: " input')))
))
-## Combinators
-(def: #export (fail message)
- (All [a] (-> Text (Lexer a)))
- (function [input]
- (#R;Error message)))
-
(def: #export any
{#;doc "Just returns the next character without applying any logic."}
(Lexer Text)
@@ -89,41 +40,6 @@
(#R;Error "Cannot parse character from empty text."))
))
-(def: #export (seq left right)
- {#;doc "Sequencing combinator."}
- (All [a b] (-> (Lexer a) (Lexer b) (Lexer [a b])))
- (do Monad<Lexer>
- [=left left
- =right right]
- (wrap [=left =right])))
-
-(def: #export (alt left right)
- {#;doc "Heterogeneous alternative combinator."}
- (All [a b] (-> (Lexer a) (Lexer b) (Lexer (| a b))))
- (function [input]
- (case (left input)
- (#R;Error msg)
- (case (right input)
- (#R;Error msg)
- (#R;Error msg)
-
- (#R;Success [input' output])
- (#R;Success [input' (+1 output)]))
-
- (#R;Success [input' output])
- (#R;Success [input' (+0 output)]))))
-
-(def: #export (not! p)
- {#;doc "Ensure a lexer fails."}
- (All [a] (-> (Lexer a) (Lexer Unit)))
- (function [input]
- (case (p input)
- (#R;Error msg)
- (#R;Success [input []])
-
- _
- (#R;Error "Expected to fail; yet succeeded."))))
-
(def: #export (not p)
{#;doc "Produce a character if the lexer fails."}
(All [a] (-> (Lexer a) (Lexer Text)))
@@ -135,103 +51,6 @@
_
(#R;Error "Expected to fail; yet succeeded."))))
-(def: #export (either left right)
- {#;doc "Homogeneous alternative combinator."}
- (All [a] (-> (Lexer a) (Lexer a) (Lexer a)))
- (function [input]
- (case (left input)
- (#R;Error msg)
- (right input)
-
- output
- output)))
-
-(def: #export (assert message test)
- {#;doc "Fails with the given message if the test is false."}
- (-> Text Bool (Lexer Unit))
- (function [input]
- (if test
- (#R;Success [input []])
- (#R;Error message))))
-
-(def: #export (some p)
- {#;doc "0-or-more combinator."}
- (All [a] (-> (Lexer a) (Lexer (List a))))
- (function [input]
- (case (p input)
- (#R;Error msg)
- (#R;Success [input (list)])
-
- (#R;Success [input' x])
- (run' input'
- (do Monad<Lexer>
- [xs (some p)]
- (wrap (#;Cons x xs)))))
- ))
-
-(def: #export (many p)
- {#;doc "1-or-more combinator."}
- (All [a] (-> (Lexer a) (Lexer (List a))))
- (do Monad<Lexer>
- [x p
- xs (some p)]
- (wrap (#;Cons x xs))))
-
-(def: #export (exactly n p)
- {#;doc "Lex exactly N times."}
- (All [a] (-> Nat (Lexer a) (Lexer (List a))))
- (if (n.> +0 n)
- (do Monad<Lexer>
- [x p
- xs (exactly (n.dec n) p)]
- (wrap (#;Cons x xs)))
- (:: Monad<Lexer> wrap (list))))
-
-(def: #export (at-most n p)
- {#;doc "Lex at most N times."}
- (All [a] (-> Nat (Lexer a) (Lexer (List a))))
- (if (n.> +0 n)
- (function [input]
- (case (p input)
- (#R;Error msg)
- (#R;Success [input (list)])
-
- (#R;Success [input' x])
- (run' input'
- (do Monad<Lexer>
- [xs (at-most (n.dec n) p)]
- (wrap (#;Cons x xs))))
- ))
- (:: Monad<Lexer> wrap (list))))
-
-(def: #export (at-least n p)
- {#;doc "Lex at least N times."}
- (All [a] (-> Nat (Lexer a) (Lexer (List a))))
- (do Monad<Lexer>
- [min-xs (exactly n p)
- extras (some p)]
- (wrap (list;concat (list min-xs extras)))))
-
-(def: #export (between from to p)
- {#;doc "Lex between N and M times."}
- (All [a] (-> Nat Nat (Lexer a) (Lexer (List a))))
- (do Monad<Lexer>
- [min-xs (exactly from p)
- max-xs (at-most (n.- from to) p)]
- (wrap (list;concat (list min-xs max-xs)))))
-
-(def: #export (opt p)
- {#;doc "Optionality combinator."}
- (All [a] (-> (Lexer a) (Lexer (Maybe a))))
- (function [input]
- (case (p input)
- (#R;Error msg)
- (#R;Success [input #;None])
-
- (#R;Success [input value])
- (#R;Success [input (#;Some value)])
- )))
-
(def: #export (this reference)
{#;doc "Lex a text if it matches the given sample."}
(-> Text (Lexer Unit))
@@ -241,7 +60,7 @@
#;None (#R;Error "")
(#;Some [_ input']) (#R;Success [input' []]))
(let [(^open "T/") text;Codec<Text,Text>]
- (#R;Error ($_ Text/append "Invalid match: " (T/encode reference) " @ " (T/encode input)))))))
+ (#R;Error (format "Invalid match: " (T/encode reference) " @ " (T/encode input)))))))
(def: #export (this? reference)
{#;doc "Lex a text if it matches the given sample."}
@@ -254,28 +73,13 @@
(#R;Success [input false]))
))
-(def: #export (sep-by sep lexer)
- {#;doc "Apply a lexer multiple times, checking that a separator lexer succeeds between each time."}
- (All [a b] (-> (Lexer b) (Lexer a) (Lexer (List a))))
- (do Monad<Lexer>
- [?x (opt lexer)]
- (case ?x
- #;None
- (wrap #;Nil)
-
- (#;Some x)
- (do @
- [xs' (some (seq sep lexer))]
- (wrap (#;Cons x (map product;right xs'))))
- )))
-
(def: #export end
{#;doc "Ensure the lexer's input is empty."}
(Lexer Unit)
(function [input]
(case input
"" (#R;Success [input []])
- _ (#R;Error ($_ Text/append "The text input has not been fully consumed @ " (:: text;Codec<Text,Text> encode input)))
+ _ (#R;Error (format "The text input has not been fully consumed @ " (:: text;Codec<Text,Text> encode input)))
)))
(def: #export peek
@@ -299,18 +103,18 @@
(def: #export (char-range bottom top)
{#;doc "Only lex characters within a range."}
(-> Char Char (Lexer Text))
- (do Monad<Lexer>
+ (do p;Monad<Parser>
[input get-input
char any
#let [char' (|> char (text;nth +0) assume)]
- _ (assert ($_ Text/append "Character is not within range: " (Char/encode bottom) "-" (Char/encode top) " @ " (:: text;Codec<Text,Text> encode input))
- (and (Char/>= bottom char')
- (Char/<= top char')))]
+ _ (p;assert (format "Character is not within range: " (C/encode bottom) "-" (C/encode top) " @ " (:: text;Codec<Text,Text> encode input))
+ (and (C/>= bottom char')
+ (C/<= top char')))]
(wrap char)))
(do-template [<name> <bottom> <top> <desc>]
[(def: #export <name>
- {#;doc (#;TextA ($_ Text/append "Only lex " <desc> " characters."))}
+ {#;doc (#;TextA (format "Only lex " <desc> " characters."))}
(Lexer Text)
(char-range <bottom> <top>))]
@@ -323,17 +127,17 @@
(def: #export alpha
{#;doc "Only lex alphabetic characters."}
(Lexer Text)
- (either lower upper))
+ (p;either lower upper))
(def: #export alpha-num
{#;doc "Only lex alphanumeric characters."}
(Lexer Text)
- (either alpha digit))
+ (p;either alpha digit))
(def: #export hex-digit
{#;doc "Only lex hexadecimal digits."}
(Lexer Text)
- ($_ either
+ ($_ p;either
digit
(char-range #"a" #"f")
(char-range #"A" #"F")))
@@ -351,7 +155,7 @@
_
(#R;Error ""))
- (#R;Error ($_ Text/append "Character (" init ") is not one of: " options " @ " (:: text;Codec<Text,Text> encode input))))
+ (#R;Error (format "Character (" init ") is not one of: " options " @ " (:: text;Codec<Text,Text> encode input))))
_
(#R;Error "Cannot parse character from empty text."))))
@@ -369,7 +173,7 @@
_
(#R;Error ""))
- (#R;Error ($_ Text/append "Character (" init ") is one of: " options " @ " (:: text;Codec<Text,Text> encode input))))
+ (#R;Error (format "Character (" init ") is one of: " options " @ " (:: text;Codec<Text,Text> encode input))))
_
(#R;Error "Cannot parse character from empty text."))))
@@ -386,7 +190,7 @@
(#;Some [input' output])
(if (p output)
(#R;Success [input' (char;as-text output)])
- (#R;Error ($_ Text/append "Character does not satisfy predicate: " (:: text;Codec<Text,Text> encode input))))
+ (#R;Error (format "Character does not satisfy predicate: " (:: text;Codec<Text,Text> encode input))))
_
(#R;Error "Cannot parse character from empty text."))))
@@ -396,47 +200,42 @@
(Lexer Text)
(satisfies char;space?))
-(def: #export (constrain test lexer)
- (All [a] (-> (-> a Bool) (Lexer a) (Lexer a)))
- (do Monad<Lexer>
- [input get-input
- output lexer
- _ (assert (Text/append "Input fails the constraint: "
- (:: text;Codec<Text,Text> encode input))
- (test output))]
- (wrap output)))
+(def: #export (seq left right)
+ (-> (Lexer Text) (Lexer Text) (Lexer Text))
+ (do p;Monad<Parser>
+ [=left left
+ =right right]
+ (wrap (format =left =right))))
(do-template [<name> <base> <doc>]
[(def: #export (<name> p)
{#;doc <doc>}
(-> (Lexer Text) (Lexer Text))
- (do Monad<Lexer>
+ (do p;Monad<Parser>
[]
(|> p <base> (:: @ map text;concat))))]
- [some' some "Lex some characters as a single continuous text."]
- [many' many "Lex many characters as a single continuous text."]
+ [some p;some "Lex some characters as a single continuous text."]
+ [many p;many "Lex many characters as a single continuous text."]
)
(do-template [<name> <base> <doc>]
[(def: #export (<name> n p)
{#;doc <doc>}
(-> Nat (Lexer Text) (Lexer Text))
- (do Monad<Lexer>
+ (do p;Monad<Parser>
[]
(|> p (<base> n) (:: @ map text;concat))))]
- [exactly' exactly "Lex exactly N characters."]
- [at-most' at-most "Lex at most N characters."]
- [at-least' at-least "Lex at least N characters."]
+ [exactly p;exactly "Lex exactly N characters."]
+ [at-most p;at-most "Lex at most N characters."]
+ [at-least p;at-least "Lex at least N characters."]
)
-(def: #export (between' from to p)
+(def: #export (between from to p)
{#;doc "Lex between N and M characters."}
(-> Nat Nat (Lexer Text) (Lexer Text))
- (do Monad<Lexer>
- []
- (|> p (between from to) (:: @ map text;concat))))
+ (|> p (p;between from to) (:: p;Monad<Parser> map text;concat)))
(def: #export end?
{#;doc "Ask if the lexer's input is empty."}
@@ -444,25 +243,6 @@
(function [input]
(#R;Success [input (text;empty? input)])))
-(def: #export (after param subject)
- (All [p s] (-> (Lexer p) (Lexer s) (Lexer s)))
- (do Monad<Lexer>
- [_ param]
- subject))
-
-(def: #export (before param subject)
- (All [p s] (-> (Lexer p) (Lexer s) (Lexer s)))
- (do Monad<Lexer>
- [output subject
- _ param]
- (wrap output)))
-
-(def: #export (default value lexer)
- {#;doc "If the given lexer fails, this lexer will succeed with the provided value."}
- (All [a] (-> a (Lexer a) (Lexer a)))
- (|> (opt lexer)
- (:: Monad<Lexer> map (|>. (;default value)))))
-
(def: #export (codec codec lexer)
{#;doc "Lex a token by means of a codec."}
(All [a] (-> (Codec Text a) (Lexer Text) (Lexer a)))
@@ -482,31 +262,18 @@
(def: #export (enclosed [start end] lexer)
(All [a] (-> [Text Text] (Lexer a) (Lexer a)))
(|> lexer
- (before (this end))
- (after (this start))))
-
-(def: #export (rec lexer)
- (All [a] (-> (-> (Lexer a) (Lexer a))
- (Lexer a)))
- (function [input]
- (run' input (lexer (rec lexer)))))
+ (p;before (this end))
+ (p;after (this start))))
(def: #export (local local-input lexer)
{#;doc "Run a lexer with the given input, instead of the real one."}
(All [a] (-> Text (Lexer a) (Lexer a)))
(function [real-input]
- (case (run' local-input lexer)
+ (case (p;run local-input lexer)
(#R;Error error)
(#R;Error error)
(#R;Success [unconsumed value])
- (if (Text/= "" unconsumed)
+ (if (T/= "" unconsumed)
(#R;Success [real-input value])
- (#R;Error ($_ Text/append "Unconsumed input: " unconsumed))))))
-
-(def: #export (seq' left right)
- (-> (Lexer Text) (Lexer Text) (Lexer Text))
- (do Monad<Lexer>
- [=left left
- =right right]
- (wrap (Text/append =left =right))))
+ (#R;Error (format "Unconsumed input: " unconsumed))))))
diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux
index 405eca618..3666f68b8 100644
--- a/stdlib/source/lux/data/text/regex.lux
+++ b/stdlib/source/lux/data/text/regex.lux
@@ -1,32 +1,33 @@
(;module:
lux
- (lux (control monad)
+ (lux (control monad
+ ["p" parser "p/" Monad<Parser>])
(data [char]
[text]
- ["&" text/lexer #+ Lexer Monad<Lexer> "&/" Monad<Lexer>]
+ ["l" text/lexer]
text/format
[number "Int/" Codec<Text,Int>]
[product]
- (coll [list "" Fold<List> "List/" Monad<List>]))
+ (coll [list "L/" Fold<List> Monad<List>]))
[macro #- run]
(macro [code]
["s" syntax #+ syntax:])))
## [Utils]
(def: regex-char^
- (Lexer Text)
- (&;none-of "\\.|&()[]{}"))
+ (l;Lexer Text)
+ (l;none-of "\\.|&()[]{}"))
(def: escaped-char^
- (Lexer Text)
- (do Monad<Lexer>
- [? (&;this? "\\")]
+ (l;Lexer Text)
+ (do p;Monad<Parser>
+ [? (l;this? "\\")]
(if ?
- &;any
+ l;any
regex-char^)))
(def: (local^ state lexer)
- (All [a] (-> Text (Lexer a) (Lexer a)))
+ (All [a] (-> Text (l;Lexer a) (l;Lexer a)))
(function [old-state]
(case (lexer state)
(#;Left error)
@@ -36,178 +37,176 @@
(#;Right [old-state value]))))
(def: #hidden (refine^ refinement^ base^)
- (All [a] (-> (Lexer a) (Lexer Text) (Lexer Text)))
- (do Monad<Lexer>
+ (All [a] (-> (l;Lexer a) (l;Lexer Text) (l;Lexer Text)))
+ (do p;Monad<Parser>
[output base^
_ (local^ output refinement^)]
(wrap output)))
(def: #hidden word^
- (Lexer Text)
- (&;either &;alpha-num
- (&;one-of "_")))
+ (l;Lexer Text)
+ (p;either l;alpha-num
+ (l;one-of "_")))
(def: #hidden (copy reference)
- (-> Text (Lexer Text))
- (&;after (&;this reference) (&/wrap reference)))
+ (-> Text (l;Lexer Text))
+ (p;after (l;this reference) (p/wrap reference)))
(def: #hidden (join-text^ part^)
- (-> (Lexer (List Text)) (Lexer Text))
- (do Monad<Lexer>
+ (-> (l;Lexer (List Text)) (l;Lexer Text))
+ (do p;Monad<Parser>
[parts part^]
(wrap (text;join-with "" parts))))
(def: identifier-char^
- (Lexer Text)
- (&;none-of "[]{}()s\"#;<>"))
+ (l;Lexer Text)
+ (l;none-of "[]{}()s\"#;<>"))
(def: identifier-part^
- (Lexer Text)
- (do Monad<Lexer>
- [head (refine^ (&;not &;digit)
+ (l;Lexer Text)
+ (do p;Monad<Parser>
+ [head (refine^ (l;not l;digit)
identifier-char^)
- tail (&;some' identifier-char^)]
+ tail (l;some identifier-char^)]
(wrap (format head tail))))
(def: (identifier^ current-module)
- (-> Text (Lexer Ident))
- (do Monad<Lexer>
- []
- ($_ &;either
- (&;seq (wrap current-module) (&;after (&;this ";;") identifier-part^))
- (&;seq identifier-part^ (&;after (&;this ";") identifier-part^))
- (&;seq (wrap "lux") (&;after (&;this ";") identifier-part^))
- (&;seq (wrap "") identifier-part^))))
+ (-> Text (l;Lexer Ident))
+ ($_ p;either
+ (p;seq (p/wrap current-module) (p;after (l;this ";;") identifier-part^))
+ (p;seq identifier-part^ (p;after (l;this ";") identifier-part^))
+ (p;seq (p/wrap "lux") (p;after (l;this ";") identifier-part^))
+ (p;seq (p/wrap "") identifier-part^)))
(def: (re-var^ current-module)
- (-> Text (Lexer Code))
- (do Monad<Lexer>
- [ident (&;enclosed ["\\@<" ">"] (identifier^ current-module))]
- (wrap (` (: (Lexer Text) (~ (code;symbol ident)))))))
+ (-> Text (l;Lexer Code))
+ (do p;Monad<Parser>
+ [ident (l;enclosed ["\\@<" ">"] (identifier^ current-module))]
+ (wrap (` (: (l;Lexer Text) (~ (code;symbol ident)))))))
(def: re-char-range^
- (Lexer Code)
- (do Monad<Lexer>
+ (l;Lexer Code)
+ (do p;Monad<Parser>
[from (|> regex-char^ (:: @ map (|>. (text;nth +0) assume)))
- _ (&;this "-")
+ _ (l;this "-")
to (|> regex-char^ (:: @ map (|>. (text;nth +0) assume)))]
- (wrap (` (&;char-range (~ (code;char from)) (~ (code;char to)))))))
+ (wrap (` (l;char-range (~ (code;char from)) (~ (code;char to)))))))
(def: re-char^
- (Lexer Code)
- (do Monad<Lexer>
+ (l;Lexer Code)
+ (do p;Monad<Parser>
[char escaped-char^]
(wrap (` (;;copy (~ (code;text char)))))))
(def: re-char-options^
- (Lexer Code)
- (do Monad<Lexer>
- [options (&;many' escaped-char^)]
- (wrap (` (&;one-of (~ (code;text options)))))))
+ (l;Lexer Code)
+ (do p;Monad<Parser>
+ [options (l;many escaped-char^)]
+ (wrap (` (l;one-of (~ (code;text options)))))))
(def: re-user-class^'
- (Lexer Code)
- (do Monad<Lexer>
- [negate? (&;opt (&;this "^"))
- parts (&;many ($_ &;either
+ (l;Lexer Code)
+ (do p;Monad<Parser>
+ [negate? (p;opt (l;this "^"))
+ parts (p;many ($_ p;either
re-char-range^
re-char-options^))]
(wrap (case negate?
- (#;Some _) (` (&;not ($_ &;either (~@ parts))))
- #;None (` ($_ &;either (~@ parts)))))))
+ (#;Some _) (` (l;not ($_ p;either (~@ parts))))
+ #;None (` ($_ p;either (~@ parts)))))))
(def: re-user-class^
- (Lexer Code)
- (do Monad<Lexer>
+ (l;Lexer Code)
+ (do p;Monad<Parser>
[_ (wrap [])
init re-user-class^'
- rest (&;some (&;after (&;this "&&") (&;enclosed ["[" "]"] re-user-class^')))]
- (wrap (fold (function [refinement base]
- (` (refine^ (~ refinement) (~ base))))
- init
- rest))))
+ rest (p;some (p;after (l;this "&&") (l;enclosed ["[" "]"] re-user-class^')))]
+ (wrap (L/fold (function [refinement base]
+ (` (refine^ (~ refinement) (~ base))))
+ init
+ rest))))
(def: #hidden blank^
- (Lexer Text)
- (&;one-of " \t"))
+ (l;Lexer Text)
+ (l;one-of " \t"))
(def: #hidden ascii^
- (Lexer Text)
- (&;char-range #"\u0000" #"\u007F"))
+ (l;Lexer Text)
+ (l;char-range #"\u0000" #"\u007F"))
(def: #hidden control^
- (Lexer Text)
- (&;either (&;char-range #"\u0000" #"\u001F")
- (&;one-of "\u007F")))
+ (l;Lexer Text)
+ (p;either (l;char-range #"\u0000" #"\u001F")
+ (l;one-of "\u007F")))
(def: #hidden punct^
- (Lexer Text)
- (&;one-of "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"))
+ (l;Lexer Text)
+ (l;one-of "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"))
(def: #hidden graph^
- (Lexer Text)
- (&;either punct^ &;alpha-num))
+ (l;Lexer Text)
+ (p;either punct^ l;alpha-num))
(def: #hidden print^
- (Lexer Text)
- (&;either graph^
- (&;one-of "\u0020")))
+ (l;Lexer Text)
+ (p;either graph^
+ (l;one-of "\u0020")))
(def: re-system-class^
- (Lexer Code)
- (do Monad<Lexer>
+ (l;Lexer Code)
+ (do p;Monad<Parser>
[]
- ($_ &;either
- (&;after (&;this ".") (wrap (` &;any)))
- (&;after (&;this "\\d") (wrap (` &;digit)))
- (&;after (&;this "\\D") (wrap (` (&;not &;digit))))
- (&;after (&;this "\\s") (wrap (` &;space)))
- (&;after (&;this "\\S") (wrap (` (&;not &;space))))
- (&;after (&;this "\\w") (wrap (` word^)))
- (&;after (&;this "\\W") (wrap (` (&;not word^))))
-
- (&;after (&;this "\\p{Lower}") (wrap (` &;lower)))
- (&;after (&;this "\\p{Upper}") (wrap (` &;upper)))
- (&;after (&;this "\\p{Alpha}") (wrap (` &;alpha)))
- (&;after (&;this "\\p{Digit}") (wrap (` &;digit)))
- (&;after (&;this "\\p{Alnum}") (wrap (` &;alpha-num)))
- (&;after (&;this "\\p{Space}") (wrap (` &;space)))
- (&;after (&;this "\\p{HexDigit}") (wrap (` &;hex-digit)))
- (&;after (&;this "\\p{OctDigit}") (wrap (` &;oct-digit)))
- (&;after (&;this "\\p{Blank}") (wrap (` blank^)))
- (&;after (&;this "\\p{ASCII}") (wrap (` ascii^)))
- (&;after (&;this "\\p{Contrl}") (wrap (` control^)))
- (&;after (&;this "\\p{Punct}") (wrap (` punct^)))
- (&;after (&;this "\\p{Graph}") (wrap (` graph^)))
- (&;after (&;this "\\p{Print}") (wrap (` print^)))
+ ($_ p;either
+ (p;after (l;this ".") (wrap (` l;any)))
+ (p;after (l;this "\\d") (wrap (` l;digit)))
+ (p;after (l;this "\\D") (wrap (` (l;not l;digit))))
+ (p;after (l;this "\\s") (wrap (` l;space)))
+ (p;after (l;this "\\S") (wrap (` (l;not l;space))))
+ (p;after (l;this "\\w") (wrap (` word^)))
+ (p;after (l;this "\\W") (wrap (` (l;not word^))))
+
+ (p;after (l;this "\\p{Lower}") (wrap (` l;lower)))
+ (p;after (l;this "\\p{Upper}") (wrap (` l;upper)))
+ (p;after (l;this "\\p{Alpha}") (wrap (` l;alpha)))
+ (p;after (l;this "\\p{Digit}") (wrap (` l;digit)))
+ (p;after (l;this "\\p{Alnum}") (wrap (` l;alpha-num)))
+ (p;after (l;this "\\p{Space}") (wrap (` l;space)))
+ (p;after (l;this "\\p{HexDigit}") (wrap (` l;hex-digit)))
+ (p;after (l;this "\\p{OctDigit}") (wrap (` l;oct-digit)))
+ (p;after (l;this "\\p{Blank}") (wrap (` blank^)))
+ (p;after (l;this "\\p{ASCII}") (wrap (` ascii^)))
+ (p;after (l;this "\\p{Contrl}") (wrap (` control^)))
+ (p;after (l;this "\\p{Punct}") (wrap (` punct^)))
+ (p;after (l;this "\\p{Graph}") (wrap (` graph^)))
+ (p;after (l;this "\\p{Print}") (wrap (` print^)))
)))
(def: re-class^
- (Lexer Code)
- (&;either re-system-class^
- (&;enclosed ["[" "]"] re-user-class^)))
+ (l;Lexer Code)
+ (p;either re-system-class^
+ (l;enclosed ["[" "]"] re-user-class^)))
(def: number^
- (Lexer Nat)
- (|> (&;many' &;digit)
- (&;codec number;Codec<Text,Int>)
- (&/map int-to-nat)))
+ (l;Lexer Nat)
+ (|> (l;many l;digit)
+ (l;codec number;Codec<Text,Int>)
+ (p/map int-to-nat)))
(def: re-back-reference^
- (Lexer Code)
- (&;either (do Monad<Lexer>
- [_ (&;this "\\")
+ (l;Lexer Code)
+ (p;either (do p;Monad<Parser>
+ [_ (l;this "\\")
id number^]
(wrap (` (;;copy (~ (code;symbol ["" (Int/encode (nat-to-int id))]))))))
- (do Monad<Lexer>
- [_ (&;this "\\k<")
+ (do p;Monad<Parser>
+ [_ (l;this "\\k<")
captured-name identifier-part^
- _ (&;this ">")]
+ _ (l;this ">")]
(wrap (` (;;copy (~ (code;symbol ["" captured-name]))))))))
(def: (re-simple^ current-module)
- (-> Text (Lexer Code))
- ($_ &;either
+ (-> Text (l;Lexer Code))
+ ($_ p;either
re-class^
(re-var^ current-module)
re-back-reference^
@@ -215,51 +214,51 @@
))
(def: (re-simple-quantified^ current-module)
- (-> Text (Lexer Code))
- (do Monad<Lexer>
+ (-> Text (l;Lexer Code))
+ (do p;Monad<Parser>
[base (re-simple^ current-module)
- quantifier (&;one-of "?*+")]
+ quantifier (l;one-of "?*+")]
(case quantifier
"?"
- (wrap (` (&;default "" (~ base))))
+ (wrap (` (p;default "" (~ base))))
"*"
- (wrap (` (join-text^ (&;some (~ base)))))
+ (wrap (` (join-text^ (p;some (~ base)))))
## "+"
_
- (wrap (` (join-text^ (&;many (~ base)))))
+ (wrap (` (join-text^ (p;many (~ base)))))
)))
(def: (re-counted-quantified^ current-module)
- (-> Text (Lexer Code))
- (do Monad<Lexer>
+ (-> Text (l;Lexer Code))
+ (do p;Monad<Parser>
[base (re-simple^ current-module)]
- (&;enclosed ["{" "}"]
- ($_ &;either
+ (l;enclosed ["{" "}"]
+ ($_ p;either
(do @
- [[from to] (&;seq number^ (&;after (&;this ",") number^))]
- (wrap (` (join-text^ (&;between (~ (code;nat from))
+ [[from to] (p;seq number^ (p;after (l;this ",") number^))]
+ (wrap (` (join-text^ (p;between (~ (code;nat from))
(~ (code;nat to))
(~ base))))))
(do @
- [limit (&;after (&;this ",") number^)]
- (wrap (` (join-text^ (&;at-most (~ (code;nat limit)) (~ base))))))
+ [limit (p;after (l;this ",") number^)]
+ (wrap (` (join-text^ (p;at-most (~ (code;nat limit)) (~ base))))))
(do @
- [limit (&;before (&;this ",") number^)]
- (wrap (` (join-text^ (&;at-least (~ (code;nat limit)) (~ base))))))
+ [limit (p;before (l;this ",") number^)]
+ (wrap (` (join-text^ (p;at-least (~ (code;nat limit)) (~ base))))))
(do @
[limit number^]
- (wrap (` (join-text^ (&;exactly (~ (code;nat limit)) (~ base))))))))))
+ (wrap (` (join-text^ (p;exactly (~ (code;nat limit)) (~ base))))))))))
(def: (re-quantified^ current-module)
- (-> Text (Lexer Code))
- (&;either (re-simple-quantified^ current-module)
+ (-> Text (l;Lexer Code))
+ (p;either (re-simple-quantified^ current-module)
(re-counted-quantified^ current-module)))
(def: (re-complex^ current-module)
- (-> Text (Lexer Code))
- ($_ &;either
+ (-> Text (l;Lexer Code))
+ ($_ p;either
(re-quantified^ current-module)
(re-simple^ current-module)))
@@ -273,61 +272,61 @@
(def: (re-sequential^ capturing? re-scoped^ current-module)
(-> Bool
- (-> Text (Lexer [Re-Group Code]))
+ (-> Text (l;Lexer [Re-Group Code]))
Text
- (Lexer [Nat Code]))
- (do Monad<Lexer>
- [parts (&;many (&;alt (re-complex^ current-module)
+ (l;Lexer [Nat Code]))
+ (do p;Monad<Parser>
+ [parts (p;many (p;alt (re-complex^ current-module)
(re-scoped^ current-module)))
#let [g!total (code;symbol ["" "0total"])
g!temp (code;symbol ["" "0temp"])
- [_ names steps] (fold (: (-> (Either Code [Re-Group Code])
- [Int (List Code) (List (List Code))]
- [Int (List Code) (List (List Code))])
- (function [part [idx names steps]]
- (case part
- (^or (#;Left complex) (#;Right [#Non-Capturing complex]))
- [idx
- names
- (list& (list g!temp complex
- (' #let) (` [(~ g!total) (_Text/append_ (~ g!total) (~ g!temp))]))
- steps)]
-
- (#;Right [(#Capturing [?name num-captures]) scoped])
- (let [[idx! name!] (case ?name
- (#;Some _name)
- [idx (code;symbol ["" _name])]
-
- #;None
- [(i.inc idx) (code;symbol ["" (Int/encode idx)])])
- access (if (n.> +0 num-captures)
- (` (product;left (~ name!)))
- name!)]
- [idx!
- (list& name! names)
- (list& (list name! scoped
- (' #let) (` [(~ g!total) (_Text/append_ (~ g!total) (~ access))]))
- steps)])
- )))
- [0
- (: (List Code) (list))
- (: (List (List Code)) (list))]
- parts)]]
+ [_ names steps] (L/fold (: (-> (Either Code [Re-Group Code])
+ [Int (List Code) (List (List Code))]
+ [Int (List Code) (List (List Code))])
+ (function [part [idx names steps]]
+ (case part
+ (^or (#;Left complex) (#;Right [#Non-Capturing complex]))
+ [idx
+ names
+ (list& (list g!temp complex
+ (' #let) (` [(~ g!total) (_Text/append_ (~ g!total) (~ g!temp))]))
+ steps)]
+
+ (#;Right [(#Capturing [?name num-captures]) scoped])
+ (let [[idx! name!] (case ?name
+ (#;Some _name)
+ [idx (code;symbol ["" _name])]
+
+ #;None
+ [(i.inc idx) (code;symbol ["" (Int/encode idx)])])
+ access (if (n.> +0 num-captures)
+ (` (product;left (~ name!)))
+ name!)]
+ [idx!
+ (list& name! names)
+ (list& (list name! scoped
+ (' #let) (` [(~ g!total) (_Text/append_ (~ g!total) (~ access))]))
+ steps)])
+ )))
+ [0
+ (: (List Code) (list))
+ (: (List (List Code)) (list))]
+ parts)]]
(wrap [(if capturing?
(list;size names)
+0)
- (` (do Monad<Lexer>
+ (` (do p;Monad<Parser>
[(~ (' #let)) [(~ g!total) ""]
- (~@ (|> steps list;reverse List/join))]
+ (~@ (|> steps list;reverse L/join))]
((~ (' wrap)) [(~ g!total) (~@ (list;reverse names))])))])
))
(def: #hidden (unflatten^ lexer)
- (-> (Lexer Text) (Lexer [Text Unit]))
- (&;seq lexer (:: Monad<Lexer> wrap [])))
+ (-> (l;Lexer Text) (l;Lexer [Text Unit]))
+ (p;seq lexer (:: p;Monad<Parser> wrap [])))
(def: #hidden (|||^ left right)
- (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer [Text (| l r)])))
+ (All [l r] (-> (l;Lexer [Text l]) (l;Lexer [Text r]) (l;Lexer [Text (| l r)])))
(function [input]
(case (left input)
(#;Right [input' [lt lv]])
@@ -342,7 +341,7 @@
(#;Left error)))))
(def: #hidden (|||_^ left right)
- (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer Text)))
+ (All [l r] (-> (l;Lexer [Text l]) (l;Lexer [Text r]) (l;Lexer Text)))
(function [input]
(case (left input)
(#;Right [input' [lt lv]])
@@ -364,48 +363,48 @@
(def: (re-alternative^ capturing? re-scoped^ current-module)
(-> Bool
- (-> Text (Lexer [Re-Group Code]))
+ (-> Text (l;Lexer [Re-Group Code]))
Text
- (Lexer [Nat Code]))
- (do Monad<Lexer>
+ (l;Lexer [Nat Code]))
+ (do p;Monad<Parser>
[#let [sub^ (re-sequential^ capturing? re-scoped^ current-module)]
head sub^
- tail (&;some (&;after (&;this "|") sub^))
+ tail (p;some (p;after (l;this "|") sub^))
#let [g!op (if capturing?
(` |||^)
(` |||_^))]]
(if (list;empty? tail)
(wrap head)
- (wrap [(fold n.max (product;left head) (List/map product;left tail))
- (` ($_ (~ g!op) (~ (prep-alternative head)) (~@ (List/map prep-alternative tail))))]))))
+ (wrap [(L/fold n.max (product;left head) (L/map product;left tail))
+ (` ($_ (~ g!op) (~ (prep-alternative head)) (~@ (L/map prep-alternative tail))))]))))
(def: (re-scoped^ current-module)
- (-> Text (Lexer [Re-Group Code]))
- ($_ &;either
- (do Monad<Lexer>
- [_ (&;this "(?:")
+ (-> Text (l;Lexer [Re-Group Code]))
+ ($_ p;either
+ (do p;Monad<Parser>
+ [_ (l;this "(?:")
[_ scoped] (re-alternative^ false re-scoped^ current-module)
- _ (&;this ")")]
+ _ (l;this ")")]
(wrap [#Non-Capturing scoped]))
- (do Monad<Lexer>
+ (do p;Monad<Parser>
[complex (re-complex^ current-module)]
(wrap [#Non-Capturing complex]))
- (do Monad<Lexer>
- [_ (&;this "(?<")
+ (do p;Monad<Parser>
+ [_ (l;this "(?<")
captured-name identifier-part^
- _ (&;this ">")
+ _ (l;this ">")
[num-captures pattern] (re-alternative^ true re-scoped^ current-module)
- _ (&;this ")")]
+ _ (l;this ")")]
(wrap [(#Capturing [(#;Some captured-name) num-captures]) pattern]))
- (do Monad<Lexer>
- [_ (&;this "(")
+ (do p;Monad<Parser>
+ [_ (l;this "(")
[num-captures pattern] (re-alternative^ true re-scoped^ current-module)
- _ (&;this ")")]
+ _ (l;this ")")]
(wrap [(#Capturing [#;None num-captures]) pattern]))))
(def: (regex^ current-module)
- (-> Text (Lexer Code))
- (:: Monad<Lexer> map product;right (re-alternative^ true re-scoped^ current-module)))
+ (-> Text (l;Lexer Code))
+ (:: p;Monad<Parser> map product;right (re-alternative^ true re-scoped^ current-module)))
## [Syntax]
(syntax: #export (regex [pattern s;text])
@@ -470,8 +469,8 @@
(do @
[current-module macro;current-module-name]
(case (|> (regex^ current-module)
- (&;before &;end)
- (&;run pattern))
+ (p;before l;end)
+ (l;run pattern))
(#;Left error)
(macro;fail (format "Error while parsing regular-expression:\n"
error))
@@ -480,9 +479,9 @@
(wrap (list regex))
)))
-(syntax: #export (^regex [[pattern bindings] (s;form (s;seq s;text (s;opt s;any)))]
+(syntax: #export (^regex [[pattern bindings] (s;form (p;seq s;text (p;opt s;any)))]
body
- [branches (s;many s;any)])
+ [branches (p;many s;any)])
{#;doc (doc "Allows you to test text against regular expressions."
(case some-text
(^regex "(\\d{3})-(\\d{3})-(\\d{4})"
@@ -497,7 +496,7 @@
(do @
[g!temp (macro;gensym "temp")]
(wrap (list& (` (^multi (~ g!temp)
- [(&;run (~ g!temp) (regex (~ (code;text pattern))))
+ [(l;run (~ g!temp) (regex (~ (code;text pattern))))
(#;Right (~ (default g!temp
bindings)))]))
body
diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux
index 0da2a2587..2a6aa45f4 100644
--- a/stdlib/source/lux/host.js.lux
+++ b/stdlib/source/lux/host.js.lux
@@ -1,6 +1,7 @@
(;module:
lux
- (lux (control monad)
+ (lux (control monad
+ ["p" parser])
(data (coll [list #* "L/" Fold<List>]))
[macro #+ with-gensyms]
(macro [code]
@@ -42,7 +43,7 @@
(wrap (list (` (:! (~ type)
(;_lux_proc ["js" "get-field"] [(~ object) (~ field-name)]))))))
-(syntax: #export (object [kvs (s;some (s;seq s;any s;any))])
+(syntax: #export (object [kvs (p;some (p;seq s;any s;any))])
{#;doc (doc "A way to create JavaScript objects."
(object)
(object "foo" foo "bar" (inc bar)))}
@@ -51,7 +52,7 @@
(` (;_lux_proc ["js" "object"] []))
kvs))))
-(syntax: #export (ref [name s;text] [type (s;opt s;any)])
+(syntax: #export (ref [name s;text] [type (p;opt s;any)])
{#;doc (doc "A way to refer to JavaScript variables."
(ref "document")
(ref "Math.ceil" (-> Real Real)))}
@@ -68,8 +69,8 @@
[undef "undefined" "Undefined."]
)
-(syntax: #export (call! [shape (s;alt ($_ s;seq s;any (s;tuple (s;some s;any)) (s;opt s;any))
- ($_ s;seq s;any s;text (s;tuple (s;some s;any)) (s;opt s;any)))])
+(syntax: #export (call! [shape (p;alt ($_ p;seq s;any (s;tuple (p;some s;any)) (p;opt s;any))
+ ($_ p;seq s;any s;text (s;tuple (p;some s;any)) (p;opt s;any)))])
{#;doc (doc "A way to call JavaScript functions and methods."
(call! (ref "Math.ceil") [123.45])
(call! (ref "Math") "ceil" [123.45]))}
diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux
index 10acfa13d..05f8313fc 100644
--- a/stdlib/source/lux/host.jvm.lux
+++ b/stdlib/source/lux/host.jvm.lux
@@ -1,7 +1,8 @@
(;module:
lux
(lux (control monad
- [enum])
+ [enum]
+ ["p" parser])
[io #+ IO Monad<IO> io]
(data (coll [list #* "" Functor<List> Fold<List> "List/" Monad<List> Monoid<List>]
[array #+ Array])
@@ -531,24 +532,24 @@
(def: (make-get-const-parser class-name field-name)
(-> Text Text (Syntax Code))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[#let [dotted-name (format "." field-name)]
_ (s;this (code;symbol ["" dotted-name]))]
(wrap (`' (_lux_proc ["jvm" (~ (code;text (format "getstatic" ":" class-name ":" field-name)))] [])))))
(def: (make-get-var-parser class-name field-name)
(-> Text Text (Syntax Code))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[#let [dotted-name (format "." field-name)]
_ (s;this (code;symbol ["" dotted-name]))]
(wrap (`' (_lux_proc ["jvm" (~ (code;text (format "getfield" ":" class-name ":" field-name)))] [_jvm_this])))))
(def: (make-put-var-parser class-name field-name)
(-> Text Text (Syntax Code))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[#let [dotted-name (format "." field-name)]
[_ _ value] (: (Syntax [Unit Unit Code])
- (s;form ($_ s;seq (s;this (' :=)) (s;this (code;symbol ["" dotted-name])) s;any)))]
+ (s;form ($_ p;seq (s;this (' :=)) (s;this (code;symbol ["" dotted-name])) s;any)))]
(wrap (`' (_lux_proc ["jvm" (~ (code;text (format "putfield" ":" class-name ":" field-name)))] [_jvm_this (~ value)])))))
(def: (pre-walk-replace f input)
@@ -571,7 +572,7 @@
(def: (parser->replacer p ast)
(-> (Syntax Code) (-> Code Code))
- (case (s;run (list ast) p)
+ (case (p;run (list ast) p)
(#;Right [#;Nil ast'])
ast'
@@ -586,24 +587,24 @@
(make-get-const-parser class-name field-name)
(#VariableField _)
- (s;either (make-get-var-parser class-name field-name)
+ (p;either (make-get-var-parser class-name field-name)
(make-put-var-parser class-name field-name))))
(def: (make-constructor-parser params class-name arg-decls)
(-> (List TypeParam) Text (List ArgDecl) (Syntax Code))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[[_ args] (: (Syntax [Unit (List Code)])
- (s;form ($_ s;seq (s;this (' .new!)) (s;tuple (s;exactly (list;size arg-decls) s;any)))))
+ (s;form ($_ p;seq (s;this (' .new!)) (s;tuple (p;exactly (list;size arg-decls) s;any)))))
#let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]]
(wrap (` (;_lux_proc ["jvm" (~ (code;text (format "new" ":" class-name ":" (text;join-with "," arg-decls'))))]
[(~@ args)])))))
(def: (make-static-method-parser params class-name method-name arg-decls)
(-> (List TypeParam) Text Text (List ArgDecl) (Syntax Code))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[#let [dotted-name (format "." method-name "!")]
[_ args] (: (Syntax [Unit (List Code)])
- (s;form ($_ s;seq (s;this (code;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any)))))
+ (s;form ($_ p;seq (s;this (code;symbol ["" dotted-name])) (s;tuple (p;exactly (list;size arg-decls) s;any)))))
#let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]]
(wrap (`' (;_lux_proc ["jvm" (~ (code;text (format "invokestatic" ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))]
[(~@ args)])))))
@@ -611,10 +612,10 @@
(do-template [<name> <jvm-op>]
[(def: (<name> params class-name method-name arg-decls)
(-> (List TypeParam) Text Text (List ArgDecl) (Syntax Code))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[#let [dotted-name (format "." method-name "!")]
[_ args] (: (Syntax [Unit (List Code)])
- (s;form ($_ s;seq (s;this (code;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any)))))
+ (s;form ($_ p;seq (s;this (code;symbol ["" dotted-name])) (s;tuple (p;exactly (list;size arg-decls) s;any)))))
#let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]]
(wrap (`' (;_lux_proc ["jvm" (~ (code;text (format <jvm-op> ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))]
[(~' _jvm_this) (~@ args)])))))]
@@ -644,14 +645,14 @@
## Syntaxs
(def: (full-class-name^ imports)
(-> ClassImports (Syntax Text))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[name s;local-symbol]
(wrap (fully-qualify-class-name imports name))))
(def: privacy-modifier^
(Syntax PrivacyModifier)
- (let [(^open) s;Monad<Syntax>]
- ($_ s;alt
+ (let [(^open) p;Monad<Parser>]
+ ($_ p;alt
(s;this (' #public))
(s;this (' #private))
(s;this (' #protected))
@@ -659,29 +660,29 @@
(def: inheritance-modifier^
(Syntax InheritanceModifier)
- (let [(^open) s;Monad<Syntax>]
- ($_ s;alt
+ (let [(^open) p;Monad<Parser>]
+ ($_ p;alt
(s;this (' #final))
(s;this (' #abstract))
(wrap []))))
(def: bound-kind^
(Syntax BoundKind)
- (s;alt (s;this (' <))
+ (p;alt (s;this (' <))
(s;this (' >))))
(def: (generic-type^ imports type-vars)
(-> ClassImports (List TypeParam) (Syntax GenericType))
- ($_ s;either
- (do s;Monad<Syntax>
+ ($_ p;either
+ (do p;Monad<Parser>
[_ (s;this (' ?))]
(wrap (#GenericWildcard #;None)))
- (s;tuple (do s;Monad<Syntax>
+ (s;tuple (do p;Monad<Parser>
[_ (s;this (' ?))
bound-kind bound-kind^
bound (generic-type^ imports type-vars)]
(wrap (#GenericWildcard (#;Some [bound-kind bound])))))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[name (full-class-name^ imports)]
(with-expansions
[<branches> (do-template [<class> <name>]
@@ -703,7 +704,7 @@
## else
(wrap (#GenericClass name (list))))))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[name (s;this (' Array))
component (generic-type^ imports type-vars)]
(case component
@@ -721,93 +722,93 @@
_
(wrap (#GenericArray component)))))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[name (full-class-name^ imports)
- params (s;some (generic-type^ imports type-vars))
- _ (s;assert (format name " cannot be a type-parameter!")
+ params (p;some (generic-type^ imports type-vars))
+ _ (p;assert (format name " cannot be a type-parameter!")
(not (member? text;Eq<Text> (map product;left type-vars) name)))]
(wrap (#GenericClass name params))))
))
(def: (type-param^ imports)
(-> ClassImports (Syntax TypeParam))
- (s;either (do s;Monad<Syntax>
+ (p;either (do p;Monad<Parser>
[param-name s;local-symbol]
(wrap [param-name (list)]))
- (s;tuple (do s;Monad<Syntax>
+ (s;tuple (do p;Monad<Parser>
[param-name s;local-symbol
_ (s;this (' <))
- bounds (s;many (generic-type^ imports (list)))]
+ bounds (p;many (generic-type^ imports (list)))]
(wrap [param-name bounds])))))
(def: (type-params^ imports)
(-> ClassImports (Syntax (List TypeParam)))
- (s;tuple (s;some (type-param^ imports))))
+ (s;tuple (p;some (type-param^ imports))))
(def: (class-decl^ imports)
(-> ClassImports (Syntax ClassDecl))
- (s;either (do s;Monad<Syntax>
+ (p;either (do p;Monad<Parser>
[name (full-class-name^ imports)]
(wrap [name (list)]))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[name (full-class-name^ imports)
- params (s;some (type-param^ imports))]
+ params (p;some (type-param^ imports))]
(wrap [name params])))
))
(def: (super-class-decl^ imports type-vars)
(-> ClassImports (List TypeParam) (Syntax SuperClassDecl))
- (s;either (do s;Monad<Syntax>
+ (p;either (do p;Monad<Parser>
[name (full-class-name^ imports)]
(wrap [name (list)]))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[name (full-class-name^ imports)
- params (s;some (generic-type^ imports type-vars))]
+ params (p;some (generic-type^ imports type-vars))]
(wrap [name params])))))
(def: annotation-params^
(Syntax (List AnnotationParam))
- (s;record (s;some (s;seq s;local-tag s;any))))
+ (s;record (p;some (p;seq s;local-tag s;any))))
(def: (annotation^ imports)
(-> ClassImports (Syntax Annotation))
- (s;either (do s;Monad<Syntax>
+ (p;either (do p;Monad<Parser>
[ann-name (full-class-name^ imports)]
(wrap [ann-name (list)]))
- (s;form (s;seq (full-class-name^ imports)
+ (s;form (p;seq (full-class-name^ imports)
annotation-params^))))
(def: (annotations^' imports)
(-> ClassImports (Syntax (List Annotation)))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[_ (s;this (' #ann))]
- (s;tuple (s;some (annotation^ imports)))))
+ (s;tuple (p;some (annotation^ imports)))))
(def: (annotations^ imports)
(-> ClassImports (Syntax (List Annotation)))
- (do s;Monad<Syntax>
- [anns?? (s;opt (annotations^' imports))]
+ (do p;Monad<Parser>
+ [anns?? (p;opt (annotations^' imports))]
(wrap (default (list) anns??))))
(def: (throws-decl'^ imports type-vars)
(-> ClassImports (List TypeParam) (Syntax (List GenericType)))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[_ (s;this (' #throws))]
- (s;tuple (s;some (generic-type^ imports type-vars)))))
+ (s;tuple (p;some (generic-type^ imports type-vars)))))
(def: (throws-decl^ imports type-vars)
(-> ClassImports (List TypeParam) (Syntax (List GenericType)))
- (do s;Monad<Syntax>
- [exs? (s;opt (throws-decl'^ imports type-vars))]
+ (do p;Monad<Parser>
+ [exs? (p;opt (throws-decl'^ imports type-vars))]
(wrap (default (list) exs?))))
(def: (method-decl^ imports type-vars)
(-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDecl]))
- (s;form (do s;Monad<Syntax>
- [tvars (s;default (list) (type-params^ imports))
+ (s;form (do p;Monad<Parser>
+ [tvars (p;default (list) (type-params^ imports))
name s;local-symbol
anns (annotations^ imports)
- inputs (s;tuple (s;some (generic-type^ imports type-vars)))
+ inputs (s;tuple (p;some (generic-type^ imports type-vars)))
output (generic-type^ imports type-vars)
exs (throws-decl^ imports type-vars)]
(wrap [[name #PublicPM anns] {#method-tvars tvars
@@ -817,21 +818,21 @@
(def: state-modifier^
(Syntax StateModifier)
- ($_ s;alt
+ ($_ p;alt
(s;this (' #volatile))
(s;this (' #final))
- (:: s;Monad<Syntax> wrap [])))
+ (:: p;Monad<Parser> wrap [])))
(def: (field-decl^ imports type-vars)
(-> ClassImports (List TypeParam) (Syntax [MemberDecl FieldDecl]))
- (s;either (s;form (do s;Monad<Syntax>
+ (p;either (s;form (do p;Monad<Parser>
[_ (s;this (' #const))
name s;local-symbol
anns (annotations^ imports)
type (generic-type^ imports type-vars)
body s;any]
(wrap [[name #PublicPM anns] (#ConstantField [type body])])))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[pm privacy-modifier^
sm state-modifier^
name s;local-symbol
@@ -841,29 +842,29 @@
(def: (arg-decl^ imports type-vars)
(-> ClassImports (List TypeParam) (Syntax ArgDecl))
- (s;tuple (s;seq s;local-symbol
+ (s;tuple (p;seq s;local-symbol
(generic-type^ imports type-vars))))
(def: (arg-decls^ imports type-vars)
(-> ClassImports (List TypeParam) (Syntax (List ArgDecl)))
- (s;some (arg-decl^ imports type-vars)))
+ (p;some (arg-decl^ imports type-vars)))
(def: (constructor-arg^ imports type-vars)
(-> ClassImports (List TypeParam) (Syntax ConstructorArg))
- (s;tuple (s;seq (generic-type^ imports type-vars) s;any)))
+ (s;tuple (p;seq (generic-type^ imports type-vars) s;any)))
(def: (constructor-args^ imports type-vars)
(-> ClassImports (List TypeParam) (Syntax (List ConstructorArg)))
- (s;tuple (s;some (constructor-arg^ imports type-vars))))
+ (s;tuple (p;some (constructor-arg^ imports type-vars))))
(def: (constructor-method^ imports class-vars)
(-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef]))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[pm privacy-modifier^
strict-fp? (s;this? (' #strict))
- method-vars (s;default (list) (type-params^ imports))
+ method-vars (p;default (list) (type-params^ imports))
#let [total-vars (List/append class-vars method-vars)]
- [_ arg-decls] (s;form (s;seq (s;this (' new))
+ [_ arg-decls] (s;form (p;seq (s;this (' new))
(arg-decls^ imports total-vars)))
constructor-args (constructor-args^ imports total-vars)
exs (throws-decl^ imports total-vars)
@@ -876,13 +877,13 @@
(def: (virtual-method-def^ imports class-vars)
(-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef]))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[pm privacy-modifier^
strict-fp? (s;this? (' #strict))
final? (s;this? (' #final))
- method-vars (s;default (list) (type-params^ imports))
+ method-vars (p;default (list) (type-params^ imports))
#let [total-vars (List/append class-vars method-vars)]
- [name arg-decls] (s;form (s;seq s;local-symbol
+ [name arg-decls] (s;form (p;seq s;local-symbol
(arg-decls^ imports total-vars)))
return-type (generic-type^ imports total-vars)
exs (throws-decl^ imports total-vars)
@@ -895,12 +896,12 @@
(def: (overriden-method-def^ imports)
(-> ClassImports (Syntax [MemberDecl MethodDef]))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[strict-fp? (s;this? (' #strict))
owner-class (class-decl^ imports)
- method-vars (s;default (list) (type-params^ imports))
+ method-vars (p;default (list) (type-params^ imports))
#let [total-vars (List/append (product;right owner-class) method-vars)]
- [name arg-decls] (s;form (s;seq s;local-symbol
+ [name arg-decls] (s;form (p;seq s;local-symbol
(arg-decls^ imports total-vars)))
return-type (generic-type^ imports total-vars)
exs (throws-decl^ imports total-vars)
@@ -913,13 +914,13 @@
(def: (static-method-def^ imports)
(-> ClassImports (Syntax [MemberDecl MethodDef]))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[pm privacy-modifier^
strict-fp? (s;this? (' #strict))
_ (s;this (' #static))
- method-vars (s;default (list) (type-params^ imports))
+ method-vars (p;default (list) (type-params^ imports))
#let [total-vars method-vars]
- [name arg-decls] (s;form (s;seq s;local-symbol
+ [name arg-decls] (s;form (p;seq s;local-symbol
(arg-decls^ imports total-vars)))
return-type (generic-type^ imports total-vars)
exs (throws-decl^ imports total-vars)
@@ -932,12 +933,12 @@
(def: (abstract-method-def^ imports)
(-> ClassImports (Syntax [MemberDecl MethodDef]))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[pm privacy-modifier^
_ (s;this (' #abstract))
- method-vars (s;default (list) (type-params^ imports))
+ method-vars (p;default (list) (type-params^ imports))
#let [total-vars method-vars]
- [name arg-decls] (s;form (s;seq s;local-symbol
+ [name arg-decls] (s;form (p;seq s;local-symbol
(arg-decls^ imports total-vars)))
return-type (generic-type^ imports total-vars)
exs (throws-decl^ imports total-vars)
@@ -949,12 +950,12 @@
(def: (native-method-def^ imports)
(-> ClassImports (Syntax [MemberDecl MethodDef]))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[pm privacy-modifier^
_ (s;this (' #native))
- method-vars (s;default (list) (type-params^ imports))
+ method-vars (p;default (list) (type-params^ imports))
#let [total-vars method-vars]
- [name arg-decls] (s;form (s;seq s;local-symbol
+ [name arg-decls] (s;form (p;seq s;local-symbol
(arg-decls^ imports total-vars)))
return-type (generic-type^ imports total-vars)
exs (throws-decl^ imports total-vars)
@@ -966,7 +967,7 @@
(def: (method-def^ imports class-vars)
(-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef]))
- ($_ s;either
+ ($_ p;either
(constructor-method^ imports class-vars)
(virtual-method-def^ imports class-vars)
(overriden-method-def^ imports)
@@ -976,50 +977,50 @@
(def: partial-call^
(Syntax PartialCall)
- (s;form (s;seq s;any s;any)))
+ (s;form (p;seq s;any s;any)))
(def: class-kind^
(Syntax ClassKind)
- (s;either (do s;Monad<Syntax>
+ (p;either (do p;Monad<Parser>
[_ (s;this (' #class))]
(wrap #Class))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[_ (s;this (' #interface))]
(wrap #Interface))
))
(def: import-member-alias^
(Syntax (Maybe Text))
- (s;opt (do s;Monad<Syntax>
+ (p;opt (do p;Monad<Parser>
[_ (s;this (' #as))]
s;local-symbol)))
(def: (import-member-args^ imports type-vars)
(-> ClassImports (List TypeParam) (Syntax (List [Bool GenericType])))
- (s;tuple (s;some (s;seq (s;this? (' #?)) (generic-type^ imports type-vars)))))
+ (s;tuple (p;some (p;seq (s;this? (' #?)) (generic-type^ imports type-vars)))))
(def: import-member-return-flags^
(Syntax [Bool Bool Bool])
- ($_ s;seq (s;this? (' #io)) (s;this? (' #try)) (s;this? (' #?))))
+ ($_ p;seq (s;this? (' #io)) (s;this? (' #try)) (s;this? (' #?))))
(def: primitive-mode^
(Syntax Primitive-Mode)
- (s;alt (s;this (' #manual))
+ (p;alt (s;this (' #manual))
(s;this (' #auto))))
(def: (import-member-decl^ imports owner-vars)
(-> ClassImports (List TypeParam) (Syntax ImportMemberDecl))
- ($_ s;either
- (s;form (do s;Monad<Syntax>
+ ($_ p;either
+ (s;form (do p;Monad<Parser>
[_ (s;this (' #enum))
- enum-members (s;some s;local-symbol)]
+ enum-members (p;some s;local-symbol)]
(wrap (#EnumDecl enum-members))))
- (s;form (do s;Monad<Syntax>
- [tvars (s;default (list) (type-params^ imports))
+ (s;form (do p;Monad<Parser>
+ [tvars (p;default (list) (type-params^ imports))
_ (s;this (' new))
?alias import-member-alias^
#let [total-vars (List/append owner-vars tvars)]
- ?prim-mode (s;opt primitive-mode^)
+ ?prim-mode (p;opt primitive-mode^)
args (import-member-args^ imports total-vars)
[io? try? maybe?] import-member-return-flags^]
(wrap (#ConstructorDecl [{#import-member-mode (default #AutoPrM ?prim-mode)
@@ -1032,15 +1033,15 @@
#import-member-io? io?}
{}]))
))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[kind (: (Syntax ImportMethodKind)
- (s;alt (s;this (' #static))
+ (p;alt (s;this (' #static))
(wrap [])))
- tvars (s;default (list) (type-params^ imports))
+ tvars (p;default (list) (type-params^ imports))
name s;local-symbol
?alias import-member-alias^
#let [total-vars (List/append owner-vars tvars)]
- ?prim-mode (s;opt primitive-mode^)
+ ?prim-mode (p;opt primitive-mode^)
args (import-member-args^ imports total-vars)
[io? try? maybe?] import-member-return-flags^
return (generic-type^ imports total-vars)]
@@ -1055,10 +1056,10 @@
{#import-method-name name
#import-method-return return
}]))))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[static? (s;this? (' #static))
name s;local-symbol
- ?prim-mode (s;opt primitive-mode^)
+ ?prim-mode (p;opt primitive-mode^)
gtype (generic-type^ imports owner-vars)
maybe? (s;this? (' #?))
setter? (s;this? (' #!))]
@@ -1223,9 +1224,9 @@
(code;to-text (pre-walk-replace replacer body)))))
(#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs)
- (let [super-replacer (parser->replacer (s;form (do s;Monad<Syntax>
+ (let [super-replacer (parser->replacer (s;form (do p;Monad<Parser>
[_ (s;this (' .super!))
- args (s;tuple (s;exactly (list;size arg-decls) s;any))
+ args (s;tuple (p;exactly (list;size arg-decls) s;any))
#let [arg-decls' (: (List Text) (map (. (simple-class$ (list)) product;right)
arg-decls))]]
(wrap (`' (;_lux_proc ["jvm" (~ (code;text (format "invokespecial" ":" (get@ #super-class-name super-class) ":" name ":" (text;join-with "," arg-decls'))))]
@@ -1299,13 +1300,13 @@
imports (add-import [(short-class-name full-class-name) full-class-name]
(class-imports *compiler*))]]
[#let [class-vars (product;right class-decl)]]
- [super (s;default object-super-class
+ [super (p;default object-super-class
(super-class-decl^ imports class-vars))]
- [interfaces (s;default (list)
- (s;tuple (s;some (super-class-decl^ imports class-vars))))]
+ [interfaces (p;default (list)
+ (s;tuple (p;some (super-class-decl^ imports class-vars))))]
[annotations (annotations^ imports)]
- [fields (s;some (field-decl^ imports class-vars))]
- [methods (s;some (method-def^ imports class-vars))])
+ [fields (p;some (field-decl^ imports class-vars))]
+ [methods (p;some (method-def^ imports class-vars))])
{#;doc (doc "Allows defining JVM classes in Lux code."
"For example:"
(class: #final (JvmPromise A) []
@@ -1364,8 +1365,8 @@
#let [fully-qualified-class-name (format (text;replace-all "/" "." current-module) "." full-class-name)
field-parsers (map (field->parser fully-qualified-class-name) fields)
method-parsers (map (method->parser (product;right class-decl) fully-qualified-class-name) methods)
- replacer (parser->replacer (fold s;either
- (s;fail "")
+ replacer (parser->replacer (fold p;either
+ (p;fail "")
(List/append field-parsers method-parsers)))
def-code (format "class:"
(spaced (list (class-decl$ class-decl)
@@ -1383,10 +1384,10 @@
imports (add-import [(short-class-name full-class-name) full-class-name]
(class-imports *compiler*))]]
[#let [class-vars (product;right class-decl)]]
- [supers (s;default (list)
- (s;tuple (s;some (super-class-decl^ imports class-vars))))]
+ [supers (p;default (list)
+ (s;tuple (p;some (super-class-decl^ imports class-vars))))]
[annotations (annotations^ imports)]
- [members (s;some (method-decl^ imports class-vars))])
+ [members (p;some (method-decl^ imports class-vars))])
{#;doc (doc "Allows defining JVM interfaces."
(interface: TestInterface
([] foo [boolean String] void #throws [Exception])))}
@@ -1400,12 +1401,12 @@
(syntax: #export (object [#let [imports (class-imports *compiler*)]]
[#let [class-vars (list)]]
- [super (s;default object-super-class
+ [super (p;default object-super-class
(super-class-decl^ imports class-vars))]
- [interfaces (s;default (list)
- (s;tuple (s;some (super-class-decl^ imports class-vars))))]
+ [interfaces (p;default (list)
+ (s;tuple (p;some (super-class-decl^ imports class-vars))))]
[constructor-args (constructor-args^ imports class-vars)]
- [methods (s;some (overriden-method-def^ imports))])
+ [methods (p;some (overriden-method-def^ imports))])
{#;doc (doc "Allows defining anonymous classes."
"The 1st vector corresponds to parent interfaces."
"The 2nd vector corresponds to arguments to the super class constructor."
@@ -1480,7 +1481,7 @@
(syntax: #export (instance? [#let [imports (class-imports *compiler*)]]
[class (generic-type^ imports (list))]
- [obj (s;opt s;any)])
+ [obj (p;opt s;any)])
{#;doc (doc "Checks whether an object is an instance of a particular class."
"Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes."
(instance? String "YOLO"))}
@@ -1504,7 +1505,7 @@
(finish-the-computation ...))))}
(wrap (list (` (;_lux_proc ["jvm" "synchronized"] [(~ lock) (~ body)])))))
-(syntax: #export (do-to obj [methods (s;some partial-call^)])
+(syntax: #export (do-to obj [methods (p;some partial-call^)])
{#;doc (doc "Call a variety of methods on an object; then return the object."
(do-to vreq
(HttpServerRequest.setExpectMultipart [true])
@@ -1921,7 +1922,7 @@
[#let [full-class-name (product;left class-decl)
imports (add-import [(short-class-name full-class-name) full-class-name]
(class-imports *compiler*))]]
- [members (s;some (import-member-decl^ imports (product;right class-decl)))])
+ [members (p;some (import-member-decl^ imports (product;right class-decl)))])
{#;doc (doc "Allows importing JVM classes, and using them as types."
"Their methods, fields and enum options can also be imported."
"Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes."
@@ -2083,7 +2084,7 @@
(def: simple-bindings^
(Syntax (List [Text Code]))
- (s;tuple (s;some (s;seq s;local-symbol s;any))))
+ (s;tuple (p;some (p;seq s;local-symbol s;any))))
(syntax: #export (with-open [bindings simple-bindings^] body)
{#;doc (doc "Creates a local-binding with the desired resources, and runs the body (assumed to be in the IO type)."
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
index 67a2a5013..7f1c7bc8c 100644
--- a/stdlib/source/lux/macro/poly.lux
+++ b/stdlib/source/lux/macro/poly.lux
@@ -1,7 +1,8 @@
(;module:
[lux #- function]
(lux (control monad
- [eq])
+ [eq]
+ ["p" parser])
(data [text]
text/format
(coll [list "List/" Fold<List> Monad<List>]
@@ -312,10 +313,10 @@
))))
(syntax: #export (poly: [_ex-lev csr;export]
- [[name env inputs] (s;form ($_ s;seq
+ [[name env inputs] (s;form ($_ p;seq
s;local-symbol
s;local-symbol
- (s;many s;local-symbol)))]
+ (p;many s;local-symbol)))]
body)
(with-gensyms [g!body]
(let [g!inputs (List/map (|>. [""] code;symbol) inputs)
@@ -346,9 +347,9 @@
#;None))
(syntax: #export (derived: [_ex-lev csr;export]
- [?name (s;opt s;local-symbol)]
- [[poly-func poly-args] (s;form (s;seq s;symbol (s;many s;symbol)))]
- [?custom-impl (s;opt s;any)])
+ [?name (p;opt s;local-symbol)]
+ [[poly-func poly-args] (s;form (p;seq s;symbol (p;many s;symbol)))]
+ [?custom-impl (p;opt s;any)])
(do @
[poly-args (mapM @ macro;normalize poly-args)
name (case ?name
diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux
index f5742d6ef..d9eb96731 100644
--- a/stdlib/source/lux/macro/syntax.lux
+++ b/stdlib/source/lux/macro/syntax.lux
@@ -1,10 +1,11 @@
(;module:
- [lux #- not default]
+ lux
(lux [macro #+ Monad<Lux> with-gensyms]
(control functor
applicative
monad
- eq)
+ eq
+ ["p" parser])
(data [bool]
[char]
[number]
@@ -23,52 +24,9 @@
(#;Cons [[x y] pairs']) (list& x y (join-pairs pairs'))))
## [Types]
-(type: #export (Syntax a)
+(type: #export Syntax
{#;doc "A Lux syntax parser."}
- (-> (List Code) (R;Result [(List Code) a])))
-
-## [Structures]
-(struct: #export _ (Functor Syntax)
- (def: (map f ma)
- (function [tokens]
- (case (ma tokens)
- (#R;Error msg)
- (#R;Error msg)
-
- (#R;Success [tokens' a])
- (#R;Success [tokens' (f a)])))))
-
-(struct: #export _ (Applicative Syntax)
- (def: functor Functor<Syntax>)
-
- (def: (wrap x tokens)
- (#R;Success [tokens x]))
-
- (def: (apply ff fa)
- (function [tokens]
- (case (ff tokens)
- (#R;Success [tokens' f])
- (case (fa tokens')
- (#R;Success [tokens'' a])
- (#R;Success [tokens'' (f a)])
-
- (#R;Error msg)
- (#R;Error msg))
-
- (#R;Error msg)
- (#R;Error msg)))))
-
-(struct: #export _ (Monad Syntax)
- (def: applicative Applicative<Syntax>)
-
- (def: (join mma)
- (function [tokens]
- (case (mma tokens)
- (#R;Error msg)
- (#R;Error msg)
-
- (#R;Success [tokens' ma])
- (ma tokens')))))
+ (p;Parser (List Code)))
## [Utils]
(def: (remaining-inputs asts)
@@ -137,20 +95,12 @@
_
(#R;Error "There are no tokens to parse!"))))
-(def: #export (assert message test)
- {#;doc "Fails with the given message if the test is false."}
- (-> Text Bool (Syntax Unit))
- (function [tokens]
- (if test
- (#R;Success [tokens []])
- (#R;Error ($_ Text/append message (remaining-inputs tokens))))))
-
(do-template [<name> <comp> <error>]
[(def: #export <name>
(Syntax Int)
- (do Monad<Syntax>
+ (do p;Monad<Parser>
[n int
- _ (assert <error> (<comp> 0 n))]
+ _ (p;assert <error> (<comp> 0 n))]
(wrap n)))]
[pos-int i.> "Expected a positive integer: N > 0"]
@@ -206,74 +156,6 @@
_
(#R;Error ($_ Text/append "Cannot parse record" (remaining-inputs tokens))))))
-(def: #export (opt p)
- {#;doc "Optionality combinator."}
- (All [a]
- (-> (Syntax a) (Syntax (Maybe a))))
- (function [tokens]
- (case (p tokens)
- (#R;Error _) (#R;Success [tokens #;None])
- (#R;Success [tokens' x]) (#R;Success [tokens' (#;Some x)]))))
-
-(def: #export (run tokens p)
- (All [a]
- (-> (List Code) (Syntax a) (R;Result [(List Code) a])))
- (p tokens))
-
-(def: #export (some p)
- {#;doc "0-or-more combinator."}
- (All [a]
- (-> (Syntax a) (Syntax (List a))))
- (function [tokens]
- (case (p tokens)
- (#R;Error _) (#R;Success [tokens (list)])
- (#R;Success [tokens' x]) (run tokens'
- (do Monad<Syntax>
- [xs (some p)]
- (wrap (list& x xs)))
- ))))
-
-(def: #export (many p)
- {#;doc "1-or-more combinator."}
- (All [a]
- (-> (Syntax a) (Syntax (List a))))
- (do Monad<Syntax>
- [x p
- xs (some p)]
- (wrap (list& x xs))))
-
-(def: #export (seq p1 p2)
- {#;doc "Sequencing combinator."}
- (All [a b]
- (-> (Syntax a) (Syntax b) (Syntax [a b])))
- (do Monad<Syntax>
- [x1 p1
- x2 p2]
- (wrap [x1 x2])))
-
-(def: #export (alt p1 p2)
- {#;doc "Heterogeneous alternative combinator."}
- (All [a b]
- (-> (Syntax a) (Syntax b) (Syntax (| a b))))
- (function [tokens]
- (case (p1 tokens)
- (#R;Success [tokens' x1]) (#R;Success [tokens' (+0 x1)])
- (#R;Error _) (run tokens
- (do Monad<Syntax>
- [x2 p2]
- (wrap (+1 x2))))
- )))
-
-(def: #export (either pl pr)
- {#;doc "Homogeneous alternative combinator."}
- (All [a]
- (-> (Syntax a) (Syntax a) (Syntax a)))
- (function [tokens]
- (case (pl tokens)
- (#R;Error _) (pr tokens)
- output output
- )))
-
(def: #export end!
{#;doc "Ensures there are no more inputs."}
(Syntax Unit)
@@ -290,90 +172,6 @@
#;Nil (#R;Success [tokens true])
_ (#R;Success [tokens false]))))
-(def: #export (exactly n p)
- {#;doc "Parse exactly N times."}
- (All [a] (-> Nat (Syntax a) (Syntax (List a))))
- (if (n.> +0 n)
- (do Monad<Syntax>
- [x p
- xs (exactly (n.dec n) p)]
- (wrap (#;Cons x xs)))
- (:: Monad<Syntax> wrap (list))))
-
-(def: #export (at-least n p)
- {#;doc "Parse at least N times."}
- (All [a] (-> Nat (Syntax a) (Syntax (List a))))
- (do Monad<Syntax>
- [min (exactly n p)
- extra (some p)]
- (wrap (List/append min extra))))
-
-(def: #export (at-most n p)
- {#;doc "Parse at most N times."}
- (All [a] (-> Nat (Syntax a) (Syntax (List a))))
- (if (n.> +0 n)
- (function [input]
- (case (p input)
- (#R;Error msg)
- (#R;Success [input (list)])
-
- (#R;Success [input' x])
- (run input'
- (do Monad<Syntax>
- [xs (at-most (n.dec n) p)]
- (wrap (#;Cons x xs))))
- ))
- (:: Monad<Syntax> wrap (list))))
-
-(def: #export (between from to p)
- {#;doc "Parse between N and M times."}
- (All [a] (-> Nat Nat (Syntax a) (Syntax (List a))))
- (do Monad<Syntax>
- [min-xs (exactly from p)
- max-xs (at-most (n.- from to) p)]
- (wrap (:: Monad<List> join (list min-xs max-xs)))))
-
-(def: #export (sep-by sep p)
- {#;doc "Parsers instances of 'p' that are separated by instances of 'sep'."}
- (All [a b] (-> (Syntax b) (Syntax a) (Syntax (List a))))
- (do Monad<Syntax>
- [?x (opt p)]
- (case ?x
- #;None
- (wrap #;Nil)
-
- (#;Some x)
- (do @
- [xs' (some (seq sep p))]
- (wrap (#;Cons x (map product;right xs'))))
- )))
-
-(def: #export (not p)
- (All [a] (-> (Syntax a) (Syntax Unit)))
- (function [input]
- (case (p input)
- (#R;Error msg)
- (#R;Success [input []])
-
- _
- (#R;Error "Expected to fail; yet succeeded."))))
-
-(def: #export (fail message)
- (All [a] (-> Text (Syntax a)))
- (function [input]
- (#R;Error message)))
-
-(def: #export (default value parser)
- {#;doc "If the given parser fails, returns the default value."}
- (All [a] (-> a (Syntax a) (Syntax a)))
- (function [input]
- (case (parser input)
- (#R;Error error)
- (#R;Success [input value])
-
- (#R;Success [input' output])
- (#R;Success [input' output]))))
-
(def: #export (on compiler action)
{#;doc "Run a Lux operation as if it was a Syntax parser."}
(All [a] (-> Compiler (Lux a) (Syntax a)))
@@ -404,28 +202,12 @@
(|> (map code;to-text unconsumed-inputs)
(text;join-with ", "))))))))
-(def: #export (rec syntax)
- {#;doc "Combinator for recursive syntax."}
- (All [a] (-> (-> (Syntax a) (Syntax a)) (Syntax a)))
- (function [inputs]
- (run inputs (syntax (rec syntax)))))
-
-(def: #export (after param subject)
- (All [p s] (-> (Syntax p) (Syntax s) (Syntax s)))
- (do Monad<Syntax>
- [_ param]
- subject))
-
-(def: #export (before param subject)
- (All [p s] (-> (Syntax p) (Syntax s) (Syntax s)))
- (do Monad<Syntax>
- [output subject
- _ param]
- (wrap output)))
-
## [Syntax]
(def: #hidden text.join-with text;join-with)
+(def: #hidden _run_ p;run)
+(def: #hidden _Monad<Parser>_ p;Monad<Parser>)
+
(macro: #export (syntax: tokens)
{#;doc (doc "A more advanced way to define macros than macro:."
"The inputs to the macro can be parsed in complex ways through the use of syntax parsers."
@@ -497,14 +279,14 @@
(wrap (list (` (macro: (~@ export-ast) ((~ (code;symbol ["" name])) (~ g!tokens))
(~ meta)
(function [(~ g!state)]
- (;_lux_case (run (~ g!tokens)
- (: (Syntax (Lux (List Code)))
- (do Monad<Syntax>
- [(~@ (join-pairs vars+parsers))
- (~ g!end) end!]
- ((~' wrap) (do Monad<Lux>
- []
- (~ body))))))
+ (;_lux_case (;;_run_ (~ g!tokens)
+ (: (Syntax (Lux (List Code)))
+ (do ;;_Monad<Parser>_
+ [(~@ (join-pairs vars+parsers))
+ (~ g!end) end!]
+ ((~' wrap) (do Monad<Lux>
+ []
+ (~ body))))))
(#R;Success [(~ g!tokens) (~ g!body)])
((~ g!body) (~ g!state))
diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux
index 19a454ba8..2e14825d5 100644
--- a/stdlib/source/lux/macro/syntax/common/reader.lux
+++ b/stdlib/source/lux/macro/syntax/common/reader.lux
@@ -1,6 +1,7 @@
(;module: {#;doc "Commons syntax readers."}
lux
- (lux (control monad)
+ (lux (control monad
+ ["p" parser])
(data (coll [list "L/" Functor<List>])
[ident "Ident/" Eq<Ident>]
[product])
@@ -15,7 +16,7 @@
#export
#hidden)}
(Syntax (Maybe Export))
- (s;opt (s;alt (s;this (' #export))
+ (p;opt (p;alt (s;this (' #export))
(s;this (' #hidden)))))
## Declarations
@@ -25,62 +26,62 @@
quux
(foo bar baz))}
(Syntax Declaration)
- (s;either (s;seq s;local-symbol
- (:: s;Monad<Syntax> wrap (list)))
- (s;form (s;seq s;local-symbol
- (s;many s;local-symbol)))))
+ (p;either (p;seq s;local-symbol
+ (:: p;Monad<Parser> wrap (list)))
+ (s;form (p;seq s;local-symbol
+ (p;many s;local-symbol)))))
## Annotations
(def: #export annotations
{#;doc "Reader for the common annotations syntax used by def: statements."}
(Syntax Annotations)
- (s;record (s;some (s;seq s;tag s;any))))
+ (s;record (p;some (p;seq s;tag s;any))))
## Definitions
(def: check^
(Syntax [(Maybe Code) Code])
- (s;either (s;form (do s;Monad<Syntax>
+ (p;either (s;form (do p;Monad<Parser>
[_ (s;this (' lux;_lux_:))
type s;any
value s;any]
(wrap [(#;Some type) value])))
- (s;seq (:: s;Monad<Syntax> wrap #;None)
+ (p;seq (:: p;Monad<Parser> wrap #;None)
s;any)))
(def: _definition-anns-tag^
(Syntax Ident)
- (s;tuple (s;seq s;text s;text)))
+ (s;tuple (p;seq s;text s;text)))
(def: (_definition-anns^ _)
(-> Top (Syntax Annotations))
- (s;alt (s;this (' #lux;Nil))
- (s;form (do s;Monad<Syntax>
+ (p;alt (s;this (' #lux;Nil))
+ (s;form (do p;Monad<Parser>
[_ (s;this (' #lux;Cons))
- [head tail] (s;seq (s;tuple (s;seq _definition-anns-tag^ s;any))
+ [head tail] (p;seq (s;tuple (p;seq _definition-anns-tag^ s;any))
(_definition-anns^ []))]
(wrap [head tail])))
))
(def: (flat-list^ _)
(-> Top (Syntax (List Code)))
- (s;either (do s;Monad<Syntax>
+ (p;either (do p;Monad<Parser>
[_ (s;this (' #lux;Nil))]
(wrap (list)))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[_ (s;this (' #lux;Cons))
- [head tail] (s;tuple (s;seq s;any s;any))
+ [head tail] (s;tuple (p;seq s;any s;any))
tail (s;local (list tail) (flat-list^ []))]
(wrap (#;Cons head tail))))))
(def: list-meta^
(Syntax (List Code))
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[_ (s;this (' #lux;ListA))]
(flat-list^ []))))
(def: text-meta^
(Syntax Text)
- (s;form (do s;Monad<Syntax>
+ (s;form (do p;Monad<Parser>
[_ (s;this (' #lux;TextA))]
s;text)))
@@ -89,9 +90,9 @@
(default (list)
(case (list;find (|>. product;left (Ident/= ["lux" "func-args"])) meta-data)
(^multi (#;Some [_ value])
- [(s;run (list value) list-meta^)
+ [(p;run (list value) list-meta^)
(#;Right [_ args])]
- [(s;run args (s;some text-meta^))
+ [(p;run args (p;some text-meta^))
(#;Right [_ args])])
(#;Some args)
@@ -102,7 +103,7 @@
(def: #export (definition compiler)
{#;doc "A reader that first macro-expands and then analyses the input Code, to ensure it's a definition."}
(-> Compiler (Syntax Definition))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[definition-raw s;any
me-definition-raw (s;on compiler
(macro;macro-expand-all definition-raw))]
@@ -124,23 +125,23 @@
(def: #export (typed-definition compiler)
{#;doc "A reader for definitions that ensures the input syntax is typed."}
(-> Compiler (Syntax Definition))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[_definition (definition compiler)
_ (case (get@ #..;definition-type _definition)
(#;Some _)
(wrap [])
#;None
- (s;fail "Typed definition must have a type!")
+ (p;fail "Typed definition must have a type!")
)]
(wrap _definition)))
(def: #export typed-input
{#;doc "Reader for the common typed-argument syntax used by many macros."}
(Syntax [Text Code])
- (s;tuple (s;seq s;local-symbol s;any)))
+ (s;tuple (p;seq s;local-symbol s;any)))
(def: #export type-variables
{#;doc "Reader for the common type var/param used by many macros."}
(Syntax (List Text))
- (s;tuple (s;some s;local-symbol)))
+ (s;tuple (p;some s;local-symbol)))
diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux
index 64a40867e..874c600f0 100644
--- a/stdlib/source/lux/math.lux
+++ b/stdlib/source/lux/math.lux
@@ -1,10 +1,11 @@
(;module: {#;doc "Common mathematical constants and functions."}
lux
- (lux (control monad)
+ (lux (control monad
+ ["p" parser "p/" Functor<Parser>])
(data (coll [list "L/" Fold<List>])
[product])
[macro]
- (macro ["s" syntax #+ syntax: Syntax "s/" Functor<Syntax>]
+ (macro ["s" syntax #+ syntax: Syntax]
[code])))
## [Values]
@@ -102,36 +103,36 @@
(def: (infix^ _)
(-> Unit (Syntax Infix))
- ($_ s;alt
- ($_ s;either
- (s/map code;bool s;bool)
- (s/map code;nat s;nat)
- (s/map code;int s;int)
- (s/map code;deg s;deg)
- (s/map code;real s;real)
- (s/map code;char s;char)
- (s/map code;text s;text)
- (s/map code;symbol s;symbol)
- (s/map code;tag s;tag))
- (s;form (s;many s;any))
- (s;tuple (s;either (do s;Monad<Syntax>
+ ($_ p;alt
+ ($_ p;either
+ (p/map code;bool s;bool)
+ (p/map code;nat s;nat)
+ (p/map code;int s;int)
+ (p/map code;deg s;deg)
+ (p/map code;real s;real)
+ (p/map code;char s;char)
+ (p/map code;text s;text)
+ (p/map code;symbol s;symbol)
+ (p/map code;tag s;tag))
+ (s;form (p;many s;any))
+ (s;tuple (p;either (do p;Monad<Parser>
[_ (s;this (' #and))
init-subject (infix^ [])
init-op s;any
init-param (infix^ [])
- steps (s;some (s;seq s;any (infix^ [])))]
+ steps (p;some (p;seq s;any (infix^ [])))]
(wrap (product;right (L/fold (function [[op param] [subject [_subject _op _param]]]
[param [(#Infix _subject _op _param)
(` and)
(#Infix subject op param)]])
[init-param [init-subject init-op init-param]]
steps))))
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[_ (wrap [])
init-subject (infix^ [])
init-op s;any
init-param (infix^ [])
- steps (s;some (s;seq s;any (infix^ [])))]
+ steps (p;some (p;seq s;any (infix^ [])))]
(wrap (L/fold (function [[op param] [_subject _op _param]]
[(#Infix _subject _op _param) op param])
[init-subject init-op init-param]
diff --git a/stdlib/source/lux/math/simple.lux b/stdlib/source/lux/math/simple.lux
index 26c212f82..752f5a5b5 100644
--- a/stdlib/source/lux/math/simple.lux
+++ b/stdlib/source/lux/math/simple.lux
@@ -1,6 +1,7 @@
(;module: {#;doc "Polymorphic arithmetic operators that work with all primitive numeric types, without requiring any prefixes."}
lux
- (lux (control monad)
+ (lux (control monad
+ ["p" parser])
(data text/format
[product]
(coll [list]))
@@ -42,9 +43,9 @@
(wrap raw-type))))
(do-template [<name> <rec> <nat-op> <int-op> <real-op> <deg-op>]
- [(syntax: #export (<name> [args ($_ s;alt
- (s;seq (s;alt s;symbol s;any)
- (s;some s;any))
+ [(syntax: #export (<name> [args ($_ p;alt
+ (p;seq (p;alt s;symbol s;any)
+ (p;some s;any))
s;end!)])
## {#;doc (doc (= (<name> +1 +2)
## (<nat-op> +1 +2))
@@ -106,9 +107,9 @@
)
(do-template [<name> <rec> <nat-op> <int-op> <real-op> <deg-op>]
- [(syntax: #export (<name> [args ($_ s;alt
- (s;seq (s;alt s;symbol s;any)
- (s;some s;any))
+ [(syntax: #export (<name> [args ($_ p;alt
+ (p;seq (p;alt s;symbol s;any)
+ (p;some s;any))
s;end!)])
## {#;doc (doc (= (<name> +1 +2)
## (<nat-op> +1 +2))
@@ -170,9 +171,9 @@
)
(do-template [<name> <rec> <nat-op> <int-op>]
- [(syntax: #export (<name> [args ($_ s;alt
- (s;seq (s;alt s;symbol s;any)
- (s;some s;any))
+ [(syntax: #export (<name> [args ($_ p;alt
+ (p;seq (p;alt s;symbol s;any)
+ (p;some s;any))
s;end!)])
## {#;doc (doc (= (<name> +1 +2)
## (<nat-op> +1 +2))
@@ -215,7 +216,7 @@
)
(do-template [<name> <rec> <nat-op> <int-op>]
- [(syntax: #export (<name> [args ($_ s;alt
+ [(syntax: #export (<name> [args ($_ p;alt
s;symbol
s;any
s;end!)])
@@ -260,7 +261,7 @@
)
(do-template [<name> <rec> <nat-op> <int-op>]
- [(syntax: #export (<name> [args ($_ s;alt
+ [(syntax: #export (<name> [args ($_ p;alt
s;symbol
s;any
s;end!)])
diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux
index 124809b89..f8e0425aa 100644
--- a/stdlib/source/lux/test.lux
+++ b/stdlib/source/lux/test.lux
@@ -5,7 +5,8 @@
[code])
(control functor
applicative
- monad)
+ monad
+ ["p" parser])
(concurrency [promise #+ Promise Monad<Promise>])
(data (coll [list "L/" Monad<List> Fold<List>])
[product]
@@ -135,23 +136,23 @@
(def: config^
(Syntax Test-Config)
- (s;alt (do s;Monad<Syntax>
+ (p;alt (do p;Monad<Parser>
[_ (s;this (' #seed))]
s;nat)
- (do s;Monad<Syntax>
+ (do p;Monad<Parser>
[_ (s;this (' #times))]
s;nat)))
(def: property-test^
(Syntax Property-Test)
- ($_ s;seq
- (s;opt config^)
- (s;tuple (s;some (s;seq s;any s;any)))
+ ($_ p;seq
+ (p;opt config^)
+ (s;tuple (p;some (p;seq s;any s;any)))
s;any))
(def: test^
(Syntax Test-Kind)
- (s;alt property-test^
+ (p;alt property-test^
s;any))
(def: (pair-to-list [x y])
diff --git a/stdlib/source/lux/type/auto.lux b/stdlib/source/lux/type/auto.lux
index cd6093f97..8fd88da82 100644
--- a/stdlib/source/lux/type/auto.lux
+++ b/stdlib/source/lux/type/auto.lux
@@ -1,7 +1,8 @@
(;module:
lux
(lux (control monad
- [eq])
+ [eq]
+ ["p" parser])
(data [text "Text/" Eq<Text>]
text/format
[number]
@@ -305,8 +306,8 @@
(` ((~ (code;symbol constructor)) (~@ (List/map instance$ dependencies))))))
(syntax: #export (::: [member s;symbol]
- [args (s;alt (s;seq (s;some s;symbol) s;end!)
- (s;seq (s;some s;any) s;end!))])
+ [args (p;alt (p;seq (p;some s;symbol) s;end!)
+ (p;seq (p;some s;any) s;end!))])
{#;doc (doc "Automatic structure selection (for type-class style polymorphism)."
"This feature layers type-class style polymorphism on top of Lux's signatures and structures."
"When calling a polymorphic function, or using a polymorphic constant,"
diff --git a/stdlib/test/test/lux/cli.lux b/stdlib/test/test/lux/cli.lux
index b19a9d345..8e1188a02 100644
--- a/stdlib/test/test/lux/cli.lux
+++ b/stdlib/test/test/lux/cli.lux
@@ -2,7 +2,8 @@
lux
(lux [io]
(control monad
- pipe)
+ pipe
+ ["p" parser])
(data text/format
[text "Text/" Eq<Text>]
[number]
@@ -18,77 +19,44 @@
#let [(^open "Nat/") number;Codec<Text,Nat>
gen-arg (:: @ map Nat/encode R;nat)]
option-name (R;text +5)
- args (R;list num-args gen-arg)]
+ singleton gen-arg]
($_ seq
(test "Can read any argument."
- (|> (&;run &;any args)
+ (|> (&;run (list singleton) &;any)
(case> (#;Left _)
- (n.= +0 num-args)
+ false
(#;Right arg)
- (and (not (n.= +0 num-args))
- (Text/= arg (default (undefined)
- (list;head args)))))))
-
- (test "Can safely fail parsing an argument."
- (|> (&;run (&;opt &;any) args)
- (case> (#;Right (#;Some arg))
- (and (not (n.= +0 num-args))
- (Text/= arg (default (undefined)
- (list;head args))))
-
- (#;Right #;None)
- (n.= +0 num-args)
-
- _
- false)))
-
- (test "Can read multiple arguments."
- (and (|> (&;run (&;some &;any) args)
- (case> (#;Left _)
- false
-
- (#;Right args')
- (n.= num-args (list;size args'))))
- (|> (&;run (&;many &;any) args)
- (case> (#;Left _)
- (n.= +0 num-args)
-
- (#;Right args')
- (n.= num-args (list;size args'))))))
+ (Text/= arg singleton))))
(test "Can use custom token parsers."
- (|> (&;run (&;parse Nat/decode) args)
+ (|> (&;run (list singleton) (&;parse Nat/decode))
(case> (#;Left _)
- (n.= +0 num-args)
+ false
(#;Right parsed)
(Text/= (Nat/encode parsed)
- (default (undefined)
- (list;head args))))))
+ singleton))))
(test "Can obtain option values."
- (and (|> (&;run (&;option (list option-name)) (list& option-name args))
+ (and (|> (&;run (list option-name singleton) (&;option (list option-name)))
(case> (#;Left _)
- (n.= +0 num-args)
+ false
(#;Right value)
- (Text/= value (default (undefined)
- (list;head args)))))
- (|> (&;run (&;option (list option-name)) args)
+ (Text/= value singleton)))
+ (|> (&;run (list singleton) (&;option (list option-name)))
(case> (#;Left _) true (#;Right _) false))))
(test "Can check flags."
- (and (|> (&;run (&;flag (list option-name)) (list& option-name args))
+ (and (|> (&;run (list option-name) (&;flag (list option-name)))
(case> (#;Right true) true _ false))
- (|> (&;run (&;flag (list option-name)) args)
+ (|> (&;run (list) (&;flag (list option-name)))
(case> (#;Right false) true _ false))))
(test "Can query if there are any more inputs."
- (and (|> (&;run &;end args)
- (case> (#;Right []) (n.= +0 num-args)
- _ (n.> +0 num-args)))
- (|> (&;run (&;not &;end) args)
- (case> (#;Right []) (n.> +0 num-args)
- _ (n.= +0 num-args)))))
+ (and (|> (&;run (list) &;end)
+ (case> (#;Right []) true _ false))
+ (|> (&;run (list singleton) (p;not &;end))
+ (case> (#;Right []) false _ true))))
))
diff --git a/stdlib/test/test/lux/control/parser.lux b/stdlib/test/test/lux/control/parser.lux
new file mode 100644
index 000000000..5c4f5851c
--- /dev/null
+++ b/stdlib/test/test/lux/control/parser.lux
@@ -0,0 +1,183 @@
+(;module:
+ lux
+ (lux [io]
+ (control monad
+ eq
+ ["&" parser]
+ pipe)
+ (data [text "Text/" Monoid<Text>]
+ text/format
+ [number]
+ [bool]
+ [char]
+ [ident]
+ ["R" result])
+ ["r" math/random]
+ [macro]
+ (macro [code]
+ ["s" syntax #+ syntax:]))
+ lux/test)
+
+## [Utils]
+(def: (should-fail input)
+ (All [a] (-> (R;Result a) Bool))
+ (case input
+ (#R;Error _) true
+ _ false))
+
+(def: (enforced? parser input)
+ (All [s] (-> (&;Parser s Unit) s Bool))
+ (case (&;run input parser)
+ (#R;Success [_ []])
+ true
+
+ _
+ false))
+
+(def: (found? parser input)
+ (All [s] (-> (&;Parser s Bool) s Bool))
+ (case (&;run input parser)
+ (#R;Success [_ true])
+ true
+
+ _
+ false))
+
+(def: (is? Eq<a> test parser input)
+ (All [s a] (-> (Eq a) a (&;Parser s a) s Bool))
+ (case (&;run input parser)
+ (#R;Success [_ output])
+ (:: Eq<a> = test output)
+
+ _
+ false))
+
+(def: (fails? input)
+ (All [a] (-> (R;Result a) Bool))
+ (case input
+ (#R;Error _)
+ true
+
+ _
+ false))
+
+(syntax: (match pattern input)
+ (wrap (list (` (case (~ input)
+ (^ (#R;Success [(~' _) (~ pattern)]))
+ true
+
+ (~' _)
+ false)))))
+
+## [Tests]
+(context: "Assertions"
+ (test "Can make assertions while parsing."
+ (and (match []
+ (&;run (list (code;bool true) (code;int 123))
+ (&;assert "yolo" true)))
+ (fails? (&;run (list (code;bool true) (code;int 123))
+ (&;assert "yolo" false))))))
+
+(context: "Combinators [Part 1]"
+ ($_ seq
+ (test "Can optionally succeed with some parser."
+ (and (match (#;Some +123)
+ (&;run (list (code;nat +123))
+ (&;opt s;nat)))
+ (match #;None
+ (&;run (list (code;int -123))
+ (&;opt s;nat)))))
+
+ (test "Can apply a parser 0 or more times."
+ (and (match (list +123 +456 +789)
+ (&;run (list (code;nat +123) (code;nat +456) (code;nat +789))
+ (&;some s;nat)))
+ (match (list)
+ (&;run (list (code;int -123))
+ (&;some s;nat)))))
+
+ (test "Can apply a parser 1 or more times."
+ (and (match (list +123 +456 +789)
+ (&;run (list (code;nat +123) (code;nat +456) (code;nat +789))
+ (&;many s;nat)))
+ (match (list +123)
+ (&;run (list (code;nat +123))
+ (&;many s;nat)))
+ (fails? (&;run (list (code;int -123))
+ (&;many s;nat)))))
+
+ (test "Can use either parser."
+ (and (match 123
+ (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;either s;pos-int s;int)))
+ (match -123
+ (&;run (list (code;int -123) (code;int 456) (code;int 789))
+ (&;either s;pos-int s;int)))
+ (fails? (&;run (list (code;bool true) (code;int 456) (code;int 789))
+ (&;either s;pos-int s;int)))))
+
+ (test "Can create the opposite/negation of any parser."
+ (and (fails? (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;not s;int)))
+ (match []
+ (&;run (list (code;bool true) (code;int 456) (code;int 789))
+ (&;not s;int)))))
+ ))
+
+(context: "Combinators Part [2]"
+ ($_ seq
+ (test "Can fail at will."
+ (should-fail (&;run (list)
+ (&;fail "Well, it really SHOULD fail..."))))
+
+ (test "Can apply a parser N times."
+ (and (match (list 123 456 789)
+ (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;exactly +3 s;int)))
+ (match (list 123 456)
+ (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;exactly +2 s;int)))
+ (fails? (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;exactly +4 s;int)))))
+
+ (test "Can apply a parser at-least N times."
+ (and (match (list 123 456 789)
+ (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;at-least +3 s;int)))
+ (match (list 123 456 789)
+ (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;at-least +2 s;int)))
+ (fails? (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;at-least +4 s;int)))))
+
+ (test "Can apply a parser at-most N times."
+ (and (match (list 123 456 789)
+ (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;at-most +3 s;int)))
+ (match (list 123 456)
+ (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;at-most +2 s;int)))
+ (match (list 123 456 789)
+ (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;at-most +4 s;int)))))
+
+ (test "Can apply a parser between N and M times."
+ (and (match (list 123 456 789)
+ (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;between +3 +10 s;int)))
+ (fails? (&;run (list (code;int 123) (code;int 456) (code;int 789))
+ (&;between +4 +10 s;int)))))
+
+ (test "Can parse while taking separators into account."
+ (and (match (list 123 456 789)
+ (&;run (list (code;int 123) (code;text "YOLO") (code;int 456) (code;text "YOLO") (code;int 789))
+ (&;sep-by (s;this (' "YOLO")) s;int)))
+ (match (list 123 456)
+ (&;run (list (code;int 123) (code;text "YOLO") (code;int 456) (code;int 789))
+ (&;sep-by (s;this (' "YOLO")) s;int)))))
+
+ (test "Can obtain the whole of the remaining input."
+ (|> &;remaining
+ (&;run (list (code;int 123) (code;int 456) (code;int 789)))
+ (match (list [_ (#;Int 123)] [_ (#;Int 456)] [_ (#;Int 789)]))))
+ ))
diff --git a/stdlib/test/test/lux/data/text/lexer.lux b/stdlib/test/test/lux/data/text/lexer.lux
index 8f1d94185..76eadfbb0 100644
--- a/stdlib/test/test/lux/data/text/lexer.lux
+++ b/stdlib/test/test/lux/data/text/lexer.lux
@@ -1,7 +1,8 @@
(;module:
lux
(lux (control monad
- pipe)
+ pipe
+ ["p" parser])
[io]
(data ["R" result]
[text "T/" Eq<Text>]
@@ -70,36 +71,19 @@
(context: "Literals"
[size (|> r;nat (:: @ map (|>. (n.% +100) (n.max +10))))
- pre (r;text size)
- post (|> (r;text size)
- (r;filter (|>. (text;starts-with? pre) not)))]
+ sample (r;text size)
+ non-sample (|> (r;text size)
+ (r;filter (|>. (T/= sample) not)))]
($_ seq
(test "Can find literal text fragments."
- (and (|> (&;run (format pre post)
- (&;this pre))
+ (and (|> (&;run sample
+ (&;this sample))
(case> (#;Right []) true _ false))
- (|> (&;run post
- (&;this pre))
+ (|> (&;run non-sample
+ (&;this sample))
(case> (#;Left _) true _ false))))
))
-(context: "Char lexers"
- ($_ seq
- (test "Can lex characters."
- (and (|> (&;run "YOLO"
- (&;this "Y"))
- (case> (#;Right []) true _ false))
- (|> (&;run "MEME"
- (&;this "Y"))
- (case> (#;Left _) true _ false))))
-
- (test "Can lex characters ranges."
- (and (should-passT "Y" (&;run "YOLO"
- (&;char-range #"X" #"Z")))
- (should-fail (&;run "MEME"
- (&;char-range #"X" #"Z")))))
- ))
-
(context: "Custom lexers"
($_ seq
(test "Can lex anything"
@@ -107,16 +91,22 @@
&;any))
(should-fail (&;run ""
&;any))))
+
+ (test "Can lex characters ranges."
+ (and (should-passT "Y" (&;run "Y"
+ (&;char-range #"X" #"Z")))
+ (should-fail (&;run "M"
+ (&;char-range #"X" #"Z")))))
(test "Can lex upper-case and &;lower-case letters."
- (and (should-passT "Y" (&;run "YOLO"
+ (and (should-passT "Y" (&;run "Y"
&;upper))
- (should-fail (&;run "meme"
+ (should-fail (&;run "m"
&;upper))
- (should-passT "y" (&;run "yolo"
+ (should-passT "y" (&;run "y"
&;lower))
- (should-fail (&;run "MEME"
+ (should-fail (&;run "M"
&;lower))))
(test "Can lex numbers."
@@ -168,34 +158,18 @@
(context: "Combinators"
($_ seq
(test "Can combine lexers sequentially."
- (and (|> (&;run "YOLO"
- (&;seq &;any &;any))
+ (and (|> (&;run "YO"
+ (p;seq &;any &;any))
(case> (#;Right ["Y" "O"]) true
_ false))
(should-fail (&;run "Y"
- (&;seq &;any &;any)))))
+ (p;seq &;any &;any)))))
- (test "Can combine lexers alternatively."
- (and (should-passE (#;Left "0") (&;run "0"
- (&;alt &;digit &;upper)))
- (should-passE (#;Right "A") (&;run "A"
- (&;alt &;digit &;upper)))
- (should-fail (&;run "a"
- (&;alt &;digit &;upper)))))
-
(test "Can create the opposite of a lexer."
(and (should-passT "a" (&;run "a"
- (&;not (&;alt &;digit &;upper))))
+ (&;not (p;alt &;digit &;upper))))
(should-fail (&;run "A"
- (&;not (&;alt &;digit &;upper))))))
-
- (test "Can use either lexer."
- (and (should-passT "0" (&;run "0"
- (&;either &;digit &;upper)))
- (should-passT "A" (&;run "A"
- (&;either &;digit &;upper)))
- (should-fail (&;run "a"
- (&;either &;digit &;upper)))))
+ (&;not (p;alt &;digit &;upper))))))
(test "Can select from among a set of characters."
(and (should-passT "C" (&;run "C"
@@ -216,90 +190,11 @@
(&;satisfies (function [c] false))))))
(test "Can apply a lexer multiple times."
- (and (should-passT "0123456789ABCDEF" (&;run "0123456789ABCDEF yolo"
- (&;many' &;hex-digit)))
- (should-fail (&;run "yolo"
- (&;many' &;hex-digit)))
-
- (should-passT "" (&;run "yolo"
- (&;some' &;hex-digit)))))
- ))
-
-(context: "Yet more combinators..."
- ($_ seq
- (test "Can fail at will."
- (should-fail (&;run "yolo"
- (&;fail "Well, it really SHOULD fail..."))))
-
- (test "Can make assertions."
- (and (should-fail (&;run "yolo"
- (&;assert "Well, it really SHOULD fail..." false)))
- (|> (&;run "yolo"
- (&;assert "GO, GO, GO!" true))
- (case> (#;Right []) true
- _ false))))
-
- (test "Can apply a lexer multiple times."
- (and (should-passL (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F")
- (&;run "0123456789ABCDEF yolo"
- (&;many &;hex-digit)))
+ (and (should-passT "0123456789ABCDEF" (&;run "0123456789ABCDEF"
+ (&;many &;hex-digit)))
(should-fail (&;run "yolo"
(&;many &;hex-digit)))
- (should-passL (list)
- (&;run "yolo"
- (&;some &;hex-digit)))))
-
- (test "Can lex exactly N elements."
- (and (should-passL (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F")
- (&;run "0123456789ABCDEF yolo"
- (&;exactly +16 &;hex-digit)))
- (should-passL (list "0" "1" "2")
- (&;run "0123456789ABCDEF yolo"
- (&;exactly +3 &;hex-digit)))
- (should-fail (&;run "0123456789ABCDEF yolo"
- (&;exactly +17 &;hex-digit)))))
-
- (test "Can lex at-most N elements."
- (and (should-passL (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F")
- (&;run "0123456789ABCDEF yolo"
- (&;at-most +16 &;hex-digit)))
- (should-passL (list "0" "1" "2")
- (&;run "0123456789ABCDEF yolo"
- (&;at-most +3 &;hex-digit)))
- (should-passL (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F")
- (&;run "0123456789ABCDEF yolo"
- (&;at-most +17 &;hex-digit)))))
-
- (test "Can lex tokens between lower and upper boundaries of quantity."
- (and (should-passL (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F")
- (&;run "0123456789ABCDEF yolo"
- (&;between +0 +16 &;hex-digit)))
- (should-passL (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F")
- (&;run "0123456789ABCDEF yolo"
- (&;between +3 +16 &;hex-digit)))
- (should-fail (&;run "0123456789ABCDEF yolo"
- (&;between +17 +100 &;hex-digit)))
- (should-passL (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F")
- (&;run "0123456789ABCDEF yolo"
- (&;between +15 +20 &;hex-digit)))))
-
- (test "Can optionally lex a token."
- (and (|> (&;run "123abc"
- (&;opt &;hex-digit))
- (case> (#;Right (#;Some "1")) true
- _ false))
- (|> (&;run "yolo"
- (&;opt &;hex-digit))
- (case> (#;Right #;None) true
- _ false))))
-
- (test "Can take into account separators during lexing."
- (should-passL (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "a" "b" "c" "d" "e" "f")
- (&;run "0 1 2 3 4 5 6 7 8 9 a b c d e f YOLO"
- (&;sep-by &;space &;hex-digit))))
-
- (test "Can obtain the whole of the remaining input."
- (should-passT "yolo" (&;run "yolo"
- &;get-input)))
+ (should-passT "" (&;run ""
+ (&;some &;hex-digit)))))
))
diff --git a/stdlib/test/test/lux/data/text/regex.lux b/stdlib/test/test/lux/data/text/regex.lux
index bef24c0bf..ce18c0539 100644
--- a/stdlib/test/test/lux/data/text/regex.lux
+++ b/stdlib/test/test/lux/data/text/regex.lux
@@ -2,7 +2,8 @@
lux
(lux [io]
(control monad
- pipe)
+ pipe
+ ["p" parser])
(data [product]
[text "T/" Eq<Text>]
text/format
@@ -216,7 +217,7 @@
($_ seq
(test "Can match a pattern N times."
(and (should-passT "aa" (&;regex "a{2}") "aa")
- (should-passT "a" (&;regex "a{1}") "aa")
+ (should-passT "a" (&;regex "a{1}") "a")
(should-fail (&;regex "a{3}") "aa")))
(test "Can match a pattern at-least N times."
@@ -225,14 +226,12 @@
(should-fail (&;regex "a{3,}") "aa")))
(test "Can match a pattern at-most N times."
- (and (should-passT "a" (&;regex "a{,1}") "aa")
- (should-passT "aa" (&;regex "a{,2}") "aa")
+ (and (should-passT "aa" (&;regex "a{,2}") "aa")
(should-passT "aa" (&;regex "a{,3}") "aa")))
(test "Can match a pattern between N and M times."
(and (should-passT "a" (&;regex "a{1,2}") "a")
- (should-passT "aa" (&;regex "a{1,2}") "aa")
- (should-passT "aa" (&;regex "a{1,2}") "aaa")))
+ (should-passT "aa" (&;regex "a{1,2}") "aa")))
))
(context: "Regular Expressions [Groups]"
diff --git a/stdlib/test/test/lux/macro/syntax.lux b/stdlib/test/test/lux/macro/syntax.lux
index 5f84f5c26..fa53e4596 100644
--- a/stdlib/test/test/lux/macro/syntax.lux
+++ b/stdlib/test/test/lux/macro/syntax.lux
@@ -2,7 +2,8 @@
lux
(lux [io]
(control monad
- eq)
+ eq
+ ["p" parser])
(data [text "Text/" Monoid<Text>]
text/format
[number]
@@ -19,7 +20,7 @@
## [Utils]
(def: (enforced? parser input)
(-> (Syntax []) (List Code) Bool)
- (case (s;run input parser)
+ (case (p;run input parser)
(#;Right [_ []])
true
@@ -28,7 +29,7 @@
(def: (found? parser input)
(-> (Syntax Bool) (List Code) Bool)
- (case (s;run input parser)
+ (case (p;run input parser)
(#;Right [_ true])
true
@@ -37,7 +38,7 @@
(def: (is? Eq<a> test parser input)
(All [a] (-> (Eq a) a (Syntax a) (List Code) Bool))
- (case (s;run input parser)
+ (case (p;run input parser)
(#;Right [_ output])
(:: Eq<a> = test output)
@@ -85,16 +86,16 @@
(test "Can parse symbols belonging to the current namespace."
(and (match "yolo"
- (s;run (list (code;local-symbol "yolo"))
+ (p;run (list (code;local-symbol "yolo"))
s;local-symbol))
- (fails? (s;run (list (code;symbol ["yolo" "lol"]))
+ (fails? (p;run (list (code;symbol ["yolo" "lol"]))
s;local-symbol))))
(test "Can parse tags belonging to the current namespace."
(and (match "yolo"
- (s;run (list (code;local-tag "yolo"))
+ (p;run (list (code;local-tag "yolo"))
s;local-tag))
- (fails? (s;run (list (code;tag ["yolo" "lol"]))
+ (fails? (p;run (list (code;tag ["yolo" "lol"]))
s;local-tag))))
)))
@@ -103,21 +104,21 @@
[<group-tests> (do-template [<type> <parser> <ctor>]
[(test (format "Can parse " <type> " syntax.")
(and (match [true 123]
- (s;run (list (<ctor> (list (code;bool true) (code;int 123))))
- (<parser> (s;seq s;bool s;int))))
+ (p;run (list (<ctor> (list (code;bool true) (code;int 123))))
+ (<parser> (p;seq s;bool s;int))))
(match true
- (s;run (list (<ctor> (list (code;bool true))))
+ (p;run (list (<ctor> (list (code;bool true))))
(<parser> s;bool)))
- (fails? (s;run (list (<ctor> (list (code;bool true) (code;int 123))))
+ (fails? (p;run (list (<ctor> (list (code;bool true) (code;int 123))))
(<parser> s;bool)))
(match (#;Left true)
- (s;run (list (<ctor> (list (code;bool true))))
- (<parser> (s;alt s;bool s;int))))
+ (p;run (list (<ctor> (list (code;bool true))))
+ (<parser> (p;alt s;bool s;int))))
(match (#;Right 123)
- (s;run (list (<ctor> (list (code;int 123))))
- (<parser> (s;alt s;bool s;int))))
- (fails? (s;run (list (<ctor> (list (code;real 123.0))))
- (<parser> (s;alt s;bool s;int))))))]
+ (p;run (list (<ctor> (list (code;int 123))))
+ (<parser> (p;alt s;bool s;int))))
+ (fails? (p;run (list (<ctor> (list (code;real 123.0))))
+ (<parser> (p;alt s;bool s;int))))))]
["form" s;form code;form]
["tuple" s;tuple code;tuple])]
@@ -126,129 +127,29 @@
(test "Can parse record syntax."
(match [true 123]
- (s;run (list (code;record (list [(code;bool true) (code;int 123)])))
- (s;record (s;seq s;bool s;int)))))
+ (p;run (list (code;record (list [(code;bool true) (code;int 123)])))
+ (s;record (p;seq s;bool s;int)))))
)))
-(context: "Assertions"
- (test "Can make assertions while parsing."
- (and (match []
- (s;run (list (code;bool true) (code;int 123))
- (s;assert "yolo" true)))
- (fails? (s;run (list (code;bool true) (code;int 123))
- (s;assert "yolo" false))))))
-
-(context: "Combinators [Part 1]"
+(context: "Combinators"
($_ seq
(test "Can parse any Code."
(match [_ (#;Bool true)]
- (s;run (list (code;bool true) (code;int 123))
+ (p;run (list (code;bool true) (code;int 123))
s;any)))
- (test "Can optionally succeed with some parser."
- (and (match (#;Some +123)
- (s;run (list (code;nat +123))
- (s;opt s;nat)))
- (match #;None
- (s;run (list (code;int -123))
- (s;opt s;nat)))))
-
- (test "Can apply a parser 0 or more times."
- (and (match (list +123 +456 +789)
- (s;run (list (code;nat +123) (code;nat +456) (code;nat +789))
- (s;some s;nat)))
- (match (list)
- (s;run (list (code;int -123))
- (s;some s;nat)))))
-
- (test "Can apply a parser 1 or more times."
- (and (match (list +123 +456 +789)
- (s;run (list (code;nat +123) (code;nat +456) (code;nat +789))
- (s;many s;nat)))
- (match (list +123)
- (s;run (list (code;nat +123))
- (s;many s;nat)))
- (fails? (s;run (list (code;int -123))
- (s;many s;nat)))))
-
- (test "Can use either parser."
- (and (match 123
- (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;either s;pos-int s;int)))
- (match -123
- (s;run (list (code;int -123) (code;int 456) (code;int 789))
- (s;either s;pos-int s;int)))
- (fails? (s;run (list (code;bool true) (code;int 456) (code;int 789))
- (s;either s;pos-int s;int)))))
-
- (test "Can create the opposite/negation of any parser."
- (and (fails? (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;not s;int)))
- (match []
- (s;run (list (code;bool true) (code;int 456) (code;int 789))
- (s;not s;int)))))
- ))
-
-(context: "Combinators Part [2]"
- ($_ seq
(test "Can check whether the end has been reached."
(and (match true
- (s;run (list)
+ (p;run (list)
s;end?))
(match false
- (s;run (list (code;bool true))
+ (p;run (list (code;bool true))
s;end?))))
(test "Can ensure the end has been reached."
(and (match []
- (s;run (list)
+ (p;run (list)
s;end!))
- (fails? (s;run (list (code;bool true))
+ (fails? (p;run (list (code;bool true))
s;end!))))
-
- (test "Can apply a parser N times."
- (and (match (list 123 456 789)
- (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;exactly +3 s;int)))
- (match (list 123 456)
- (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;exactly +2 s;int)))
- (fails? (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;exactly +4 s;int)))))
-
- (test "Can apply a parser at-least N times."
- (and (match (list 123 456 789)
- (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;at-least +3 s;int)))
- (match (list 123 456 789)
- (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;at-least +2 s;int)))
- (fails? (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;at-least +4 s;int)))))
-
- (test "Can apply a parser at-most N times."
- (and (match (list 123 456 789)
- (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;at-most +3 s;int)))
- (match (list 123 456)
- (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;at-most +2 s;int)))
- (match (list 123 456 789)
- (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;at-most +4 s;int)))))
-
- (test "Can apply a parser between N and M times."
- (and (match (list 123 456 789)
- (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;between +3 +10 s;int)))
- (fails? (s;run (list (code;int 123) (code;int 456) (code;int 789))
- (s;between +4 +10 s;int)))))
-
- (test "Can parse while taking separators into account."
- (and (match (list 123 456 789)
- (s;run (list (code;int 123) (code;text "YOLO") (code;int 456) (code;text "YOLO") (code;int 789))
- (s;sep-by (s;this (' "YOLO")) s;int)))
- (match (list 123 456)
- (s;run (list (code;int 123) (code;text "YOLO") (code;int 456) (code;int 789))
- (s;sep-by (s;this (' "YOLO")) s;int)))))
))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index 0a609ce13..a663db7bf 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -21,7 +21,8 @@
["_;" cont]
["_;" reader]
["_;" state]
- ["_;" thunk])
+ ["_;" thunk]
+ ["_;" parser])
(data ["_;" bit]
["_;" bool]
["_;" char]
@@ -31,11 +32,11 @@
["_;" log]
["_;" maybe]
["_;" number]
- (number ["_;" ratio]
- ["_;" complex])
["_;" product]
["_;" sum]
["_;" text]
+ (number ["_;" ratio]
+ ["_;" complex])
(format ["_;" json]
["_;" xml])
(coll ["_;" array]
@@ -67,7 +68,7 @@
["_;" type]
(type ["_;" check]
["_;" auto])
- (paradigm ["_;" object])
+ ## (paradigm ["_;" object])
))
(lux (control [contract])
(data [env]