Moved the code/syntax parser under "lux/control/parser/".

1 files changed, 193 insertions, 0 deletions

diff --git a/stdlib/source/lux/control/parser/code.lux b/stdlib/source/lux/control/parser/code.lux
new file mode 100644
index 000000000..56cbe5bc2
--- /dev/null
+++ b/stdlib/source/lux/control/parser/code.lux
@@ -0,0 +1,193 @@
+(.module:
+  [lux (#- nat int rev)
+   [abstract
+    ["." monad (#+ do)]]
+   [data
+    ["." bit]
+    ["." name]
+    ["." error (#+ Error)]
+    [number
+     ["." nat]
+     ["." int]
+     ["." rev]
+     ["." frac]]
+    ["." text ("#@." monoid)]
+    [collection
+     ["." list ("#@." functor)]]]
+   [macro
+    ["." code ("#@." equivalence)]]]
+  ["." //])
+
+(def: (join-pairs pairs)
+  (All [a] (-> (List [a a]) (List a)))
+  (case pairs
+    #.Nil                   #.Nil
+    (#.Cons [[x y] pairs']) (list& x y (join-pairs pairs'))))
+
+(type: #export Parser
+  {#.doc "A Lux syntax parser."}
+  (//.Parser (List Code)))
+
+(def: (remaining-inputs asts)
+  (-> (List Code) Text)
+  ($_ text@compose text.new-line "Remaining input: "
+      (|> asts (list@map code.to-text) (list.interpose " ") (text.join-with ""))))
+
+(def: #export any
+  {#.doc "Just returns the next input without applying any logic."}
+  (Parser Code)
+  (function (_ tokens)
+    (case tokens
+      #.Nil                (#error.Failure "There are no tokens to parse!")
+      (#.Cons [t tokens']) (#error.Success [tokens' t]))))
+
+(template [<get-name> <type> <tag> <eq> <desc>]
+  [(def: #export <get-name>
+     {#.doc (code.text ($_ text@compose "Parses the next " <desc> " input Code."))}
+     (Parser <type>)
+     (function (_ tokens)
+       (case tokens
+         (#.Cons [[_ (<tag> x)] tokens'])
+         (#error.Success [tokens' x])
+
+         _
+         (#error.Failure ($_ text@compose "Cannot parse " <desc> (remaining-inputs tokens))))))]
+
+  [   bit     Bit  #.Bit        bit.equivalence  "bit"]
+  [   nat     Nat  #.Nat        nat.equivalence  "nat"]
+  [   int     Int  #.Int        int.equivalence  "int"]
+  [   rev     Rev  #.Rev        rev.equivalence  "rev"]
+  [  frac     Frac #.Frac       frac.equivalence "frac"]
+  [  text     Text #.Text       text.equivalence "text"]
+  [identifier Name #.Identifier name.equivalence "identifier"]
+  [   tag     Name #.Tag        name.equivalence "tag"]
+  )
+
+(def: #export (this? ast)
+  {#.doc "Asks if the given Code is the next input."}
+  (-> Code (Parser Bit))
+  (function (_ tokens)
+    (case tokens
+      (#.Cons [token tokens'])
+      (let [is-it? (code@= ast token)
+            remaining (if is-it?
+                        tokens'
+                        tokens)]
+        (#error.Success [remaining is-it?]))
+
+      _
+      (#error.Success [tokens #0]))))
+
+(def: #export (this ast)
+  {#.doc "Ensures the given Code is the next input."}
+  (-> Code (Parser Any))
+  (function (_ tokens)
+    (case tokens
+      (#.Cons [token tokens'])
+      (if (code@= ast token)
+        (#error.Success [tokens' []])
+        (#error.Failure ($_ text@compose "Expected a " (code.to-text ast) " but instead got " (code.to-text token)
+                            (remaining-inputs tokens))))
+
+      _
+      (#error.Failure "There are no tokens to parse!"))))
+
+(template [<name> <tag> <desc>]
+  [(def: #export <name>
+     {#.doc (code.text ($_ text@compose "Parse a local " <desc> " (a " <desc> " that has no module prefix)."))}
+     (Parser Text)
+     (function (_ tokens)
+       (case tokens
+         (#.Cons [[_ (<tag> ["" x])] tokens'])
+         (#error.Success [tokens' x])
+
+         _
+         (#error.Failure ($_ text@compose "Cannot parse local " <desc> (remaining-inputs tokens))))))]
+
+  [local-identifier #.Identifier "identifier"]
+  [   local-tag     #.Tag        "tag"]
+  )
+
+(template [<name> <tag> <desc>]
+  [(def: #export (<name> p)
+     {#.doc (code.text ($_ text@compose "Parse inside the contents of a " <desc> " as if they were the input Codes."))}
+     (All [a]
+       (-> (Parser a) (Parser a)))
+     (function (_ tokens)
+       (case tokens
+         (#.Cons [[_ (<tag> members)] tokens'])
+         (case (p members)
+           (#error.Success [#.Nil x]) (#error.Success [tokens' x])
+           _                          (#error.Failure ($_ text@compose "Parser was expected to fully consume " <desc> (remaining-inputs tokens))))
+
+         _
+         (#error.Failure ($_ text@compose "Cannot parse " <desc> (remaining-inputs tokens))))))]
+
+  [ form  #.Form "form"]
+  [tuple #.Tuple "tuple"]
+  )
+
+(def: #export (record p)
+  {#.doc (code.text ($_ text@compose "Parse inside the contents of a record as if they were the input Codes."))}
+  (All [a]
+    (-> (Parser a) (Parser a)))
+  (function (_ tokens)
+    (case tokens
+      (#.Cons [[_ (#.Record pairs)] tokens'])
+      (case (p (join-pairs pairs))
+        (#error.Success [#.Nil x]) (#error.Success [tokens' x])
+        _                          (#error.Failure ($_ text@compose "Parser was expected to fully consume record" (remaining-inputs tokens))))
+
+      _
+      (#error.Failure ($_ text@compose "Cannot parse record" (remaining-inputs tokens))))))
+
+(def: #export end!
+  {#.doc "Ensures there are no more inputs."}
+  (Parser Any)
+  (function (_ tokens)
+    (case tokens
+      #.Nil (#error.Success [tokens []])
+      _     (#error.Failure ($_ text@compose "Expected list of tokens to be empty!" (remaining-inputs tokens))))))
+
+(def: #export end?
+  {#.doc "Checks whether there are no more inputs."}
+  (Parser Bit)
+  (function (_ tokens)
+    (case tokens
+      #.Nil (#error.Success [tokens #1])
+      _     (#error.Success [tokens #0]))))
+
+(def: #export (lift outcome)
+  (All [a] (-> (Error a) (Parser a)))
+  (function (_ input)
+    (case outcome
+      (#error.Failure error)
+      (#error.Failure error)
+
+      (#error.Success value)
+      (#error.Success [input value])
+      )))
+
+(def: #export (run inputs syntax)
+  (All [a] (-> (List Code) (Parser a) (Error a)))
+  (case (syntax inputs)
+    (#error.Failure error)
+    (#error.Failure error)
+
+    (#error.Success [unconsumed value])
+    (case unconsumed
+      #.Nil
+      (#error.Success value)
+
+      _
+      (#error.Failure (text@compose "Unconsumed inputs: "
+                                    (|> (list@map code.to-text unconsumed)
+                                        (text.join-with ", ")))))))
+
+(def: #export (local inputs syntax)
+  {#.doc "Run a syntax parser with the given list of inputs, instead of the real ones."}
+  (All [a] (-> (List Code) (Parser a) (Parser a)))
+  (function (_ real)
+    (do error.monad
+      [value (run inputs syntax)]
+      (wrap [real value]))))