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 +- 11 files changed, 1201 insertions(+), 1232 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 (limited to 'stdlib/source') 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 @ -- cgit v1.2.3