1 files changed, 142 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/control/parser/xml.lux b/stdlib/source/library/lux/control/parser/xml.lux
new file mode 100644
index 000000000..3fed4030e
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/xml.lux
@@ -0,0 +1,142 @@
+(.module:
+  [library
+   [lux #*
+    [abstract
+     [monad (#+ do)]]
+    [control
+     ["." try (#+ Try) ("#\." functor)]
+     ["." exception (#+ exception:)]]
+    [data
+     ["." name ("#\." equivalence codec)]
+     ["." text
+      ["%" format (#+ format)]]
+     [collection
+      ["." list]
+      ["." dictionary]]
+     [format
+      ["/" xml (#+ Attribute Attrs Tag XML)]]]]]
+  ["." //])
+
+(type: #export (Parser a)
+  (//.Parser [Attrs (List XML)] a))
+
+(exception: #export empty_input)
+(exception: #export unexpected_input)
+
+(exception: #export (wrong_tag {expected Tag} {actual Tag})
+  (exception.report
+   ["Expected" (%.text (/.tag expected))]
+   ["Actual" (%.text (/.tag actual))]))
+
+(exception: #export (unknown_attribute {expected Attribute} {available (List Attribute)})
+  (exception.report
+   ["Expected" (%.text (/.attribute expected))]
+   ["Available" (exception.enumerate (|>> /.attribute %.text) available)]))
+
+(exception: #export (unconsumed_inputs {inputs (List XML)})
+  (exception.report
+   ["Inputs" (exception.enumerate (\ /.codec encode) inputs)]))
+
+(def: (run' parser attrs documents)
+  (All [a] (-> (Parser a) Attrs (List XML) (Try a)))
+  (case (//.run parser [attrs documents])
+    (#try.Success [[attrs' remaining] output])
+    (if (list.empty? remaining)
+      (#try.Success output)
+      (exception.throw ..unconsumed_inputs remaining))
+    
+    (#try.Failure error)
+    (#try.Failure error)))
+
+(def: #export (run parser documents)
+  (All [a] (-> (Parser a) (List XML) (Try a)))
+  (..run' parser /.attributes documents))
+
+(def: #export text
+  (Parser Text)
+  (function (_ [attrs documents])
+    (case documents
+      #.Nil
+      (exception.throw ..empty_input [])
+      
+      (#.Cons head tail)
+      (case head
+        (#/.Text value)
+        (#try.Success [[attrs tail] value])
+        
+        (#/.Node _)
+        (exception.throw ..unexpected_input [])))))
+
+(def: #export tag
+  (Parser Tag)
+  (function (_ [attrs documents])
+    (case documents
+      #.Nil
+      (exception.throw ..empty_input [])
+      
+      (#.Cons head _)
+      (case head
+        (#/.Text _)
+        (exception.throw ..unexpected_input [])
+        
+        (#/.Node tag _ _)
+        (#try.Success [[attrs documents] tag])))))
+
+(def: #export (attribute name)
+  (-> Attribute (Parser Text))
+  (function (_ [attrs documents])
+    (case (dictionary.get name attrs)
+      #.None
+      (exception.throw ..unknown_attribute [name (dictionary.keys attrs)])
+      
+      (#.Some value)
+      (#try.Success [[attrs documents] value]))))
+
+(def: #export (node expected parser)
+  (All [a] (-> Tag (Parser a) (Parser a)))
+  (function (_ [attrs documents])
+    (case documents
+      #.Nil
+      (exception.throw ..empty_input [])
+      
+      (#.Cons head tail)
+      (case head
+        (#/.Text _)
+        (exception.throw ..unexpected_input [])
+        
+        (#/.Node actual attrs' children)
+        (if (name\= expected actual)
+          (|> children
+              (..run' parser attrs')
+              (try\map (|>> [[attrs tail]])))
+          (exception.throw ..wrong_tag [expected actual]))))))
+
+(def: #export ignore
+  (Parser Any)
+  (function (_ [attrs documents])
+    (case documents
+      #.Nil
+      (exception.throw ..empty_input [])
+      
+      (#.Cons head tail)
+      (#try.Success [[attrs tail] []]))))
+
+(exception: #export nowhere)
+
+(def: #export (somewhere parser)
+  (All [a] (-> (Parser a) (Parser a)))
+  (function (recur [attrs input])
+    (case (//.run parser [attrs input])
+      (#try.Success [[attrs remaining] output])
+      (#try.Success [[attrs remaining] output])
+      
+      (#try.Failure error)
+      (case input
+        #.Nil
+        (exception.throw ..nowhere [])
+        
+        (#.Cons head tail)
+        (do try.monad
+          [[[attrs tail'] output] (recur [attrs tail])]
+          (wrap [[attrs (#.Cons head tail')]
+                 output]))))))