FEATURE: XML DSL for creating xml documents safely.

std/tests/xml_test.ucg

@@ -0,0 +1,111 @@
+let xml = import "std/xml.ucg";
+let list = import "std/lists.ucg";
+
+let t = import "std/testing.ucg";
+
+let simple_name = "simple";
+let simple_tag = xml.tag{name=simple_name};
+
+assert t.equal{
+    left = simple_tag.name,
+    right = simple_name,
+};
+
+assert t.equal{
+    left = simple_tag.attrs,
+    right = {},
+};
+
+assert t.equal{
+    left = simple_tag.children,
+    right = [],
+};
+
+assert t.ok{
+    test = not ("ns" in simple_tag),
+    desc = "@ has no ns field" % (simple_tag),
+};
+
+let myns = xml.ns("myns", NULL);
+let simple_tag_ns = xml.tag{name=simple_name, ns=myns};
+
+assert t.ok{
+    test = xml.validate_ns(myns),
+    desc = "@ is a valid namespace" % (myns),
+};
+
+assert t.equal{
+    left = simple_tag_ns.ns,
+    right = myns,
+};
+
+let cplxns = xml.ns(myns, "http://example.com/");
+let cplx_tag_ns = xml.tag{name=simple_name, ns=cplxns};
+
+assert t.ok{
+    test = xml.validate_ns(cplxns),
+    desc = "@ is a valid namespace" % (cplxns),
+};
+
+assert t.equal{
+    left = cplx_tag_ns.ns,
+    right = cplxns,
+};
+
+let invalidns = {prefix="foons", url=""};
+
+assert t.not_ok{
+    test = xml.validate_ns(invalidns),
+    desc = "@ is not a valid namespace" % (invalidns),
+};
+
+assert t.ok{
+    test = xml.validate_node("simple text"),
+    desc = "@ is a valid node" % ("simple text"),
+};
+
+assert t.ok{
+    test = xml.is_tag({name="simple"}),
+    desc = "@ is a valid tag" % ({name="simple"}),
+};
+
+assert t.ok{
+    test = xml.validate_node({name="simple"}),
+    desc = "@ is a valid node" % ({name="simple"}),
+};
+
+assert t.ok{
+    test = xml.validate_node(simple_tag),
+    desc = "@ is a valid tag" % (simple_tag),
+};
+
+assert t.ok{
+    test = xml.validate_node(cplx_tag_ns),
+    desc = "@ is a valid tag" % (cplx_tag_ns),
+};
+
+let doc = xml.doc(cplx_tag_ns);
+
+assert t.equal{
+    left = doc.root,
+    right = cplx_tag_ns,
+};
+
+let cplx_tag_children = xml.tag{name=simple_name, children=[simple_tag]};
+
+assert t.equal{
+    left = cplx_tag_children.children.0,
+    right = simple_tag,
+};
+
+assert t.equal{
+    left = list.ops{list=cplx_tag_children.children}.len,
+    right = 1,
+};
+
+let cplx_tag_attrs = xml.tag{name=simple_name, attrs={id="myid"}};
+
+assert t.equal{
+    left = cplx_tag_attrs.attrs.id,
+    right = "myid",
+};

std/xml.ucg

@@ -0,0 +1,53 @@
+
+let schema = import "std/schema.ucg";
+
+// Validates that a namespace is the right shape for an xml tag or document.
+let validate_ns = func(ns) => schema.any{val=ns, types=["", {prefix="", uri=""}]};
+
+// Constructs an xml namespace for use in an xml tag or document root.
+// Use NULL for the uri argument to use just the prefix.
+let ns = func(prefix, uri) => select uri != NULL, {
+    true = {
+        prefix = prefix,
+        uri = uri,
+    },
+    false = prefix,
+};
+
+let tag = module{
+    name = NULL,
+    attrs = {},
+    children = [],
+    ns = NULL,
+} => (result) {
+    let schema = import "std/schema.ucg";
+    let pkg = mod.pkg();
+
+    (mod.name != NULL) || fail "XML Tag names must have a name";
+    let base = {
+        name = mod.name,
+        attrs = mod.attrs,
+        children = mod.children,
+    };
+
+    let result = select mod.ns == NULL, {
+        true = base,
+        false = select pkg.validate_ns(mod.ns), {
+           true = base{ns=mod.ns},
+           false = fail "XML Tag namespaces must be a string or tuple of {prefix=, uri=} but is @" % (mod.ns),
+        },
+    };
+};
+
+// returns true for a valid tag.
+let is_tag = func(t) => schema.shaped{val=t, shape={name=""}, partial=true};
+
+// validates that a node is either a valid tag or a text node.
+let validate_node = func(node) => schema.any{val=node, types=["", {name = ""}], partial=true};
+
+let doc = func(root) => select validate_node(root), {
+    true = {
+        root = root,
+    },
+    false = fail "The document root must be a valid xml tag but instead is @" % (root),
+};