diff options
Diffstat (limited to 'stdlib/source')
27 files changed, 985 insertions, 1307 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 "<") (lex/wrap "<")) - (l;after (l;this ">") (lex/wrap ">")) - (l;after (l;this "&") (lex/wrap "&")) - (l;after (l;this "'") (lex/wrap "'")) - (l;after (l;this """) (lex/wrap "\"")))) + ($_ p;either + (p;after (l;this "<") (p/wrap "<")) + (p;after (l;this ">") (p/wrap ">")) + (p;after (l;this "&") (p/wrap "&")) + (p;after (l;this "'") (p/wrap "'")) + (p;after (l;this """) (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," |