hexpat 0.11 → 0.12

raw patch · 11 files changed

+452/−271 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Text/XML/Expat/Annotated.hs +152/−80
• Text/XML/Expat/Cursor.hs +5/−5
• Text/XML/Expat/Format.hs +54/−12
• Text/XML/Expat/IO.hs +0/−2
• Text/XML/Expat/Namespaced.hs +71/−65
• Text/XML/Expat/NodeClass.hs +83/−0
• Text/XML/Expat/Proc.hs +1/−1
• Text/XML/Expat/Qualified.hs +6/−26
• Text/XML/Expat/SAX.hs +0/−3
• Text/XML/Expat/Tree.hs +71/−71
• hexpat.cabal +9/−6

@@ -1,64 +1,90 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -- | A variant of /Node/ in which Element nodes have an annotation of any type, -- and some concrete functions that annotate with the XML parse location.--- It is assumed you will usually want /Tree/ or /Annotated/, not both, so many--- of the names conflict. ----- Support for qualified and namespaced trees annotated with location information--- is not complete.+-- The names conflict with those in /Tree/ so you must use qualified import+-- if you want to use both modules. module Text.XML.Expat.Annotated (-        -- * Tree structure-        Node(..),-        Attributes,  -- re-export from Tree-        UNode,-        UAttributes,-        LNode,-        ULNode,-        textContent,-        unannotate,+  -- * Tree structure+  Node(..),+  Attributes,  -- re-export from Tree+  UNode,+  UAttributes,+  LNode,+  ULNode,+  textContent,+  isElement,+  isNamed,+  isText,+  getName,+  getAttributes,+  getAttribute,+  getChildren,+  modifyName,+  modifyAttributes,+  setAttribute,+  deleteAttribute,+  alterAttribute,+  modifyChildren,+  mapAllTags, -        -- * Qualified nodes-        QName(..),-        QNode,-        QAttributes,-        QLNode,+  -- * Annotation-specific+  unannotate,+  modifyAnnotation,+  mapAnnotation, -        -- * Namespaced nodes-        NName (..),-        NNode,-        NAttributes,-        NLNode,-        mkNName,-        mkAnNName,-        xmlnsUri,-        xmlns,+  -- * Qualified nodes+  QName(..),+  QNode,+  QAttributes,+  QLNode,+  toQualified,+  fromQualified, -        -- * Deprecated parse functions-        parseSAX,-        parseSAXThrowing,-        parseSAXLocations,-        parseSAXLocationsThrowing,-        parseTree,-        parseTree',-        parseTreeThrowing,+  -- * Namespaced nodes+  NName (..),+  NNode,+  NAttributes,+  NLNode,+  mkNName,+  mkAnNName,+  toNamespaced,+  fromNamespaced,+  xmlnsUri,+  xmlns, -        -- * Parse to tree-        Encoding(..),-        XMLParseError(..),-        XMLParseLocation(..),-        parse,-        parse',-        parseThrowing,+  -- * Parse to tree+  Tree.ParserOptions(..),+  Tree.defaultParserOptions,+  Encoding(..),+  parse,+  parse',+  XMLParseError(..),+  XMLParseLocation(..), -        -- * SAX-style parse-        SAXEvent(..),-        saxToTree,+  -- * Variant that throws exceptions+  parseThrowing,+  XMLParseException(..), -        -- * Variants that throw exceptions-        XMLParseException(..),-        -- * Abstraction of string types-        GenericXMLString(..)-    ) where+  -- * SAX-style parse+  SAXEvent(..),+  saxToTree, +  -- * Abstraction of string types+  GenericXMLString(..),++  -- * Deprecated+  eAttrs,+  parseSAX,+  parseSAXThrowing,+  parseSAXLocations,+  parseSAXLocationsThrowing,+  parseTree,+  parseTree',+  parseTreeThrowing+) where++import Control.Arrow import Text.XML.Expat.Tree ( Attributes, UAttributes ) import qualified Text.XML.Expat.Tree as Tree import Text.XML.Expat.SAX ( Encoding(..)@@ -72,10 +98,10 @@                           , parseSAXThrowing                           , parseSAXLocations                           , parseSAXLocationsThrowing )- import qualified Text.XML.Expat.SAX as SAX import Text.XML.Expat.Qualified hiding (QNode, QNodes) import Text.XML.Expat.Namespaced hiding (NNode, NNodes)+import Text.XML.Expat.NodeClass  import Control.Monad (mplus) import Control.Parallel.Strategies@@ -85,77 +111,123 @@   -- | Annotated variant of the tree representation of the XML document.-data Node tag text a =+data Node a tag text =     Element {-        eName     :: !tag,-        eAttrs    :: ![(tag,text)],-        eChildren :: [Node tag text a],-        eAnn      :: a+        eName       :: !tag,+        eAttributes :: ![(tag,text)],+        eChildren   :: [Node a tag text],+        eAnn        :: a     } |     Text !text     deriving (Eq, Show) -instance (NFData tag, NFData text, NFData a) => NFData (Node tag text a) where+eAttrs :: Node a tag text -> [(tag, text)]+{-# DEPRECATED eAttrs "use eAttributes instead" #-}+eAttrs = eAttributes++instance (NFData tag, NFData text, NFData a) => NFData (Node a tag text) where     rnf (Element nam att chi ann) = rnf (nam, att, chi, ann)     rnf (Text txt) = rnf txt -unannotate :: Node tag text a -> Tree.Node tag text+instance NodeClass (Node a) where+    textContent (Element _ _ children _) = mconcat $ map textContent children+    textContent (Text txt) = txt+    +    isElement (Element _ _ _ _) = True+    isElement _                 = False+    +    isText (Text _) = True+    isText _        = False+    +    isNamed _  (Text _) = False+    isNamed nm (Element nm' _ _ _) = nm == nm'++    getName (Text _)             = gxFromString ""+    getName (Element name _ _ _) = name++    getAttributes (Text _)              = []+    getAttributes (Element _ attrs _ _) = attrs++    getChildren (Text _)           = []+    getChildren (Element _ _ ch _) = ch++    modifyName _ node@(Text _) = node+    modifyName f (Element n a c ann) = Element (f n) a c ann++    modifyAttributes _ node@(Text _) = node+    modifyAttributes f (Element n a c ann) = Element n (f a) c ann++    modifyChildren _ node@(Text _) = node+    modifyChildren f (Element n a c ann) = Element n a (f c) ann++    mapAllTags _ (Text t) = Text t+    mapAllTags f (Element n a c ann) = Element (f n) (map (first f) a) (map (mapAllTags f) c) ann++    mapElement _ (Text t) = Text t+    mapElement f (Element n a c ann) =+        let (n', a', c') = f (n, a, c)+        in  Element n' a' c' ann++-- | Convert an annotated tree (/Annotated/ module) into a non-annotated+-- tree (/Tree/ module).  Needed, for example, when you @format@ your tree to+-- XML, since @format@ takes a non-annotated tree.+unannotate :: Node a tag text -> Tree.Node tag text unannotate (Element na at ch _) = (Tree.Element na at (map unannotate ch)) unannotate (Text t) = Tree.Text t --- | Extract all text content from inside a tag into a single string, including--- any text contained in children.-textContent :: Monoid text => Node tag text a -> text-textContent (Element _ _ children _) = mconcat $ map textContent children-textContent (Text txt) = txt- -- | Type shortcut for a single annotated node with unqualified tag names where -- tag and text are the same string type-type UNode text a = Node text text a+type UNode a text = Node a text text  -- | Type shortcut for a single annotated node, annotated with parse location-type LNode tag text = Node tag text XMLParseLocation+type LNode tag text = Node XMLParseLocation tag text  -- | Type shortcut for a single node with unqualified tag names where -- tag and text are the same string type, annotated with parse location type ULNode text = LNode text text   -- | Type shortcut for a single annotated node where qualified names are used for tags-type QNode text a = Node (QName text) text a+type QNode a text = Node a (QName text) text  -- | Type shortcut for a single node where qualified names are used for tags, annotated with parse location type QLNode text = LNode (QName text) text  -- | Type shortcut for a single annotated node where namespaced names are used for tags-type NNode text a = Node (NName text) text a+type NNode text a = Node a (NName text) text  -- | Type shortcut for a single node where namespaced names are used for tags, annotated with parse location type NLNode text = LNode (NName text) text -instance Functor (Node tag text) where-    f `fmap` Element na at ch an = Element na at (map (f `fmap`) ch) (f an)-    f `fmap` Text t = Text t+-- | Modify this node's annotation (non-recursively) if it's an element, otherwise no-op.+modifyAnnotation :: (a -> a) -> Node a tag text -> Node a tag text+f `modifyAnnotation` Element na at ch an = Element na at ch (f an)+_ `modifyAnnotation` Text t = Text t +-- | Modify this node's annotation and all its children recursively if it's an element, otherwise no-op.+mapAnnotation :: (a -> b) -> Node a tag text -> Node b tag text+f `mapAnnotation` Element na at ch an = Element na at (map (f `mapAnnotation`) ch) (f an)+_ `mapAnnotation` Text t = Text t+ -- | A lower level function that lazily converts a SAX stream into a tree structure. -- Variant that takes annotations for start tags. saxToTree :: GenericXMLString tag =>              [(SAXEvent tag text, a)]-          -> (Node tag text a, Maybe XMLParseError)+          -> (Node a tag text, Maybe XMLParseError) saxToTree events =     let (nodes, mError, _) = ptl events     in  (safeHead nodes, mError)   where     safeHead (a:_) = a     safeHead [] = Element (gxFromString "") [] [] (error "saxToTree null annotation")-    ptl ((StartElement name attrs, ann):rem) =-        let (children, err1, rem') = ptl rem+    ptl ((StartElement name attrs, ann):rema) =+        let (children, err1, rema') = ptl rema             elt = Element name attrs children ann-            (out, err2, rem'') = ptl rem'-        in  (elt:out, err1 `mplus` err2, rem'')-    ptl ((EndElement name, _):rem) = ([], Nothing, rem)-    ptl ((CharacterData txt, _):rem) =-        let (out, err, rem') = ptl rem-        in  (Text txt:out, err, rem')+            (out, err2, rema'') = ptl rema'+        in  (elt:out, err1 `mplus` err2, rema'')+    ptl ((EndElement _, _):rema) = ([], Nothing, rema)+    ptl ((CharacterData txt, _):rema) =+        let (out, err, rema') = ptl rema+        in  (Text txt:out, err, rema')     ptl ((FailDocument err, _):_) = ([], Just err, [])     ptl [] = ([], Nothing, []) 

@@ -2,7 +2,7 @@ -- | -- Module    : Text.XML.Expat.Cursor ----- This module ported from Text.XML.Light.Proc+-- This module ported from Text.XML.Light.Cursor -- -- XML cursors for working XML content withing the context of -- an XML document.  This implementation is based on the general@@ -85,9 +85,9 @@ -}  fromTag :: Tag tag text -> [Node tag text] -> Node tag text-fromTag t cs = Element { eName     = tagName t-                       , eAttrs    = tagAttribs t-                       , eChildren = cs+fromTag t cs = Element { eName       = tagName t+                       , eAttributes = tagAttribs t+                       , eChildren   = cs                        }  type Path tag text = [([Node tag text],Tag tag text,[Node tag text])]@@ -197,7 +197,7 @@  getTag :: Node tag text -> Tag tag text getTag e = Tag { tagName = eName e-               , tagAttribs = eAttrs e+               , tagAttribs = eAttributes e                }  

@@ -20,16 +20,18 @@         xmlHeader,         treeToSAX,         formatSAX,-        formatSAX'+        formatSAX',+        -- * Indentation+        indent,+        indent_     ) where -import Text.XML.Expat.IO import Text.XML.Expat.Tree import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w, w2c)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE+import Data.Char (isSpace)+import Data.List import Data.Word  -- | DEPRECATED: Renamed to 'format'.@@ -52,8 +54,8 @@  -- | Format document with <?xml.. header - strict variant that returns strict ByteString. format' :: (GenericXMLString tag, GenericXMLString text) =>-               Node tag text-            -> B.ByteString+           Node tag text+        -> B.ByteString format' = B.concat . L.toChunks . formatTree  -- | Format XML node with no header - lazy variant that returns lazy ByteString.@@ -109,7 +111,7 @@ putSAX :: (GenericXMLString tag, GenericXMLString text) =>            [SAXEvent tag text]         -> [B.ByteString]-putSAX (StartElement name attrs:EndElement name2:elts) =+putSAX (StartElement name attrs:EndElement _:elts) =     B.concat (startTagHelper name attrs ++ [pack "/>"]):putSAX elts putSAX (StartElement name attrs:elts) =     B.concat (startTagHelper name attrs ++ [B.singleton (c2w '>')]):putSAX elts@@ -132,12 +134,52 @@     let (good, bad) = B.span (`notElem` escapees) str     in  if B.null good             then case w2c $ B.head str of-                '&'  -> pack "&amp;":escapeText rem-                '<'  -> pack "&lt;":escapeText rem-                '"'  -> pack "&quot;":escapeText rem-                '\'' -> pack "&apos;":escapeText rem+                '&'  -> pack "&amp;":escapeText rema+                '<'  -> pack "&lt;":escapeText rema+                '"'  -> pack "&quot;":escapeText rema+                '\'' -> pack "&apos;":escapeText rema                 _        -> error "hexpat: impossible"             else good:escapeText bad   where-    rem = B.tail str+    rema = B.tail str++-- | Make the output prettier by adding indentation.+indent :: (GenericXMLString tag, GenericXMLString text) =>+          Int   -- ^ Number of indentation spaces per nesting level+       -> Node tag text+       -> Node tag text+indent = indent_ 0++-- | Make the output prettier by adding indentation, specifying initial indent.+indent_ :: (GenericXMLString tag, GenericXMLString text) =>+           Int   -- ^ Initial indent (spaces)+        -> Int   -- ^ Number of indentation spaces per nesting level+        -> Node tag text+        -> Node tag text+indent_ _ _ t@(Text _) = t+indent_ cur perLevel elt@(Element name attrs chs) =+    if any isElement chs+        then Element name attrs $+                let (_, chs') = mapAccumL (\startOfText ch -> case ch of+                            Element _ _ _ ->+                                let cur' = cur + perLevel+                                in  (+                                        True,+                                        [+                                            Text (gxFromString ('\n':replicate cur' ' ')),+                                            indent_ cur' perLevel ch+                                        ]+                                    )+                            Text t | startOfText ->+                                case strip t of+                                    Nothing -> (True, [])+                                    Just t' -> (False, [Text t'])+                            Text _ -> (False, [ch])+                        ) True chs+                in  concat chs' ++ [Text $ gxFromString ('\n':replicate cur ' ')]+        else elt+  where+    strip t | gxNullString t = Nothing+    strip t | isSpace (gxHead t) = strip (gxTail t)+    strip t = Just t 

@@ -53,8 +53,6 @@ import Control.Monad import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Internal as BSI-import Data.Maybe (maybe) import Data.IORef import Foreign import CForeign

@@ -12,6 +12,7 @@       ) where  import Text.XML.Expat.Tree+import Text.XML.Expat.NodeClass import Text.XML.Expat.Qualified import Control.Parallel.Strategies import qualified Data.Map as M@@ -84,75 +85,80 @@    , (Just xmlnsUri, Just xmlns)    ] -toNamespaced :: (GenericXMLString text, Ord text, Show text)-               => QNode text -> NNode text+toNamespaced :: (NodeClass n, GenericXMLString text, Ord text, Show text)+               => n (QName text) text -> n (NName text) text toNamespaced = nodeWithNamespaces baseNsBindings -nodeWithNamespaces :: (GenericXMLString text, Ord text, Show text)-                   => NsPrefixMap text -> QNode text -> NNode text-nodeWithNamespaces _ (Text t) = Text t-nodeWithNamespaces bindings (Element qname qattrs qchildren) = Element nname nattrs nchildren+nodeWithNamespaces :: (NodeClass n, GenericXMLString text, Ord text, Show text)+                   => NsPrefixMap text -> n (QName text) text -> n (NName text) text+nodeWithNamespaces bindings = mapElement namespaceify   where-    for = flip map-    (nsAtts, otherAtts) = L.partition ((== Just xmlns) . qnPrefix . fst) qattrs-    (dfAtt, normalAtts) = L.partition ((== QName Nothing xmlns) . fst) otherAtts-    nsMap  = M.fromList $ for nsAtts $ \((QName _ lp), uri) -> (Just lp, Just uri)-    -- fixme: when snd q is null, use Nothing-    dfMap  = M.fromList $ for dfAtt $ \q -> (Nothing, Just $ snd q)-    chldBs = M.unions [dfMap, nsMap, bindings]--    trans bs (QName pref qual) = case pref `M.lookup` bs of-      Nothing -> error -              $  "Namespace prefix referenced but never bound: '"-              ++ (show . DM.fromJust) pref-              ++ "'"-      Just mUri -> NName mUri qual-    nname       = trans chldBs qname--    -- attributes with no prefix are in the same namespace as the element-    attBs = M.insert Nothing (nnNamespace nname) chldBs--    transAt (qn, v) = (trans attBs qn, v)--    nNsAtts     = map transAt nsAtts-    nDfAtt      = map transAt dfAtt-    nNormalAtts = map transAt normalAtts-    nattrs      = concat [nNsAtts, nDfAtt, nNormalAtts]--    nchildren   = for qchildren $ nodeWithNamespaces chldBs+    namespaceify (qname, qattrs, qchildren) = (nname, nattrs, nchildren)+      where+        for = flip map+        (nsAtts, otherAtts) = L.partition ((== Just xmlns) . qnPrefix . fst) qattrs+        (dfAtt, normalAtts) = L.partition ((== QName Nothing xmlns) . fst) otherAtts+        nsMap  = M.fromList $ for nsAtts $ \((QName _ lp), uri) -> (Just lp, Just uri)+        -- fixme: when snd q is null, use Nothing+        dfMap  = M.fromList $ for dfAtt $ \q -> (Nothing, Just $ snd q)+        chldBs = M.unions [dfMap, nsMap, bindings]+    +        trans bs (QName pref qual) = case pref `M.lookup` bs of+          Nothing -> error +                  $  "Namespace prefix referenced but never bound: '"+                  ++ (show . DM.fromJust) pref+                  ++ "'"+          Just mUri -> NName mUri qual+        nname       = trans chldBs qname+    +        -- attributes with no prefix are in the same namespace as the element+        attBs = M.insert Nothing (nnNamespace nname) chldBs+    +        transAt (qn, v) = (trans attBs qn, v)+    +        nNsAtts     = map transAt nsAtts+        nDfAtt      = map transAt dfAtt+        nNormalAtts = map transAt normalAtts+        nattrs      = concat [nNsAtts, nDfAtt, nNormalAtts]+    +        nchildren   = for qchildren $ nodeWithNamespaces chldBs -fromNamespaced :: (GenericXMLString text, Ord text) => NNode text -> QNode text+fromNamespaced :: (NodeClass n, GenericXMLString text, Ord text) =>+                  n (NName text) text -> n (QName text) text fromNamespaced = nodeWithQualifiers 1 basePfBindings -nodeWithQualifiers :: (GenericXMLString text, Ord text)-                   => Int -> PrefixNsMap text -> NNode text -> QNode text-nodeWithQualifiers _ _ (Text text) = Text text-nodeWithQualifiers cntr bindings (Element nname nattrs nchildren) = Element qname qattrs qchildren+nodeWithQualifiers :: (NodeClass n, GenericXMLString text, Ord text) =>+                      Int+                   -> PrefixNsMap text+                   -> n (NName text) text -> n (QName text) text+nodeWithQualifiers cntr bindings = mapElement namespaceify   where-    for = flip map-    (nsAtts, otherAtts) = L.partition ((== Just xmlnsUri) . nnNamespace . fst) nattrs-    (dfAtt, normalAtts) = L.partition ((== NName Nothing xmlns) . fst) otherAtts-    nsMap = M.fromList $ for nsAtts $ \((NName _ lp), uri) -> (Just uri, Just lp)-    dfMap = M.fromList $ for dfAtt  $ \(_, uri) -> (Just uri, Just xmlns)-    chldBs = M.unions [dfMap, nsMap, bindings]--    trans (i, bs, as) (NName nspace qual) =-      case nspace `M.lookup` bs of-           Nothing -> let-                        pfx = gxFromString $ "ns" ++ show i-                        bs' = M.insert nspace (Just pfx) bs-                        as' = (NName (Just xmlnsUri) pfx, DM.fromJust nspace) : as-                      in trans (i+1, bs', as') (NName nspace qual)-           Just pfx -> ((i, bs, as), QName pfx qual)-    transAt ibs (nn, v) = let (ibs', qn) = trans ibs nn-                          in  (ibs', (qn, v))--    ((i', bs', as'), qname) = trans (cntr, chldBs, []) nname--    ((i'',   bs'',   as''),   qNsAtts)     = L.mapAccumL transAt (i',    bs',    as')    nsAtts-    ((i''',  bs''',  as'''),  qDfAtt)      = L.mapAccumL transAt (i'',   bs'',   as'')   dfAtt-    ((i'''', bs'''', as''''), qNormalAtts) = L.mapAccumL transAt (i''',  bs''',  as''')  normalAtts-    (_,                       qas)         = L.mapAccumL transAt (i'''', bs'''', as'''') as''''-    qattrs = concat [qNsAtts, qDfAtt, qNormalAtts, qas]--    qchildren = for nchildren $ nodeWithQualifiers i'''' bs''''+    namespaceify (nname, nattrs, nchildren) = (qname, qattrs, qchildren) +      where+        for = flip map+        (nsAtts, otherAtts) = L.partition ((== Just xmlnsUri) . nnNamespace . fst) nattrs+        (dfAtt, normalAtts) = L.partition ((== NName Nothing xmlns) . fst) otherAtts+        nsMap = M.fromList $ for nsAtts $ \((NName _ lp), uri) -> (Just uri, Just lp)+        dfMap = M.fromList $ for dfAtt  $ \(_, uri) -> (Just uri, Just xmlns)+        chldBs = M.unions [dfMap, nsMap, bindings]+    +        trans (i, bs, as) (NName nspace qual) =+          case nspace `M.lookup` bs of+               Nothing -> let+                            pfx = gxFromString $ "ns" ++ show i+                            bsN = M.insert nspace (Just pfx) bs+                            asN = (NName (Just xmlnsUri) pfx, DM.fromJust nspace) : as+                          in trans (i+1, bsN, asN) (NName nspace qual)+               Just pfx -> ((i, bs, as), QName pfx qual)+        transAt ibs (nn, v) = let (ibs', qn) = trans ibs nn+                              in  (ibs', (qn, v))+    +        ((i', bs', as'), qname) = trans (cntr, chldBs, []) nname+    +        ((i'',   bs'',   as''),   qNsAtts)     = L.mapAccumL transAt (i',    bs',    as')    nsAtts+        ((i''',  bs''',  as'''),  qDfAtt)      = L.mapAccumL transAt (i'',   bs'',   as'')   dfAtt+        ((i'''', bs'''', as''''), qNormalAtts) = L.mapAccumL transAt (i''',  bs''',  as''')  normalAtts+        (_,                       qas)         = L.mapAccumL transAt (i'''', bs'''', as'''') as''''+        qattrs = concat [qNsAtts, qDfAtt, qNormalAtts, qas]+    +        qchildren = for nchildren $ nodeWithQualifiers i'''' bs''''

@@ -0,0 +1,83 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}+-- | A typeclass to allow for functions that work with different node types+-- such as the ones defined in /Tree/ and /Annotated/.+module Text.XML.Expat.NodeClass where++import Data.Monoid (Monoid)+import Text.XML.Expat.SAX (GenericXMLString)+++class NodeClass n where+    -- | Is the given node an element?+    isElement :: n tag text -> Bool++    -- | Is the given node text?+    isText :: n tag text -> Bool++    -- | Extract all text content from inside a tag into a single string, including+    -- any text contained in children.+    textContent :: Monoid text => n tag text -> text++    -- | Is the given node a tag with the given name?+    isNamed :: Eq tag => tag -> n tag text -> Bool++    -- | Get the name of this node if it's an element, return empty string otherwise.+    getName :: GenericXMLString tag => n tag text -> tag++    -- | Get the attributes of a node if it's an element, return empty list otherwise.+    getAttributes :: n tag text -> [(tag,text)]++    -- | Get children of a node if it's an element, return empty list otherwise.+    getChildren :: n tag text -> [n tag text]++    -- | Modify name if it's an element, no-op otherwise.+    modifyName :: (tag -> tag)+               -> n tag text+               -> n tag text++    -- | Modify attributes if it's an element, no-op otherwise.+    modifyAttributes :: ([(tag, text)] -> [(tag, text)])+                     -> n tag text+                     -> n tag text++    -- | Modify children (non-recursively) if it's an element, no-op otherwise.+    modifyChildren :: ([n tag text] -> [n tag text])+                   -> n tag text+                   -> n tag text++    -- | Map all tags (both tag names and attribute names) recursively.+    mapAllTags :: (tag -> tag')+            -> n tag text+            -> n tag' text++    -- | Map an element non-recursively, allowing the tag type to be changed.+    mapElement :: ((tag, [(tag, text)], [n tag text]) -> (tag', [(tag', text)], [n tag' text]))+                  -> n tag text+                  -> n tag' text++-- | Get the value of the attribute having the specified name.+getAttribute :: (NodeClass n, GenericXMLString tag) => n tag text -> tag -> Maybe text+getAttribute n t = lookup t $ getAttributes n++-- | Set the value of the attribute with the specified name to the value, overwriting+-- the first existing attribute with that name if present.+setAttribute :: (Eq tag, NodeClass n, GenericXMLString tag) => tag -> text -> n tag text -> n tag text+setAttribute t newValue = modifyAttributes set+  where+    set [] = [(t, newValue)]+    set ((name, _):atts) | name == t = (name, newValue):atts+    set (att:atts) = att:set atts++-- | Delete the first attribute matching the specified name.+deleteAttribute :: (Eq tag, NodeClass n, GenericXMLString tag) => tag -> n tag text -> n tag text+deleteAttribute t = modifyAttributes del+  where+    del [] = []+    del ((name, _):atts) | name == t = atts+    del (att:atts) = att:del atts++-- | setAttribute if /Just/, deleteAttribute if /Nothing/.+alterAttribute :: (Eq tag, NodeClass n, GenericXMLString tag) => tag -> Maybe text -> n tag text -> n tag text+alterAttribute t (Just newValue) = setAttribute t newValue+alterAttribute t Nothing = deleteAttribute t+

@@ -64,7 +64,7 @@ filterElements p e  | p e        = [e]  | otherwise  = case e of-                  Element n a c -> concatMap (filterElements p) $ onlyElems c+                  Element _ _ c -> concatMap (filterElements p) $ onlyElems c                   _             -> []  -- | Find all non-nested occurences of an element wrt a predicate over element names.

@@ -20,20 +20,10 @@         fromQualified     ) where -import Text.XML.Expat.IO+import Text.XML.Expat.NodeClass import Text.XML.Expat.Tree-import Text.XML.Expat.Format-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Internal as I-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import Control.Applicative import Control.Monad.Writer import Control.Parallel.Strategies-import Data.Monoid-import qualified Codec.Binary.UTF8.String as U8  -- | A qualified name. --@@ -73,29 +63,19 @@ mkAnQName :: text -> QName text mkAnQName localPart = QName Nothing localPart -toQualified :: (GenericXMLString text) => UNode text -> QNode text-toQualified (Text text) = Text text-toQualified (Element uname uatts uchldrn) = Element qname qatts qchldrn+toQualified :: (NodeClass n, GenericXMLString text) => n text text -> n (QName text) text+toQualified = mapAllTags qual   where-    qname   = qual uname-    qatts   = map (\(tag, text) -> (qual tag, text)) uatts-    qchldrn = map toQualified uchldrn-     qual ident =         case gxBreakOn ':' ident of              (prefix, _local) | not (gxNullString _local)                               && gxHead _local == ':'                                  -> QName (Just prefix) (gxTail _local)-             otherwise           -> QName Nothing ident+             _                   -> QName Nothing ident -fromQualified :: (GenericXMLString text) => QNode text -> UNode text-fromQualified (Text text) = Text text-fromQualified (Element qname qatts qchldrn) = Element uname uatts uchldrn+fromQualified :: (NodeClass n, GenericXMLString text) => n (QName text) text -> n text text+fromQualified = mapAllTags tag   where-    uname   = tag qname-    uatts   = map (\(qual, text) -> (tag qual, text)) qatts-    uchldrn = map fromQualified qchldrn-     tag (QName (Just prefix) local) = prefix `mappend` gxFromChar ':' `mappend` local     tag (QName Nothing       local) = local 

@@ -6,8 +6,6 @@  -- | This module provides functions to parse an XML document to a lazy -- stream of SAX events.---- module Text.XML.Expat.SAX (   -- * XML primitives   Encoding(..),@@ -48,7 +46,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Codec.Binary.UTF8.String as U8-import Data.Monoid import Data.Typeable import Control.Exception.Extensible as Exc import Control.Applicative

@@ -1,11 +1,12 @@-{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances,+        MultiParamTypeClasses #-}  -- hexpat, a Haskell wrapper for expat -- Copyright (C) 2008 Evan Martin <martine@danga.com> -- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>  -- | This module provides functions to parse an XML document to a tree structure,--- either strictly or lazily, as well as a lazy SAX-style interface.+-- either strictly or lazily. -- -- The 'GenericXMLString' type class allows you to use any string type. Three -- string types are provided for here: 'String', 'ByteString' and 'Text'.@@ -94,64 +95,63 @@ module Text.XML.Expat.Tree (   -- * Tree structure   Node(..),-  Nodes,   Attributes,   UNode,-  UNodes,   UAttributes,   textContent,   isElement,   isNamed,   isText,+  getName,+  getAttributes,   getAttribute,   getChildren,+  modifyName,+  modifyAttributes,+  setAttribute,+  deleteAttribute,+  alterAttribute,   modifyChildren,+  mapAllTags, -  -- * Parse functions+  -- * Parse to tree   ParserOptions(..),   defaultParserOptions,+  Encoding(..),   parse,   parse',-  parseThrowing,--  -- * Deprecated parse functions-  parseTree,-  parseTree',--  parseSAX,-  parseSAXLocations,--  parseTreeThrowing,-  parseSAXThrowing,-  parseSAXLocationsThrowing,--  extractText,--  -- * Parse to tree-  Encoding(..),   XMLParseError(..),   XMLParseLocation(..), +  -- * Variant that throws exceptions+  parseThrowing,+  XMLParseException(..),+   -- * SAX-style parse   SAXEvent(..),   saxToTree, -  -- * Variants that throw exceptions-  XMLParseException(..),-   -- * Abstraction of string types-  GenericXMLString(..)+  GenericXMLString(..),++  -- * Deprecated+  eAttrs,+  Nodes,+  UNodes,+  parseTree,+  parseTree',+  parseSAX,+  parseSAXLocations,+  parseTreeThrowing,+  parseSAXThrowing,+  parseSAXLocationsThrowing ) where  ------------------------------------------------------------------------------ import Text.XML.Expat.IO hiding (parse,parse') import qualified Text.XML.Expat.IO as IO--import Text.XML.Expat.SAX ( Encoding(..)-                          , ParserOptions(..)+import Text.XML.Expat.SAX ( ParserOptions(..)                           , XMLParseException(..)-                          , XMLParseError(..)-                          , XMLParseLocation(..)                           , SAXEvent(..)                           , defaultParserOptions                           , mkText@@ -161,14 +161,14 @@                           , parseSAXThrowing                           , GenericXMLString(..) ) import qualified Text.XML.Expat.SAX as SAX+import Text.XML.Expat.NodeClass  ------------------------------------------------------------------------------+import Control.Arrow import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Internal as I import Data.IORef-import qualified Data.Monoid as M-import Data.Monoid+import Data.Monoid (Monoid,mconcat) import Control.Parallel.Strategies import Control.Monad import System.IO.Unsafe@@ -179,13 +179,17 @@ -- | The tree representation of the XML document. data Node tag text =     Element {-        eName     :: !tag,-        eAttrs    :: ![(tag,text)],-        eChildren :: [Node tag text]+        eName       :: !tag,+        eAttributes :: ![(tag,text)],+        eChildren   :: [Node tag text]     } |     Text !text     deriving (Eq, Show) +eAttrs :: Node tag text -> [(tag, text)]+{-# DEPRECATED eAttrs "use eAttributes instead" #-}+eAttrs = eAttributes+ instance (NFData tag, NFData text) => NFData (Node tag text) where     rnf (Element nam att chi) = rnf (nam, att, chi)     rnf (Text txt) = rnf txt@@ -214,48 +218,44 @@ -- text are the same string type. type UAttributes text = Attributes text text --- | Extract all text content from inside a tag into a single string, including--- any text contained in children.-textContent :: Monoid text => Node tag text -> text-textContent (Element _ _ children) = mconcat $ map textContent children-textContent (Text txt) = txt+instance NodeClass Node where+    textContent (Element _ _ children) = mconcat $ map textContent children+    textContent (Text txt) = txt+    +    isElement (Element _ _ _) = True+    isElement _               = False+    +    isText (Text _) = True+    isText _        = False+    +    isNamed _  (Text _) = False+    isNamed nm (Element nm' _ _) = nm == nm' --- | DEPRECATED: Renamed to 'textContent'.-extractText :: Monoid text => Node tag text -> text-{-# DEPRECATED extractText "renamed to textContent" #-}-extractText = textContent+    getName (Text _)             = gxFromString ""+    getName (Element name _ _)   = name --- | Is the given node an element?-isElement :: Node tag text -> Bool-isElement (Element _ _ _) = True-isElement _               = False+    getAttributes (Text _)            = []+    getAttributes (Element _ attrs _) = attrs --- | Is the given node text?-isText :: Node tag text -> Bool-isText (Text _) = True-isText _        = False+    getChildren (Text _)         = []+    getChildren (Element _ _ ch) = ch --- | Is the given node a tag with the given name?-isNamed :: (Eq tag) => tag -> Node tag text -> Bool-isNamed _  (Text _) = False-isNamed nm (Element nm' _ _) = nm == nm'+    modifyName _ node@(Text _) = node+    modifyName f (Element n a c) = Element (f n) a c --- | Get the value of the attribute having the specified name.-getAttribute :: GenericXMLString tag => Node tag text -> tag -> Maybe text-getAttribute n t = lookup t $ eAttrs n+    modifyAttributes _ node@(Text _) = node+    modifyAttributes f (Element n a c) = Element n (f a) c --- | Get children of a node if it's an element, return empty list otherwise.-getChildren :: Node tag text -> [Node tag text]-getChildren (Text _)         = []-getChildren (Element _ _ ch) = ch+    modifyChildren _ node@(Text _) = node+    modifyChildren f (Element n a c) = Element n a (f c) --- | Modify a node's children using the specified function.-modifyChildren :: ([Node tag text] -> [Node tag text])-               -> Node tag text-               -> Node tag text-modifyChildren _ node@(Text _) = node-modifyChildren f (Element n a c) = Element n a (f c)+    mapAllTags _ (Text t) = Text t+    mapAllTags f (Element n a c) = Element (f n) (map (first f) a) (map (mapAllTags f) c) +    mapElement _ (Text t) = Text t+    mapElement f (Element n a c) =+        let (n', a', c') = f (n, a, c)+        in  Element n' a' c'  setEntityDecoder :: (GenericXMLString tag, GenericXMLString text)                  => Parser

@@ -1,9 +1,9 @@ Cabal-Version: >= 1.4 Name: hexpat-Version: 0.11+Version: 0.12 Synopsis: wrapper for expat, the fast XML parser Description:-  This package provides a general purpose Haskell XML library using the Expat do+  This package provides a general purpose Haskell XML library using Expat to   do its parsing (<http://expat.sourceforge.net/> - a fast stream-oriented XML   parser written in C).  It is extensible to any string type, with @String@,   @ByteString@ and @Text@ provided out of the box.@@ -22,7 +22,8 @@   .   DARCS repository: <http://code.haskell.org/hexpat/>   .-  Credits to the @xml@ (XML.Light) package for /Proc/ and /Cursor/.+  Credits to Iavor Diatchki <iavor.diatchki@gmail.com> and the @xml@ (XML.Light)+  package for /Proc/ and /Cursor/. Category: XML License: BSD3 License-File: LICENSE@@ -35,10 +36,11 @@ Maintainer: http://blacksapphire.com/antispam/ Copyright:   (c) 2009 Doug Beardsley <mightybyte@gmail.com>,-  (c) 2009 Stephen Blackheath <http://blacksapphire.com/antispam/>,+  (c) 2009-2010 Stephen Blackheath <http://blacksapphire.com/antispam/>,   (c) 2009 Gregory Collins,   (c) 2008 Evan Martin <martine@danga.com>,-  (c) 2009 Matthew Pocock <matthew.pocock@ncl.ac.uk>+  (c) 2009 Matthew Pocock <matthew.pocock@ncl.ac.uk>,+  (c) 2007-2009 Galois Inc. Homepage: http://haskell.org/haskellwiki/Hexpat/ Build-Type: Simple Stability: beta@@ -60,9 +62,10 @@     Text.XML.Expat.Format,     Text.XML.Expat.IO,     Text.XML.Expat.Namespaced,+    Text.XML.Expat.NodeClass,     Text.XML.Expat.Proc,     Text.XML.Expat.Qualified,     Text.XML.Expat.SAX,     Text.XML.Expat.Tree   Extra-Libraries: expat-  --ghc-options: -Wall+  ghc-options: -Wall