From adf8aeaa2a52760e294e08618e7aca5fc371fc0f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 5 Apr 2017 18:05:23 -0400 Subject: - Moved lux/lexer and lux/lexer/regex to lux/data/text/lexer and lux/data/text/regex. - Moved lux/pipe to lux/control/pipe. - Moved the @pre and @post macros to lux/control/contract. - Improved error reporting for lux/type/auto. - Added a test for third-order type-checking for lux/type/auto. - Fixed a bug in the tests for lux/data/coll/vector. --- stdlib/source/lux.lux | 66 +-- stdlib/source/lux/control/contract.lux | 37 ++ stdlib/source/lux/control/pipe.lux | 146 +++++++ stdlib/source/lux/data/coll/vector.lux | 1 - stdlib/source/lux/data/format/json.lux | 3 +- stdlib/source/lux/data/text/lexer.lux | 502 +++++++++++++++++++++ stdlib/source/lux/data/text/regex.lux | 509 ++++++++++++++++++++++ stdlib/source/lux/lexer.lux | 502 --------------------- stdlib/source/lux/lexer/regex.lux | 509 ---------------------- stdlib/source/lux/pipe.lux | 146 ------- stdlib/source/lux/type/auto.lux | 12 +- stdlib/test/test/lux/cli.lux | 6 +- stdlib/test/test/lux/concurrency/atom.lux | 3 +- stdlib/test/test/lux/concurrency/promise.lux | 6 +- stdlib/test/test/lux/concurrency/stm.lux | 3 +- stdlib/test/test/lux/control/effect.lux | 3 +- stdlib/test/test/lux/control/interval.lux | 4 +- stdlib/test/test/lux/control/pipe.lux | 74 ++++ stdlib/test/test/lux/data/char.lux | 6 +- stdlib/test/test/lux/data/coll/array.lux | 6 +- stdlib/test/test/lux/data/coll/dict.lux | 3 +- stdlib/test/test/lux/data/coll/list.lux | 6 +- stdlib/test/test/lux/data/coll/ordered.lux | 3 +- stdlib/test/test/lux/data/coll/priority-queue.lux | 3 +- stdlib/test/test/lux/data/coll/queue.lux | 3 +- stdlib/test/test/lux/data/coll/seq.lux | 6 +- stdlib/test/test/lux/data/coll/set.lux | 3 +- stdlib/test/test/lux/data/coll/stack.lux | 3 +- stdlib/test/test/lux/data/coll/stream.lux | 3 +- stdlib/test/test/lux/data/coll/tree/rose.lux | 3 +- stdlib/test/test/lux/data/coll/tree/zipper.lux | 6 +- stdlib/test/test/lux/data/coll/vector.lux | 5 +- stdlib/test/test/lux/data/error.lux | 6 +- stdlib/test/test/lux/data/error/exception.lux | 3 +- stdlib/test/test/lux/data/format/json.lux | 4 +- stdlib/test/test/lux/data/ident.lux | 6 +- stdlib/test/test/lux/data/log.lux | 6 +- stdlib/test/test/lux/data/maybe.lux | 6 +- stdlib/test/test/lux/data/number.lux | 6 +- stdlib/test/test/lux/data/number/complex.lux | 6 +- stdlib/test/test/lux/data/number/ratio.lux | 6 +- stdlib/test/test/lux/data/sum.lux | 6 +- stdlib/test/test/lux/data/text.lux | 6 +- stdlib/test/test/lux/data/text/lexer.lux | 315 +++++++++++++ stdlib/test/test/lux/data/text/regex.lux | 285 ++++++++++++ stdlib/test/test/lux/function/cont.lux | 3 +- stdlib/test/test/lux/function/reader.lux | 6 +- stdlib/test/test/lux/function/state.lux | 6 +- stdlib/test/test/lux/function/thunk.lux | 1 - stdlib/test/test/lux/host.js.lux | 3 +- stdlib/test/test/lux/host.jvm.lux | 6 +- stdlib/test/test/lux/lexer.lux | 315 ------------- stdlib/test/test/lux/lexer/regex.lux | 285 ------------ stdlib/test/test/lux/macro/ast.lux | 1 - stdlib/test/test/lux/macro/poly/eq.lux | 1 - stdlib/test/test/lux/macro/poly/functor.lux | 1 - stdlib/test/test/lux/macro/poly/text-encoder.lux | 1 - stdlib/test/test/lux/macro/syntax.lux | 1 - stdlib/test/test/lux/math.lux | 1 - stdlib/test/test/lux/math/logic/continuous.lux | 1 - stdlib/test/test/lux/math/logic/fuzzy.lux | 1 - stdlib/test/test/lux/math/simple.lux | 1 - stdlib/test/test/lux/pipe.lux | 74 ---- stdlib/test/test/lux/type.lux | 4 +- stdlib/test/test/lux/type/auto.lux | 6 +- stdlib/test/test/lux/type/check.lux | 1 - stdlib/test/tests.lux | 72 +-- 67 files changed, 1996 insertions(+), 2047 deletions(-) create mode 100644 stdlib/source/lux/control/contract.lux create mode 100644 stdlib/source/lux/control/pipe.lux create mode 100644 stdlib/source/lux/data/text/lexer.lux create mode 100644 stdlib/source/lux/data/text/regex.lux delete mode 100644 stdlib/source/lux/lexer.lux delete mode 100644 stdlib/source/lux/lexer/regex.lux delete mode 100644 stdlib/source/lux/pipe.lux create mode 100644 stdlib/test/test/lux/control/pipe.lux create mode 100644 stdlib/test/test/lux/data/text/lexer.lux create mode 100644 stdlib/test/test/lux/data/text/regex.lux delete mode 100644 stdlib/test/test/lux/lexer.lux delete mode 100644 stdlib/test/test/lux/lexer/regex.lux delete mode 100644 stdlib/test/test/lux/pipe.lux diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 541b4bcdc..557992ba4 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -5591,36 +5591,6 @@ _ (fail "Wrong syntax for :!!"))) -(def: #hidden hack_Text/append - (-> Text Text Text) - Text/append) - -(def: get-cursor - (Lux Cursor) - (lambda [state] - (let [{#;info info #;source source #;modules modules #;scopes scopes - #;type-vars types #;host host #;seed seed - #;expected expected #;cursor cursor - #;scope-type-vars scope-type-vars} state] - (#;Right [state cursor])))) - -(macro: #export (with-cursor tokens) - {#;doc (doc "Given some text, appends to it a prefix for identifying where the text comes from." - "For example:" - (with-cursor (format "User: " user-id)) - "Would be the same as:" - (format "[the-module,the-line,the-column] " (format "User: " user-id)))} - (case tokens - (^ (list message)) - (do Monad - [cursor get-cursor] - (let [[module line column] cursor - cursor-prefix ($_ hack_Text/append "[" module "," (Nat/encode line) "," (Nat/encode column) "] ")] - (wrap (list (` (hack_Text/append (~ (text$ cursor-prefix)) (~ message))))))) - - _ - (fail "Wrong syntax for @"))) - (macro: #export (undefined tokens) {#;doc (doc "Meant to be used as a stand-in for functions with undefined implementations." "Undefined expressions will type-check against everything, so they make good dummy implementations." @@ -5630,45 +5600,11 @@ "If an undefined expression is ever evaluated, it will raise an error.")} (case tokens #;Nil - (return (list (` (error! (with-cursor "Undefined behavior."))))) + (return (list (` (error! "Undefined behavior.")))) _ (fail "Wrong syntax for undefined"))) -(macro: #export (@pre tokens) - {#;doc (doc "Pre-conditions." - "Given a test and an expression to run, only runs the expression if the test passes." - "Otherwise, an error is raised." - (@pre (i.= 4 (i.+ 2 2)) - (foo 123 456 789)))} - (case tokens - (^ (list test expr)) - (return (list (` (if (~ test) - (~ expr) - (error! (with-cursor (~ (text$ (Text/append "Pre-condition failed: " (ast-to-text test)))))))))) - - _ - (fail "Wrong syntax for @pre"))) - -(macro: #export (@post tokens) - {#;doc (doc "Post-conditions." - "Given a predicate and an expression to run, evaluates the expression and then tests the output with the predicate." - "If the predicate returns true, returns the value of the expression." - "Otherwise, an error is raised." - (@post i.even? - (i.+ 2 2)))} - (case tokens - (^ (list test expr)) - (do Monad - [g!output (gensym "")] - (wrap (list (` (let [(~ g!output) (~ expr)] - (if ((~ test) (~ g!output)) - (~ g!output) - (error! (with-cursor (~ (text$ (Text/append "Post-condition failed: " (ast-to-text test)))))))))))) - - _ - (fail "Wrong syntax for @post"))) - (macro: #export (type-of tokens) {#;doc (doc "Generates the type corresponding to a given definition or variable." (let [my-num (: Int 123)] diff --git a/stdlib/source/lux/control/contract.lux b/stdlib/source/lux/control/contract.lux new file mode 100644 index 000000000..2f347dfa5 --- /dev/null +++ b/stdlib/source/lux/control/contract.lux @@ -0,0 +1,37 @@ +(;module: + lux + (lux (control monad) + (data text/format) + [compiler #+ Monad] + (macro [ast] + ["s" syntax #+ syntax:]))) + +(def: #export (assert! message test) + (-> Text Bool []) + (if test + [] + (error! message))) + +(syntax: #export (@pre test expr) + {#;doc (doc "Pre-conditions." + "Given a test and an expression to run, only runs the expression if the test passes." + "Otherwise, an error is raised." + (@pre (i.= 4 (i.+ 2 2)) + (foo 123 456 789)))} + (wrap (list (` (exec (assert! (~ (ast;text (format "Pre-condition failed: " (%ast test)))) + (~ test)) + (~ expr)))))) + +(syntax: #export (@post test expr) + {#;doc (doc "Post-conditions." + "Given a predicate and an expression to run, evaluates the expression and then tests the output with the predicate." + "If the predicate returns true, returns the value of the expression." + "Otherwise, an error is raised." + (@post i.even? + (i.+ 2 2)))} + (do @ + [g!output (compiler;gensym "")] + (wrap (list (` (let [(~ g!output) (~ expr)] + (exec (assert! (~ (ast;text (format "Post-condition failed: " (%ast test)))) + ((~ test) (~ g!output))) + (~ g!output)))))))) diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux new file mode 100644 index 000000000..cfb05491d --- /dev/null +++ b/stdlib/source/lux/control/pipe.lux @@ -0,0 +1,146 @@ +(;module: {#;doc "Composable extensions to the piping macro |> that enhance it with various abilities."} + lux + (lux (control monad) + (data (coll [list #+ Monad "" Fold "List/" Monad]) + maybe) + [compiler #+ with-gensyms Monad] + (macro ["s" syntax #+ syntax: Syntax] + [ast]) + )) + +## [Syntax] +(def: body^ + (Syntax (List AST)) + (s;tuple (s;many s;any))) + +(syntax: #export (_> [tokens (s;at-least +2 s;any)]) + {#;doc (doc "Ignores the piped argument, and begins a new pipe." + (|> 20 + (i.* 3) + (i.+ 4) + (_> 0 i.inc)))} + (case (list;reverse tokens) + (^ (list& _ r-body)) + (wrap (list (` (|> (~@ (list;reverse r-body)))))) + + _ + (undefined))) + +(syntax: #export (@> [name (s;default "@" s;local-symbol)] + [body body^] + prev) + {#;doc (doc "Gives a name to the piped-argument, within the given expression." + "If given no name, defaults to '@'." + (|> 5 + (@> X [(i.+ X X)])) + + (|> 5 + (@> [(i.+ @ @)])))} + (wrap (list (fold (lambda [next prev] + (` (let% [(~ (ast;symbol ["" name])) (~ prev)] + (~ next)))) + prev + body)))) + +(syntax: #export (?> [branches (s;many (s;seq body^ body^))] + [?else (s;opt body^)] + prev) + {#;doc (doc "Branching for pipes." + "Both the tests and the bodies are piped-code, and must be given inside a tuple." + "If a last else-pipe isn't given, the piped-argument will be used instead." + (|> 5 + (?> [i.even?] [(i.* 2)] + [i.odd?] [(i.* 3)] + [(_> -1)])))} + (with-gensyms [g!temp] + (wrap (list (` (let% [(~ g!temp) (~ prev)] + (cond (~@ (do Monad + [[test then] branches] + (list (` (|> (~ g!temp) (~@ test))) + (` (|> (~ g!temp) (~@ then)))))) + (~ (case ?else + (#;Some else) + (` (|> (~ g!temp) (~@ else))) + + _ + g!temp))))))))) + +(syntax: #export (!> [test body^] [then body^] prev) + {#;doc (doc "Loops for pipes." + "Both the testing and calculating steps are pipes and must be given inside tuples." + (|> 1 + (!> [(i.< 10)] + [i.inc])))} + (with-gensyms [g!temp] + (wrap (list (` (loop [(~ g!temp) (~ prev)] + (if (|> (~ g!temp) (~@ test)) + ((~' recur) (|> (~ g!temp) (~@ then))) + (~ g!temp)))))))) + +(syntax: #export (%> monad [steps (s;some body^)] prev) + {#;doc (doc "Monadic pipes." + "Each steps in the monadic computation is a pipe and must be given inside a tuple." + (|> 5 + (%> Id/Monad + [(i.* 3)] + [(i.+ 4)] + [i.inc])))} + (with-gensyms [g!temp] + (case (list;reverse steps) + (^ (list& last-step prev-steps)) + (let [step-bindings (do Monad + [step (list;reverse prev-steps)] + (list g!temp (` (|> (~ g!temp) (~@ step)))))] + (wrap (list (` (do (~ monad) + [(~ g!temp) (~ prev) + (~@ step-bindings)] + (|> (~ g!temp) (~@ last-step))))))) + + _ + (wrap (list prev))))) + +(syntax: #export (~> [body body^] prev) + {#;doc (doc "Non-updating pipes." + "Will generate piped computations, but their results won't be used in the larger scope." + (|> 5 + (~> [int-to-nat %n log!]) + (i.* 10)))} + (do @ + [g!temp (compiler;gensym "")] + (wrap (list (` (let [(~ g!temp) (~ prev)] + (exec (|> (~ g!temp) (~@ body)) + (~ g!temp)))))))) + +(syntax: #export (&> [paths (s;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 + (&> [(i.* 10)] + [i.dec (i./ 2)] + [Int/encode])) + "Will become: [50 2 \"5\"]")} + (do @ + [g!temp (compiler;gensym "")] + (wrap (list (` (let [(~ g!temp) (~ prev)] + [(~@ (List/map (lambda [body] (` (|> (~ g!temp) (~@ body)))) + paths))])))))) + +(syntax: #export (case> [branches (s;many (s;seq s;any s;any))] prev) + {#;doc (doc "Pattern-matching for pipes." + "The bodies of each branch are NOT pipes; just regular values." + (|> 5 + (case> 0 "zero" + 1 "one" + 2 "two" + 3 "three" + 4 "four" + 5 "five" + 6 "six" + 7 "seven" + 8 "eight" + 9 "nine" + _ "???")))} + (let [(^open "List/") Monad] + (wrap (list (` (case (~ prev) + (~@ (List/join (List/map (lambda [[pattern body]] (list pattern body)) + branches))))))))) diff --git a/stdlib/source/lux/data/coll/vector.lux b/stdlib/source/lux/data/coll/vector.lux index b0ef6aa46..1c4a1dd9d 100644 --- a/stdlib/source/lux/data/coll/vector.lux +++ b/stdlib/source/lux/data/coll/vector.lux @@ -15,7 +15,6 @@ [compiler #+ with-gensyms] (macro [ast] ["s" syntax #+ syntax: Syntax]) - [pipe] )) ## This implementation of vectors is based on Clojure's diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 066777fdf..153920700 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -10,6 +10,7 @@ (data [bool] [text "Text/" Eq Monoid] text/format + (text [lexer #+ Lexer Monad]) [number #* "Real/" Codec] maybe [char "Char/" Eq Codec] @@ -24,7 +25,7 @@ [ast] [poly #+ poly:]) [type] - [lexer #+ Lexer Monad])) + )) ## [Types] (do-template [ ] diff --git a/stdlib/source/lux/data/text/lexer.lux b/stdlib/source/lux/data/text/lexer.lux new file mode 100644 index 000000000..e28cb0a68 --- /dev/null +++ b/stdlib/source/lux/data/text/lexer.lux @@ -0,0 +1,502 @@ +(;module: + [lux #- not default] + (lux (control functor + applicative + monad + codec) + (data [text "Text/" Eq Monoid] + [number "Int/" Codec] + [product] + [char "Char/" Order] + maybe + ["E" error #- fail] + (coll [list "" Functor])))) + +## [Types] +(type: #export (Lexer a) + (-> Text (Error [Text a]))) + +## [Structures] +(struct: #export _ (Functor Lexer) + (def: (map f fa) + (lambda [input] + (case (fa input) + (#E;Error msg) (#E;Error msg) + (#E;Success [input' output]) (#E;Success [input' (f output)]))))) + +(struct: #export _ (Applicative Lexer) + (def: functor Functor) + + (def: (wrap a) + (lambda [input] + (#E;Success [input a]))) + + (def: (apply ff fa) + (lambda [input] + (case (ff input) + (#E;Success [input' f]) + (case (fa input') + (#E;Success [input'' a]) + (#E;Success [input'' (f a)]) + + (#E;Error msg) + (#E;Error msg)) + + (#E;Error msg) + (#E;Error msg))))) + +(struct: #export _ (Monad Lexer) + (def: applicative Applicative) + + (def: (join mma) + (lambda [input] + (case (mma input) + (#E;Error msg) (#E;Error msg) + (#E;Success [input' ma]) (ma input')))) + ) + +## [Values] +## Runner +(def: #export (run' input lexer) + (All [a] (-> Text (Lexer a) (Error [Text a]))) + (lexer input)) + +(def: #export (run input lexer) + (All [a] (-> Text (Lexer a) (Error a))) + (case (lexer input) + (#E;Error msg) + (#E;Error msg) + + (#E;Success [input' output]) + (#E;Success output) + )) + +## Combinators +(def: #export (fail message) + (All [a] (-> Text (Lexer a))) + (lambda [input] + (#E;Error message))) + +(def: #export any + {#;doc "Just returns the next character without applying any logic."} + (Lexer Char) + (lambda [input] + (case [(text;nth +0 input) (text;split +1 input)] + [(#;Some output) (#;Some [_ input'])] + (#E;Success [input' output]) + + _ + (#E;Error "Can't 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 + [=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)))) + (lambda [input] + (case (left input) + (#E;Error msg) + (case (right input) + (#E;Error msg) + (#E;Error msg) + + (#E;Success [input' output]) + (#E;Success [input' (+1 output)])) + + (#E;Success [input' output]) + (#E;Success [input' (+0 output)])))) + +(def: #export (not! p) + {#;doc "Ensure a lexer fails."} + (All [a] (-> (Lexer a) (Lexer Unit))) + (lambda [input] + (case (p input) + (#E;Error msg) + (#E;Success [input []]) + + _ + (#E;Error "Expected to fail; yet succeeded.")))) + +(def: #export (not p) + {#;doc "Produce a character if the lexer fails."} + (All [a] (-> (Lexer a) (Lexer Char))) + (lambda [input] + (case (p input) + (#E;Error msg) + (any input) + + _ + (#E;Error "Expected to fail; yet succeeded.")))) + +(def: #export (either left right) + {#;doc "Homogeneous alternative combinator."} + (All [a] (-> (Lexer a) (Lexer a) (Lexer a))) + (lambda [input] + (case (left input) + (#E;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)) + (lambda [input] + (if test + (#E;Success [input []]) + (#E;Error message)))) + +(def: #export (some p) + {#;doc "0-or-more combinator."} + (All [a] (-> (Lexer a) (Lexer (List a)))) + (lambda [input] + (case (p input) + (#E;Error msg) + (#E;Success [input (list)]) + + (#E;Success [input' x]) + (run' input' + (do Monad + [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 + [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 + [x p + xs (exactly (n.dec n) p)] + (wrap (#;Cons x xs))) + (:: Monad 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) + (lambda [input] + (case (p input) + (#E;Error msg) + (#E;Success [input (list)]) + + (#E;Success [input' x]) + (run' input' + (do Monad + [xs (at-most (n.dec n) p)] + (wrap (#;Cons x xs)))) + )) + (:: Monad wrap (list)))) + +(def: #export (at-least n p) + {#;doc "Lex at least N times."} + (All [a] (-> Nat (Lexer a) (Lexer (List a)))) + (do Monad + [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 + [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)))) + (lambda [input] + (case (p input) + (#E;Error msg) + (#E;Success [input #;None]) + + (#E;Success [input value]) + (#E;Success [input (#;Some value)]) + ))) + +(def: #export (text test) + {#;doc "Lex a text if it matches the given sample."} + (-> Text (Lexer Text)) + (lambda [input] + (if (text;starts-with? test input) + (case (text;split (text;size test) input) + #;None (#E;Error "") + (#;Some [_ input']) (#E;Success [input' test])) + (#E;Error ($_ Text/append "Invalid match: " test " @ " (:: text;Codec encode input)))) + )) + +(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 + [?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) + (lambda [input] + (case input + "" (#E;Success [input []]) + _ (#E;Error ($_ Text/append "The text input has not been fully consumed @ " (:: text;Codec encode input))) + ))) + +(def: #export peek + {#;doc "Lex the next character (without consuming it from the input)."} + (Lexer Char) + (lambda [input] + (case (text;nth +0 input) + (#;Some output) + (#E;Success [input output]) + + _ + (#E;Error "Can't peek character from empty text.")) + )) + +(def: #export (char test) + {#;doc "Lex a character if it matches the given sample."} + (-> Char (Lexer Char)) + (lambda [input] + (case [(text;nth +0 input) (text;split +1 input)] + [(#;Some char') (#;Some [_ input'])] + (if (Char/= test char') + (#E;Success [input' test]) + (#E;Error ($_ Text/append "Expected " (:: char;Codec encode test) " @ " (:: text;Codec encode input)))) + + _ + (#E;Error "Can't parse character from empty text.")) + )) + +(def: #export get-input + {#;doc "Get all of the remaining input (without consuming it)."} + (Lexer Text) + (lambda [input] + (#E;Success [input input]))) + +(def: #export (char-range bottom top) + {#;doc "Only lex characters within a range."} + (-> Char Char (Lexer Char)) + (do Monad + [input get-input + char any + _ (assert ($_ Text/append "Character is not within range: " (:: char;Codec encode bottom) "-" (:: char;Codec encode top) " @ " (:: text;Codec encode input)) + (and (Char/>= bottom char) + (Char/<= top char)))] + (wrap char))) + +(do-template [ ] + [(def: #export + {#;doc (#;TextA ($_ Text/append "Only lex " " characters."))} + (Lexer Char) + (char-range ))] + + [upper #"A" #"Z" "uppercase"] + [lower #"a" #"z" "lowercase"] + [digit #"0" #"9" "decimal"] + [oct-digit #"0" #"7" "octal"] + ) + +(def: #export alpha + {#;doc "Only lex alphabetic characters."} + (Lexer Char) + (either lower upper)) + +(def: #export alpha-num + {#;doc "Only lex alphanumeric characters."} + (Lexer Char) + (either alpha digit)) + +(def: #export hex-digit + {#;doc "Only lex hexadecimal digits."} + (Lexer Char) + ($_ either + digit + (char-range #"a" #"f") + (char-range #"A" #"F"))) + +(def: #export (one-of options) + {#;doc "Only lex characters that are part of a piece of text."} + (-> Text (Lexer Char)) + (lambda [input] + (case (text;split +1 input) + (#;Some [init input']) + (if (text;contains? init options) + (case (text;nth +0 init) + (#;Some output) + (#E;Success [input' output]) + + _ + (#E;Error "")) + (#E;Error ($_ Text/append "Character (" init ") is not one of: " options " @ " (:: text;Codec encode input)))) + + _ + (#E;Error "Can't parse character from empty text.")))) + +(def: #export (none-of options) + {#;doc "Only lex characters that aren't part of a piece of text."} + (-> Text (Lexer Char)) + (lambda [input] + (case (text;split +1 input) + (#;Some [init input']) + (if (;not (text;contains? init options)) + (case (text;nth +0 init) + (#;Some output) + (#E;Success [input' output]) + + _ + (#E;Error "")) + (#E;Error ($_ Text/append "Character (" init ") is one of: " options " @ " (:: text;Codec encode input)))) + + _ + (#E;Error "Can't parse character from empty text.")))) + +(def: #export (satisfies p) + {#;doc "Only lex characters that satisfy a predicate."} + (-> (-> Char Bool) (Lexer Char)) + (lambda [input] + (case (: (Maybe [Text Char]) + (do Monad + [[init input'] (text;split +1 input) + output (text;nth +0 init)] + (wrap [input' output]))) + (#;Some [input' output]) + (if (p output) + (#E;Success [input' output]) + (#E;Error ($_ Text/append "Character does not satisfy predicate: " (:: text;Codec encode input)))) + + _ + (#E;Error "Can't parse character from empty text.")))) + +(def: #export space + {#;doc "Only lex white-space."} + (Lexer Char) + (satisfies char;space?)) + +(do-template [ ] + [(def: #export ( p) + {#;doc } + (-> (Lexer Char) (Lexer Text)) + (do Monad + [cs ( p)] + (wrap (text;concat (map char;as-text cs)))))] + + [some' some "Lex some characters as a single continuous text."] + [many' many "Lex many characters as a single continuous text."] + ) + +(do-template [ ] + [(def: #export ( n p) + {#;doc } + (-> Nat (Lexer Char) (Lexer Text)) + (do Monad + [cs ( n p)] + (wrap (text;concat (map char;as-text cs)))))] + + [exactly' exactly "Lex exactly N characters."] + [at-most' at-most "Lex at most N characters."] + [at-least' at-least "Lex at least N characters."] + ) + +(def: #export (between' from to p) + {#;doc "Lex between N and M characters."} + (-> Nat Nat (Lexer Char) (Lexer Text)) + (do Monad + [cs (between from to p)] + (wrap (text;concat (map char;as-text cs))))) + +(def: #export end? + {#;doc "Ask if the lexer's input is empty."} + (Lexer Bool) + (lambda [input] + (#E;Success [input (text;empty? input)]))) + +(def: #export (_& left right) + (All [a b] (-> (Lexer a) (Lexer b) (Lexer b))) + (do Monad + [_ left] + right)) + +(def: #export (&_ left right) + (All [a b] (-> (Lexer a) (Lexer b) (Lexer a))) + (do Monad + [output left + _ right] + (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))) + (lambda [input] + (case (lexer input) + (#E;Error error) + (#E;Success [input value]) + + (#E;Success input'+value) + (#E;Success input'+value)))) + +(def: #export (codec codec lexer) + {#;doc "Lex a token by means of a codec."} + (All [a] (-> (Codec Text a) (Lexer Text) (Lexer a))) + (lambda [input] + (case (lexer input) + (#E;Error error) + (#E;Error error) + + (#E;Success [input' to-decode]) + (case (:: codec decode to-decode) + (#E;Error error) + (#E;Error error) + + (#E;Success value) + (#E;Success [input' value]))))) + +(def: #export (enclosed [start end] lexer) + (All [a] (-> [Text Text] (Lexer a) (Lexer a))) + (_& (text start) + (&_ lexer + (text end)))) + +(def: #export (rec lexer) + (All [a] (-> (-> (Lexer a) (Lexer a)) + (Lexer a))) + (lambda [input] + (run' input (lexer (rec lexer))))) + +(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))) + (lambda [real-input] + (case (run' local-input lexer) + (#E;Error error) + (#E;Error error) + + (#E;Success [unconsumed value]) + (if (Text/= "" unconsumed) + (#E;Success [real-input value]) + (#E;Error ($_ Text/append "Unconsumed input: " unconsumed)))))) diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux new file mode 100644 index 000000000..21358c9b0 --- /dev/null +++ b/stdlib/source/lux/data/text/regex.lux @@ -0,0 +1,509 @@ +(;module: + lux + (lux (control monad) + (data [char] + [text] + ["&" text/lexer #+ Lexer Monad] + text/format + [number "Int/" Codec] + [product] + (coll [list "" Fold "List/" Monad])) + [compiler #- run] + (macro [ast] + ["s" syntax #+ syntax:]))) + +## [Utils] +(def: #hidden (->Text lexer^) + (-> (Lexer Char) (Lexer Text)) + (do Monad + [output lexer^] + (wrap (char;as-text output)))) + +(def: regex-char^ + (Lexer Char) + (&;none-of "\\.|&()[]{}")) + +(def: escaped-char^ + (Lexer Char) + (do Monad + [? (&;opt (&;char #"\\")) + char (case ? + (#;Some _) &;any + #;None regex-char^)] + (wrap char))) + +(def: (local^ state lexer) + (All [a] (-> Text (Lexer a) (Lexer a))) + (lambda [old-state] + (case (lexer state) + (#;Left error) + (#;Left error) + + (#;Right [_ value]) + (#;Right [old-state value])))) + +(def: #hidden (refine^ refinement^ base^) + (All [a] (-> (Lexer a) (Lexer Text) (Lexer Text))) + (do Monad + [output base^ + _ (local^ output refinement^)] + (wrap output))) + +(def: #hidden word^ + (Lexer Char) + (&;either &;alpha-num + (&;char #"_"))) + +(def: #hidden (join-text^ part^) + (-> (Lexer (List Text)) (Lexer Text)) + (do Monad + [parts part^] + (wrap (text;join-with "" parts)))) + +(def: identifier-char^ + (Lexer Char) + (&;none-of "[]{}()s\"#;<>")) + +(def: identifier-part^ + (Lexer Text) + (do Monad + [head (refine^ (&;not &;digit) + (->Text identifier-char^)) + tail (&;some' identifier-char^)] + (wrap (format head tail)))) + +(def: (identifier^ current-module) + (-> Text (Lexer Ident)) + (do Monad + [] + ($_ &;either + (&;seq (wrap current-module) (&;_& (&;text ";;") identifier-part^)) + (&;seq identifier-part^ (&;_& (&;text ";") identifier-part^)) + (&;seq (wrap "lux") (&;_& (&;text ";") identifier-part^)) + (&;seq (wrap "") identifier-part^)))) + +(def: (re-var^ current-module) + (-> Text (Lexer AST)) + (do Monad + [ident (&;enclosed ["\\@<" ">"] (identifier^ current-module))] + (wrap (` (: (Lexer Text) (~ (ast;symbol ident))))))) + +(def: re-char-range^ + (Lexer AST) + (do Monad + [from regex-char^ + _ (&;char #"-") + to regex-char^] + (wrap (` (&;char-range (~ (ast;char from)) (~ (ast;char to))))))) + +(def: re-char^ + (Lexer AST) + (do Monad + [char escaped-char^] + (wrap (` (&;char (~ (ast;char char))))))) + +(def: re-char+^ + (Lexer AST) + (do Monad + [base re-char^] + (wrap (` (->Text (~ base)))))) + +(def: re-char-options^ + (Lexer AST) + (do Monad + [options (&;many' escaped-char^)] + (wrap (` (&;one-of (~ (ast;text options))))))) + +(def: re-user-class^' + (Lexer AST) + (do Monad + [negate? (&;opt (&;char #"^")) + parts (&;many ($_ &;either + re-char-range^ + re-char-options^))] + (wrap (case negate? + (#;Some _) (` (->Text (&;not ($_ &;either (~@ parts))))) + #;None (` (->Text ($_ &;either (~@ parts)))))))) + +(def: re-user-class^ + (Lexer AST) + (do Monad + [_ (wrap []) + init re-user-class^' + rest (&;some (&;_& (&;text "&&") (&;enclosed ["[" "]"] re-user-class^')))] + (wrap (fold (lambda [refinement base] + (` (refine^ (~ refinement) (~ base)))) + init + rest)))) + +(def: #hidden blank^ + (Lexer Char) + (&;one-of " \t")) + +(def: #hidden ascii^ + (Lexer Char) + (&;char-range #"\u0000" #"\u007F")) + +(def: #hidden control^ + (Lexer Char) + (&;either (&;char-range #"\u0000" #"\u001F") + (&;char #"\u007F"))) + +(def: #hidden punct^ + (Lexer Char) + (&;one-of "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~")) + +(def: #hidden graph^ + (Lexer Char) + (&;either punct^ &;alpha-num)) + +(def: #hidden print^ + (Lexer Char) + (&;either graph^ + (&;char #"\u0020"))) + +(def: re-system-class^ + (Lexer AST) + (do Monad + [] + ($_ &;either + (&;_& (&;char #".") (wrap (` (->Text &;any)))) + (&;_& (&;text "\\d") (wrap (` (->Text &;digit)))) + (&;_& (&;text "\\D") (wrap (` (->Text (&;not &;digit))))) + (&;_& (&;text "\\s") (wrap (` (->Text &;space)))) + (&;_& (&;text "\\S") (wrap (` (->Text (&;not &;space))))) + (&;_& (&;text "\\w") (wrap (` (->Text word^)))) + (&;_& (&;text "\\W") (wrap (` (->Text (&;not word^))))) + (&;_& (&;text "\\d") (wrap (` (->Text &;digit)))) + + (&;_& (&;text "\\p{Lower}") (wrap (` (->Text &;lower)))) + (&;_& (&;text "\\p{Upper}") (wrap (` (->Text &;upper)))) + (&;_& (&;text "\\p{Alpha}") (wrap (` (->Text &;alpha)))) + (&;_& (&;text "\\p{Digit}") (wrap (` (->Text &;digit)))) + (&;_& (&;text "\\p{Alnum}") (wrap (` (->Text &;alpha-num)))) + (&;_& (&;text "\\p{Space}") (wrap (` (->Text &;space)))) + (&;_& (&;text "\\p{HexDigit}") (wrap (` (->Text &;hex-digit)))) + (&;_& (&;text "\\p{OctDigit}") (wrap (` (->Text &;oct-digit)))) + (&;_& (&;text "\\p{Blank}") (wrap (` (->Text blank^)))) + (&;_& (&;text "\\p{ASCII}") (wrap (` (->Text ascii^)))) + (&;_& (&;text "\\p{Contrl}") (wrap (` (->Text control^)))) + (&;_& (&;text "\\p{Punct}") (wrap (` (->Text punct^)))) + (&;_& (&;text "\\p{Graph}") (wrap (` (->Text graph^)))) + (&;_& (&;text "\\p{Print}") (wrap (` (->Text print^)))) + ))) + +(def: re-class^ + (Lexer AST) + (&;either re-system-class^ + (&;enclosed ["[" "]"] re-user-class^))) + +(def: int^ + (Lexer Int) + (&;codec number;Codec (&;many' &;digit))) + +(def: re-back-reference^ + (Lexer AST) + (&;either (do Monad + [_ (&;char #"\\") + id int^] + (wrap (` (&;text (~ (ast;symbol ["" (Int/encode id)])))))) + (do Monad + [_ (&;text "\\k<") + captured-name identifier-part^ + _ (&;text ">")] + (wrap (` (&;text (~ (ast;symbol ["" captured-name])))))))) + +(def: (re-simple^ current-module) + (-> Text (Lexer AST)) + ($_ &;either + re-class^ + (re-var^ current-module) + re-back-reference^ + re-char+^ + )) + +(def: (re-simple-quantified^ current-module) + (-> Text (Lexer AST)) + (do Monad + [base (re-simple^ current-module) + quantifier (&;one-of "?*+")] + (case quantifier + #"?" + (wrap (` (&;default "" (~ base)))) + + #"*" + (wrap (` (join-text^ (&;some (~ base))))) + + _ + (wrap (` (join-text^ (&;many (~ base))))) + ))) + +(def: (re-counted-quantified^ current-module) + (-> Text (Lexer AST)) + (do Monad + [base (re-simple^ current-module)] + (&;enclosed ["{" "}"] + ($_ &;either + (do @ + [[from to] (&;seq int^ (&;_& (&;char #",") int^))] + (wrap (` (join-text^ (&;between (~ (ast;nat (int-to-nat from))) + (~ (ast;nat (int-to-nat to))) + (~ base)))))) + (do @ + [limit (&;_& (&;char #",") int^)] + (wrap (` (join-text^ (&;at-most (~ (ast;nat (int-to-nat limit))) (~ base)))))) + (do @ + [limit (&;&_ int^ (&;char #","))] + (wrap (` (join-text^ (&;at-least (~ (ast;nat (int-to-nat limit))) (~ base)))))) + (do @ + [limit int^] + (wrap (` (join-text^ (&;exactly (~ (ast;nat (int-to-nat limit))) (~ base)))))))))) + +(def: (re-quantified^ current-module) + (-> Text (Lexer AST)) + (&;either (re-simple-quantified^ current-module) + (re-counted-quantified^ current-module))) + +(def: (re-complex^ current-module) + (-> Text (Lexer AST)) + ($_ &;either + (re-quantified^ current-module) + (re-simple^ current-module))) + +(def: #hidden _Text/append_ + (-> Text Text Text) + (:: text;Monoid append)) + +(type: Re-Group + #Non-Capturing + (#Capturing [(Maybe Text) Nat])) + +(def: (re-sequential^ capturing? re-scoped^ current-module) + (-> Bool + (-> Text (Lexer [Re-Group AST])) + Text + (Lexer [Nat AST])) + (do Monad + [parts (&;many (&;alt (re-complex^ current-module) + (re-scoped^ current-module))) + #let [g!total (ast;symbol ["" "0total"]) + g!temp (ast;symbol ["" "0temp"]) + [_ names steps] (fold (: (-> (Either AST [Re-Group AST]) + [Int (List AST) (List (List AST))] + [Int (List AST) (List (List AST))]) + (lambda [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 (ast;symbol ["" _name])] + + #;None + [(i.inc idx) (ast;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 AST) (list)) + (: (List (List AST)) (list))] + parts)]] + (wrap [(if capturing? + (list;size names) + +0) + (` (do Monad + [(~ (' #let)) [(~ g!total) ""] + (~@ (|> steps list;reverse List/join))] + ((~ (' wrap)) [(~ g!total) (~@ (list;reverse names))])))]) + )) + +(def: #hidden (unflatten^ lexer) + (-> (Lexer Text) (Lexer [Text Unit])) + (&;seq lexer (:: Monad wrap []))) + +(def: #hidden (|||^ left right) + (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer [Text (| l r)]))) + (lambda [input] + (case (left input) + (#;Right [input' [lt lv]]) + (#;Right [input' [lt (+0 lv)]]) + + (#;Left _) + (case (right input) + (#;Right [input' [rt rv]]) + (#;Right [input' [rt (+1 rv)]]) + + (#;Left error) + (#;Left error))))) + +(def: #hidden (|||_^ left right) + (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer Text))) + (lambda [input] + (case (left input) + (#;Right [input' [lt lv]]) + (#;Right [input' lt]) + + (#;Left _) + (case (right input) + (#;Right [input' [rt rv]]) + (#;Right [input' rt]) + + (#;Left error) + (#;Left error))))) + +(def: (prep-alternative [num-captures alt]) + (-> [Nat AST] AST) + (if (n.> +0 num-captures) + alt + (` (unflatten^ (~ alt))))) + +(def: (re-alternative^ capturing? re-scoped^ current-module) + (-> Bool + (-> Text (Lexer [Re-Group AST])) + Text + (Lexer [Nat AST])) + (do Monad + [#let [sub^ (re-sequential^ capturing? re-scoped^ current-module)] + head sub^ + tail (&;some (&;_& (&;char #"|") 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))))])))) + +(def: (re-scoped^ current-module) + (-> Text (Lexer [Re-Group AST])) + ($_ &;either + (do Monad + [_ (&;text "(?:") + [_ scoped] (re-alternative^ false re-scoped^ current-module) + _ (&;char #")")] + (wrap [#Non-Capturing scoped])) + (do Monad + [complex (re-complex^ current-module)] + (wrap [#Non-Capturing complex])) + (do Monad + [_ (&;text "(?<") + captured-name identifier-part^ + _ (&;text ">") + [num-captures pattern] (re-alternative^ true re-scoped^ current-module) + _ (&;char #")")] + (wrap [(#Capturing [(#;Some captured-name) num-captures]) pattern])) + (do Monad + [_ (&;char #"(") + [num-captures pattern] (re-alternative^ true re-scoped^ current-module) + _ (&;char #")")] + (wrap [(#Capturing [#;None num-captures]) pattern])))) + +(def: (regex^ current-module) + (-> Text (Lexer AST)) + (:: Monad map product;right (re-alternative^ true re-scoped^ current-module))) + +## [Syntax] +(syntax: #export (regex [pattern s;text]) + {#;doc (doc "Create lexers using regular-expression syntax." + "For example:" + + "Literals" + (regex "a") + + "Wildcards" + (regex ".") + + "Escaping" + (regex "\\.") + + "Character classes" + (regex "\\d") + (regex "\\p{Lower}") + (regex "[abc]") + (regex "[a-z]") + (regex "[a-zA-Z]") + (regex "[a-z&&[def]]") + + "Negation" + (regex "[^abc]") + (regex "[^a-z]") + (regex "[^a-zA-Z]") + (regex "[a-z&&[^bc]]") + (regex "[a-z&&[^m-p]]") + + "Combinations" + (regex "aa") + (regex "a?") + (regex "a*") + (regex "a+") + + "Specific amounts" + (regex "a{2}") + + "At least" + (regex "a{1,}") + + "At most" + (regex "a{,1}") + + "Between" + (regex "a{1,2}") + + "Groups" + (regex "a(.)c") + (regex "a(b+)c") + (regex "(\\d{3})-(\\d{3})-(\\d{4})") + (regex "(\\d{3})-(?:\\d{3})-(\\d{4})") + (regex "(?\\d{3})-\\k-(\\d{4})") + (regex "(?\\d{3})-\\k-(\\d{4})-\\0") + (regex "(\\d{3})-((\\d{3})-(\\d{4}))") + + "Alternation" + (regex "a|b") + (regex "a(.)(.)|b(.)(.)") + )} + (do @ + [current-module compiler;current-module-name] + (case (&;run pattern + (&;&_ (regex^ current-module) &;end)) + (#;Left error) + (compiler;fail error) + + (#;Right regex) + (wrap (list regex)) + ))) + +(syntax: #export (^regex [[pattern bindings] (s;form (s;seq s;text (s;opt s;any)))] + body + [branches (s;many s;any)]) + {#;doc (doc "Allows you to test text against regular expressions." + (case some-text + (^regex "(\\d{3})-(\\d{3})-(\\d{4})" + [_ country-code area-code place-code]) + do-some-thing-when-number + + (^regex "\\w+") + do-some-thing-when-word + + _ + do-something-else))} + (do @ + [g!temp (compiler;gensym "temp")] + (wrap (list& (` (^=> (~ g!temp) + [(&;run (~ g!temp) (regex (~ (ast;text pattern)))) + (#;Right (~ (default g!temp + bindings)))])) + body + branches)))) diff --git a/stdlib/source/lux/lexer.lux b/stdlib/source/lux/lexer.lux deleted file mode 100644 index e28cb0a68..000000000 --- a/stdlib/source/lux/lexer.lux +++ /dev/null @@ -1,502 +0,0 @@ -(;module: - [lux #- not default] - (lux (control functor - applicative - monad - codec) - (data [text "Text/" Eq Monoid] - [number "Int/" Codec] - [product] - [char "Char/" Order] - maybe - ["E" error #- fail] - (coll [list "" Functor])))) - -## [Types] -(type: #export (Lexer a) - (-> Text (Error [Text a]))) - -## [Structures] -(struct: #export _ (Functor Lexer) - (def: (map f fa) - (lambda [input] - (case (fa input) - (#E;Error msg) (#E;Error msg) - (#E;Success [input' output]) (#E;Success [input' (f output)]))))) - -(struct: #export _ (Applicative Lexer) - (def: functor Functor) - - (def: (wrap a) - (lambda [input] - (#E;Success [input a]))) - - (def: (apply ff fa) - (lambda [input] - (case (ff input) - (#E;Success [input' f]) - (case (fa input') - (#E;Success [input'' a]) - (#E;Success [input'' (f a)]) - - (#E;Error msg) - (#E;Error msg)) - - (#E;Error msg) - (#E;Error msg))))) - -(struct: #export _ (Monad Lexer) - (def: applicative Applicative) - - (def: (join mma) - (lambda [input] - (case (mma input) - (#E;Error msg) (#E;Error msg) - (#E;Success [input' ma]) (ma input')))) - ) - -## [Values] -## Runner -(def: #export (run' input lexer) - (All [a] (-> Text (Lexer a) (Error [Text a]))) - (lexer input)) - -(def: #export (run input lexer) - (All [a] (-> Text (Lexer a) (Error a))) - (case (lexer input) - (#E;Error msg) - (#E;Error msg) - - (#E;Success [input' output]) - (#E;Success output) - )) - -## Combinators -(def: #export (fail message) - (All [a] (-> Text (Lexer a))) - (lambda [input] - (#E;Error message))) - -(def: #export any - {#;doc "Just returns the next character without applying any logic."} - (Lexer Char) - (lambda [input] - (case [(text;nth +0 input) (text;split +1 input)] - [(#;Some output) (#;Some [_ input'])] - (#E;Success [input' output]) - - _ - (#E;Error "Can't 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 - [=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)))) - (lambda [input] - (case (left input) - (#E;Error msg) - (case (right input) - (#E;Error msg) - (#E;Error msg) - - (#E;Success [input' output]) - (#E;Success [input' (+1 output)])) - - (#E;Success [input' output]) - (#E;Success [input' (+0 output)])))) - -(def: #export (not! p) - {#;doc "Ensure a lexer fails."} - (All [a] (-> (Lexer a) (Lexer Unit))) - (lambda [input] - (case (p input) - (#E;Error msg) - (#E;Success [input []]) - - _ - (#E;Error "Expected to fail; yet succeeded.")))) - -(def: #export (not p) - {#;doc "Produce a character if the lexer fails."} - (All [a] (-> (Lexer a) (Lexer Char))) - (lambda [input] - (case (p input) - (#E;Error msg) - (any input) - - _ - (#E;Error "Expected to fail; yet succeeded.")))) - -(def: #export (either left right) - {#;doc "Homogeneous alternative combinator."} - (All [a] (-> (Lexer a) (Lexer a) (Lexer a))) - (lambda [input] - (case (left input) - (#E;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)) - (lambda [input] - (if test - (#E;Success [input []]) - (#E;Error message)))) - -(def: #export (some p) - {#;doc "0-or-more combinator."} - (All [a] (-> (Lexer a) (Lexer (List a)))) - (lambda [input] - (case (p input) - (#E;Error msg) - (#E;Success [input (list)]) - - (#E;Success [input' x]) - (run' input' - (do Monad - [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 - [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 - [x p - xs (exactly (n.dec n) p)] - (wrap (#;Cons x xs))) - (:: Monad 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) - (lambda [input] - (case (p input) - (#E;Error msg) - (#E;Success [input (list)]) - - (#E;Success [input' x]) - (run' input' - (do Monad - [xs (at-most (n.dec n) p)] - (wrap (#;Cons x xs)))) - )) - (:: Monad wrap (list)))) - -(def: #export (at-least n p) - {#;doc "Lex at least N times."} - (All [a] (-> Nat (Lexer a) (Lexer (List a)))) - (do Monad - [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 - [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)))) - (lambda [input] - (case (p input) - (#E;Error msg) - (#E;Success [input #;None]) - - (#E;Success [input value]) - (#E;Success [input (#;Some value)]) - ))) - -(def: #export (text test) - {#;doc "Lex a text if it matches the given sample."} - (-> Text (Lexer Text)) - (lambda [input] - (if (text;starts-with? test input) - (case (text;split (text;size test) input) - #;None (#E;Error "") - (#;Some [_ input']) (#E;Success [input' test])) - (#E;Error ($_ Text/append "Invalid match: " test " @ " (:: text;Codec encode input)))) - )) - -(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 - [?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) - (lambda [input] - (case input - "" (#E;Success [input []]) - _ (#E;Error ($_ Text/append "The text input has not been fully consumed @ " (:: text;Codec encode input))) - ))) - -(def: #export peek - {#;doc "Lex the next character (without consuming it from the input)."} - (Lexer Char) - (lambda [input] - (case (text;nth +0 input) - (#;Some output) - (#E;Success [input output]) - - _ - (#E;Error "Can't peek character from empty text.")) - )) - -(def: #export (char test) - {#;doc "Lex a character if it matches the given sample."} - (-> Char (Lexer Char)) - (lambda [input] - (case [(text;nth +0 input) (text;split +1 input)] - [(#;Some char') (#;Some [_ input'])] - (if (Char/= test char') - (#E;Success [input' test]) - (#E;Error ($_ Text/append "Expected " (:: char;Codec encode test) " @ " (:: text;Codec encode input)))) - - _ - (#E;Error "Can't parse character from empty text.")) - )) - -(def: #export get-input - {#;doc "Get all of the remaining input (without consuming it)."} - (Lexer Text) - (lambda [input] - (#E;Success [input input]))) - -(def: #export (char-range bottom top) - {#;doc "Only lex characters within a range."} - (-> Char Char (Lexer Char)) - (do Monad - [input get-input - char any - _ (assert ($_ Text/append "Character is not within range: " (:: char;Codec encode bottom) "-" (:: char;Codec encode top) " @ " (:: text;Codec encode input)) - (and (Char/>= bottom char) - (Char/<= top char)))] - (wrap char))) - -(do-template [ ] - [(def: #export - {#;doc (#;TextA ($_ Text/append "Only lex " " characters."))} - (Lexer Char) - (char-range ))] - - [upper #"A" #"Z" "uppercase"] - [lower #"a" #"z" "lowercase"] - [digit #"0" #"9" "decimal"] - [oct-digit #"0" #"7" "octal"] - ) - -(def: #export alpha - {#;doc "Only lex alphabetic characters."} - (Lexer Char) - (either lower upper)) - -(def: #export alpha-num - {#;doc "Only lex alphanumeric characters."} - (Lexer Char) - (either alpha digit)) - -(def: #export hex-digit - {#;doc "Only lex hexadecimal digits."} - (Lexer Char) - ($_ either - digit - (char-range #"a" #"f") - (char-range #"A" #"F"))) - -(def: #export (one-of options) - {#;doc "Only lex characters that are part of a piece of text."} - (-> Text (Lexer Char)) - (lambda [input] - (case (text;split +1 input) - (#;Some [init input']) - (if (text;contains? init options) - (case (text;nth +0 init) - (#;Some output) - (#E;Success [input' output]) - - _ - (#E;Error "")) - (#E;Error ($_ Text/append "Character (" init ") is not one of: " options " @ " (:: text;Codec encode input)))) - - _ - (#E;Error "Can't parse character from empty text.")))) - -(def: #export (none-of options) - {#;doc "Only lex characters that aren't part of a piece of text."} - (-> Text (Lexer Char)) - (lambda [input] - (case (text;split +1 input) - (#;Some [init input']) - (if (;not (text;contains? init options)) - (case (text;nth +0 init) - (#;Some output) - (#E;Success [input' output]) - - _ - (#E;Error "")) - (#E;Error ($_ Text/append "Character (" init ") is one of: " options " @ " (:: text;Codec encode input)))) - - _ - (#E;Error "Can't parse character from empty text.")))) - -(def: #export (satisfies p) - {#;doc "Only lex characters that satisfy a predicate."} - (-> (-> Char Bool) (Lexer Char)) - (lambda [input] - (case (: (Maybe [Text Char]) - (do Monad - [[init input'] (text;split +1 input) - output (text;nth +0 init)] - (wrap [input' output]))) - (#;Some [input' output]) - (if (p output) - (#E;Success [input' output]) - (#E;Error ($_ Text/append "Character does not satisfy predicate: " (:: text;Codec encode input)))) - - _ - (#E;Error "Can't parse character from empty text.")))) - -(def: #export space - {#;doc "Only lex white-space."} - (Lexer Char) - (satisfies char;space?)) - -(do-template [ ] - [(def: #export ( p) - {#;doc } - (-> (Lexer Char) (Lexer Text)) - (do Monad - [cs ( p)] - (wrap (text;concat (map char;as-text cs)))))] - - [some' some "Lex some characters as a single continuous text."] - [many' many "Lex many characters as a single continuous text."] - ) - -(do-template [ ] - [(def: #export ( n p) - {#;doc } - (-> Nat (Lexer Char) (Lexer Text)) - (do Monad - [cs ( n p)] - (wrap (text;concat (map char;as-text cs)))))] - - [exactly' exactly "Lex exactly N characters."] - [at-most' at-most "Lex at most N characters."] - [at-least' at-least "Lex at least N characters."] - ) - -(def: #export (between' from to p) - {#;doc "Lex between N and M characters."} - (-> Nat Nat (Lexer Char) (Lexer Text)) - (do Monad - [cs (between from to p)] - (wrap (text;concat (map char;as-text cs))))) - -(def: #export end? - {#;doc "Ask if the lexer's input is empty."} - (Lexer Bool) - (lambda [input] - (#E;Success [input (text;empty? input)]))) - -(def: #export (_& left right) - (All [a b] (-> (Lexer a) (Lexer b) (Lexer b))) - (do Monad - [_ left] - right)) - -(def: #export (&_ left right) - (All [a b] (-> (Lexer a) (Lexer b) (Lexer a))) - (do Monad - [output left - _ right] - (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))) - (lambda [input] - (case (lexer input) - (#E;Error error) - (#E;Success [input value]) - - (#E;Success input'+value) - (#E;Success input'+value)))) - -(def: #export (codec codec lexer) - {#;doc "Lex a token by means of a codec."} - (All [a] (-> (Codec Text a) (Lexer Text) (Lexer a))) - (lambda [input] - (case (lexer input) - (#E;Error error) - (#E;Error error) - - (#E;Success [input' to-decode]) - (case (:: codec decode to-decode) - (#E;Error error) - (#E;Error error) - - (#E;Success value) - (#E;Success [input' value]))))) - -(def: #export (enclosed [start end] lexer) - (All [a] (-> [Text Text] (Lexer a) (Lexer a))) - (_& (text start) - (&_ lexer - (text end)))) - -(def: #export (rec lexer) - (All [a] (-> (-> (Lexer a) (Lexer a)) - (Lexer a))) - (lambda [input] - (run' input (lexer (rec lexer))))) - -(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))) - (lambda [real-input] - (case (run' local-input lexer) - (#E;Error error) - (#E;Error error) - - (#E;Success [unconsumed value]) - (if (Text/= "" unconsumed) - (#E;Success [real-input value]) - (#E;Error ($_ Text/append "Unconsumed input: " unconsumed)))))) diff --git a/stdlib/source/lux/lexer/regex.lux b/stdlib/source/lux/lexer/regex.lux deleted file mode 100644 index 616f02086..000000000 --- a/stdlib/source/lux/lexer/regex.lux +++ /dev/null @@ -1,509 +0,0 @@ -(;module: - lux - (lux (control monad) - (data [char] - [text] - text/format - [number "Int/" Codec] - [product] - (coll [list "" Fold "List/" Monad])) - [compiler #- run] - (macro [ast] - ["s" syntax #+ syntax:]) - ["&" lexer #+ Lexer Monad])) - -## [Utils] -(def: #hidden (->Text lexer^) - (-> (Lexer Char) (Lexer Text)) - (do Monad - [output lexer^] - (wrap (char;as-text output)))) - -(def: regex-char^ - (Lexer Char) - (&;none-of "\\.|&()[]{}")) - -(def: escaped-char^ - (Lexer Char) - (do Monad - [? (&;opt (&;char #"\\")) - char (case ? - (#;Some _) &;any - #;None regex-char^)] - (wrap char))) - -(def: (local^ state lexer) - (All [a] (-> Text (Lexer a) (Lexer a))) - (lambda [old-state] - (case (lexer state) - (#;Left error) - (#;Left error) - - (#;Right [_ value]) - (#;Right [old-state value])))) - -(def: #hidden (refine^ refinement^ base^) - (All [a] (-> (Lexer a) (Lexer Text) (Lexer Text))) - (do Monad - [output base^ - _ (local^ output refinement^)] - (wrap output))) - -(def: #hidden word^ - (Lexer Char) - (&;either &;alpha-num - (&;char #"_"))) - -(def: #hidden (join-text^ part^) - (-> (Lexer (List Text)) (Lexer Text)) - (do Monad - [parts part^] - (wrap (text;join-with "" parts)))) - -(def: identifier-char^ - (Lexer Char) - (&;none-of "[]{}()s\"#;<>")) - -(def: identifier-part^ - (Lexer Text) - (do Monad - [head (refine^ (&;not &;digit) - (->Text identifier-char^)) - tail (&;some' identifier-char^)] - (wrap (format head tail)))) - -(def: (identifier^ current-module) - (-> Text (Lexer Ident)) - (do Monad - [] - ($_ &;either - (&;seq (wrap current-module) (&;_& (&;text ";;") identifier-part^)) - (&;seq identifier-part^ (&;_& (&;text ";") identifier-part^)) - (&;seq (wrap "lux") (&;_& (&;text ";") identifier-part^)) - (&;seq (wrap "") identifier-part^)))) - -(def: (re-var^ current-module) - (-> Text (Lexer AST)) - (do Monad - [ident (&;enclosed ["\\@<" ">"] (identifier^ current-module))] - (wrap (` (: (Lexer Text) (~ (ast;symbol ident))))))) - -(def: re-char-range^ - (Lexer AST) - (do Monad - [from regex-char^ - _ (&;char #"-") - to regex-char^] - (wrap (` (&;char-range (~ (ast;char from)) (~ (ast;char to))))))) - -(def: re-char^ - (Lexer AST) - (do Monad - [char escaped-char^] - (wrap (` (&;char (~ (ast;char char))))))) - -(def: re-char+^ - (Lexer AST) - (do Monad - [base re-char^] - (wrap (` (->Text (~ base)))))) - -(def: re-char-options^ - (Lexer AST) - (do Monad - [options (&;many' escaped-char^)] - (wrap (` (&;one-of (~ (ast;text options))))))) - -(def: re-user-class^' - (Lexer AST) - (do Monad - [negate? (&;opt (&;char #"^")) - parts (&;many ($_ &;either - re-char-range^ - re-char-options^))] - (wrap (case negate? - (#;Some _) (` (->Text (&;not ($_ &;either (~@ parts))))) - #;None (` (->Text ($_ &;either (~@ parts)))))))) - -(def: re-user-class^ - (Lexer AST) - (do Monad - [_ (wrap []) - init re-user-class^' - rest (&;some (&;_& (&;text "&&") (&;enclosed ["[" "]"] re-user-class^')))] - (wrap (fold (lambda [refinement base] - (` (refine^ (~ refinement) (~ base)))) - init - rest)))) - -(def: #hidden blank^ - (Lexer Char) - (&;one-of " \t")) - -(def: #hidden ascii^ - (Lexer Char) - (&;char-range #"\u0000" #"\u007F")) - -(def: #hidden control^ - (Lexer Char) - (&;either (&;char-range #"\u0000" #"\u001F") - (&;char #"\u007F"))) - -(def: #hidden punct^ - (Lexer Char) - (&;one-of "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~")) - -(def: #hidden graph^ - (Lexer Char) - (&;either punct^ &;alpha-num)) - -(def: #hidden print^ - (Lexer Char) - (&;either graph^ - (&;char #"\u0020"))) - -(def: re-system-class^ - (Lexer AST) - (do Monad - [] - ($_ &;either - (&;_& (&;char #".") (wrap (` (->Text &;any)))) - (&;_& (&;text "\\d") (wrap (` (->Text &;digit)))) - (&;_& (&;text "\\D") (wrap (` (->Text (&;not &;digit))))) - (&;_& (&;text "\\s") (wrap (` (->Text &;space)))) - (&;_& (&;text "\\S") (wrap (` (->Text (&;not &;space))))) - (&;_& (&;text "\\w") (wrap (` (->Text word^)))) - (&;_& (&;text "\\W") (wrap (` (->Text (&;not word^))))) - (&;_& (&;text "\\d") (wrap (` (->Text &;digit)))) - - (&;_& (&;text "\\p{Lower}") (wrap (` (->Text &;lower)))) - (&;_& (&;text "\\p{Upper}") (wrap (` (->Text &;upper)))) - (&;_& (&;text "\\p{Alpha}") (wrap (` (->Text &;alpha)))) - (&;_& (&;text "\\p{Digit}") (wrap (` (->Text &;digit)))) - (&;_& (&;text "\\p{Alnum}") (wrap (` (->Text &;alpha-num)))) - (&;_& (&;text "\\p{Space}") (wrap (` (->Text &;space)))) - (&;_& (&;text "\\p{HexDigit}") (wrap (` (->Text &;hex-digit)))) - (&;_& (&;text "\\p{OctDigit}") (wrap (` (->Text &;oct-digit)))) - (&;_& (&;text "\\p{Blank}") (wrap (` (->Text blank^)))) - (&;_& (&;text "\\p{ASCII}") (wrap (` (->Text ascii^)))) - (&;_& (&;text "\\p{Contrl}") (wrap (` (->Text control^)))) - (&;_& (&;text "\\p{Punct}") (wrap (` (->Text punct^)))) - (&;_& (&;text "\\p{Graph}") (wrap (` (->Text graph^)))) - (&;_& (&;text "\\p{Print}") (wrap (` (->Text print^)))) - ))) - -(def: re-class^ - (Lexer AST) - (&;either re-system-class^ - (&;enclosed ["[" "]"] re-user-class^))) - -(def: int^ - (Lexer Int) - (&;codec number;Codec (&;many' &;digit))) - -(def: re-back-reference^ - (Lexer AST) - (&;either (do Monad - [_ (&;char #"\\") - id int^] - (wrap (` (&;text (~ (ast;symbol ["" (Int/encode id)])))))) - (do Monad - [_ (&;text "\\k<") - captured-name identifier-part^ - _ (&;text ">")] - (wrap (` (&;text (~ (ast;symbol ["" captured-name])))))))) - -(def: (re-simple^ current-module) - (-> Text (Lexer AST)) - ($_ &;either - re-class^ - (re-var^ current-module) - re-back-reference^ - re-char+^ - )) - -(def: (re-simple-quantified^ current-module) - (-> Text (Lexer AST)) - (do Monad - [base (re-simple^ current-module) - quantifier (&;one-of "?*+")] - (case quantifier - #"?" - (wrap (` (&;default "" (~ base)))) - - #"*" - (wrap (` (join-text^ (&;some (~ base))))) - - _ - (wrap (` (join-text^ (&;many (~ base))))) - ))) - -(def: (re-counted-quantified^ current-module) - (-> Text (Lexer AST)) - (do Monad - [base (re-simple^ current-module)] - (&;enclosed ["{" "}"] - ($_ &;either - (do @ - [[from to] (&;seq int^ (&;_& (&;char #",") int^))] - (wrap (` (join-text^ (&;between (~ (ast;nat (int-to-nat from))) - (~ (ast;nat (int-to-nat to))) - (~ base)))))) - (do @ - [limit (&;_& (&;char #",") int^)] - (wrap (` (join-text^ (&;at-most (~ (ast;nat (int-to-nat limit))) (~ base)))))) - (do @ - [limit (&;&_ int^ (&;char #","))] - (wrap (` (join-text^ (&;at-least (~ (ast;nat (int-to-nat limit))) (~ base)))))) - (do @ - [limit int^] - (wrap (` (join-text^ (&;exactly (~ (ast;nat (int-to-nat limit))) (~ base)))))))))) - -(def: (re-quantified^ current-module) - (-> Text (Lexer AST)) - (&;either (re-simple-quantified^ current-module) - (re-counted-quantified^ current-module))) - -(def: (re-complex^ current-module) - (-> Text (Lexer AST)) - ($_ &;either - (re-quantified^ current-module) - (re-simple^ current-module))) - -(def: #hidden _Text/append_ - (-> Text Text Text) - (:: text;Monoid append)) - -(type: Re-Group - #Non-Capturing - (#Capturing [(Maybe Text) Nat])) - -(def: (re-sequential^ capturing? re-scoped^ current-module) - (-> Bool - (-> Text (Lexer [Re-Group AST])) - Text - (Lexer [Nat AST])) - (do Monad - [parts (&;many (&;alt (re-complex^ current-module) - (re-scoped^ current-module))) - #let [g!total (ast;symbol ["" "0total"]) - g!temp (ast;symbol ["" "0temp"]) - [_ names steps] (fold (: (-> (Either AST [Re-Group AST]) - [Int (List AST) (List (List AST))] - [Int (List AST) (List (List AST))]) - (lambda [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 (ast;symbol ["" _name])] - - #;None - [(i.inc idx) (ast;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 AST) (list)) - (: (List (List AST)) (list))] - parts)]] - (wrap [(if capturing? - (list;size names) - +0) - (` (do Monad - [(~ (' #let)) [(~ g!total) ""] - (~@ (|> steps list;reverse List/join))] - ((~ (' wrap)) [(~ g!total) (~@ (list;reverse names))])))]) - )) - -(def: #hidden (unflatten^ lexer) - (-> (Lexer Text) (Lexer [Text Unit])) - (&;seq lexer (:: Monad wrap []))) - -(def: #hidden (|||^ left right) - (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer [Text (| l r)]))) - (lambda [input] - (case (left input) - (#;Right [input' [lt lv]]) - (#;Right [input' [lt (+0 lv)]]) - - (#;Left _) - (case (right input) - (#;Right [input' [rt rv]]) - (#;Right [input' [rt (+1 rv)]]) - - (#;Left error) - (#;Left error))))) - -(def: #hidden (|||_^ left right) - (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer Text))) - (lambda [input] - (case (left input) - (#;Right [input' [lt lv]]) - (#;Right [input' lt]) - - (#;Left _) - (case (right input) - (#;Right [input' [rt rv]]) - (#;Right [input' rt]) - - (#;Left error) - (#;Left error))))) - -(def: (prep-alternative [num-captures alt]) - (-> [Nat AST] AST) - (if (n.> +0 num-captures) - alt - (` (unflatten^ (~ alt))))) - -(def: (re-alternative^ capturing? re-scoped^ current-module) - (-> Bool - (-> Text (Lexer [Re-Group AST])) - Text - (Lexer [Nat AST])) - (do Monad - [#let [sub^ (re-sequential^ capturing? re-scoped^ current-module)] - head sub^ - tail (&;some (&;_& (&;char #"|") 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))))])))) - -(def: (re-scoped^ current-module) - (-> Text (Lexer [Re-Group AST])) - ($_ &;either - (do Monad - [_ (&;text "(?:") - [_ scoped] (re-alternative^ false re-scoped^ current-module) - _ (&;char #")")] - (wrap [#Non-Capturing scoped])) - (do Monad - [complex (re-complex^ current-module)] - (wrap [#Non-Capturing complex])) - (do Monad - [_ (&;text "(?<") - captured-name identifier-part^ - _ (&;text ">") - [num-captures pattern] (re-alternative^ true re-scoped^ current-module) - _ (&;char #")")] - (wrap [(#Capturing [(#;Some captured-name) num-captures]) pattern])) - (do Monad - [_ (&;char #"(") - [num-captures pattern] (re-alternative^ true re-scoped^ current-module) - _ (&;char #")")] - (wrap [(#Capturing [#;None num-captures]) pattern])))) - -(def: (regex^ current-module) - (-> Text (Lexer AST)) - (:: Monad map product;right (re-alternative^ true re-scoped^ current-module))) - -## [Syntax] -(syntax: #export (regex [pattern s;text]) - {#;doc (doc "Create lexers using regular-expression syntax." - "For example:" - - "Literals" - (regex "a") - - "Wildcards" - (regex ".") - - "Escaping" - (regex "\\.") - - "Character classes" - (regex "\\d") - (regex "\\p{Lower}") - (regex "[abc]") - (regex "[a-z]") - (regex "[a-zA-Z]") - (regex "[a-z&&[def]]") - - "Negation" - (regex "[^abc]") - (regex "[^a-z]") - (regex "[^a-zA-Z]") - (regex "[a-z&&[^bc]]") - (regex "[a-z&&[^m-p]]") - - "Combinations" - (regex "aa") - (regex "a?") - (regex "a*") - (regex "a+") - - "Specific amounts" - (regex "a{2}") - - "At least" - (regex "a{1,}") - - "At most" - (regex "a{,1}") - - "Between" - (regex "a{1,2}") - - "Groups" - (regex "a(.)c") - (regex "a(b+)c") - (regex "(\\d{3})-(\\d{3})-(\\d{4})") - (regex "(\\d{3})-(?:\\d{3})-(\\d{4})") - (regex "(?\\d{3})-\\k-(\\d{4})") - (regex "(?\\d{3})-\\k-(\\d{4})-\\0") - (regex "(\\d{3})-((\\d{3})-(\\d{4}))") - - "Alternation" - (regex "a|b") - (regex "a(.)(.)|b(.)(.)") - )} - (do @ - [current-module compiler;current-module-name] - (case (&;run pattern - (&;&_ (regex^ current-module) &;end)) - (#;Left error) - (compiler;fail error) - - (#;Right regex) - (wrap (list regex)) - ))) - -(syntax: #export (^regex [[pattern bindings] (s;form (s;seq s;text (s;opt s;any)))] - body - [branches (s;many s;any)]) - {#;doc (doc "Allows you to test text against regular expressions." - (case some-text - (^regex "(\\d{3})-(\\d{3})-(\\d{4})" - [_ country-code area-code place-code]) - do-some-thing-when-number - - (^regex "\\w+") - do-some-thing-when-word - - _ - do-something-else))} - (do @ - [g!temp (compiler;gensym "temp")] - (wrap (list& (` (^=> (~ g!temp) - [(&;run (~ g!temp) (regex (~ (ast;text pattern)))) - (#;Right (~ (default g!temp - bindings)))])) - body - branches)))) diff --git a/stdlib/source/lux/pipe.lux b/stdlib/source/lux/pipe.lux deleted file mode 100644 index cfb05491d..000000000 --- a/stdlib/source/lux/pipe.lux +++ /dev/null @@ -1,146 +0,0 @@ -(;module: {#;doc "Composable extensions to the piping macro |> that enhance it with various abilities."} - lux - (lux (control monad) - (data (coll [list #+ Monad "" Fold "List/" Monad]) - maybe) - [compiler #+ with-gensyms Monad] - (macro ["s" syntax #+ syntax: Syntax] - [ast]) - )) - -## [Syntax] -(def: body^ - (Syntax (List AST)) - (s;tuple (s;many s;any))) - -(syntax: #export (_> [tokens (s;at-least +2 s;any)]) - {#;doc (doc "Ignores the piped argument, and begins a new pipe." - (|> 20 - (i.* 3) - (i.+ 4) - (_> 0 i.inc)))} - (case (list;reverse tokens) - (^ (list& _ r-body)) - (wrap (list (` (|> (~@ (list;reverse r-body)))))) - - _ - (undefined))) - -(syntax: #export (@> [name (s;default "@" s;local-symbol)] - [body body^] - prev) - {#;doc (doc "Gives a name to the piped-argument, within the given expression." - "If given no name, defaults to '@'." - (|> 5 - (@> X [(i.+ X X)])) - - (|> 5 - (@> [(i.+ @ @)])))} - (wrap (list (fold (lambda [next prev] - (` (let% [(~ (ast;symbol ["" name])) (~ prev)] - (~ next)))) - prev - body)))) - -(syntax: #export (?> [branches (s;many (s;seq body^ body^))] - [?else (s;opt body^)] - prev) - {#;doc (doc "Branching for pipes." - "Both the tests and the bodies are piped-code, and must be given inside a tuple." - "If a last else-pipe isn't given, the piped-argument will be used instead." - (|> 5 - (?> [i.even?] [(i.* 2)] - [i.odd?] [(i.* 3)] - [(_> -1)])))} - (with-gensyms [g!temp] - (wrap (list (` (let% [(~ g!temp) (~ prev)] - (cond (~@ (do Monad - [[test then] branches] - (list (` (|> (~ g!temp) (~@ test))) - (` (|> (~ g!temp) (~@ then)))))) - (~ (case ?else - (#;Some else) - (` (|> (~ g!temp) (~@ else))) - - _ - g!temp))))))))) - -(syntax: #export (!> [test body^] [then body^] prev) - {#;doc (doc "Loops for pipes." - "Both the testing and calculating steps are pipes and must be given inside tuples." - (|> 1 - (!> [(i.< 10)] - [i.inc])))} - (with-gensyms [g!temp] - (wrap (list (` (loop [(~ g!temp) (~ prev)] - (if (|> (~ g!temp) (~@ test)) - ((~' recur) (|> (~ g!temp) (~@ then))) - (~ g!temp)))))))) - -(syntax: #export (%> monad [steps (s;some body^)] prev) - {#;doc (doc "Monadic pipes." - "Each steps in the monadic computation is a pipe and must be given inside a tuple." - (|> 5 - (%> Id/Monad - [(i.* 3)] - [(i.+ 4)] - [i.inc])))} - (with-gensyms [g!temp] - (case (list;reverse steps) - (^ (list& last-step prev-steps)) - (let [step-bindings (do Monad - [step (list;reverse prev-steps)] - (list g!temp (` (|> (~ g!temp) (~@ step)))))] - (wrap (list (` (do (~ monad) - [(~ g!temp) (~ prev) - (~@ step-bindings)] - (|> (~ g!temp) (~@ last-step))))))) - - _ - (wrap (list prev))))) - -(syntax: #export (~> [body body^] prev) - {#;doc (doc "Non-updating pipes." - "Will generate piped computations, but their results won't be used in the larger scope." - (|> 5 - (~> [int-to-nat %n log!]) - (i.* 10)))} - (do @ - [g!temp (compiler;gensym "")] - (wrap (list (` (let [(~ g!temp) (~ prev)] - (exec (|> (~ g!temp) (~@ body)) - (~ g!temp)))))))) - -(syntax: #export (&> [paths (s;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 - (&> [(i.* 10)] - [i.dec (i./ 2)] - [Int/encode])) - "Will become: [50 2 \"5\"]")} - (do @ - [g!temp (compiler;gensym "")] - (wrap (list (` (let [(~ g!temp) (~ prev)] - [(~@ (List/map (lambda [body] (` (|> (~ g!temp) (~@ body)))) - paths))])))))) - -(syntax: #export (case> [branches (s;many (s;seq s;any s;any))] prev) - {#;doc (doc "Pattern-matching for pipes." - "The bodies of each branch are NOT pipes; just regular values." - (|> 5 - (case> 0 "zero" - 1 "one" - 2 "two" - 3 "three" - 4 "four" - 5 "five" - 6 "six" - 7 "seven" - 8 "eight" - 9 "nine" - _ "???")))} - (let [(^open "List/") Monad] - (wrap (list (` (case (~ prev) - (~@ (List/join (List/map (lambda [[pattern body]] (list pattern body)) - branches))))))))) diff --git a/stdlib/source/lux/type/auto.lux b/stdlib/source/lux/type/auto.lux index fa658ffb8..7059536c3 100644 --- a/stdlib/source/lux/type/auto.lux +++ b/stdlib/source/lux/type/auto.lux @@ -278,11 +278,7 @@ (list [alt-name =deps])))) List/join) #;Nil - (compiler;fail (format "No alternatives." - "\n" - (|> alts - (List/map product;left) - (%list %ident)))) + (compiler;fail (format "No alternatives for " (%type (type;function input-types output-type)))) found (wrap found)))) @@ -339,7 +335,7 @@ (::: = (list;n.range +1 +10) (list;n.range +1 +10)) - "Functor map" + "(Functor List) map" (::: map n.inc (list;n.range +0 +9)) "Caveat emptor: You need to make sure to import the module of any structure you want to use." "Otherwise, this macro won't find it.")} @@ -363,8 +359,8 @@ (compiler;fail (format "Too many options available: " (|> chosen-ones (List/map (. %ident product;left)) - (text;join-with ", ") - ))))) + (text;join-with ", ")) + " --- for type: " (%type sig-type))))) (#;Right [args _]) (do @ diff --git a/stdlib/test/test/lux/cli.lux b/stdlib/test/test/lux/cli.lux index 8393d459b..b8ed6ca0c 100644 --- a/stdlib/test/test/lux/cli.lux +++ b/stdlib/test/test/lux/cli.lux @@ -1,7 +1,8 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data text/format [text "Text/" Eq] [number] @@ -9,8 +10,7 @@ [sum] (coll [list])) ["&" cli] - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (test: "CLI" diff --git a/stdlib/test/test/lux/concurrency/atom.lux b/stdlib/test/test/lux/concurrency/atom.lux index 9b6248ec8..84deafa07 100644 --- a/stdlib/test/test/lux/concurrency/atom.lux +++ b/stdlib/test/test/lux/concurrency/atom.lux @@ -6,8 +6,7 @@ (coll [list "" Functor]) text/format) (concurrency ["&" atom]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (test: "Atoms" diff --git a/stdlib/test/test/lux/concurrency/promise.lux b/stdlib/test/test/lux/concurrency/promise.lux index a054e5a96..7ad25fc46 100644 --- a/stdlib/test/test/lux/concurrency/promise.lux +++ b/stdlib/test/test/lux/concurrency/promise.lux @@ -1,13 +1,13 @@ (;module: lux (lux [io #- run] - (control monad) + (control monad + pipe) (data [number] text/format [error #- fail]) (concurrency ["&" promise]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (test: "Promises" diff --git a/stdlib/test/test/lux/concurrency/stm.lux b/stdlib/test/test/lux/concurrency/stm.lux index d48d20a9d..d6b6c1d43 100644 --- a/stdlib/test/test/lux/concurrency/stm.lux +++ b/stdlib/test/test/lux/concurrency/stm.lux @@ -7,8 +7,7 @@ text/format) (concurrency ["&" stm] [promise]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: iterations/processes Int 100) diff --git a/stdlib/test/test/lux/control/effect.lux b/stdlib/test/test/lux/control/effect.lux index 59fc116dc..39e5afa5d 100644 --- a/stdlib/test/test/lux/control/effect.lux +++ b/stdlib/test/test/lux/control/effect.lux @@ -7,8 +7,7 @@ (data [text] text/format) [macro] - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (do-template [ ] diff --git a/stdlib/test/test/lux/control/interval.lux b/stdlib/test/test/lux/control/interval.lux index 2127ff6df..b4c48a541 100644 --- a/stdlib/test/test/lux/control/interval.lux +++ b/stdlib/test/test/lux/control/interval.lux @@ -2,14 +2,14 @@ lux lux/test (lux (control monad + pipe ["&" interval]) [io] ["R" math/random] (data text/format [number] ["S" coll/set] - ["L" coll/list]) - pipe)) + ["L" coll/list]))) (test: "Equality." [bottom R;int diff --git a/stdlib/test/test/lux/control/pipe.lux b/stdlib/test/test/lux/control/pipe.lux new file mode 100644 index 000000000..4687a5635 --- /dev/null +++ b/stdlib/test/test/lux/control/pipe.lux @@ -0,0 +1,74 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data text/format + [number] + [product] + identity + [text "T/" Eq]) + ["R" math/random]) + lux/test) + +(test: "Pipes" + ($_ seq + (assert "Can dismiss previous pipeline results and begin a new line." + (|> 20 + (i.* 3) + (i.+ 4) + (_> 0 i.inc) + (i.= 1))) + + (assert "Can give names to piped values within a pipeline's scope." + (and (|> 5 + (@> [(i.+ @ @)]) + (i.= 10)) + (|> 5 + (@> X [(i.+ X X)]) + (i.= 10)))) + + (assert "Can do branching in pipelines." + (and (|> 5 + (?> [i.even?] [(i.* 2)] + [i.odd?] [(i.* 3)] + [(_> -1)]) + (i.= 15)) + (|> 4 + (?> [i.even?] [(i.* 2)] + [i.odd?] [(i.* 3)]) + (i.= 8)) + (|> 5 + (?> [i.even?] [(i.* 2)] + [(_> -1)]) + (i.= -1)))) + + (assert "Can loop within pipelines." + (|> 1 + (!> [(i.< 10)] + [i.inc]) + (i.= 10))) + + (assert "Can use monads within pipelines." + (|> 5 + (%> Monad + [(i.* 3)] + [(i.+ 4)] + [i.inc]) + (i.= 20))) + + (assert "Can pattern-match against piped values." + (|> 5 + (case> 0 "zero" + 1 "one" + 2 "two" + 3 "three" + 4 "four" + 5 "five" + 6 "six" + 7 "seven" + 8 "eight" + 9 "nine" + _ "???") + (T/= "five"))) + )) diff --git a/stdlib/test/test/lux/data/char.lux b/stdlib/test/test/lux/data/char.lux index 5025a1283..dd3c0c2da 100644 --- a/stdlib/test/test/lux/data/char.lux +++ b/stdlib/test/test/lux/data/char.lux @@ -1,12 +1,12 @@ (;module: lux - (lux (control [monad]) + (lux (control [monad] + pipe) [io] (data char [text] text/format) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (test: "Char operations" diff --git a/stdlib/test/test/lux/data/coll/array.lux b/stdlib/test/test/lux/data/coll/array.lux index b5003f703..f7d09ae9a 100644 --- a/stdlib/test/test/lux/data/coll/array.lux +++ b/stdlib/test/test/lux/data/coll/array.lux @@ -1,12 +1,12 @@ (;module: lux - (lux (control [monad]) + (lux (control [monad] + pipe) [io] (data (coll ["&" array] [list]) [number]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: bounded-size diff --git a/stdlib/test/test/lux/data/coll/dict.lux b/stdlib/test/test/lux/data/coll/dict.lux index 3df06abcf..34e99cf58 100644 --- a/stdlib/test/test/lux/data/coll/dict.lux +++ b/stdlib/test/test/lux/data/coll/dict.lux @@ -9,8 +9,7 @@ [char] (coll ["&" dict] [list "List/" Fold Functor])) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (test: "Dictionaries." diff --git a/stdlib/test/test/lux/data/coll/list.lux b/stdlib/test/test/lux/data/coll/list.lux index fe381340d..bd6f78015 100644 --- a/stdlib/test/test/lux/data/coll/list.lux +++ b/stdlib/test/test/lux/data/coll/list.lux @@ -1,14 +1,14 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data (coll ["&" list]) [text "Text/" Monoid] [number] [bool] [product]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: bounded-size diff --git a/stdlib/test/test/lux/data/coll/ordered.lux b/stdlib/test/test/lux/data/coll/ordered.lux index ffc2bf309..c1f5c9944 100644 --- a/stdlib/test/test/lux/data/coll/ordered.lux +++ b/stdlib/test/test/lux/data/coll/ordered.lux @@ -7,8 +7,7 @@ [list "" Fold]) [number] text/format) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: gen-nat diff --git a/stdlib/test/test/lux/data/coll/priority-queue.lux b/stdlib/test/test/lux/data/coll/priority-queue.lux index de885f1ee..3e28334db 100644 --- a/stdlib/test/test/lux/data/coll/priority-queue.lux +++ b/stdlib/test/test/lux/data/coll/priority-queue.lux @@ -4,8 +4,7 @@ (control monad) (data (coll ["&" priority-queue]) [number]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: (gen-queue size) diff --git a/stdlib/test/test/lux/data/coll/queue.lux b/stdlib/test/test/lux/data/coll/queue.lux index fac5cef12..44123f8e3 100644 --- a/stdlib/test/test/lux/data/coll/queue.lux +++ b/stdlib/test/test/lux/data/coll/queue.lux @@ -4,8 +4,7 @@ (control monad) (data (coll ["&" queue]) [number]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (test: "Queues" diff --git a/stdlib/test/test/lux/data/coll/seq.lux b/stdlib/test/test/lux/data/coll/seq.lux index 5fe3a5af1..a111ecb0e 100644 --- a/stdlib/test/test/lux/data/coll/seq.lux +++ b/stdlib/test/test/lux/data/coll/seq.lux @@ -1,7 +1,8 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data (coll ["&" seq] ["F" tree/finger] ["L" list]) @@ -10,8 +11,7 @@ [bool] [product] maybe) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: bounded-size diff --git a/stdlib/test/test/lux/data/coll/set.lux b/stdlib/test/test/lux/data/coll/set.lux index 2a4f05bb1..a91813675 100644 --- a/stdlib/test/test/lux/data/coll/set.lux +++ b/stdlib/test/test/lux/data/coll/set.lux @@ -5,8 +5,7 @@ (data (coll ["&" set] [list "" Fold]) [number]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: gen-nat diff --git a/stdlib/test/test/lux/data/coll/stack.lux b/stdlib/test/test/lux/data/coll/stack.lux index 4c44cbf06..6d26c569d 100644 --- a/stdlib/test/test/lux/data/coll/stack.lux +++ b/stdlib/test/test/lux/data/coll/stack.lux @@ -5,8 +5,7 @@ (data (coll ["&" stack] [list "" Fold]) [number]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: gen-nat diff --git a/stdlib/test/test/lux/data/coll/stream.lux b/stdlib/test/test/lux/data/coll/stream.lux index 2be6aa054..2ee3013e2 100644 --- a/stdlib/test/test/lux/data/coll/stream.lux +++ b/stdlib/test/test/lux/data/coll/stream.lux @@ -9,8 +9,7 @@ ["&" stream]) [number "Nat/" Codec]) (function [cont]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (test: "Streams" diff --git a/stdlib/test/test/lux/data/coll/tree/rose.lux b/stdlib/test/test/lux/data/coll/tree/rose.lux index ef43fae44..a4839c2a5 100644 --- a/stdlib/test/test/lux/data/coll/tree/rose.lux +++ b/stdlib/test/test/lux/data/coll/tree/rose.lux @@ -5,8 +5,7 @@ (data (coll (tree ["&" rose]) [list "List/" Monad]) [number]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: gen-nat diff --git a/stdlib/test/test/lux/data/coll/tree/zipper.lux b/stdlib/test/test/lux/data/coll/tree/zipper.lux index ed0318cfe..143229dc5 100644 --- a/stdlib/test/test/lux/data/coll/tree/zipper.lux +++ b/stdlib/test/test/lux/data/coll/tree/zipper.lux @@ -1,15 +1,15 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data (coll [list "List/" Fold Functor] (tree ["&" zipper] [rose])) [text "Text/" Monoid] text/format [number]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: gen-tree diff --git a/stdlib/test/test/lux/data/coll/vector.lux b/stdlib/test/test/lux/data/coll/vector.lux index 735374c5c..6ad6934db 100644 --- a/stdlib/test/test/lux/data/coll/vector.lux +++ b/stdlib/test/test/lux/data/coll/vector.lux @@ -7,12 +7,11 @@ [text "Text/" Monoid] text/format [number]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (test: "Vectors" - [size (|> R;nat (:: @ map (n.% +100))) + [size (|> R;nat (:: @ map (|>. (n.% +100) (n.max +1)))) idx (|> R;nat (:: @ map (n.% size))) sample (R;vector size R;nat) other-sample (R;vector size R;nat) diff --git a/stdlib/test/test/lux/data/error.lux b/stdlib/test/test/lux/data/error.lux index 34f505142..d90387c89 100644 --- a/stdlib/test/test/lux/data/error.lux +++ b/stdlib/test/test/lux/data/error.lux @@ -1,10 +1,10 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data text/format - ["&" error]) - pipe) + ["&" error])) lux/test) (test: "Errors" diff --git a/stdlib/test/test/lux/data/error/exception.lux b/stdlib/test/test/lux/data/error/exception.lux index 41d01077e..bc84df7f5 100644 --- a/stdlib/test/test/lux/data/error/exception.lux +++ b/stdlib/test/test/lux/data/error/exception.lux @@ -7,8 +7,7 @@ [text] text/format [number]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (exception: Some-Exception) diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index ad70d5c0e..37fe49786 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -3,7 +3,8 @@ (lux [io] (control monad codec - eq) + eq + pipe) (data [text "Text/" Monoid] text/format [error #- fail] @@ -21,7 +22,6 @@ [syntax #+ syntax:] [poly #+ derived:]) ["R" math/random] - pipe test) ) diff --git a/stdlib/test/test/lux/data/ident.lux b/stdlib/test/test/lux/data/ident.lux index f88693003..07aaf8d0a 100644 --- a/stdlib/test/test/lux/data/ident.lux +++ b/stdlib/test/test/lux/data/ident.lux @@ -1,12 +1,12 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data ["&" ident] [text "Text/" Eq] text/format) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: (gen-part size) diff --git a/stdlib/test/test/lux/data/log.lux b/stdlib/test/test/lux/data/log.lux index 40a124490..ea174fc6b 100644 --- a/stdlib/test/test/lux/data/log.lux +++ b/stdlib/test/test/lux/data/log.lux @@ -1,12 +1,12 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data ["&" log] [text "Text/" Monoid Eq] [number] - [product]) - pipe) + [product])) lux/test) (test: "Logs" diff --git a/stdlib/test/test/lux/data/maybe.lux b/stdlib/test/test/lux/data/maybe.lux index 07961a6d0..8cfb4c38f 100644 --- a/stdlib/test/test/lux/data/maybe.lux +++ b/stdlib/test/test/lux/data/maybe.lux @@ -1,11 +1,11 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data ["&" maybe] [text "Text/" Monoid] - [number]) - pipe) + [number])) lux/test) (test: "Maybe" diff --git a/stdlib/test/test/lux/data/number.lux b/stdlib/test/test/lux/data/number.lux index ad89649ba..eefbd584b 100644 --- a/stdlib/test/test/lux/data/number.lux +++ b/stdlib/test/test/lux/data/number.lux @@ -1,12 +1,12 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data number [text "Text/" Monoid Eq] text/format) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (do-template [category rand-gen ] diff --git a/stdlib/test/test/lux/data/number/complex.lux b/stdlib/test/test/lux/data/number/complex.lux index 8ed27680c..9555c031e 100644 --- a/stdlib/test/test/lux/data/number/complex.lux +++ b/stdlib/test/test/lux/data/number/complex.lux @@ -1,7 +1,8 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data [text "Text/" Monoid] text/format [bool "b/" Eq] @@ -10,8 +11,7 @@ (coll [list "List/" Fold Functor]) [product]) [math] - ["R" math/random] - pipe) + ["R" math/random]) lux/test) ## Based on org.apache.commons.math4.complex.Complex diff --git a/stdlib/test/test/lux/data/number/ratio.lux b/stdlib/test/test/lux/data/number/ratio.lux index c1f7e104f..7ae36e573 100644 --- a/stdlib/test/test/lux/data/number/ratio.lux +++ b/stdlib/test/test/lux/data/number/ratio.lux @@ -1,7 +1,8 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data [text "Text/" Monoid] text/format [bool "b/" Eq] @@ -9,8 +10,7 @@ ["&" number/ratio "&/" Number] (coll [list "List/" Fold Functor]) [product]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (def: gen-part diff --git a/stdlib/test/test/lux/data/sum.lux b/stdlib/test/test/lux/data/sum.lux index 8ab124c1b..389ff1b9e 100644 --- a/stdlib/test/test/lux/data/sum.lux +++ b/stdlib/test/test/lux/data/sum.lux @@ -1,12 +1,12 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data sum [text "Text/" Monoid] [number] - (coll [list])) - pipe) + (coll [list]))) lux/test) (test: "Sum operations" diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux index 4563d9b12..f306778ba 100644 --- a/stdlib/test/test/lux/data/text.lux +++ b/stdlib/test/test/lux/data/text.lux @@ -1,14 +1,14 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data ["&" text] [char] text/format [number] (coll [list])) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (test: "Size" diff --git a/stdlib/test/test/lux/data/text/lexer.lux b/stdlib/test/test/lux/data/text/lexer.lux new file mode 100644 index 000000000..92aeca0d8 --- /dev/null +++ b/stdlib/test/test/lux/data/text/lexer.lux @@ -0,0 +1,315 @@ +(;module: + lux + (lux (control monad + pipe) + [io] + (data [error #- fail] + [text "T/" Eq] + text/format + ["&" text/lexer] + [char "C/" Eq] + (coll [list])) + ["R" math/random]) + lux/test) + +## [Utils] +(def: (should-fail input) + (All [a] (-> (Error a) Bool)) + (case input + (#;Left _) true + _ false)) + +(def: (should-passC test input) + (-> Char (Error Char) Bool) + (case input + (#;Right output) + (C/= test output) + + _ + false)) + +(def: (should-passT test input) + (-> Text (Error Text) Bool) + (case input + (#;Right output) + (T/= test output) + + _ + false)) + +(def: (should-passL test input) + (-> (List Char) (Error (List Char)) Bool) + (let [(^open "L/") (list;Eq char;Eq)] + (case input + (#;Right output) + (L/= test output) + + _ + false))) + +(def: (should-passE test input) + (-> (Either Char Char) (Error (Either Char Char)) Bool) + (case input + (#;Right output) + (case [test output] + [(#;Left test) (#;Left output)] + (C/= test output) + + [(#;Right test) (#;Right output)] + (C/= test output) + + _ + false) + + _ + false)) + +## [Tests] +(test: "End" + ($_ seq + (assert "Can detect the end of the input." + (|> (&;run "" + &;end) + (case> (#;Right _) true _ false))) + + (assert "Won't mistake non-empty text for no more input." + (|> (&;run "YOLO" + &;end) + (case> (#;Left _) true _ false))) + )) + +(test: "Literals" + [size (|> R;nat (:: @ map (|>. (n.% +100) (n.max +10)))) + pre (R;text size) + post (|> (R;text size) + (R;filter (|>. (text;starts-with? pre) not)))] + ($_ seq + (assert "Can find literal text fragments." + (and (|> (&;run (format pre post) + (&;text pre)) + (case> (#;Right found) (T/= pre found) _ false)) + (|> (&;run post + (&;text pre)) + (case> (#;Left _) true _ false)))) + )) + +(test: "Char lexers" + ($_ seq + (assert "Can lex characters." + (and (|> (&;run "YOLO" + (&;char #"Y")) + (case> (#;Right #"Y") true _ false)) + (|> (&;run "MEME" + (&;char #"Y")) + (case> (#;Left _) true _ false)))) + + (assert "Can lex characters ranges." + (and (should-passC #"Y" (&;run "YOLO" + (&;char-range #"X" #"Z"))) + (should-fail (&;run "MEME" + (&;char-range #"X" #"Z"))))) + )) + +(test: "Custom lexers" + ($_ seq + (assert "Can lex anything" + (and (should-passC #"A" (&;run "A" + &;any)) + (should-fail (&;run "" + &;any)))) + + (assert "Can lex upper-case and &;lower-case letters." + (and (should-passC #"Y" (&;run "YOLO" + &;upper)) + (should-fail (&;run "meme" + &;upper)) + + (should-passC #"y" (&;run "yolo" + &;lower)) + (should-fail (&;run "MEME" + &;lower)))) + + (assert "Can lex numbers." + (and (should-passC #"1" (&;run "1" + &;digit)) + (should-fail (&;run " " + &;digit)) + + (should-passC #"7" (&;run "7" + &;oct-digit)) + (should-fail (&;run "8" + &;oct-digit)) + + (should-passC #"1" (&;run "1" + &;hex-digit)) + (should-passC #"a" (&;run "a" + &;hex-digit)) + (should-passC #"A" (&;run "A" + &;hex-digit)) + (should-fail (&;run " " + &;hex-digit)) + )) + + (assert "Can lex alphabetic characters." + (and (should-passC #"A" (&;run "A" + &;alpha)) + (should-passC #"a" (&;run "a" + &;alpha)) + (should-fail (&;run "1" + &;alpha)))) + + (assert "Can lex alphanumeric characters." + (and (should-passC #"A" (&;run "A" + &;alpha-num)) + (should-passC #"a" (&;run "a" + &;alpha-num)) + (should-passC #"1" (&;run "1" + &;alpha-num)) + (should-fail (&;run " " + &;alpha-num)))) + + (assert "Can lex white-space." + (and (should-passC #" " (&;run " " + &;space)) + (should-fail (&;run "8" + &;space)))) + )) + +(test: "Combinators" + ($_ seq + (assert "Can combine lexers sequentially." + (and (|> (&;run "YOLO" + (&;seq &;any &;any)) + (case> (#;Right [#"Y" #"O"]) true + _ false)) + (should-fail (&;run "Y" + (&;seq &;any &;any))))) + + (assert "Can combine lexers alternatively." + (and (should-passE (#;Left #"0") (&;run "0" + (&;alt &;digit &;upper))) + (should-passE (#;Right #"A") (&;run "A" + (&;alt &;digit &;upper))) + (should-fail (&;run "a" + (&;alt &;digit &;upper))))) + + (assert "Can create the opposite of a lexer." + (and (should-passC #"a" (&;run "a" + (&;not (&;alt &;digit &;upper)))) + (should-fail (&;run "A" + (&;not (&;alt &;digit &;upper)))))) + + (assert "Can use either lexer." + (and (should-passC #"0" (&;run "0" + (&;either &;digit &;upper))) + (should-passC #"A" (&;run "A" + (&;either &;digit &;upper))) + (should-fail (&;run "a" + (&;either &;digit &;upper))))) + + (assert "Can select from among a set of characters." + (and (should-passC #"C" (&;run "C" + (&;one-of "ABC"))) + (should-fail (&;run "D" + (&;one-of "ABC"))))) + + (assert "Can avoid a set of characters." + (and (should-passC #"D" (&;run "D" + (&;none-of "ABC"))) + (should-fail (&;run "C" + (&;none-of "ABC"))))) + + (assert "Can lex using arbitrary predicates." + (and (should-passC #"D" (&;run "D" + (&;satisfies (lambda [c] true)))) + (should-fail (&;run "C" + (&;satisfies (lambda [c] false)))))) + + (assert "Can apply a lexer multiple times." + (and (should-passT "0123456789ABCDEF" (&;run "0123456789ABCDEF yolo" + (&;many' &;hex-digit))) + (should-fail (&;run "yolo" + (&;many' &;hex-digit))) + + (should-passT "" (&;run "yolo" + (&;some' &;hex-digit))))) + )) + +(test: "Yet more combinators..." + ($_ seq + (assert "Can fail at will." + (should-fail (&;run "yolo" + (&;fail "Well, it really SHOULD fail...")))) + + (assert "Can make assertions." + (and (should-fail (&;run "yolo" + (&;assert "Well, it really SHOULD fail..." false))) + (|> (&;run "yolo" + (&;assert "GO, GO, GO!" true)) + (case> (#;Right []) true + _ false)))) + + (assert "Can apply a lexer multiple times." + (and (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") + (&;run "0123456789ABCDEF yolo" + (&;many &;hex-digit))) + (should-fail (&;run "yolo" + (&;many &;hex-digit))) + + (should-passL (list) + (&;run "yolo" + (&;some &;hex-digit))))) + + (assert "Can lex exactly N elements." + (and (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") + (&;run "0123456789ABCDEF yolo" + (&;exactly +16 &;hex-digit))) + (should-passL (list #"0" #"1" #"2") + (&;run "0123456789ABCDEF yolo" + (&;exactly +3 &;hex-digit))) + (should-fail (&;run "0123456789ABCDEF yolo" + (&;exactly +17 &;hex-digit))))) + + (assert "Can lex at-most N elements." + (and (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") + (&;run "0123456789ABCDEF yolo" + (&;at-most +16 &;hex-digit))) + (should-passL (list #"0" #"1" #"2") + (&;run "0123456789ABCDEF yolo" + (&;at-most +3 &;hex-digit))) + (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") + (&;run "0123456789ABCDEF yolo" + (&;at-most +17 &;hex-digit))))) + + (assert "Can lex tokens between lower and upper boundaries of quantity." + (and (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") + (&;run "0123456789ABCDEF yolo" + (&;between +0 +16 &;hex-digit))) + (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") + (&;run "0123456789ABCDEF yolo" + (&;between +3 +16 &;hex-digit))) + (should-fail (&;run "0123456789ABCDEF yolo" + (&;between +17 +100 &;hex-digit))) + (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") + (&;run "0123456789ABCDEF yolo" + (&;between +15 +20 &;hex-digit))))) + + (assert "Can optionally lex a token." + (and (|> (&;run "123abc" + (&;opt &;hex-digit)) + (case> (#;Right (#;Some #"1")) true + _ false)) + (|> (&;run "yolo" + (&;opt &;hex-digit)) + (case> (#;Right #;None) true + _ false)))) + + (assert "Can take into account separators during lexing." + (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"a" #"b" #"c" #"d" #"e" #"f") + (&;run "0 1 2 3 4 5 6 7 8 9 a b c d e f YOLO" + (&;sep-by &;space &;hex-digit)))) + + (assert "Can obtain the whole of the remaining input." + (should-passT "yolo" (&;run "yolo" + &;get-input))) + )) diff --git a/stdlib/test/test/lux/data/text/regex.lux b/stdlib/test/test/lux/data/text/regex.lux new file mode 100644 index 000000000..e737d5ee4 --- /dev/null +++ b/stdlib/test/test/lux/data/text/regex.lux @@ -0,0 +1,285 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data [error #- fail] + [product] + [text "T/" Eq] + text/format + (text [lexer] + ["&" regex])) + [compiler] + (macro [ast] + ["s" syntax #+ syntax:]) + ["R" math/random]) + lux/test) + +## [Utils] +(def: (should-pass regex input) + (-> (lexer;Lexer Text) Text Bool) + (|> (lexer;run input regex) + (case> (#;Right parsed) + (T/= parsed input) + + _ + false))) + +(def: (should-passT test regex input) + (-> Text (lexer;Lexer Text) Text Bool) + (|> (lexer;run input regex) + (case> (#;Right parsed) + (T/= test parsed) + + _ + false))) + +(def: (should-fail regex input) + (All [a] (-> (lexer;Lexer a) Text Bool)) + (|> (lexer;run input regex) + (case> (#;Left _) true _ false))) + +(syntax: (should-check pattern regex input) + (wrap (list (` (|> (lexer;run (~ input) (~ regex)) + (case> (^ (#;Right (~ pattern))) + true + + (~' _) + false)))))) + +## [Tests] +(test: "Regular Expressions [Basics]" + (assert "Can parse character literals." + (and (should-pass (&;regex "a") "a") + (should-fail (&;regex "a") ".") + (should-pass (&;regex "\\.") ".") + (should-fail (&;regex "\\.") "a")))) + +(test: "Regular Expressions [System character classes]" + ($_ seq + (assert "Can parse anything." + (should-pass (&;regex ".") "a")) + + (assert "Can parse digits." + (and (should-pass (&;regex "\\d") "0") + (should-fail (&;regex "\\d") "m"))) + + (assert "Can parse non digits." + (and (should-pass (&;regex "\\D") "m") + (should-fail (&;regex "\\D") "0"))) + + (assert "Can parse white-space." + (and (should-pass (&;regex "\\s") " ") + (should-fail (&;regex "\\s") "m"))) + + (assert "Can parse non white-space." + (and (should-pass (&;regex "\\S") "m") + (should-fail (&;regex "\\S") " "))) + + (assert "Can parse word characters." + (and (should-pass (&;regex "\\w") "_") + (should-fail (&;regex "\\w") "^"))) + + (assert "Can parse non word characters." + (and (should-pass (&;regex "\\W") ".") + (should-fail (&;regex "\\W") "a"))) + )) + +(test: "Regular Expressions [Special system character classes : Part 1]" + ($_ seq + (assert "Can parse using special character classes." + (and (and (should-pass (&;regex "\\p{Lower}") "m") + (should-fail (&;regex "\\p{Lower}") "M")) + + (and (should-pass (&;regex "\\p{Upper}") "M") + (should-fail (&;regex "\\p{Upper}") "m")) + + (and (should-pass (&;regex "\\p{Alpha}") "M") + (should-fail (&;regex "\\p{Alpha}") "0")) + + (and (should-pass (&;regex "\\p{Digit}") "1") + (should-fail (&;regex "\\p{Digit}") "n")) + + (and (should-pass (&;regex "\\p{Alnum}") "1") + (should-fail (&;regex "\\p{Alnum}") ".")) + + (and (should-pass (&;regex "\\p{Space}") " ") + (should-fail (&;regex "\\p{Space}") ".")) + )) + )) + +(test: "Regular Expressions [Special system character classes : Part 2]" + ($_ seq + (assert "Can parse using special character classes." + (and (and (should-pass (&;regex "\\p{HexDigit}") "a") + (should-fail (&;regex "\\p{HexDigit}") ".")) + + (and (should-pass (&;regex "\\p{OctDigit}") "6") + (should-fail (&;regex "\\p{OctDigit}") ".")) + + (and (should-pass (&;regex "\\p{Blank}") "\t") + (should-fail (&;regex "\\p{Blank}") ".")) + + (and (should-pass (&;regex "\\p{ASCII}") "\t") + (should-fail (&;regex "\\p{ASCII}") "\u1234")) + + (and (should-pass (&;regex "\\p{Contrl}") "\u0012") + (should-fail (&;regex "\\p{Contrl}") "a")) + + (and (should-pass (&;regex "\\p{Punct}") "@") + (should-fail (&;regex "\\p{Punct}") "a")) + + (and (should-pass (&;regex "\\p{Graph}") "@") + (should-fail (&;regex "\\p{Graph}") " ")) + + (and (should-pass (&;regex "\\p{Print}") "\u0020") + (should-fail (&;regex "\\p{Print}") "\u1234")) + )) + )) + +(test: "Regular Expressions [Custom character classes : Part 1]" + ($_ seq + (assert "Can parse using custom character classes." + (and (should-pass (&;regex "[abc]") "a") + (should-fail (&;regex "[abc]") "m"))) + + (assert "Can parse using character ranges." + (and (should-pass (&;regex "[a-z]") "a") + (should-pass (&;regex "[a-z]") "m") + (should-pass (&;regex "[a-z]") "z"))) + + (assert "Can combine character ranges." + (and (should-pass (&;regex "[a-zA-Z]") "a") + (should-pass (&;regex "[a-zA-Z]") "m") + (should-pass (&;regex "[a-zA-Z]") "z") + (should-pass (&;regex "[a-zA-Z]") "A") + (should-pass (&;regex "[a-zA-Z]") "M") + (should-pass (&;regex "[a-zA-Z]") "Z"))) + )) + +(test: "Regular Expressions [Custom character classes : Part 2]" + ($_ seq + (assert "Can negate custom character classes." + (and (should-fail (&;regex "[^abc]") "a") + (should-pass (&;regex "[^abc]") "m"))) + + (assert "Can negate character ranges.." + (and (should-fail (&;regex "[^a-z]") "a") + (should-pass (&;regex "[^a-z]") "0"))) + + (assert "Can parse negate combinations of character ranges." + (and (should-fail (&;regex "[^a-zA-Z]") "a") + (should-pass (&;regex "[^a-zA-Z]") "0"))) + )) + +(test: "Regular Expressions [Custom character classes : Part 3]" + ($_ seq + (assert "Can make custom character classes more specific." + (and (let [RE (&;regex "[a-z&&[def]]")] + (and (should-fail RE "a") + (should-pass RE "d"))) + + (let [RE (&;regex "[a-z&&[^bc]]")] + (and (should-pass RE "a") + (should-fail RE "b"))) + + (let [RE (&;regex "[a-z&&[^m-p]]")] + (and (should-pass RE "a") + (should-fail RE "m") + (should-fail RE "p"))))) + )) + +(test: "Regular Expressions [Reference]" + (let [number (&;regex "\\d+")] + (assert "Can build complex regexs by combining simpler ones." + (should-check ["809-345-6789" "809" "345" "6789"] (&;regex "(\\@)-(\\@)-(\\@)") "809-345-6789")))) + +(test: "Regular Expressions [Fuzzy Quantifiers]" + ($_ seq + (assert "Can sequentially combine patterns." + (should-passT "aa" (&;regex "aa") "aa")) + + (assert "Can match patterns optionally." + (and (should-passT "a" (&;regex "a?") "a") + (should-passT "" (&;regex "a?") ""))) + + (assert "Can match a pattern 0 or more times." + (and (should-passT "aaa" (&;regex "a*") "aaa") + (should-passT "" (&;regex "a*") ""))) + + (assert "Can match a pattern 1 or more times." + (and (should-passT "aaa" (&;regex "a+") "aaa") + (should-passT "a" (&;regex "a+") "a") + (should-fail (&;regex "a+") ""))) + )) + +(test: "Regular Expressions [Crisp Quantifiers]" + ($_ seq + (assert "Can match a pattern N times." + (and (should-passT "aa" (&;regex "a{2}") "aa") + (should-passT "a" (&;regex "a{1}") "aa") + (should-fail (&;regex "a{3}") "aa"))) + + (assert "Can match a pattern at-least N times." + (and (should-passT "aa" (&;regex "a{1,}") "aa") + (should-passT "aa" (&;regex "a{2,}") "aa") + (should-fail (&;regex "a{3,}") "aa"))) + + (assert "Can match a pattern at-most N times." + (and (should-passT "a" (&;regex "a{,1}") "aa") + (should-passT "aa" (&;regex "a{,2}") "aa") + (should-passT "aa" (&;regex "a{,3}") "aa"))) + + (assert "Can match a pattern between N and M times." + (and (should-passT "a" (&;regex "a{1,2}") "a") + (should-passT "aa" (&;regex "a{1,2}") "aa") + (should-passT "aa" (&;regex "a{1,2}") "aaa"))) + )) + +(test: "Regular Expressions [Groups]" + ($_ seq + (assert "Can extract groups of sub-matches specified in a pattern." + (and (should-check ["abc" "b"] (&;regex "a(.)c") "abc") + (should-check ["abbbbbc" "bbbbb"] (&;regex "a(b+)c") "abbbbbc") + (should-check ["809-345-6789" "809" "345" "6789"] (&;regex "(\\d{3})-(\\d{3})-(\\d{4})") "809-345-6789") + (should-check ["809-345-6789" "809" "6789"] (&;regex "(\\d{3})-(?:\\d{3})-(\\d{4})") "809-345-6789") + (should-check ["809-809-6789" "809" "6789"] (&;regex "(\\d{3})-\\0-(\\d{4})") "809-809-6789") + (should-check ["809-809-6789" "809" "6789"] (&;regex "(?\\d{3})-\\k-(\\d{4})") "809-809-6789") + (should-check ["809-809-6789-6789" "809" "6789"] (&;regex "(?\\d{3})-\\k-(\\d{4})-\\0") "809-809-6789-6789"))) + + (assert "Can specify groups within groups." + (should-check ["809-345-6789" "809" ["345-6789" "345" "6789"]] (&;regex "(\\d{3})-((\\d{3})-(\\d{4}))") "809-345-6789")) + )) + +(test: "Regular Expressions [Alternation]" + ($_ seq + (assert "Can specify alternative patterns." + (and (should-check ["a" (+0 [])] (&;regex "a|b") "a") + (should-check ["b" (+1 [])] (&;regex "a|b") "b") + (should-fail (&;regex "a|b") "c"))) + + (assert "Can have groups within alternations." + (and (should-check ["abc" (+0 ["b" "c"])] (&;regex "a(.)(.)|b(.)(.)") "abc") + (should-check ["bcd" (+1 ["c" "d"])] (&;regex "a(.)(.)|b(.)(.)") "bcd") + (should-fail (&;regex "a(.)(.)|b(.)(.)") "cde") + + (should-check ["809-345-6789" (+0 ["809" "345-6789" "345" "6789"])] + (&;regex "(\\d{3})-((\\d{3})-(\\d{4}))|b(.)d") + "809-345-6789"))) + )) + +(test: "Pattern-matching" + [sample1 (R;text +3) + sample2 (R;text +3) + sample3 (R;text +4)] + (case (format sample1 "-" sample2 "-" sample3) + (&;^regex "(.{3})-(.{3})-(.{4})" + [_ match1 match2 match3]) + (assert "Can pattern-match using regular-expressions." + (and (T/= sample1 match1) + (T/= sample2 match2) + (T/= sample3 match3))) + + _ + (assert "Cannot pattern-match using regular-expressions." + false))) diff --git a/stdlib/test/test/lux/function/cont.lux b/stdlib/test/test/lux/function/cont.lux index ba1224bb8..c2e36a06b 100644 --- a/stdlib/test/test/lux/function/cont.lux +++ b/stdlib/test/test/lux/function/cont.lux @@ -7,8 +7,7 @@ [number] [product]) (function ["&" cont]) - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (test: "Continuations" diff --git a/stdlib/test/test/lux/function/reader.lux b/stdlib/test/test/lux/function/reader.lux index 14b95af94..602efc603 100644 --- a/stdlib/test/test/lux/function/reader.lux +++ b/stdlib/test/test/lux/function/reader.lux @@ -1,12 +1,12 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data [text "Text/" Monoid] text/format [number]) - (function ["&" reader]) - pipe) + (function ["&" reader])) lux/test) (test: "Readers" diff --git a/stdlib/test/test/lux/function/state.lux b/stdlib/test/test/lux/function/state.lux index 186b786e0..9ef61e4d3 100644 --- a/stdlib/test/test/lux/function/state.lux +++ b/stdlib/test/test/lux/function/state.lux @@ -1,13 +1,13 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data [text "Text/" Monoid] text/format [number] [product]) - (function ["&" state]) - pipe) + (function ["&" state])) lux/test) (test: "State" diff --git a/stdlib/test/test/lux/function/thunk.lux b/stdlib/test/test/lux/function/thunk.lux index e3e9aca1b..753398f77 100644 --- a/stdlib/test/test/lux/function/thunk.lux +++ b/stdlib/test/test/lux/function/thunk.lux @@ -3,7 +3,6 @@ (lux [io] (control monad) (function ["&" thunk]) - pipe ["R" math/random]) lux/test) diff --git a/stdlib/test/test/lux/host.js.lux b/stdlib/test/test/lux/host.js.lux index 7d79b2b87..b7dbe043f 100644 --- a/stdlib/test/test/lux/host.js.lux +++ b/stdlib/test/test/lux/host.js.lux @@ -4,8 +4,7 @@ (control monad) (data text/format) ["&" host] - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (test: "JavaScript operations" diff --git a/stdlib/test/test/lux/host.jvm.lux b/stdlib/test/test/lux/host.jvm.lux index f58b706d5..4bd96ad62 100644 --- a/stdlib/test/test/lux/host.jvm.lux +++ b/stdlib/test/test/lux/host.jvm.lux @@ -1,14 +1,14 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data text/format [number] [product] [text "Text/" Eq]) ["&" host #+ jvm-import class: interface: object] - ["R" math/random] - pipe) + ["R" math/random]) lux/test) (jvm-import java.lang.Exception diff --git a/stdlib/test/test/lux/lexer.lux b/stdlib/test/test/lux/lexer.lux deleted file mode 100644 index 0bfd8dec7..000000000 --- a/stdlib/test/test/lux/lexer.lux +++ /dev/null @@ -1,315 +0,0 @@ -(;module: - lux - (lux (control monad) - [io] - (data [error #- fail] - [text "T/" Eq] - text/format - [char "C/" Eq] - (coll [list])) - ["R" math/random] - pipe - ["&" lexer]) - lux/test) - -## [Utils] -(def: (should-fail input) - (All [a] (-> (Error a) Bool)) - (case input - (#;Left _) true - _ false)) - -(def: (should-passC test input) - (-> Char (Error Char) Bool) - (case input - (#;Right output) - (C/= test output) - - _ - false)) - -(def: (should-passT test input) - (-> Text (Error Text) Bool) - (case input - (#;Right output) - (T/= test output) - - _ - false)) - -(def: (should-passL test input) - (-> (List Char) (Error (List Char)) Bool) - (let [(^open "L/") (list;Eq char;Eq)] - (case input - (#;Right output) - (L/= test output) - - _ - false))) - -(def: (should-passE test input) - (-> (Either Char Char) (Error (Either Char Char)) Bool) - (case input - (#;Right output) - (case [test output] - [(#;Left test) (#;Left output)] - (C/= test output) - - [(#;Right test) (#;Right output)] - (C/= test output) - - _ - false) - - _ - false)) - -## [Tests] -(test: "End" - ($_ seq - (assert "Can detect the end of the input." - (|> (&;run "" - &;end) - (case> (#;Right _) true _ false))) - - (assert "Won't mistake non-empty text for no more input." - (|> (&;run "YOLO" - &;end) - (case> (#;Left _) true _ false))) - )) - -(test: "Literals" - [size (|> R;nat (:: @ map (|>. (n.% +100) (n.max +10)))) - pre (R;text size) - post (|> (R;text size) - (R;filter (|>. (text;starts-with? pre) not)))] - ($_ seq - (assert "Can find literal text fragments." - (and (|> (&;run (format pre post) - (&;text pre)) - (case> (#;Right found) (T/= pre found) _ false)) - (|> (&;run post - (&;text pre)) - (case> (#;Left _) true _ false)))) - )) - -(test: "Char lexers" - ($_ seq - (assert "Can lex characters." - (and (|> (&;run "YOLO" - (&;char #"Y")) - (case> (#;Right #"Y") true _ false)) - (|> (&;run "MEME" - (&;char #"Y")) - (case> (#;Left _) true _ false)))) - - (assert "Can lex characters ranges." - (and (should-passC #"Y" (&;run "YOLO" - (&;char-range #"X" #"Z"))) - (should-fail (&;run "MEME" - (&;char-range #"X" #"Z"))))) - )) - -(test: "Custom lexers" - ($_ seq - (assert "Can lex anything" - (and (should-passC #"A" (&;run "A" - &;any)) - (should-fail (&;run "" - &;any)))) - - (assert "Can lex upper-case and &;lower-case letters." - (and (should-passC #"Y" (&;run "YOLO" - &;upper)) - (should-fail (&;run "meme" - &;upper)) - - (should-passC #"y" (&;run "yolo" - &;lower)) - (should-fail (&;run "MEME" - &;lower)))) - - (assert "Can lex numbers." - (and (should-passC #"1" (&;run "1" - &;digit)) - (should-fail (&;run " " - &;digit)) - - (should-passC #"7" (&;run "7" - &;oct-digit)) - (should-fail (&;run "8" - &;oct-digit)) - - (should-passC #"1" (&;run "1" - &;hex-digit)) - (should-passC #"a" (&;run "a" - &;hex-digit)) - (should-passC #"A" (&;run "A" - &;hex-digit)) - (should-fail (&;run " " - &;hex-digit)) - )) - - (assert "Can lex alphabetic characters." - (and (should-passC #"A" (&;run "A" - &;alpha)) - (should-passC #"a" (&;run "a" - &;alpha)) - (should-fail (&;run "1" - &;alpha)))) - - (assert "Can lex alphanumeric characters." - (and (should-passC #"A" (&;run "A" - &;alpha-num)) - (should-passC #"a" (&;run "a" - &;alpha-num)) - (should-passC #"1" (&;run "1" - &;alpha-num)) - (should-fail (&;run " " - &;alpha-num)))) - - (assert "Can lex white-space." - (and (should-passC #" " (&;run " " - &;space)) - (should-fail (&;run "8" - &;space)))) - )) - -(test: "Combinators" - ($_ seq - (assert "Can combine lexers sequentially." - (and (|> (&;run "YOLO" - (&;seq &;any &;any)) - (case> (#;Right [#"Y" #"O"]) true - _ false)) - (should-fail (&;run "Y" - (&;seq &;any &;any))))) - - (assert "Can combine lexers alternatively." - (and (should-passE (#;Left #"0") (&;run "0" - (&;alt &;digit &;upper))) - (should-passE (#;Right #"A") (&;run "A" - (&;alt &;digit &;upper))) - (should-fail (&;run "a" - (&;alt &;digit &;upper))))) - - (assert "Can create the opposite of a lexer." - (and (should-passC #"a" (&;run "a" - (&;not (&;alt &;digit &;upper)))) - (should-fail (&;run "A" - (&;not (&;alt &;digit &;upper)))))) - - (assert "Can use either lexer." - (and (should-passC #"0" (&;run "0" - (&;either &;digit &;upper))) - (should-passC #"A" (&;run "A" - (&;either &;digit &;upper))) - (should-fail (&;run "a" - (&;either &;digit &;upper))))) - - (assert "Can select from among a set of characters." - (and (should-passC #"C" (&;run "C" - (&;one-of "ABC"))) - (should-fail (&;run "D" - (&;one-of "ABC"))))) - - (assert "Can avoid a set of characters." - (and (should-passC #"D" (&;run "D" - (&;none-of "ABC"))) - (should-fail (&;run "C" - (&;none-of "ABC"))))) - - (assert "Can lex using arbitrary predicates." - (and (should-passC #"D" (&;run "D" - (&;satisfies (lambda [c] true)))) - (should-fail (&;run "C" - (&;satisfies (lambda [c] false)))))) - - (assert "Can apply a lexer multiple times." - (and (should-passT "0123456789ABCDEF" (&;run "0123456789ABCDEF yolo" - (&;many' &;hex-digit))) - (should-fail (&;run "yolo" - (&;many' &;hex-digit))) - - (should-passT "" (&;run "yolo" - (&;some' &;hex-digit))))) - )) - -(test: "Yet more combinators..." - ($_ seq - (assert "Can fail at will." - (should-fail (&;run "yolo" - (&;fail "Well, it really SHOULD fail...")))) - - (assert "Can make assertions." - (and (should-fail (&;run "yolo" - (&;assert "Well, it really SHOULD fail..." false))) - (|> (&;run "yolo" - (&;assert "GO, GO, GO!" true)) - (case> (#;Right []) true - _ false)))) - - (assert "Can apply a lexer multiple times." - (and (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") - (&;run "0123456789ABCDEF yolo" - (&;many &;hex-digit))) - (should-fail (&;run "yolo" - (&;many &;hex-digit))) - - (should-passL (list) - (&;run "yolo" - (&;some &;hex-digit))))) - - (assert "Can lex exactly N elements." - (and (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") - (&;run "0123456789ABCDEF yolo" - (&;exactly +16 &;hex-digit))) - (should-passL (list #"0" #"1" #"2") - (&;run "0123456789ABCDEF yolo" - (&;exactly +3 &;hex-digit))) - (should-fail (&;run "0123456789ABCDEF yolo" - (&;exactly +17 &;hex-digit))))) - - (assert "Can lex at-most N elements." - (and (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") - (&;run "0123456789ABCDEF yolo" - (&;at-most +16 &;hex-digit))) - (should-passL (list #"0" #"1" #"2") - (&;run "0123456789ABCDEF yolo" - (&;at-most +3 &;hex-digit))) - (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") - (&;run "0123456789ABCDEF yolo" - (&;at-most +17 &;hex-digit))))) - - (assert "Can lex tokens between lower and upper boundaries of quantity." - (and (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") - (&;run "0123456789ABCDEF yolo" - (&;between +0 +16 &;hex-digit))) - (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") - (&;run "0123456789ABCDEF yolo" - (&;between +3 +16 &;hex-digit))) - (should-fail (&;run "0123456789ABCDEF yolo" - (&;between +17 +100 &;hex-digit))) - (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F") - (&;run "0123456789ABCDEF yolo" - (&;between +15 +20 &;hex-digit))))) - - (assert "Can optionally lex a token." - (and (|> (&;run "123abc" - (&;opt &;hex-digit)) - (case> (#;Right (#;Some #"1")) true - _ false)) - (|> (&;run "yolo" - (&;opt &;hex-digit)) - (case> (#;Right #;None) true - _ false)))) - - (assert "Can take into account separators during lexing." - (should-passL (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"a" #"b" #"c" #"d" #"e" #"f") - (&;run "0 1 2 3 4 5 6 7 8 9 a b c d e f YOLO" - (&;sep-by &;space &;hex-digit)))) - - (assert "Can obtain the whole of the remaining input." - (should-passT "yolo" (&;run "yolo" - &;get-input))) - )) diff --git a/stdlib/test/test/lux/lexer/regex.lux b/stdlib/test/test/lux/lexer/regex.lux deleted file mode 100644 index 1a21111f8..000000000 --- a/stdlib/test/test/lux/lexer/regex.lux +++ /dev/null @@ -1,285 +0,0 @@ -(;module: - lux - (lux [io] - (control monad) - (data [error #- fail] - [product] - [text "T/" Eq] - text/format) - [compiler] - (macro [ast] - ["s" syntax #+ syntax:]) - ["R" math/random] - pipe - [lexer] - (lexer ["&" regex])) - lux/test) - -## [Utils] -(def: (should-pass regex input) - (-> (lexer;Lexer Text) Text Bool) - (|> (lexer;run input regex) - (case> (#;Right parsed) - (T/= parsed input) - - _ - false))) - -(def: (should-passT test regex input) - (-> Text (lexer;Lexer Text) Text Bool) - (|> (lexer;run input regex) - (case> (#;Right parsed) - (T/= test parsed) - - _ - false))) - -(def: (should-fail regex input) - (All [a] (-> (lexer;Lexer a) Text Bool)) - (|> (lexer;run input regex) - (case> (#;Left _) true _ false))) - -(syntax: (should-check pattern regex input) - (wrap (list (` (|> (lexer;run (~ input) (~ regex)) - (case> (^ (#;Right (~ pattern))) - true - - (~' _) - false)))))) - -## [Tests] -(test: "Regular Expressions [Basics]" - (assert "Can parse character literals." - (and (should-pass (&;regex "a") "a") - (should-fail (&;regex "a") ".") - (should-pass (&;regex "\\.") ".") - (should-fail (&;regex "\\.") "a")))) - -(test: "Regular Expressions [System character classes]" - ($_ seq - (assert "Can parse anything." - (should-pass (&;regex ".") "a")) - - (assert "Can parse digits." - (and (should-pass (&;regex "\\d") "0") - (should-fail (&;regex "\\d") "m"))) - - (assert "Can parse non digits." - (and (should-pass (&;regex "\\D") "m") - (should-fail (&;regex "\\D") "0"))) - - (assert "Can parse white-space." - (and (should-pass (&;regex "\\s") " ") - (should-fail (&;regex "\\s") "m"))) - - (assert "Can parse non white-space." - (and (should-pass (&;regex "\\S") "m") - (should-fail (&;regex "\\S") " "))) - - (assert "Can parse word characters." - (and (should-pass (&;regex "\\w") "_") - (should-fail (&;regex "\\w") "^"))) - - (assert "Can parse non word characters." - (and (should-pass (&;regex "\\W") ".") - (should-fail (&;regex "\\W") "a"))) - )) - -(test: "Regular Expressions [Special system character classes : Part 1]" - ($_ seq - (assert "Can parse using special character classes." - (and (and (should-pass (&;regex "\\p{Lower}") "m") - (should-fail (&;regex "\\p{Lower}") "M")) - - (and (should-pass (&;regex "\\p{Upper}") "M") - (should-fail (&;regex "\\p{Upper}") "m")) - - (and (should-pass (&;regex "\\p{Alpha}") "M") - (should-fail (&;regex "\\p{Alpha}") "0")) - - (and (should-pass (&;regex "\\p{Digit}") "1") - (should-fail (&;regex "\\p{Digit}") "n")) - - (and (should-pass (&;regex "\\p{Alnum}") "1") - (should-fail (&;regex "\\p{Alnum}") ".")) - - (and (should-pass (&;regex "\\p{Space}") " ") - (should-fail (&;regex "\\p{Space}") ".")) - )) - )) - -(test: "Regular Expressions [Special system character classes : Part 2]" - ($_ seq - (assert "Can parse using special character classes." - (and (and (should-pass (&;regex "\\p{HexDigit}") "a") - (should-fail (&;regex "\\p{HexDigit}") ".")) - - (and (should-pass (&;regex "\\p{OctDigit}") "6") - (should-fail (&;regex "\\p{OctDigit}") ".")) - - (and (should-pass (&;regex "\\p{Blank}") "\t") - (should-fail (&;regex "\\p{Blank}") ".")) - - (and (should-pass (&;regex "\\p{ASCII}") "\t") - (should-fail (&;regex "\\p{ASCII}") "\u1234")) - - (and (should-pass (&;regex "\\p{Contrl}") "\u0012") - (should-fail (&;regex "\\p{Contrl}") "a")) - - (and (should-pass (&;regex "\\p{Punct}") "@") - (should-fail (&;regex "\\p{Punct}") "a")) - - (and (should-pass (&;regex "\\p{Graph}") "@") - (should-fail (&;regex "\\p{Graph}") " ")) - - (and (should-pass (&;regex "\\p{Print}") "\u0020") - (should-fail (&;regex "\\p{Print}") "\u1234")) - )) - )) - -(test: "Regular Expressions [Custom character classes : Part 1]" - ($_ seq - (assert "Can parse using custom character classes." - (and (should-pass (&;regex "[abc]") "a") - (should-fail (&;regex "[abc]") "m"))) - - (assert "Can parse using character ranges." - (and (should-pass (&;regex "[a-z]") "a") - (should-pass (&;regex "[a-z]") "m") - (should-pass (&;regex "[a-z]") "z"))) - - (assert "Can combine character ranges." - (and (should-pass (&;regex "[a-zA-Z]") "a") - (should-pass (&;regex "[a-zA-Z]") "m") - (should-pass (&;regex "[a-zA-Z]") "z") - (should-pass (&;regex "[a-zA-Z]") "A") - (should-pass (&;regex "[a-zA-Z]") "M") - (should-pass (&;regex "[a-zA-Z]") "Z"))) - )) - -(test: "Regular Expressions [Custom character classes : Part 2]" - ($_ seq - (assert "Can negate custom character classes." - (and (should-fail (&;regex "[^abc]") "a") - (should-pass (&;regex "[^abc]") "m"))) - - (assert "Can negate character ranges.." - (and (should-fail (&;regex "[^a-z]") "a") - (should-pass (&;regex "[^a-z]") "0"))) - - (assert "Can parse negate combinations of character ranges." - (and (should-fail (&;regex "[^a-zA-Z]") "a") - (should-pass (&;regex "[^a-zA-Z]") "0"))) - )) - -(test: "Regular Expressions [Custom character classes : Part 3]" - ($_ seq - (assert "Can make custom character classes more specific." - (and (let [RE (&;regex "[a-z&&[def]]")] - (and (should-fail RE "a") - (should-pass RE "d"))) - - (let [RE (&;regex "[a-z&&[^bc]]")] - (and (should-pass RE "a") - (should-fail RE "b"))) - - (let [RE (&;regex "[a-z&&[^m-p]]")] - (and (should-pass RE "a") - (should-fail RE "m") - (should-fail RE "p"))))) - )) - -(test: "Regular Expressions [Reference]" - (let [number (&;regex "\\d+")] - (assert "Can build complex regexs by combining simpler ones." - (should-check ["809-345-6789" "809" "345" "6789"] (&;regex "(\\@)-(\\@)-(\\@)") "809-345-6789")))) - -(test: "Regular Expressions [Fuzzy Quantifiers]" - ($_ seq - (assert "Can sequentially combine patterns." - (should-passT "aa" (&;regex "aa") "aa")) - - (assert "Can match patterns optionally." - (and (should-passT "a" (&;regex "a?") "a") - (should-passT "" (&;regex "a?") ""))) - - (assert "Can match a pattern 0 or more times." - (and (should-passT "aaa" (&;regex "a*") "aaa") - (should-passT "" (&;regex "a*") ""))) - - (assert "Can match a pattern 1 or more times." - (and (should-passT "aaa" (&;regex "a+") "aaa") - (should-passT "a" (&;regex "a+") "a") - (should-fail (&;regex "a+") ""))) - )) - -(test: "Regular Expressions [Crisp Quantifiers]" - ($_ seq - (assert "Can match a pattern N times." - (and (should-passT "aa" (&;regex "a{2}") "aa") - (should-passT "a" (&;regex "a{1}") "aa") - (should-fail (&;regex "a{3}") "aa"))) - - (assert "Can match a pattern at-least N times." - (and (should-passT "aa" (&;regex "a{1,}") "aa") - (should-passT "aa" (&;regex "a{2,}") "aa") - (should-fail (&;regex "a{3,}") "aa"))) - - (assert "Can match a pattern at-most N times." - (and (should-passT "a" (&;regex "a{,1}") "aa") - (should-passT "aa" (&;regex "a{,2}") "aa") - (should-passT "aa" (&;regex "a{,3}") "aa"))) - - (assert "Can match a pattern between N and M times." - (and (should-passT "a" (&;regex "a{1,2}") "a") - (should-passT "aa" (&;regex "a{1,2}") "aa") - (should-passT "aa" (&;regex "a{1,2}") "aaa"))) - )) - -(test: "Regular Expressions [Groups]" - ($_ seq - (assert "Can extract groups of sub-matches specified in a pattern." - (and (should-check ["abc" "b"] (&;regex "a(.)c") "abc") - (should-check ["abbbbbc" "bbbbb"] (&;regex "a(b+)c") "abbbbbc") - (should-check ["809-345-6789" "809" "345" "6789"] (&;regex "(\\d{3})-(\\d{3})-(\\d{4})") "809-345-6789") - (should-check ["809-345-6789" "809" "6789"] (&;regex "(\\d{3})-(?:\\d{3})-(\\d{4})") "809-345-6789") - (should-check ["809-809-6789" "809" "6789"] (&;regex "(\\d{3})-\\0-(\\d{4})") "809-809-6789") - (should-check ["809-809-6789" "809" "6789"] (&;regex "(?\\d{3})-\\k-(\\d{4})") "809-809-6789") - (should-check ["809-809-6789-6789" "809" "6789"] (&;regex "(?\\d{3})-\\k-(\\d{4})-\\0") "809-809-6789-6789"))) - - (assert "Can specify groups within groups." - (should-check ["809-345-6789" "809" ["345-6789" "345" "6789"]] (&;regex "(\\d{3})-((\\d{3})-(\\d{4}))") "809-345-6789")) - )) - -(test: "Regular Expressions [Alternation]" - ($_ seq - (assert "Can specify alternative patterns." - (and (should-check ["a" (+0 [])] (&;regex "a|b") "a") - (should-check ["b" (+1 [])] (&;regex "a|b") "b") - (should-fail (&;regex "a|b") "c"))) - - (assert "Can have groups within alternations." - (and (should-check ["abc" (+0 ["b" "c"])] (&;regex "a(.)(.)|b(.)(.)") "abc") - (should-check ["bcd" (+1 ["c" "d"])] (&;regex "a(.)(.)|b(.)(.)") "bcd") - (should-fail (&;regex "a(.)(.)|b(.)(.)") "cde") - - (should-check ["809-345-6789" (+0 ["809" "345-6789" "345" "6789"])] - (&;regex "(\\d{3})-((\\d{3})-(\\d{4}))|b(.)d") - "809-345-6789"))) - )) - -(test: "Pattern-matching" - [sample1 (R;text +3) - sample2 (R;text +3) - sample3 (R;text +4)] - (case (format sample1 "-" sample2 "-" sample3) - (&;^regex "(.{3})-(.{3})-(.{4})" - [_ match1 match2 match3]) - (assert "Can pattern-match using regular-expressions." - (and (T/= sample1 match1) - (T/= sample2 match2) - (T/= sample3 match3))) - - _ - (assert "Cannot pattern-match using regular-expressions." - false))) diff --git a/stdlib/test/test/lux/macro/ast.lux b/stdlib/test/test/lux/macro/ast.lux index 768dafbf8..95ac999a0 100644 --- a/stdlib/test/test/lux/macro/ast.lux +++ b/stdlib/test/test/lux/macro/ast.lux @@ -6,7 +6,6 @@ text/format [number]) ["R" math/random] - pipe (macro ["&" ast])) lux/test) diff --git a/stdlib/test/test/lux/macro/poly/eq.lux b/stdlib/test/test/lux/macro/poly/eq.lux index c2f9c0ac1..3cd515fc6 100644 --- a/stdlib/test/test/lux/macro/poly/eq.lux +++ b/stdlib/test/test/lux/macro/poly/eq.lux @@ -9,7 +9,6 @@ [char] [text]) ["R" math/random] - pipe [macro] (macro [poly #+ derived:] ["&" poly/eq])) diff --git a/stdlib/test/test/lux/macro/poly/functor.lux b/stdlib/test/test/lux/macro/poly/functor.lux index b98d75c7a..3294556a4 100644 --- a/stdlib/test/test/lux/macro/poly/functor.lux +++ b/stdlib/test/test/lux/macro/poly/functor.lux @@ -10,7 +10,6 @@ [char] [text]) ["R" math/random] - pipe [macro] (macro [poly #+ derived:] ["&" poly/functor])) diff --git a/stdlib/test/test/lux/macro/poly/text-encoder.lux b/stdlib/test/test/lux/macro/poly/text-encoder.lux index ec312e62b..ec392fc8e 100644 --- a/stdlib/test/test/lux/macro/poly/text-encoder.lux +++ b/stdlib/test/test/lux/macro/poly/text-encoder.lux @@ -9,7 +9,6 @@ [char] [text]) ["R" math/random] - pipe [macro] (macro [poly #+ derived:] ["&" poly/text-encoder])) diff --git a/stdlib/test/test/lux/macro/syntax.lux b/stdlib/test/test/lux/macro/syntax.lux index b9dd304e1..11d456236 100644 --- a/stdlib/test/test/lux/macro/syntax.lux +++ b/stdlib/test/test/lux/macro/syntax.lux @@ -11,7 +11,6 @@ [ident] [error #- fail]) ["R" math/random] - pipe [compiler] (macro [ast] ["s" syntax #+ syntax: Syntax])) diff --git a/stdlib/test/test/lux/math.lux b/stdlib/test/test/lux/math.lux index 4d8b8d12a..2b834b9cc 100644 --- a/stdlib/test/test/lux/math.lux +++ b/stdlib/test/test/lux/math.lux @@ -9,7 +9,6 @@ (coll [list "List/" Fold Functor]) [product]) ["R" math/random] - pipe ["&" math]) lux/test) diff --git a/stdlib/test/test/lux/math/logic/continuous.lux b/stdlib/test/test/lux/math/logic/continuous.lux index fa08ec864..b1770c815 100644 --- a/stdlib/test/test/lux/math/logic/continuous.lux +++ b/stdlib/test/test/lux/math/logic/continuous.lux @@ -3,7 +3,6 @@ (lux [io] (control monad) ["R" math/random] - pipe ["&" math/logic/continuous]) lux/test) diff --git a/stdlib/test/test/lux/math/logic/fuzzy.lux b/stdlib/test/test/lux/math/logic/fuzzy.lux index afcd8b731..284fffa4b 100644 --- a/stdlib/test/test/lux/math/logic/fuzzy.lux +++ b/stdlib/test/test/lux/math/logic/fuzzy.lux @@ -8,7 +8,6 @@ [number] text/format) ["R" math/random] - pipe (math/logic ["&" fuzzy] continuous)) lux/test) diff --git a/stdlib/test/test/lux/math/simple.lux b/stdlib/test/test/lux/math/simple.lux index 32f5fb20c..9aec7f1fc 100644 --- a/stdlib/test/test/lux/math/simple.lux +++ b/stdlib/test/test/lux/math/simple.lux @@ -9,7 +9,6 @@ (coll [list "List/" Fold Functor]) [product]) ["R" math/random] - pipe ["&" math/simple]) lux/test) diff --git a/stdlib/test/test/lux/pipe.lux b/stdlib/test/test/lux/pipe.lux deleted file mode 100644 index 08866a3f4..000000000 --- a/stdlib/test/test/lux/pipe.lux +++ /dev/null @@ -1,74 +0,0 @@ -(;module: - lux - (lux [io] - (control monad) - (data text/format - [number] - [product] - identity - [text "T/" Eq]) - ["R" math/random] - pipe) - lux/test) - -(test: "Pipes" - ($_ seq - (assert "Can dismiss previous pipeline results and begin a new line." - (|> 20 - (i.* 3) - (i.+ 4) - (_> 0 i.inc) - (i.= 1))) - - (assert "Can give names to piped values within a pipeline's scope." - (and (|> 5 - (@> [(i.+ @ @)]) - (i.= 10)) - (|> 5 - (@> X [(i.+ X X)]) - (i.= 10)))) - - (assert "Can do branching in pipelines." - (and (|> 5 - (?> [i.even?] [(i.* 2)] - [i.odd?] [(i.* 3)] - [(_> -1)]) - (i.= 15)) - (|> 4 - (?> [i.even?] [(i.* 2)] - [i.odd?] [(i.* 3)]) - (i.= 8)) - (|> 5 - (?> [i.even?] [(i.* 2)] - [(_> -1)]) - (i.= -1)))) - - (assert "Can loop within pipelines." - (|> 1 - (!> [(i.< 10)] - [i.inc]) - (i.= 10))) - - (assert "Can use monads within pipelines." - (|> 5 - (%> Monad - [(i.* 3)] - [(i.+ 4)] - [i.inc]) - (i.= 20))) - - (assert "Can pattern-match against piped values." - (|> 5 - (case> 0 "zero" - 1 "one" - 2 "two" - 3 "three" - 4 "four" - 5 "five" - 6 "six" - 7 "seven" - 8 "eight" - 9 "nine" - _ "???") - (T/= "five"))) - )) diff --git a/stdlib/test/test/lux/type.lux b/stdlib/test/test/lux/type.lux index e9401c738..d1098b960 100644 --- a/stdlib/test/test/lux/type.lux +++ b/stdlib/test/test/lux/type.lux @@ -1,14 +1,14 @@ (;module: lux (lux [io] - (control monad) + (control monad + pipe) (data [text "Text/" Monoid] text/format [number] maybe (coll [list])) ["R" math/random] - pipe ["&" type]) lux/test) diff --git a/stdlib/test/test/lux/type/auto.lux b/stdlib/test/test/lux/type/auto.lux index 536e3b851..c7e321240 100644 --- a/stdlib/test/test/lux/type/auto.lux +++ b/stdlib/test/test/lux/type/auto.lux @@ -11,7 +11,6 @@ maybe (coll [list])) ["R" math/random] - pipe [type] type/auto) lux/test) @@ -32,4 +31,9 @@ (::: = (list;n.range +1 +10) (list;n.range +1 +10))) + + (assert "Can automatically select third-order structures." + (let [lln (::: map (list;n.range +1) + (list;n.range +1 +10))] + (::: = lln lln))) )) diff --git a/stdlib/test/test/lux/type/check.lux b/stdlib/test/test/lux/type/check.lux index 47904c41b..d76a53622 100644 --- a/stdlib/test/test/lux/type/check.lux +++ b/stdlib/test/test/lux/type/check.lux @@ -8,7 +8,6 @@ maybe (coll [list])) ["R" math/random] - pipe [type] ["&" type/check]) lux/test) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index c773b3f17..6b23caebd 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -9,9 +9,6 @@ (lux ["_;" cli] ["_;" host] ["_;" io] - ["_;" pipe] - ["_;" lexer] - (lexer ["_;" regex]) (function ["_;" cont] ["_;" reader] ["_;" state] @@ -22,45 +19,44 @@ ["_;" promise] ["_;" stm]) (control ["_;" effect] - ["_;" interval]) - (data [bit] - [bool] - [char] - [error] - [ident] - [identity] - [log] - [maybe] - [number] + ["_;" interval] + ["_;" pipe]) + (data ["_;" bit] + ["_;" bool] + ["_;" char] + ["_;" error] + ["_;" ident] + ["_;" identity] + ["_;" log] + ["_;" maybe] + ["_;" number] (number ["_;" ratio] ["_;" complex]) - [product] - [sum] - [text] - (error [exception]) - (format [json]) - (coll [array] - [dict] - [list] - [queue] - [set] - [ordered] - [stack] - ## [vector] - (tree [rose] - [zipper]) + ["_;" product] + ["_;" sum] + ["_;" text] + (error ["_;" exception]) + (format ["_;" json]) + (coll ["_;" array] + ["_;" dict] + ["_;" list] + ["_;" queue] + ["_;" set] + ["_;" ordered] + ["_;" stack] + ["_;" vector] + (tree ["_;" rose] + ["_;" zipper]) ["_;" seq] ["_;" priority-queue] ["_;" stream]) - (text [format]) - ) + (text ["_;" format] + ["_;" lexer] + ["_;" regex])) ["_;" math] (math ["_;" simple] (logic ["_;" continuous] - ["_;" fuzzy]) - ## ["_;" random] - ) - ## ["_;" macro] + ["_;" fuzzy])) (macro ["_;" ast] ["_;" syntax] (poly ["poly_;" eq] @@ -69,7 +65,13 @@ ["_;" type] (type ["_;" check] ["_;" auto]) - ))) + )) + (lux (control [contract]) + (data [env] + [trace] + [store]) + [macro] + (math [random]))) ## [Program] (program: args -- cgit v1.2.3