[mercury-users] crude libxml wrapper

[Michael Day]

Hi,

This is a crude libxml wrapper. It works for me. It may be useful to
someone, as it allows Mercury programs to parse XML files quicker than
they could possibly hope to do any other way. It could potentially be
extended to cover more of what libxml can offer, or given a cleaner
interface.

Is there any repository for crude code, not robust or useful enough to be
included in the extras distribution, but nonetheless potentially useful
for people if they knew it existed? extras/misc_crap perhaps?

Michael
-------------- next part --------------
:- module libxml.

:- interface.

:- import_module io, string, list, std_util.

:- type node.
:- type ns.

:- pred parse_file(string, maybe_error(node), io, io).
:- mode parse_file(in, out, di, uo) is det.

% Document
:- func get_root(node) = node is semidet.

% Node
:- func node_type(node) = int.
:- func get_name(node) = string.
:- func get_namespace(node) = ns is semidet.
:- func get_first_child(node) = node is semidet.
:- func get_last_child(node) = node is semidet.
:- func get_parent(node) = node is semidet.
:- func get_next_sibling(node) = node is semidet.
:- func get_prev_sibling(node) = node is semidet.
:- func get_document(node) = node.
:- func get_content(node) = string.
:- func get_first_attribute(node) = node is semidet.
:- func attributes(node) = list(node).
:- func children(node) = list(node).
:- func siblings(node) = list(node).

% Node types
:- func xml_document_node = int.
:- func xml_element_node = int.
:- func xml_attribute_node = int.
:- func xml_text_node = int.

% Namespace
:- func get_ns_href(ns) = string.

:- implementation.

:- import_module int.

:- type node
    --->    node(c_pointer).

:- type ns
    --->    ns(c_pointer).

:- pragma foreign_decl("C", "
#include <libxml/parser.h>
#include <libxml/tree.h>
#include <libxml/xmlmemory.h>
").

parse_file(FileName, Res) -->
    xml_parse_file(FileName, Res0, Doc),
    { if Res0 = 0 then
	Res = error("Could not parse")
    else
	Res = ok(Doc)
    }.

:- pred xml_parse_file(string, int, node, io, io).
:- mode xml_parse_file(in, out, out, di, uo) is det.

:- pragma foreign_proc("C", xml_parse_file(FileName::in, Res::out, Doc::out, IO0::di, IO::uo), [will_not_call_mercury, promise_pure], "
    
    assert(xmlMemSetup(GC_free, GC_malloc, GC_realloc, xmlStrdup) == 0);
    Doc = xmlParseFile(FileName);
    Res = Doc != NULL;
    IO = IO0;
").

attributes(Node) =
    ( if Attr = get_first_attribute(Node) then
	siblings(Attr)
    else
	[]
    ).

children(Node) =
    ( if Child = get_first_child(Node) then
	siblings(Child)
    else
	[]
    ).

siblings(Node) =
    ( if Sibling = get_next_sibling(Node) then
	[Node|siblings(Sibling)]
    else
	[Node]
    ).

:- pragma foreign_proc("C", get_root(Doc::in) = (Root::out),
	[will_not_call_mercury, promise_pure], "
    Root = xmlDocGetRootElement((xmlDocPtr)Doc);
    SUCCESS_INDICATOR = Root != 0;
").

:- pragma foreign_proc("C", get_name(Node::in) = (Name::out),
	[will_not_call_mercury, promise_pure], "
    Name = ((xmlNodePtr)Node)->name;
    assert(Name != NULL);
").

:- pragma foreign_proc("C", get_namespace(Node::in) = (Ns::out),
	[will_not_call_mercury, promise_pure], "
    Ns = ((xmlNodePtr)Node)->ns;
    SUCCESS_INDICATOR = Ns != 0;
").

:- pragma foreign_proc("C", get_first_child(Node::in) = (Child::out),
	[will_not_call_mercury, promise_pure], "
    Child = (MR_Word)((xmlNodePtr)Node)->children;
    SUCCESS_INDICATOR = Child != 0;
").

:- pragma foreign_proc("C", get_last_child(Node::in) = (Child::out),
	[will_not_call_mercury, promise_pure], "
    Child = (MR_Word)((xmlNodePtr)Node)->last;
    SUCCESS_INDICATOR = Child != 0;
").

:- pragma foreign_proc("C", get_parent(Node::in) = (Parent::out),
	[will_not_call_mercury, promise_pure], "
    Parent = (MR_Word)((xmlNodePtr)Node)->parent;
    SUCCESS_INDICATOR = Parent != 0;
").

:- pragma foreign_proc("C", get_next_sibling(Node::in) = (Sibling::out),
	[will_not_call_mercury, promise_pure], "
    Sibling = (MR_Word)((xmlNodePtr)Node)->next;
    SUCCESS_INDICATOR = Sibling != 0;
").

:- pragma foreign_proc("C", get_prev_sibling(Node::in) = (Sibling::out),
	[will_not_call_mercury, promise_pure], "
    Sibling = (MR_Word)((xmlNodePtr)Node)->prev;
    SUCCESS_INDICATOR = Sibling != 0;
").

:- pragma foreign_proc("C", get_document(Node::in) = (Doc::out),
	[will_not_call_mercury, promise_pure], "
    Doc = (MR_Word)((xmlNodePtr)Node)->doc;
").

:- pragma foreign_proc("C", get_content(Node::in) = (Content::out),
	[will_not_call_mercury, promise_pure], "
    Content = xmlNodeGetContent((xmlNodePtr)Node);
    assert(Content != NULL);
").

:- pragma foreign_proc("C", get_first_attribute(Node::in) = (Attr::out),
	[will_not_call_mercury, promise_pure], "
    Attr = (MR_Word)((xmlNodePtr)Node)->properties;
    SUCCESS_INDICATOR = Attr != 0;
").

:- pragma foreign_proc("C", node_type(Node::in) = (Type::out),
	[will_not_call_mercury, promise_pure], "
    Type = ((xmlNodePtr)Node)->type;
").

:- pragma foreign_proc("C", xml_document_node = (X::out),
	[will_not_call_mercury, promise_pure], "
    X = XML_DOCUMENT_NODE;
").

:- pragma foreign_proc("C", xml_element_node = (X::out),
	[will_not_call_mercury, promise_pure], "
    X = XML_ELEMENT_NODE;
").

:- pragma foreign_proc("C", xml_attribute_node = (X::out),
	[will_not_call_mercury, promise_pure], "
    X = XML_ATTRIBUTE_NODE;
").

:- pragma foreign_proc("C", xml_text_node = (X::out),
	[will_not_call_mercury, promise_pure], "
    X = XML_TEXT_NODE;
").

:- pragma foreign_proc("C", get_ns_href(Ns::in) = (Href::out),
	[will_not_call_mercury, promise_pure], "
    Href = ((xmlNsPtr)Ns)->href;
").