diff --git a/Text/XML/Expat/Annotated.hs b/Text/XML/Expat/Annotated.hs --- a/Text/XML/Expat/Annotated.hs +++ b/Text/XML/Expat/Annotated.hs @@ -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, []) diff --git a/Text/XML/Expat/Cursor.hs b/Text/XML/Expat/Cursor.hs --- a/Text/XML/Expat/Cursor.hs +++ b/Text/XML/Expat/Cursor.hs @@ -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 } diff --git a/Text/XML/Expat/Format.hs b/Text/XML/Expat/Format.hs --- a/Text/XML/Expat/Format.hs +++ b/Text/XML/Expat/Format.hs @@ -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 - 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 "&":escapeText rem - '<' -> pack "<":escapeText rem - '"' -> pack """:escapeText rem - '\'' -> pack "'":escapeText rem + '&' -> pack "&":escapeText rema + '<' -> pack "<":escapeText rema + '"' -> pack """:escapeText rema + '\'' -> pack "'":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 diff --git a/Text/XML/Expat/IO.hs b/Text/XML/Expat/IO.hs --- a/Text/XML/Expat/IO.hs +++ b/Text/XML/Expat/IO.hs @@ -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 diff --git a/Text/XML/Expat/Namespaced.hs b/Text/XML/Expat/Namespaced.hs --- a/Text/XML/Expat/Namespaced.hs +++ b/Text/XML/Expat/Namespaced.hs @@ -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'''' diff --git a/Text/XML/Expat/NodeClass.hs b/Text/XML/Expat/NodeClass.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/NodeClass.hs @@ -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 + diff --git a/Text/XML/Expat/Proc.hs b/Text/XML/Expat/Proc.hs --- a/Text/XML/Expat/Proc.hs +++ b/Text/XML/Expat/Proc.hs @@ -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. diff --git a/Text/XML/Expat/Qualified.hs b/Text/XML/Expat/Qualified.hs --- a/Text/XML/Expat/Qualified.hs +++ b/Text/XML/Expat/Qualified.hs @@ -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 diff --git a/Text/XML/Expat/SAX.hs b/Text/XML/Expat/SAX.hs --- a/Text/XML/Expat/SAX.hs +++ b/Text/XML/Expat/SAX.hs @@ -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 diff --git a/Text/XML/Expat/Tree.hs b/Text/XML/Expat/Tree.hs --- a/Text/XML/Expat/Tree.hs +++ b/Text/XML/Expat/Tree.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, + MultiParamTypeClasses #-} -- hexpat, a Haskell wrapper for expat -- Copyright (C) 2008 Evan Martin -- Copyright (C) 2009 Stephen Blackheath -- | 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 diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -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 ( - 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: . - Credits to the @xml@ (XML.Light) package for /Proc/ and /Cursor/. + Credits to Iavor Diatchki 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 , - (c) 2009 Stephen Blackheath , + (c) 2009-2010 Stephen Blackheath , (c) 2009 Gregory Collins, (c) 2008 Evan Martin , - (c) 2009 Matthew Pocock + (c) 2009 Matthew Pocock , + (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