diff --git a/Text/XML/Expat/Annotated.hs b/Text/XML/Expat/Annotated.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Annotated.hs @@ -0,0 +1,193 @@ +-- | 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. +module Text.XML.Expat.Annotated ( + -- * Tree structure + Node(..), + Attributes, -- re-export from Tree + Nodes, + UNode, + UNodes, + UAttributes, + LNode, + LNodes, + ULNode, + ULNodes, + textContent, + unannotate, + -- * Qualified nodes + QName(..), + QNode, + QNodes, + QAttributes, + QLNode, + QLNodes, + -- * Namespaced nodes + NName (..), + NNode, + NNodes, + NAttributes, + NLNode, + NLNodes, + mkNName, + mkAnNName, + xmlnsUri, + xmlns, + -- * Parse to tree + parseTree, + parseTree', + Encoding(..), + XMLParseError(..), + XMLParseLocation(..), + -- * SAX-style parse + parseSAX, + SAXEvent(..), + saxToTree, + parseSAXLocations, + -- * Variants that throw exceptions + XMLParseException(..), + parseTreeThrowing, + parseSAXThrowing, + parseSAXLocationsThrowing, + -- * Abstraction of string types + GenericXMLString(..) + ) where + +import Text.XML.Expat.Tree hiding (Node(..), Nodes, UNode, UNodes, saxToTree, + parseTree, parseTree', parseTreeThrowing, textContent) +import qualified Text.XML.Expat.Tree as Tree (Node(..)) +import Text.XML.Expat.Qualified hiding (QNode, QNodes) +import Text.XML.Expat.Namespaced hiding (NNode, NNodes) + +import Control.Monad (mplus) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Monoid + + +-- | Annotated variant of the tree representation of the XML document. +data Node tag text a = + Element { + eName :: !tag, + eAttrs :: ![(tag,text)], + eChildren :: [Node tag text a], + eAnn :: a + } | + Text !text + deriving (Eq, Show) + +unannotate :: Node tag text a -> 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 annotated nodes +type Nodes tag text a = [Node tag text a] + +-- | Type shortcut for annotated nodes with unqualified tag names where tag and +-- text are the same string type +type UNodes text a = Nodes text text a + +-- | 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 shortcut for a single annotated node, annotated with parse location +type LNode tag text = Node tag text XMLParseLocation + +-- | Type shortcut for annotated nodes with location information. +type LNodes tag text = [Node tag text XMLParseLocation] + +-- | 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 nodes with unqualified tag names where +-- tag and text are the same string type, annotated with parse location +type ULNodes text = LNodes text text + +-- | Type shortcut for annotated nodes where qualified names are used for tags +type QNodes text a = Nodes (QName text) text a + +-- | Type shortcut for nodes where qualified names are used for tags, annotated with parse location +type QLNodes text = LNodes (QName 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 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 annotated nodes where namespaced names are used for tags +type NNodes text a = Nodes (NName text) text a + +-- | Type shortcut for nodes where namespaced names are used for tags, annotated with parse location +type NLNodes text = LNodes (NName 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 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 + +-- | 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) +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 + 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') + ptl ((FailDocument err, _):_) = ([], Just err, []) + ptl [] = ([], Nothing, []) + +-- | Lazily parse XML to tree. Note that forcing the XMLParseError return value +-- will force the entire parse. Therefore, to ensure lazy operation, don't +-- check the error status until you have processed the tree. +parseTree :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> (LNode tag text, Maybe XMLParseError) +parseTree mEnc bs = saxToTree $ parseSAXLocations mEnc bs + +-- | Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'. +parseTreeThrowing :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> LNode tag text +parseTreeThrowing mEnc bs = fst $ saxToTree $ parseSAXLocationsThrowing mEnc bs + +-- | Strictly parse XML to tree. Returns error message or valid parsed tree. +parseTree' :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> B.ByteString -- ^ Input text (a strict ByteString) + -> Either XMLParseError (LNode tag text) +parseTree' mEnc bs = case parseTree mEnc (L.fromChunks [bs]) of + (_, Just err) -> Left err + (root, Nothing) -> Right root + 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 @@ -102,13 +102,11 @@ B.concat [pack "')]:putSAX elts putSAX (CharacterData txt:elts) = B.concat (escapeText (gxToByteString txt)):putSAX elts +putSAX (FailDocument _:elts) = putSAX elts putSAX [] = [] pack :: String -> B.ByteString pack = B.pack . map c2w - -unpack :: L.ByteString -> String -unpack = map w2c . L.unpack escapees :: [Word8] escapees = map c2w "&<\"'" 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + -- hexpat, a Haskell wrapper for expat -- Copyright (C) 2008 Evan Martin -- Copyright (C) 2009 Stephen Blackheath @@ -101,7 +103,7 @@ unStatus :: CInt -> Bool unStatus 0 = False -unStatus 1 = True +unStatus _ = True -- |@parse data@ feeds /lazy/ ByteString data into a 'Parser'. It returns Nothing -- on success, or Just the parse error. @@ -348,20 +350,20 @@ writeIORef charRef $ wrapCharacterDataHandler parser handler pairwise (x1:x2:xs) = (x1,x2) : pairwise xs -pairwise [] = [] +pairwise _ = [] -foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_ParserCreate" +foreign import ccall unsafe "XML_ParserCreate" parserCreate'_ :: ((Ptr CChar) -> (IO (Ptr ()))) -foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetStartElementHandler" +foreign import ccall unsafe "XML_SetStartElementHandler" xmlSetstartelementhandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> ((Ptr (Ptr CChar)) -> (IO ()))))) -> (IO ()))) -foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetEndElementHandler" +foreign import ccall unsafe "XML_SetEndElementHandler" xmlSetendelementhandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> (IO ())))) -> (IO ()))) -foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetCharacterDataHandler" +foreign import ccall unsafe "XML_SetCharacterDataHandler" xmlSetcharacterdatahandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (IO ()))))) -> (IO ()))) -foreign import ccall safe "Text/XML/Expat/IO.chs.h XML_Parse" +foreign import ccall safe "XML_Parse" doParseChunk'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt))))) 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 @@ -96,4 +96,3 @@ tag (QName (Just prefix) local) = prefix `mappend` gxFromChar ':' `mappend` local tag (QName Nothing local) = local - 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 @@ -91,6 +91,7 @@ UNode, UNodes, UAttributes, + textContent, extractText, -- * Parse to tree parseTree, @@ -105,8 +106,9 @@ parseSAXLocations, -- * Variants that throw exceptions XMLParseException(..), - parseSAXThrowing, parseTreeThrowing, + parseSAXThrowing, + parseSAXLocationsThrowing, -- * Abstraction of string types GenericXMLString(..) ) where @@ -180,7 +182,7 @@ gxFromChar = T.singleton gxHead = T.head gxTail = T.tail - gxBreakOn c = T.break (==c) + gxBreakOn c = T.breakBy (==c) gxFromCStringLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr gxToByteString = TE.encodeUtf8 @@ -225,9 +227,14 @@ -- | 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 + +-- | Deprecated - renamed to textContent. extractText :: Monoid text => Node tag text -> text -extractText (Element _ _ children) = mconcat $ map extractText children -extractText (Text txt) = txt +{-# DEPRECATED extractText "renamed to textContent" #-} +extractText = textContent modifyChildren :: ([Node tag text] -> [Node tag text]) -> Node tag text @@ -276,9 +283,12 @@ start name attrs stack = Element name attrs [] : stack text str (cur:rest) = modifyChildren (Text str:) cur : rest + text _ [] = impossible end (cur:parent:rest) = let node = modifyChildren reverse cur in modifyChildren (node:) parent : rest + end _ = impossible + impossible = error "parseTree' impossible" data SAXEvent tag text = StartElement tag [(tag, text)] | @@ -343,16 +353,6 @@ instance Exception XMLParseException where --- | Lazily parse XML to SAX events. In the event of an error, throw 'XMLParseException'. -parseSAXThrowing :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) - -> [SAXEvent tag text] -parseSAXThrowing mEnc bs = map freakOut $ parseSAX mEnc bs - where - freakOut (FailDocument err) = Exc.throw $ XMLParseException err - freakOut other = other - -- | A variant of parseSAX that gives a document location with each SAX event. parseSAXLocations :: (GenericXMLString tag, GenericXMLString text) => Maybe Encoding -- ^ Optional encoding override @@ -395,6 +395,27 @@ return $ reverse queue ++ rem runParser $ L.toChunks input + +-- | Lazily parse XML to SAX events. In the event of an error, throw 'XMLParseException'. +parseSAXThrowing :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> [SAXEvent tag text] +parseSAXThrowing mEnc bs = map freakOut $ parseSAX mEnc bs + where + freakOut (FailDocument err) = Exc.throw $ XMLParseException err + freakOut other = other + +-- | A variant of parseSAX that gives a document location with each SAX event. +-- In the event of an error, throw 'XMLParseException'. +parseSAXLocationsThrowing :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> [(SAXEvent tag text, XMLParseLocation)] +parseSAXLocationsThrowing mEnc bs = map freakOut $ parseSAXLocations mEnc bs + where + freakOut (FailDocument err, _) = Exc.throw $ XMLParseException err + freakOut other = other -- | A lower level function that lazily converts a SAX stream into a tree structure. saxToTree :: GenericXMLString tag => diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -1,6 +1,6 @@ Cabal-Version: >= 1.4 Name: hexpat -Version: 0.9 +Version: 0.10 Synopsis: wrapper for expat, the fast XML parser Description: Expat () is a stream-oriented XML parser @@ -48,17 +48,17 @@ haskell98, bytestring, mtl >= 1.1.0.0, - text >= 0.1, + text >= 0.5, utf8-string >= 0.3.3, parallel, containers, extensible-exceptions >= 0.1 && < 0.2 Exposed-Modules: + Text.XML.Expat.Annotated, Text.XML.Expat.Tree, Text.XML.Expat.Format, Text.XML.Expat.Namespaced, Text.XML.Expat.Qualified, Text.XML.Expat.IO - Extensions: ForeignFunctionInterface Extra-Libraries: expat diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -116,16 +116,16 @@ ["start open","start test1","end test1","start hello","end hello","end open"] l -test_extractText = do +test_textContent = do let tree = Element "cheese" [("type", "edam")] [Text "You don't actually ", Element "sub" [] [Text "have any "], Text "cheese at all", Text ", do you?"] - assertEqual "extractText" "You don't actually have any cheese at all, do you?" (extractText tree) + assertEqual "textContent" "You don't actually have any cheese at all, do you?" (textContent tree) main = do - testXML <- readFile "test.xml" + testXML <- map w2c . B.unpack <$> B.readFile "test.xml" -- Remove trailing newline let testXML' = reverse . dropWhile (== '\n') . reverse $ testXML docs = simpleDocs ++ [testXML'] @@ -159,6 +159,6 @@ TestCase $ test_error3, TestCase $ test_error4, TestCase $ test_parse, - TestCase $ test_extractText + TestCase $ test_textContent ]