aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/library/lux/control/parser/xml.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/library/lux/control/parser/xml.lux')
-rw-r--r--stdlib/source/library/lux/control/parser/xml.lux142
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]))))))