New "parser" hierarchy. [Part 3]

2 files changed, 344 insertions, 0 deletions

diff --git a/stdlib/source/parser/lux/data/format/json.lux b/stdlib/source/parser/lux/data/format/json.lux
new file mode 100644
index 000000000..2f54560e9
--- /dev/null
+++ b/stdlib/source/parser/lux/data/format/json.lux
@@ -0,0 +1,199 @@
+(.using
+ [library
+  [lux (.except symbol)
+   [abstract
+    ["[0]" monad (.only do)]]
+   [control
+    ["//" parser (.open: "[1]#[0]" functor)]
+    ["[0]" try (.only Try)]
+    ["[0]" exception (.only exception:)]]
+   [data
+    ["[0]" bit]
+    ["[0]" text (.open: "[1]#[0]" equivalence monoid)]
+    [collection
+     ["[0]" list (.open: "[1]#[0]" functor)]
+     ["[0]" sequence]
+     ["[0]" dictionary (.only Dictionary)]]]
+   [macro
+    ["[0]" code]]
+   [math
+    [number
+     ["[0]" frac]]]]]
+ [\\library
+  ["[0]" / (.only JSON)]])
+
+(type: .public (Parser a)
+  (//.Parser (List JSON) a))
+
+(exception: .public (unconsumed_input [input (List JSON)])
+  (exception.report
+   "Input" (exception.listing /.format input)))
+
+(exception: .public empty_input)
+
+(def .public (result parser json)
+  (All (_ a) (-> (Parser a) JSON (Try a)))
+  (case (//.result parser (list json))
+    {try.#Success [remainder output]}
+    (case remainder
+      {.#End}
+      {try.#Success output}
+
+      _
+      (exception.except ..unconsumed_input remainder))
+    
+    {try.#Failure error}
+    {try.#Failure error}))
+
+(def .public any
+  (Parser JSON)
+  (<| (function (_ inputs))
+      (case inputs
+        {.#End}
+        (exception.except ..empty_input [])
+        
+        {.#Item head tail}
+        {try.#Success [tail head]})))
+
+(exception: .public (unexpected_value [value JSON])
+  (exception.report
+   "Value" (/.format value)))
+
+(with_template [<name> <type> <tag>]
+  [(def .public <name>
+     (Parser <type>)
+     (do //.monad
+       [head ..any]
+       (case head
+         {<tag> value}
+         (in value)
+
+         _
+         (//.failure (exception.error ..unexpected_value [head])))))]
+
+  [null    /.Null    /.#Null]
+  [boolean /.Boolean /.#Boolean]
+  [number  /.Number  /.#Number]
+  [string  /.String  /.#String]
+  )
+
+(exception: .public [a] (value_mismatch [reference JSON
+                                         sample JSON])
+  (exception.report
+   "Reference" (/.format reference)
+   "Sample" (/.format sample)))
+
+(with_template [<test> <check> <type> <equivalence> <tag>]
+  [(def .public (<test> test)
+     (-> <type> (Parser Bit))
+     (do //.monad
+       [head ..any]
+       (case head
+         {<tag> value}
+         (in (at <equivalence> = test value))
+
+         _
+         (//.failure (exception.error ..unexpected_value [head])))))
+
+   (def .public (<check> test)
+     (-> <type> (Parser Any))
+     (do //.monad
+       [head ..any]
+       (case head
+         {<tag> value}
+         (if (at <equivalence> = test value)
+           (in [])
+           (//.failure (exception.error ..value_mismatch [{<tag> test} {<tag> value}])))
+
+         _
+         (//.failure (exception.error ..unexpected_value [head])))))]
+
+  [boolean? this_boolean /.Boolean bit.equivalence  /.#Boolean]
+  [number?  this_number  /.Number  frac.equivalence /.#Number]
+  [string?  this_string  /.String  text.equivalence /.#String]
+  )
+
+(def .public (nullable parser)
+  (All (_ a) (-> (Parser a) (Parser (Maybe a))))
+  (//.or ..null
+         parser))
+
+(def .public (array parser)
+  (All (_ a) (-> (Parser a) (Parser a)))
+  (do //.monad
+    [head ..any]
+    (case head
+      {/.#Array values}
+      (case (//.result parser (sequence.list values))
+        {try.#Failure error}
+        (//.failure error)
+
+        {try.#Success [remainder output]}
+        (case remainder
+          {.#End}
+          (in output)
+
+          _
+          (//.failure (exception.error ..unconsumed_input remainder))))
+
+      _
+      (//.failure (exception.error ..unexpected_value [head])))))
+
+(def .public (object parser)
+  (All (_ a) (-> (Parser a) (Parser a)))
+  (do //.monad
+    [head ..any]
+    (case head
+      {/.#Object kvs}
+      (case (|> kvs
+                dictionary.entries
+                (list#each (function (_ [key value])
+                             (list {/.#String key} value)))
+                list.together
+                (//.result parser))
+        {try.#Failure error}
+        (//.failure error)
+
+        {try.#Success [remainder output]}
+        (case remainder
+          {.#End}
+          (in output)
+
+          _
+          (//.failure (exception.error ..unconsumed_input remainder))))
+      
+      _
+      (//.failure (exception.error ..unexpected_value [head])))))
+
+(def .public (field field_name parser)
+  (All (_ a) (-> Text (Parser a) (Parser a)))
+  (function (again inputs)
+    (case inputs
+      (pattern (list.partial {/.#String key} value inputs'))
+      (if (text#= key field_name)
+        (case (//.result parser (list value))
+          {try.#Success [{.#End} output]}
+          {try.#Success [inputs' output]}
+
+          {try.#Success [inputs'' _]}
+          (exception.except ..unconsumed_input inputs'')
+
+          {try.#Failure error}
+          {try.#Failure error})
+        (do try.monad
+          [[inputs'' output] (again inputs')]
+          (in [(list.partial {/.#String key} value inputs'')
+               output])))
+
+      {.#End}
+      (exception.except ..empty_input [])
+
+      _
+      (exception.except ..unconsumed_input inputs))))
+
+(def .public dictionary
+  (All (_ a) (-> (Parser a) (Parser (Dictionary Text a))))
+  (|>> (//.and ..string)
+       //.some
+       ..object
+       (//#each (dictionary.of_list text.hash))))
diff --git a/stdlib/source/parser/lux/data/format/xml.lux b/stdlib/source/parser/lux/data/format/xml.lux
new file mode 100644
index 000000000..6b2ddf79c
--- /dev/null
+++ b/stdlib/source/parser/lux/data/format/xml.lux
@@ -0,0 +1,145 @@
+(.using
+ [library
+  [lux (.except)
+   [abstract
+    [monad (.only do)]]
+   [control
+    ["//" parser]
+    ["[0]" try (.only Try) (.open: "[1]#[0]" functor)]
+    ["[0]" exception (.only exception:)]]
+   [data
+    ["[0]" text
+     ["%" \\format (.only format)]]
+    [collection
+     ["[0]" list]
+     ["[0]" dictionary]]]
+   [meta
+    ["[0]" symbol (.open: "[1]#[0]" equivalence codec)]]]]
+ [\\library
+  ["[0]" / (.only Attribute Attrs Tag XML)]])
+
+(type: .public (Parser a)
+  (//.Parser [Attrs (List XML)] a))
+
+(exception: .public empty_input)
+(exception: .public unexpected_input)
+
+(exception: .public (wrong_tag [expected Tag
+                                actual Tag])
+  (exception.report
+   "Expected" (%.text (/.tag expected))
+   "Actual" (%.text (/.tag actual))))
+
+(exception: .public (unknown_attribute [expected Attribute
+                                        available (List Attribute)])
+  (exception.report
+   "Expected" (%.text (/.attribute expected))
+   "Available" (exception.listing (|>> /.attribute %.text) available)))
+
+(exception: .public (unconsumed_inputs [inputs (List XML)])
+  (exception.report
+   "Inputs" (exception.listing (at /.codec encoded) inputs)))
+
+(def (result' parser attrs documents)
+  (All (_ a) (-> (Parser a) Attrs (List XML) (Try a)))
+  (case (//.result parser [attrs documents])
+    {try.#Success [[attrs' remaining] output]}
+    (if (list.empty? remaining)
+      {try.#Success output}
+      (exception.except ..unconsumed_inputs remaining))
+    
+    {try.#Failure error}
+    {try.#Failure error}))
+
+(def .public (result parser documents)
+  (All (_ a) (-> (Parser a) (List XML) (Try a)))
+  (..result' parser /.attributes documents))
+
+(def .public text
+  (Parser Text)
+  (function (_ [attrs documents])
+    (case documents
+      {.#End}
+      (exception.except ..empty_input [])
+      
+      {.#Item head tail}
+      (case head
+        {/.#Text value}
+        {try.#Success [[attrs tail] value]}
+        
+        {/.#Node _}
+        (exception.except ..unexpected_input [])))))
+
+(def .public tag
+  (Parser Tag)
+  (function (_ [attrs documents])
+    (case documents
+      {.#End}
+      (exception.except ..empty_input [])
+      
+      {.#Item head _}
+      (case head
+        {/.#Text _}
+        (exception.except ..unexpected_input [])
+        
+        {/.#Node tag _ _}
+        {try.#Success [[attrs documents] tag]}))))
+
+(def .public (attribute name)
+  (-> Attribute (Parser Text))
+  (function (_ [attrs documents])
+    (case (dictionary.value name attrs)
+      {.#None}
+      (exception.except ..unknown_attribute [name (dictionary.keys attrs)])
+      
+      {.#Some value}
+      {try.#Success [[attrs documents] value]})))
+
+(def .public (node expected parser)
+  (All (_ a) (-> Tag (Parser a) (Parser a)))
+  (function (_ [attrs documents])
+    (case documents
+      {.#End}
+      (exception.except ..empty_input [])
+      
+      {.#Item head tail}
+      (case head
+        {/.#Text _}
+        (exception.except ..unexpected_input [])
+        
+        {/.#Node actual attrs' children}
+        (if (symbol#= expected actual)
+          (|> children
+              (..result' parser attrs')
+              (try#each (|>> [[attrs tail]])))
+          (exception.except ..wrong_tag [expected actual]))))))
+
+(def .public any
+  (Parser XML)
+  (function (_ [attrs documents])
+    (case documents
+      {.#End}
+      (exception.except ..empty_input [])
+      
+      {.#Item head tail}
+      {try.#Success [[attrs tail] head]})))
+
+(exception: .public nowhere)
+
+(def .public (somewhere parser)
+  (All (_ a) (-> (Parser a) (Parser a)))
+  (function (again [attrs input])
+    (case (//.result parser [attrs input])
+      {try.#Success [[attrs remaining] output]}
+      {try.#Success [[attrs remaining] output]}
+      
+      {try.#Failure error}
+      (case input
+        {.#End}
+        (exception.except ..nowhere [])
+        
+        {.#Item head tail}
+        (do try.monad
+          [[[attrs tail'] output] (again [attrs tail])]
+          (in [[attrs {.#Item head tail'}]
+               output]))))))