aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/control/parser/xml.lux128
-rw-r--r--stdlib/source/lux/data/format/xml.lux190
-rw-r--r--stdlib/source/test/lux/data/format/xml.lux23
3 files changed, 179 insertions, 162 deletions
diff --git a/stdlib/source/lux/control/parser/xml.lux b/stdlib/source/lux/control/parser/xml.lux
new file mode 100644
index 000000000..a2ae5dbec
--- /dev/null
+++ b/stdlib/source/lux/control/parser/xml.lux
@@ -0,0 +1,128 @@
+(.module:
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [data
+ ["." error (#+ Error)]
+ ["." name ("#@." equivalence codec)]
+ ["." text ("#@." monoid)]
+ [collection
+ ["." list ("#@." functor)]
+ ["." dictionary]]
+ [format
+ ["/" xml (#+ XML)]]]]
+ ["." //])
+
+(type: #export (Parser a)
+ (//.Parser (List XML) a))
+
+(exception: #export empty-input)
+(exception: #export unexpected-input)
+(exception: #export unknown-attribute)
+
+(exception: #export (wrong-tag {tag Name})
+ (exception.report
+ ["Tag" (name@encode tag)]))
+
+(def: blank-line ($_ text@compose text.new-line text.new-line))
+
+(exception: #export (unconsumed-inputs {inputs (List XML)})
+ (|> inputs
+ (list@map (:: /.codec encode))
+ (text.join-with blank-line)))
+
+(def: #export text
+ (Parser Text)
+ (function (_ docs)
+ (case docs
+ #.Nil
+ (exception.throw empty-input [])
+
+ (#.Cons head tail)
+ (case head
+ (#/.Text value)
+ (#error.Success [tail value])
+
+ (#/.Node _)
+ (exception.throw unexpected-input [])))))
+
+(def: #export (attr name)
+ (-> Name (Parser Text))
+ (function (_ docs)
+ (case docs
+ #.Nil
+ (exception.throw empty-input [])
+
+ (#.Cons head _)
+ (case head
+ (#/.Text _)
+ (exception.throw unexpected-input [])
+
+ (#/.Node tag attrs children)
+ (case (dictionary.get name attrs)
+ #.None
+ (exception.throw unknown-attribute [])
+
+ (#.Some value)
+ (#error.Success [docs value]))))))
+
+(def: (run' docs reader)
+ (All [a] (-> (List XML) (Parser a) (Error a)))
+ (case (//.run docs reader)
+ (#error.Success [remaining output])
+ (if (list.empty? remaining)
+ (#error.Success output)
+ (exception.throw unconsumed-inputs remaining))
+
+ (#error.Failure error)
+ (#error.Failure error)))
+
+(def: #export (node tag)
+ (-> Name (Parser Any))
+ (function (_ docs)
+ (case docs
+ #.Nil
+ (exception.throw empty-input [])
+
+ (#.Cons head _)
+ (case head
+ (#/.Text _)
+ (exception.throw unexpected-input [])
+
+ (#/.Node _tag _attrs _children)
+ (if (name@= tag _tag)
+ (#error.Success [docs []])
+ (exception.throw wrong-tag tag))))))
+
+(def: #export (children reader)
+ (All [a] (-> (Parser a) (Parser a)))
+ (function (_ docs)
+ (case docs
+ #.Nil
+ (exception.throw empty-input [])
+
+ (#.Cons head tail)
+ (case head
+ (#/.Text _)
+ (exception.throw unexpected-input [])
+
+ (#/.Node _tag _attrs _children)
+ (do error.monad
+ [output (run' _children reader)]
+ (wrap [tail output]))))))
+
+(def: #export ignore
+ (Parser Any)
+ (function (_ docs)
+ (case docs
+ #.Nil
+ (exception.throw empty-input [])
+
+ (#.Cons head tail)
+ (#error.Success [tail []]))))
+
+(def: #export (run document reader)
+ (All [a] (-> XML (Parser a) (Error a)))
+ (run' (list document) reader))
diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux
index 515243f6b..bd4fef488 100644
--- a/stdlib/source/lux/data/format/xml.lux
+++ b/stdlib/source/lux/data/format/xml.lux
@@ -1,28 +1,27 @@
-(.module: {#.doc "Functionality for reading, generating and processing values in the XML format."}
+(.module:
[lux #*
[abstract
- monad
+ [monad (#+ do)]
[equivalence (#+ Equivalence)]
- codec]
+ [codec (#+ Codec)]]
[control
- ["p" parser ("#;." monad)
- ["l" text (#+ Parser)]]
- ["ex" exception (#+ exception:)]]
+ ["p" parser ("#@." monad)
+ ["l" text (#+ Parser)]]]
[data
- ["." error (#+ Error)]
+ [error (#+ Error)]
["." product]
- ["." name ("#;." equivalence codec)]
+ ["." name ("#@." equivalence codec)]
[number
["." int]]
- ["." text ("#;." equivalence monoid)]
+ ["." text ("#@." equivalence monoid)]
[collection
- ["." list ("#;." monad)]
- ["d" dictionary]]]])
+ ["." list ("#@." functor)]
+ ["." dictionary (#+ Dictionary)]]]])
(type: #export Tag Name)
-(type: #export Attrs (d.Dictionary Name Text))
+(type: #export Attrs (Dictionary Name Text))
-(def: #export attrs Attrs (d.new name.hash))
+(def: #export attrs Attrs (dictionary.new name.hash))
(type: #export #rec XML
(#Text Text)
@@ -31,11 +30,11 @@
(def: xml-standard-escape-char^
(Parser Text)
($_ p.either
- (p.after (l.this "&lt;") (p;wrap "<"))
- (p.after (l.this "&gt;") (p;wrap ">"))
- (p.after (l.this "&amp;") (p;wrap "&"))
- (p.after (l.this "&apos;") (p;wrap "'"))
- (p.after (l.this "&quot;") (p;wrap text.double-quote))))
+ (p.after (l.this "&lt;") (p@wrap "<"))
+ (p.after (l.this "&gt;") (p@wrap ">"))
+ (p.after (l.this "&amp;") (p@wrap "&"))
+ (p.after (l.this "&apos;") (p@wrap "'"))
+ (p.after (l.this "&quot;") (p@wrap text.double-quote))))
(def: xml-unicode-escape-char^
(Parser Text)
@@ -58,7 +57,7 @@
(def: xml-char^
(Parser Text)
- (p.either (l.none-of ($_ text;compose "<>&'" text.double-quote))
+ (p.either (l.none-of ($_ text@compose "<>&'" text.double-quote))
xml-escape-char^))
(def: xml-identifier
@@ -68,7 +67,7 @@
l.alpha)
tail (l.some (p.either (l.one-of "_.-")
l.alpha-num))]
- (wrap ($_ text;compose head tail))))
+ (wrap ($_ text@compose head tail))))
(def: namespaced-symbol^
(Parser Name)
@@ -99,7 +98,7 @@
(def: attrs^
(Parser Attrs)
- (<| (:: p.monad map (d.from-list name.hash))
+ (<| (:: p.monad map (dictionary.from-list name.hash))
p.some
(p.and (spaced^ attr-name^))
(p.after (l.this "="))
@@ -112,10 +111,10 @@
spaced^
(p.after (l.this "/"))
(l.enclosed ["<" ">"]))]
- (p.assert ($_ text;compose "Close tag does not match open tag." text.new-line
- "Expected: " (name;encode expected) text.new-line
- " Actual: " (name;encode actual) text.new-line)
- (name;= expected actual))))
+ (p.assert ($_ text@compose "Close tag does not match open tag." text.new-line
+ "Expected: " (name@encode expected) text.new-line
+ " Actual: " (name@encode actual) text.new-line)
+ (name@= expected actual))))
(def: comment^
(Parser Text)
@@ -143,7 +142,7 @@
(Parser XML)
(|> (p.either cdata^
(l.many xml-char^))
- (p;map (|>> #Text))))
+ (p@map (|>> #Text))))
(def: xml^
(Parser XML)
@@ -189,23 +188,23 @@
(-> Tag Text)
(case namespace
"" name
- _ ($_ text;compose namespace ":" name)))
+ _ ($_ text@compose namespace ":" name)))
(def: (write-attrs attrs)
(-> Attrs Text)
(|> attrs
- d.entries
- (list;map (function (_ [key value])
- ($_ text;compose (write-tag key) "=" text.double-quote (sanitize-value value) text.double-quote)))
+ dictionary.entries
+ (list@map (function (_ [key value])
+ ($_ text@compose (write-tag key) "=" text.double-quote (sanitize-value value) text.double-quote)))
(text.join-with " ")))
(def: xml-header
Text
- ($_ text;compose "<?xml version=" text.double-quote "1.0" text.double-quote " encoding=" text.double-quote "UTF-8" text.double-quote "?>"))
+ ($_ text@compose "<?xml version=" text.double-quote "1.0" text.double-quote " encoding=" text.double-quote "UTF-8" text.double-quote "?>"))
(def: #export (write input)
(-> XML Text)
- ($_ text;compose xml-header
+ ($_ text@compose xml-header
(loop [input input]
(case input
(#Text value)
@@ -213,14 +212,14 @@
(#Node xml-tag xml-attrs xml-children)
(let [tag (write-tag xml-tag)
- attrs (if (d.empty? xml-attrs)
+ attrs (if (dictionary.empty? xml-attrs)
""
- ($_ text;compose " " (write-attrs xml-attrs)))]
+ ($_ text@compose " " (write-attrs xml-attrs)))]
(if (list.empty? xml-children)
- ($_ text;compose "<" tag attrs "/>")
- ($_ text;compose "<" tag attrs ">"
+ ($_ text@compose "<" tag attrs "/>")
+ ($_ text@compose "<" tag attrs ">"
(|> xml-children
- (list;map recur)
+ (list@map recur)
(text.join-with ""))
"</" tag ">")))))))
@@ -232,12 +231,12 @@
(def: (= reference sample)
(case [reference sample]
[(#Text reference/value) (#Text sample/value)]
- (text;= reference/value sample/value)
+ (text@= reference/value sample/value)
[(#Node reference/tag reference/attrs reference/children)
(#Node sample/tag sample/attrs sample/children)]
- (and (name;= reference/tag sample/tag)
- (:: (d.equivalence text.equivalence) = reference/attrs sample/attrs)
+ (and (name@= reference/tag sample/tag)
+ (:: (dictionary.equivalence text.equivalence) = reference/attrs sample/attrs)
(n/= (list.size reference/children)
(list.size sample/children))
(|> (list.zip2 reference/children sample/children)
@@ -245,114 +244,3 @@
_
#0)))
-
-(type: #export (Reader a)
- (p.Parser (List XML) a))
-
-(exception: #export empty-input)
-(exception: #export unexpected-input)
-(exception: #export unknown-attribute)
-
-(exception: #export (wrong-tag {tag Name})
- (name;encode tag))
-
-(def: blank-line ($_ text;compose text.new-line text.new-line))
-
-(exception: #export (unconsumed-inputs {inputs (List XML)})
- (|> inputs
- (list;map (:: ..codec encode))
- (text.join-with blank-line)))
-
-(def: #export text
- (Reader Text)
- (function (_ docs)
- (case docs
- #.Nil
- (ex.throw empty-input [])
-
- (#.Cons head tail)
- (case head
- (#Text value)
- (#error.Success [tail value])
-
- (#Node _)
- (ex.throw unexpected-input [])))))
-
-(def: #export (attr name)
- (-> Name (Reader Text))
- (function (_ docs)
- (case docs
- #.Nil
- (ex.throw empty-input [])
-
- (#.Cons head _)
- (case head
- (#Text _)
- (ex.throw unexpected-input [])
-
- (#Node tag attrs children)
- (case (d.get name attrs)
- #.None
- (ex.throw unknown-attribute [])
-
- (#.Some value)
- (#error.Success [docs value]))))))
-
-(def: (run' docs reader)
- (All [a] (-> (List XML) (Reader a) (Error a)))
- (case (p.run docs reader)
- (#error.Success [remaining output])
- (if (list.empty? remaining)
- (#error.Success output)
- (ex.throw unconsumed-inputs remaining))
-
- (#error.Failure error)
- (#error.Failure error)))
-
-(def: #export (node tag)
- (-> Name (Reader Any))
- (function (_ docs)
- (case docs
- #.Nil
- (ex.throw empty-input [])
-
- (#.Cons head _)
- (case head
- (#Text _)
- (ex.throw unexpected-input [])
-
- (#Node _tag _attrs _children)
- (if (name;= tag _tag)
- (#error.Success [docs []])
- (ex.throw wrong-tag tag))))))
-
-(def: #export (children reader)
- (All [a] (-> (Reader a) (Reader a)))
- (function (_ docs)
- (case docs
- #.Nil
- (ex.throw empty-input [])
-
- (#.Cons head tail)
- (case head
- (#Text _)
- (ex.throw unexpected-input [])
-
- (#Node _tag _attrs _children)
- (do error.monad
- [output (run' _children reader)]
- (wrap [tail output]))))))
-
-(def: #export ignore
- (Reader Any)
- (function (_ docs)
- (case docs
- #.Nil
- (ex.throw empty-input [])
-
- (#.Cons head tail)
- (#error.Success [tail []]))))
-
-(def: #export (run document reader)
- (All [a] (-> XML (Reader a) (Error a)))
- (run' (list document) reader))
diff --git a/stdlib/source/test/lux/data/format/xml.lux b/stdlib/source/test/lux/data/format/xml.lux
index cf2b10f65..48ca29d92 100644
--- a/stdlib/source/test/lux/data/format/xml.lux
+++ b/stdlib/source/test/lux/data/format/xml.lux
@@ -10,7 +10,8 @@
["$." codec]]}]
[control
pipe
- ["p" parser]]
+ ["p" parser
+ ["</>" xml]]]
[data
["." name]
["E" error]
@@ -84,28 +85,28 @@
(_.test "Can parse text."
(E.default #0
(do E.monad
- [output (/.run (#/.Text text)
- /.text)]
+ [output (</>.run (#/.Text text)
+ </>.text)]
(wrap (text@= text output)))))
(_.test "Can parse attributes."
(E.default #0
(do E.monad
- [output (|> (/.attr attr)
- (p.before /.ignore)
- (/.run node))]
+ [output (|> (</>.attr attr)
+ (p.before </>.ignore)
+ (</>.run node))]
(wrap (text@= value output)))))
(_.test "Can parse nodes."
(E.default #0
(do E.monad
- [_ (|> (/.node tag)
- (p.before /.ignore)
- (/.run node))]
+ [_ (|> (</>.node tag)
+ (p.before </>.ignore)
+ (</>.run node))]
(wrap #1))))
(_.test "Can parse children."
(E.default #0
(do E.monad
- [outputs (|> (/.children (p.some /.text))
- (/.run node))]
+ [outputs (|> (</>.children (p.some </>.text))
+ (</>.run node))]
(wrap (:: (list.equivalence text.equivalence) =
children
outputs)))))