packages feed

hexml (empty) → 0.1

raw patch · 9 files changed

+992/−0 lines, 9 filesdep +basedep +bytestringdep +extrasetup-changed

Dependencies added: base, bytestring, extra, hexml

Files

+ CHANGES.txt view
@@ -0,0 +1,4 @@+Changelog for Hexml++0.1+    Initial version
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2016.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Neil Mitchell nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,11 @@+# Hexml [![Hackage version](https://img.shields.io/hackage/v/hexml.svg?label=Hackage)](https://hackage.haskell.org/package/hexml) [![Stackage version](https://www.stackage.org/package/hexml/badge/lts?label=Stackage)](https://www.stackage.org/package/hexml) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/hexml.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/hexml) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/hexml.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/hexml)++An XML DOM-style parser, that only parses a subset of XML, but is designed to be fast. In particular:++* Entities, e.g. `&amp;`, are not expanded.+* Not all the validity conditions are checked.+* No support for `<!DOCTYPE` related features.++The name "hexml" is a combination of "Hex" (a curse) and "XML". The "X" should not be capitalised because the parser is more curse and less XML.++Hexml may be suitable if you want to quickly parse XML, from known sources, and a full XML parser has been shown to be a bottleneck. As an alternative to hexml, which supports things like entities but is still pretty fast, see Pugixml.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/hexml.c view
@@ -0,0 +1,548 @@+#include "hexml.h"+#include <malloc.h>+#include <string.h>+#include <assert.h>+#include <ctype.h>+#include <stdio.h>++typedef int bool;++/////////////////////////////////////////////////////////////////////+// TYPES++int static inline end(str s) { return s.start + s.length; }++str static inline start_length(int32_t start, int32_t length)+{+    if (start < 0 || length < 0) assert(0);+    str res;+    res.start = start;+    res.length = length;+    return res;+}++str static inline start_end(int32_t start, int32_t end)+{+    return start_length(start, end - start);+}++typedef struct+{+    int size;+    int used;+    attr* attrs; // dynamically allocated buffer+    attr* alloc; // what to call free on+} attr_buffer;++typedef struct+{+    // have a cursor at the front, which is all the stuff I have written out, final+    // have a cursor at the end, which is stack scoped, so children write out, then I do+    // when you commit, you copy over from end to front++    // nodes +    int size;+    int used_front; // front entries, stored for good+    int used_back; // back entries, stack based, copied into front+    node* nodes; // dynamically allocated buffer+    node* alloc; // what to call free on+} node_buffer;+++struct document+{+    char* body; // pointer to initial argument, not owned by us++    // things only used while parsing+    char* cursor; // pointer to where we are in body+    char* end; // pointer to one past the last char+    // if cursor is > end we have gone past the end++    char* error_message;+    node_buffer nodes;+    attr_buffer attrs;+};++int static inline doc_length(document* d) { return (int) (d->end - d->body); }+int static inline doc_position(document* d) { return (int) (d->cursor - d->body); }+++/////////////////////////////////////////////////////////////////////+// RENDER CODE++typedef struct+{+    document* d;+    char* buffer;+    int length;+    int cursor;+} render;++void static inline render_char(render* r, char c)+{+    if (r->cursor < r->length)+        r->buffer[r->cursor] = c;+    r->cursor++;+}++void static inline bound(char* msg, int index, int mn, int mx)+{+    if (index < mn || index > mx)+    {+        //printf("Bounds checking failed %s, got %i, which should be in %i:%i\n", msg, index, mn, mx);+        assert(0);+    }+}++void static inline bound_str(char* msg, str s, int mn, int mx)+{+    if (s.length < 0) assert(0);+    bound(msg, s.start, mn, mx);+    bound(msg, end(s), mn, mx);+}++void render_str(render* r, str s)+{+    bound_str("render_str", s, 0, doc_length(r->d));+    for (int i = 0; i < s.length; i++)+        render_char(r, r->d->body[s.start + i]);+}++void render_tag(render* r, node* n);++void render_content(render* r, node* n)+{+    bound_str("render_conent inner", n->inner, 0, doc_length(r->d));+    bound_str("render_conent nodes", n->nodes, 0, r->d->nodes.used_front);+    bound_str("render_conent attrs", n->attrs, 0, r->d->attrs.used);++    int done = n->inner.start;+    for (int i = 0; i < n->nodes.length; i++)+    {+        node* x = &r->d->nodes.nodes[n->nodes.start + i];+        render_str(r, start_end(done, x->outer.start));+        done = end(x->outer);+        render_tag(r, x);+    }+    render_str(r, start_end(done, end(n->inner)));+}++void render_tag(render* r, node* n)+{+    render_char(r, '<');+    render_str(r, n->name);+    for (int i = 0; i < n->attrs.length; i++)+    {+        attr* x = &r->d->attrs.attrs[n->attrs.start + i];+        render_char(r, ' ');+        render_str(r, x->name);+        render_char(r, '=');+        render_char(r, '\"');+        render_str(r, x->value);+        render_char(r, '\"');+    }+    render_char(r, '>');+    render_content(r, n);+    render_char(r, '<');+    render_char(r, '/');+    render_str(r, n->name);+    render_char(r, '>');+}++int node_render(document* d, node* n, char* buffer, int length)+{+    render r;+    r.d = d;+    r.buffer = buffer;+    r.length = length;+    r.cursor = 0;+    // The root node (and only the root node) has an empty length, so just render its innards+    if (n->name.length == 0)+        render_content(&r, n);+    else+        render_tag(&r, n);+    return r.cursor;+}+++/////////////////////////////////////////////////////////////////////+// NOT THE PARSER++char* document_error(document* d){return d->error_message;}+node* document_node(document* d){return &d->nodes.nodes[0];}++void document_free(document* d)+{+    free(d->error_message);+    free(d->nodes.alloc);+    free(d->attrs.alloc);+    free(d);+}++node* node_children(document* d, node* n, int* res)+{+    *res = n->nodes.length;+    return &d->nodes.nodes[n->nodes.start];+}++attr* node_attributes(document* d, node* n, int* res)+{+    *res = n->attrs.length;+    return &d->attrs.attrs[n->attrs.start];+}+++attr* node_attributeBy(document* d, node* n, char* s, int slen)+{+    if (slen == -1) slen = (int) strlen(s);+    const int limit = end(n->attrs);+    for (int i = n->attrs.start; i < limit; i++)+    {+        attr* r = &d->attrs.attrs[i];+        if (r->name.length == slen && memcmp(s, &d->body[r->name.start], slen) == 0)+            return r;+    }+    return NULL;+}++// Search for given strings within a node+node* node_childBy(document* d, node* parent, node* prev, char* s, int slen)+{+    if (slen == -1) slen = (int) strlen(s);+    int i = prev == NULL ? parent->nodes.start : (int) (prev + 1 - d->nodes.nodes);+    const int limit = end(parent->nodes);+    for (; i < limit; i++)+    {+        node* r = &d->nodes.nodes[i];+        if (r->name.length == slen && memcmp(s, &d->body[r->name.start], slen) == 0)+            return r;+    }+    return NULL;+}+++/////////////////////////////////////////////////////////////////////+// PARSE TABLE++const char tag_name1 = 0x1;+const char tag_name = 0x2;+const char tag_space = 0x4;++char parse_table[256];++void init_parse_table()+{+    static bool done = 0;+    if (done) return;+    for (int i = 0; i < 256; i++)+    {+        bool name1 = i == ':' || i == '_' || (i >= 'a' && i <= 'z') || (i >= 'A' && i <= 'Z');+        bool name = name1 || i == '-' || (i >= '0' && i <= '9');+        bool space = i == ' ' || i == '\t' || i == '\r' || i == '\n';+        parse_table[i] = (name1 ? tag_name1 : 0) | (name ? tag_name : 0) | (space ? tag_space : 0);+    }+    done = 1;+}++bool static inline is(char c, char tag) { return parse_table[c] & tag; }+bool static inline is_name1(char c) { return is(c, tag_name1); }+bool static inline is_name(char c) { return is(c, tag_name); }+bool static inline is_space(char c) { return is(c, tag_space); }+++/////////////////////////////////////////////////////////////////////+// PARSER COMBINATORS++char static inline peekAt(document* d, int i) { return d->cursor[i]; }+void static inline skip(document* d, int i) { d->cursor += i; }+char static inline peek(document* d) { return peekAt(d, 0); }+char static inline get(document* d) { char c = peek(d); skip(d, 1); return c; }++// Remove whitespace characters from the cursor while they are still whitespace+void static inline trim(document* d)+{+    while (is_space(peek(d)))+        skip(d, 1);+}++// Find this character form the cursor onwards, if true adjust the cursor to that char, otherwise leave it at the end+bool find(document* d, char c)+{+    char* x = memchr(d->cursor, c, d->end - d->cursor);+    if (x == NULL)+    {+        d->cursor = d->end;+        return 0;+    }+    else+    {+        d->cursor = x;+        return 1;+    }+}+++/////////////////////////////////////////////////////////////////////+// PARSING CODE++void static inline node_alloc(node_buffer* b, int ask)+{+    int space = b->size - b->used_back - b->used_front;+    if (space >= ask) return;+    int size2 = (b->size + 1000 + ask) * 2;+    node* buf2 = malloc(size2 * sizeof(node));+    assert(buf2);+    memcpy(buf2, b->nodes, b->used_front * sizeof(node));+    memcpy(&buf2[size2 - b->used_back], &b->nodes[b->size - b->used_back], b->used_back * sizeof(node));+    free(b->alloc);+    b->size = size2;+    b->nodes = buf2;+    b->alloc = buf2;+}++void static inline attr_alloc(attr_buffer* b, int ask)+{+    int space = b->size - b->used;+    if (space >= ask) return;+    int size2 = (b->size + 1000 + ask) * 2;+    attr* buf2 = malloc(size2 * sizeof(attr));+    assert(buf2);+    memcpy(buf2, b->attrs, b->used * sizeof(attr));+    free(b->alloc);+    b->size = size2;+    b->attrs = buf2;+    b->alloc = buf2;+}++void set_error(document* d, char* msg)+{+    if (d->error_message != NULL) return; // keep the first error message+    d->error_message = malloc(strlen(msg)+1);+    assert(d->error_message);+    strcpy(d->error_message, msg);+}++// you now expect a name, perhaps preceeded by whitespace+// the name may be empty+str static inline parse_name(document* d)+{+    int start = doc_position(d);+    if (!is_name1(peek(d)))+        return start_length(start, 0);+    skip(d, 1);+    while (is_name(peek(d)))+        skip(d, 1);+    return start_end(start, doc_position(d));+}++str static inline parse_attrval(document* d)+{+    trim(d);+    if (get(d) != '=')+    {+        set_error(d, "Expected = in attribute, but missing");+        return start_length(0, 0);+    }+    trim(d);+    char c = peek(d);+    if (c == '\"' || c == '\'')+    {+        skip(d, 1);+        int start = doc_position(d);+        if (!find(d, c))+        {+            set_error(d, "Couldn't find closing attribute bit");+            return start_length(0, 0);+        }+        skip(d, 1);+        return start_end(start, doc_position(d) - 1);+    }+    else+    {+        set_error(d, "Invalid attribute");+        return start_length(0, 0);+    }+}++++// seen a tag name, now looking for attributes terminated by >+// puts the attributes it finds in the attribute buffer+str static inline parse_attributes(document* d)+{+    int start = d->attrs.used;+    for (int i = 0; ; i++)+    {+        trim(d);+        str name = parse_name(d);+        if (name.length == 0) break;+        attr_alloc(&d->attrs, 1);+        d->attrs.attrs[d->attrs.used].name = name;+        d->attrs.attrs[d->attrs.used].value = parse_attrval(d);+        d->attrs.used++;+    }+    return start_end(start, d->attrs.used);+}++str parse_content(document* d);+++// Add a new entry into tag, am at a '<'+void static inline parse_tag(document* d)+{+    node_alloc(&d->nodes, 1);+    d->nodes.used_back++;+    node* me = &d->nodes.nodes[d->nodes.size - d->nodes.used_back];++    me->outer.start = doc_position(d);+    char c = get(d);+    assert(c == '<');+    if (peek(d) == '?') skip(d, 1);+    me->name = parse_name(d);+    me->attrs = parse_attributes(d);++    c = get(d);+    if ((c == '/' || c == '?') && peek(d) == '>')+    {+        skip(d, 1);+        me->nodes = start_length(0, 0);+        me->outer.length = start_end(me->outer.start, doc_position(d)).length;+        me->inner = start_length(doc_position(d), 0);+        return;+    }+    else if (c != '>')+    {+        set_error(d, "Gunk at the end of the tag");+        return;+    }+    me->inner.start = doc_position(d);+    str content = parse_content(d);++    // parse_content may have allocated more nodes, so recompute me+    me = &d->nodes.nodes[d->nodes.size - d->nodes.used_back];+    me->nodes = content;+    me->inner.length = start_end(me->inner.start, doc_position(d)).length;++    if (d->error_message != NULL) return;+    if (peek(d) == '<' && peekAt(d, 1) == '/')+    {+        skip(d, 2);+        if (d->end - d->cursor >= me->name.length &&+            memcmp(d->cursor, &d->body[me->name.start], me->name.length) == 0)+        {+            skip(d, me->name.length);+            trim(d);+            if (get(d) == '>')+            {+                me->outer.length = start_end(me->outer.start, doc_position(d)).length;+                return;+            }+        }+        set_error(d, "Mismatch in closing tags");+        return;+    }+    set_error(d, "Weirdness when trying to close tags");+}++// Parser until </, return the index of your node children+// Not inline as it is recursive+str parse_content(document* d)+{+    int before = d->nodes.used_back;+    while (d->error_message == NULL)+    {+        // only < can have any impact+        if (!find(d, '<'))+        {+            break;+        }+        else if (peekAt(d, 1) == '/')+        {+            // have found a </+            break;+        }+        else if (peekAt(d, 1) == '!' && peekAt(d, 2) == '-' && peekAt(d, 3) == '-')+        {+            skip(d, 3);+            // you can't reuse the two '-' characters for the closing as well+            if (peekAt(d, 0) == '\0' || peekAt(d, 1) == '\0')+            {+                set_error(d, "Didn't get a closing comment");+                return start_end(0, 0);+            }+            skip(d, 2);+            while (1)+            {+                if (!find(d, '>'))+                {+                    set_error(d, "Didn't get a closing comment");+                    return start_end(0, 0);+                }+                skip(d, 1);+                if (peekAt(d, -3) == '-' && peekAt(d, -2))+                    break;+            }+        }+        else+        {+            parse_tag(d);+        }+    }+    int diff = d->nodes.used_back - before;+    node_alloc(&d->nodes, diff);+    str res = start_length(d->nodes.used_front, diff);+    for (int i = 0; i < diff; i++)+        d->nodes.nodes[d->nodes.used_front + i] = d->nodes.nodes[d->nodes.size - d->nodes.used_back + diff - 1 - i];+    d->nodes.used_front += diff;+    d->nodes.used_back -= diff;+    return res;+}++// Based on looking at ~50Kb XML documents, they seem to have ~700 attributes+// and ~300 nodes, so size appropriately to cope with that.+typedef struct+{+    document document;+    attr attrs[1000];+    node nodes[500];+} buffer;++document* document_parse(char* s, int slen)+{+    if (slen == -1) slen = (int) strlen(s);+    assert(s[slen] == 0);+    init_parse_table();++    buffer* buf = malloc(sizeof(buffer));+    assert(buf);+    document* d = &buf->document;+    d->body = s;+    d->cursor = s;+    d->end = &s[slen];+    d->error_message = NULL;+    d->attrs.size = 1000;+    d->attrs.used = 0;+    d->attrs.attrs = buf->attrs;+    d->attrs.alloc = NULL;+    d->nodes.size = 500;+    d->nodes.used_back = 0;+    d->nodes.used_front = 1;+    d->nodes.nodes = buf->nodes;+    d->nodes.alloc = NULL;++    d->nodes.nodes[0].name = start_length(0, 0);+    d->nodes.nodes[0].outer = start_length(0, slen);+    d->nodes.nodes[0].inner = start_length(0, slen);+    d->nodes.nodes[0].attrs = start_length(0, 0);+    +    // Introduce an intermediate result, otherwise behaviour is undefined+    // because there is no guaranteed ordering between LHS and RHS evaluation+    str content = parse_content(d);+    d->nodes.nodes[0].nodes = content;++    if (d->cursor < d->end && d->error_message == NULL)+    {+        set_error(d, "Trailing junk at the end of the document");+    }+    return d;+}
+ cbits/hexml.h view
@@ -0,0 +1,56 @@++#include <stdint.h>++typedef struct document document;++// Pair of indexes into the input string+typedef struct+{+    int32_t start;+    int32_t length;+} str;++typedef struct+{+    str name;+    str value;+} attr;++typedef struct+{+    str name; // tag name, e.g. <[foo]>+    str inner; // inner text, <foo>[bar]</foo>+    str outer; // outer text, [<foo>bar</foo>]+    str attrs; // all the attributes, in the attribute buffer (not usable)+    str nodes; // all the nodes, in the node buffer (not usable)+} node;++// Convention: if slen can be -1 for nul-terminated, or given explicitly++// Parse a document, returns a potentially invalid document - use document_error to check+// Must use document_free to release the memory (even if invalid).+// The string must be nul terminated, e.g. slen != -1 ==> slen[0]+document* document_parse(char* s, int slen);++// Free the memory returned from document_parse.+void document_free(document* d);++// Generate a fresh string with the same semantics as the node.+// Requires an input buffer, returns the size of the rendered document.+// Requires the string passed to document_parse to be valid.+int node_render(document* d, node* n, char* buffer, int length);++// Return either NULL (successful parse) or the error message.+char* document_error(document* d);++// Return the root node of the document - imagine the document is wrapped in <>$DOC</> tags.+node* document_node(document* d);++// List all items within a node+node* node_children(document* d, node* n, int* res);+attr* node_attributes(document* d, node* n, int* res);++// Search for given strings within a node, note that prev may be NULL+// Requires the string passed to document_parse to be valid.+node* node_childBy(document* d, node* parent, node* prev, char* s, int slen);+attr* node_attributeBy(document* d, node* n, char* s, int slen);
+ hexml.cabal view
@@ -0,0 +1,54 @@+cabal-version:      >= 1.18+build-type:         Simple+name:               hexml+version:            0.1+license:            BSD3+license-file:       LICENSE+category:           Development+author:             Neil Mitchell <ndmitchell@gmail.com>+maintainer:         Neil Mitchell <ndmitchell@gmail.com>+copyright:          Neil Mitchell 2016+synopsis:           XML subset DOM parser+description:+    An XML DOM-style parser, that only parses a subset of XML, but is designed to be fast.+homepage:           https://github.com/ndmitchell/hexml#readme+bug-reports:        https://github.com/ndmitchell/hexml/issues+tested-with:        GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3+extra-doc-files:+    README.md+    CHANGES.txt+extra-source-files:+    cbits/*.h+    cbits/*.c++source-repository head+    type:     git+    location: https://github.com/ndmitchell/hexml.git++library+    hs-source-dirs:     src+    default-language:   Haskell2010++    build-depends:+        base > 4 && < 5,+        bytestring,+        extra++    c-sources:        cbits/hexml.c+    include-dirs:     cbits+    includes:         hexml.h+    install-includes: hexml.h+    cc-options:       -std=c99++    exposed-modules:+        Text.XML.Hexml++test-suite hexml-test+    type:               exitcode-stdio-1.0+    main-is:            src/Main.hs+    default-language:   Haskell2010++    build-depends:+        base,+        bytestring,+        hexml
+ src/Main.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}++module Main(main) where++import Text.XML.Hexml as X+import qualified Data.ByteString.Char8 as BS+import Control.Monad+import Data.Monoid+import Data.Char+++examples :: [(Bool, BS.ByteString)]+examples =+    [(True, "<test id='bob'>here<extra/>there</test>")+    ,(True, "<test /><close />")+    ,(True, "<test /><!-- comment > --><close />")+    ,(True, "<test id=\"bob value\" another-attr=\"test with <\">here </test> more text at the end<close />")+    ,(False, "<test></more>")+    ,(False, "<test")+    ,(True, "<?xml version=\"1.1\"?>\n<greeting>Hello, world!</greeting>")+    ]++main :: IO ()+main = do+    forM_ examples $ \(parses, src) -> do+        case parse src of+            Left err -> when parses $ fail $ "Unexpected parse failure, " ++ show err+            Right doc -> do+                unless parses $ fail "Unexpected parse success"+                checkFind doc+                let r = render doc+                r === rerender doc+                let Right d = parse r+                r === render d++    let Right doc = parse "<test id=\"1\" extra=\"2\" />\n<test id=\"2\" /><b><test id=\"3\" /></b><test id=\"4\" /><test />"+    map name (children doc) === ["test","test","b","test","test"]+    location (children doc !! 2) === (2,16)+    length (childrenBy doc "test") === 4+    length (childrenBy doc "b") === 1+    length (childrenBy doc "extra") === 0+    attributes (head $ children doc) === [Attribute "id" "1", Attribute "extra" "2"]+    map (`attributeBy` "id") (childrenBy doc "test") === map (fmap (Attribute "id")) [Just "1", Just "2", Just "4", Nothing]++    Right _ <- return $ parse $ "<test " <> BS.unwords [BS.pack $ "x" ++ show i ++ "='value'" | i <- [1..10000]] <> " />"+    Right _ <- return $ parse $ BS.unlines $ replicate 10000 "<test x='value' />"++    let attrs = ["usd:jpy","test","extra","more","stuff","jpy:usd","xxx","xxxx"]+    Right doc <- return $ parse $ "<test " <> BS.unwords [x <> "='" <> x <> "'" | x <- attrs] <> ">middle</test>"+    [c] <- return $ childrenBy doc "test"+    forM_ attrs $ \a -> attributeBy c a === Just (Attribute a a)+    forM_ ["missing","gone","nothing"] $ \a -> attributeBy c a === Nothing+    putStrLn "\nSuccess"+++checkFind :: Node -> IO ()+checkFind n = do+    forM_ (attributes n) $ \a -> attributeBy n (attributeName a) === Just a+    attributeBy n "xxx" === Nothing+    let cs = children n+    forM_ ("xxx":map name cs) $ \c ->+        map outer (filter ((==) c . name) cs) === map outer (childrenBy n c)+    mapM_ checkFind $ children n+++a === b = if a == b then putChar '.' else fail $ "mismatch, " ++ show a ++ " /= " ++ show b++rerender :: Node -> BS.ByteString+rerender = inside+    where+        inside x = BS.concat $ map (either validStr node) $ contents x+        node x = "<" <> BS.unwords (validName (name x) : map attr (attributes x)) <> ">" <>+                 inside x <>+                 "</" <> name x <> ">"+        attr (Attribute a b) = validName a <> "=\"" <> validAttr b <> "\""++        validName x | BS.all (\x -> isAlphaNum x || x `elem` ("-:_" :: String)) x = x+                    | otherwise = error "Invalid name"+        validAttr x | BS.notElem '\"' x = x+                    | otherwise = error "Invalid attribute"+        validStr x | BS.notElem '<' x || BS.isInfixOf "<!--" x = x+                   | otherwise = error $ show ("Invalid string", x)
+ src/Text/XML/Hexml.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE RecordWildCards, BangPatterns #-}++-- | A module for fast first-approximation parsing of XML.+--   Note that entities, e.g. @&amp;@, are not expanded.+module Text.XML.Hexml(+    Node, Attribute(..),+    parse, render,+    location, name, inner, outer,+    attributes, children, contents,+    attributeBy, childrenBy+    ) where++import Control.Applicative+import Control.Monad+import Data.Int+import Foreign.C+import Foreign.Ptr+import Foreign.Marshal hiding (void)+import Foreign.ForeignPtr+import Foreign.Storable+import System.IO.Unsafe+import Data.Monoid+import Data.Tuple.Extra+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString.Internal as BS+import Prelude++data CDocument+data CNode+data CAttr++szAttr = 2 * sizeOf (undefined :: Str)+szNode = 5 * sizeOf (undefined :: Str)+++data Str = Str {strStart :: {-# UNPACK #-} !Int32, strLength :: {-# UNPACK #-} !Int32} deriving Show++strEnd :: Str -> Int32+strEnd Str{..} = strStart + strLength++instance Storable Str where+    sizeOf _ = 8+    alignment _ = alignment (0 :: Int64)+    peek p = Str <$> peekByteOff p 0 <*> peekByteOff p 4+    poke p Str{..} = pokeByteOff p 0 strStart >> pokeByteOff p 4 strLength++foreign import ccall document_parse :: CString -> CInt -> IO (Ptr CDocument)+foreign import ccall document_free :: Ptr CDocument -> IO ()+foreign import ccall "&document_free" document_free_funptr :: FunPtr (Ptr CDocument -> IO ())+foreign import ccall node_render :: Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO CInt+foreign import ccall document_error :: Ptr CDocument -> IO CString+foreign import ccall document_node :: Ptr CDocument -> IO (Ptr CNode)++foreign import ccall node_children :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CNode)+foreign import ccall node_attributes :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CAttr)++foreign import ccall node_childBy :: Ptr CDocument -> Ptr CNode -> Ptr CNode -> CString -> CInt -> IO (Ptr CNode)+foreign import ccall node_attributeBy :: Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO (Ptr CAttr)++-- | A node in an XML document, created by 'parse', then calling functions such+--   as 'children' on that initial 'Node'.+data Node = Node BS.ByteString (ForeignPtr CDocument) (Ptr CNode)++-- | An XML attribute, comprising of a name and a value. As an example,+--   @hello=\"world\"@ would produce @Attribute \"hello\" \"world\"@.+data Attribute = Attribute+    {attributeName :: BS.ByteString+    ,attributeValue :: BS.ByteString+    } deriving (Show, Eq, Ord)++instance Show Node where+    show d = "Node " ++ show (BS.unpack $ outer d)+++touchBS :: BS.ByteString -> IO ()+touchBS = touchForeignPtr . fst3 . BS.toForeignPtr+++-- | Parse a ByteString as an XML document, returning a 'Left' error message, or a 'Right' document.+--   Note that the returned node will have a 'name' of @\"\"@, no 'attributes', and 'contents' as per the document.+--   Often the first child will be the @\<?xml ... ?\>@ element. For documents which comprise an XML node and a single+--   root element, use @'children' n !! 1@.+parse :: BS.ByteString -> Either BS.ByteString Node+parse src = do+    let src0 = src <> BS.singleton '\0'+    unsafePerformIO $ BS.unsafeUseAsCStringLen src0 $ \(str, len) -> do+        doc <- document_parse str (fromIntegral len - 1)+        err <- document_error doc+        if err /= nullPtr then do+            bs <- BS.packCString =<< document_error doc+            document_free doc+            return $ Left bs+         else do+            node <- document_node doc+            doc <- newForeignPtr document_free_funptr doc+            return $ Right $ Node src0 doc node++-- | Given a node, rerender it to something with an equivalent parse tree.+--   Mostly useful for debugging - if you want the real source document use 'outer' instead.+render :: Node -> BS.ByteString+render (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \d -> do+    i <- node_render d n nullPtr 0+    res <- BS.create (fromIntegral i) $ \ptr -> void $ node_render d n (castPtr ptr) i+    touchBS src+    return res++applyStr :: BS.ByteString -> Str -> BS.ByteString+applyStr bs Str{..} = BS.take (fromIntegral strLength) $ BS.drop (fromIntegral strStart) bs++nodeStr :: Int -> Node -> Str+nodeStr i (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \_ -> peekElemOff (castPtr n) i++nodeBS :: Int -> Node -> BS.ByteString+nodeBS i node@(Node src doc n) = applyStr src $ nodeStr i node++attrPeek :: BS.ByteString -> ForeignPtr CDocument -> Ptr CAttr -> Attribute+attrPeek src doc a = unsafePerformIO $ withForeignPtr doc $ \_ -> do+    name <- applyStr src <$> peekElemOff (castPtr a) 0+    val  <- applyStr src <$> peekElemOff (castPtr a) 1+    return $ Attribute name val++-- | Get the name of a node, e.g. @\<test /\>@ produces @\"test\"@.+name :: Node -> BS.ByteString+name = nodeBS 0++-- | Get the inner text, from inside the tag, e.g. @\<test /\>@ produces @\"\"@+--   and @\<test\>hello\</test\>@ produces @\"hello\"@.+--   The result will have identical layout/spacing to the source document.+inner :: Node -> BS.ByteString+inner = nodeBS 1++-- | Get the outer text, including the tag itself, e.g. @\<test /\>@ produces @\"\<test /\>\"@+--   and @\<test\>hello\</test\>@ produces @\"\<test\>hello\</test\>\"@.+--   The result will have identical layout/spacing to the source document.+outer :: Node -> BS.ByteString+outer = nodeBS 2++-- | Get the contents of a node, including both the content strings (as 'Left', never blank) and+--   the direct child nodes (as 'Right').+--   If you only want the child nodes, use 'children'.+contents :: Node -> [Either BS.ByteString Node]+contents n@(Node src _ _) = f (strStart inner) outers+    where+        f i [] = string i (strEnd inner) ++ []+        f i ((x, n):xs) = string i (strStart x) ++ Right n : f (strEnd x) xs++        string start end | start == end = []+                         | otherwise = [Left $ applyStr src $ Str start (end - start)]+        inner = nodeStr 1 n+        outers = map (nodeStr 2 &&& id) $ children n++-- | Get the direct child nodes of this node.+children :: Node -> [Node]+children (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \d -> do+    alloca $ \count -> do+        res <- node_children d n count+        count <- fromIntegral <$> peek count+        return [Node src doc $ plusPtr res $ i*szNode | i <- [0..count-1]]++-- | Get the attributes of this node.+attributes :: Node -> [Attribute]+attributes (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \d -> do+    alloca $ \count -> do+        res <- node_attributes d n count+        count <- fromIntegral <$> peek count+        return [attrPeek src doc $ plusPtr res $ i*szAttr | i <- [0..count-1]]++-- | Get the direct children of this node which have a specific name.+--   A more efficient version of:+--+-- > childrenBy p s = filter (\n -> name n == s) $ children p+childrenBy :: Node -> BS.ByteString -> [Node]+childrenBy (Node src doc n) str = go nullPtr+    where+        go old = unsafePerformIO $ withForeignPtr doc $ \d ->+            BS.unsafeUseAsCStringLen str $ \(bs, len) -> do+                r <- node_childBy d n old bs $ fromIntegral len+                touchBS src+                return $ if r == nullPtr then [] else Node src doc r : go r++-- | Get the first attribute of this node which has a specific name, if there is one.+--   A more efficient version of:+--+-- > attributeBy n s = listToMaybe $ filter (\(Attribute a _) -> a == s $ attributes n+attributeBy :: Node -> BS.ByteString -> Maybe Attribute+attributeBy (Node src doc n) str = unsafePerformIO $ withForeignPtr doc $ \d ->+    BS.unsafeUseAsCStringLen str $ \(bs, len) -> do+        r <- node_attributeBy d n bs $ fromIntegral len+        touchBS src+        return $ if r == nullPtr then Nothing else Just $ attrPeek src doc r++-- | Find the starting location of a node, the @<@ character.+--   The first character will be reported as @(line 1,column 1)@, because thats+--   how error messages typically do it.+location :: Node -> (Int, Int)+location n@(Node src _ _) = BS.foldl' f (pair 1 1) $ BS.take (fromIntegral i) src+    where+        pair !a !b = (a,b)++        i = strStart $ nodeStr 2 n+        f (!line, !col) c+            | c == '\n' = pair (line+1) 1+            | c == '\t' = pair line (col+8)+            | otherwise = pair line (col+1)