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 @@ -9,61 +9,76 @@ -- * 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 + + -- * Deprecated parse functions + parseSAX, + parseSAXThrowing, + parseSAXLocations, + parseSAXLocationsThrowing, parseTree, parseTree', + parseTreeThrowing, + + -- * Parse to tree Encoding(..), XMLParseError(..), XMLParseLocation(..), + parse, + parse', + parseThrowing, + -- * 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.Tree ( Attributes, UAttributes ) +import qualified Text.XML.Expat.Tree as Tree +import Text.XML.Expat.SAX ( Encoding(..) + , GenericXMLString(..) + , ParserOptions(..) + , SAXEvent(..) + , XMLParseError(..) + , XMLParseException(..) + , XMLParseLocation(..) + , parseSAX + , 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 Control.Monad (mplus) +import Control.Parallel.Strategies import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Monoid @@ -80,6 +95,10 @@ Text !text deriving (Eq, Show) +instance (NFData tag, NFData text, NFData a) => NFData (Node tag text a) 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 unannotate (Element na at ch _) = (Tree.Element na at (map unannotate ch)) unannotate (Text t) = Tree.Text t @@ -90,13 +109,6 @@ 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 @@ -104,35 +116,16 @@ -- | 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 @@ -169,25 +162,63 @@ -- | 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. +parse :: (GenericXMLString tag, GenericXMLString text) => + ParserOptions tag text -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> (LNode tag text, Maybe XMLParseError) +parse opts bs = saxToTree $ SAX.parseLocations opts bs + +-- | DEPRECATED: Use 'parse' instead. +-- +-- 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 +{-# DEPRECATED parseTree "use Text.XML.Annotated.parse instead" #-} +parseTree mEnc = parse (ParserOptions mEnc Nothing) -- | Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'. +-- +-- @parseThrowing@ can throw an exception from pure code, which is generally a bad +-- way to handle errors, because Haskell\'s lazy evaluation means it\'s hard to +-- predict where it will be thrown from. However, it may be acceptable in +-- situations where it's not expected during normal operation, depending on the +-- design of your program. +parseThrowing :: (GenericXMLString tag, GenericXMLString text) => + ParserOptions tag text -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> LNode tag text +parseThrowing opts bs = fst $ saxToTree $ SAX.parseLocationsThrowing opts bs + +-- | DEPRECATED: use 'parseThrowing' instead +-- +-- 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 +{-# DEPRECATED parseTreeThrowing "use Text.XML.Annotated.parseThrowing instead" #-} +parseTreeThrowing mEnc = parseThrowing (ParserOptions mEnc Nothing) -- | Strictly parse XML to tree. Returns error message or valid parsed tree. +parse' :: (GenericXMLString tag, GenericXMLString text) => + ParserOptions tag text -- ^ Optional encoding override + -> B.ByteString -- ^ Input text (a strict ByteString) + -> Either XMLParseError (LNode tag text) +parse' opts bs = case parse opts (L.fromChunks [bs]) of + (_, Just err) -> Left err + (root, Nothing) -> Right root + +-- | DEPRECATED: use 'parse' instead. +-- +-- 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 +{-# DEPRECATED parseTree' "use Text.XML.Expat.parse' instead" #-} +parseTree' mEnc = parse' (ParserOptions mEnc Nothing) diff --git a/Text/XML/Expat/Cursor.hs b/Text/XML/Expat/Cursor.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Cursor.hs @@ -0,0 +1,378 @@ +-------------------------------------------------------------------- +-- | +-- Module : Text.XML.Expat.Cursor +-- +-- This module ported from Text.XML.Light.Proc +-- +-- XML cursors for working XML content withing the context of +-- an XML document. This implementation is based on the general +-- tree zipper written by Krasimir Angelov and Iavor S. Diatchki. +-- + +module Text.XML.Expat.Cursor + ( Tag(..), getTag, fromTag + , Cursor(..), Path + + -- * Conversions + , fromTree + , fromForest + , toForest + , toTree + + -- * Moving around + , parent + , root + , getChild + , firstChild + , lastChild + , left + , right + , nextDF + + -- ** Searching + , findChild + , findLeft + , findRight + , findRec + + -- * Node classification + , isRoot + , isFirst + , isLast + , isLeaf + , isChild + , hasChildren + , getNodeIndex + + -- * Updates + , setContent + , modifyContent + , modifyContentList + , modifyContentM + + -- ** Inserting content + , insertLeft + , insertRight + , insertManyLeft + , insertManyRight + , insertFirstChild + , insertLastChild + , insertManyFirstChild + , insertManyLastChild + , insertGoLeft + , insertGoRight + + -- ** Removing content + , removeLeft + , removeRight + , removeGoLeft + , removeGoRight + , removeGoUp + + ) where + +import Text.XML.Expat.Tree +import Data.Maybe(isNothing) +import Control.Monad(mplus) + +data Tag tag text = Tag { tagName :: tag + , tagAttribs :: Attributes tag text + } deriving (Show) + +{- +setTag :: Tag -> Element -> Element +setTag t e = fromTag t (elContent e) +-} + +fromTag :: Tag tag text -> [Node tag text] -> Node tag text +fromTag t cs = Element { eName = tagName t + , eAttrs = tagAttribs t + , eChildren = cs + } + +type Path tag text = [([Node tag text],Tag tag text,[Node tag text])] + +-- | The position of a piece of content in an XML document. +data Cursor tag text = Cur + { current :: Node tag text -- ^ The currently selected content. + , lefts :: [Node tag text] -- ^ Siblings on the left, closest first. + , rights :: [Node tag text] -- ^ Siblings on the right, closest first. + , parents :: Path tag text -- ^ The contexts of the parent elements of this location. + } deriving (Show) + +-- Moving around --------------------------------------------------------------- + +-- | The parent of the given location. +parent :: Cursor tag text -> Maybe (Cursor tag text) +parent loc = + case parents loc of + (pls,v,prs) : ps -> Just + Cur { current = (fromTag v + (combChildren (lefts loc) (current loc) (rights loc))) + , lefts = pls, rights = prs, parents = ps + } + [] -> Nothing + + +-- | The top-most parent of the given location. +root :: Cursor tag text -> Cursor tag text +root loc = maybe loc root (parent loc) + +-- | The left sibling of the given location. +left :: Cursor tag text -> Maybe (Cursor tag text) +left loc = + case lefts loc of + t : ts -> Just loc { current = t, lefts = ts + , rights = current loc : rights loc } + [] -> Nothing + +-- | The right sibling of the given location. +right :: Cursor tag text -> Maybe (Cursor tag text) +right loc = + case rights loc of + t : ts -> Just loc { current = t, lefts = current loc : lefts loc + , rights = ts } + [] -> Nothing + +-- | The first child of the given location. +firstChild :: Cursor tag text -> Maybe (Cursor tag text) +firstChild loc = + do (t : ts, ps) <- downParents loc + return Cur { current = t, lefts = [], rights = ts , parents = ps } + +-- | The last child of the given location. +lastChild :: Cursor tag text -> Maybe (Cursor tag text) +lastChild loc = + do (ts, ps) <- downParents loc + case reverse ts of + l : ls -> return Cur { current = l, lefts = ls, rights = [] + , parents = ps } + [] -> Nothing + +-- | Find the next left sibling that satisfies a predicate. +findLeft :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text) +findLeft p loc = do loc1 <- left loc + if p loc1 then return loc1 else findLeft p loc1 + +-- | Find the next right sibling that satisfies a predicate. +findRight :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text) +findRight p loc = do loc1 <- right loc + if p loc1 then return loc1 else findRight p loc1 + +-- | The first child that satisfies a predicate. +findChild :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text) +findChild p loc = + do loc1 <- firstChild loc + if p loc1 then return loc1 else findRight p loc1 + +-- | The next position in a left-to-right depth-first traversal of a document: +-- either the first child, right sibling, or the right sibling of a parent that +-- has one. +nextDF :: Cursor tag text -> Maybe (Cursor tag text) +nextDF c = firstChild c `mplus` up c + where up x = right x `mplus` (up =<< parent x) + +-- | Perform a depth first search for a descendant that satisfies the +-- given predicate. +findRec :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text) +findRec p c = if p c then Just c else findRec p =<< nextDF c + + +-- | The child with the given index (starting from 0). +getChild :: Int -> Cursor tag text -> Maybe (Cursor tag text) +getChild n loc = + do (ts,ps) <- downParents loc + (ls,t,rs) <- splitChildren ts n + return Cur { current = t, lefts = ls, rights = rs, parents = ps } + + +-- | private: computes the parent for "down" operations. +downParents :: Cursor tag text -> Maybe ([Node tag text], Path tag text) +downParents loc = + case current loc of + Element n a c -> Just ( c + , (lefts loc, Tag n a, rights loc) : parents loc + ) + _ -> Nothing + +getTag :: Node tag text -> Tag tag text +getTag e = Tag { tagName = eName e + , tagAttribs = eAttrs e + } + + +-- Conversions ----------------------------------------------------------------- + +-- | A cursor for the given content. +fromTree :: Node tag text -> Cursor tag text +fromTree t = Cur { current = t, lefts = [], rights = [], parents = [] } + +-- | The location of the first tree in a forest. +fromForest :: [Node tag text] -> Maybe (Cursor tag text) +fromForest (t:ts) = Just Cur { current = t, lefts = [], rights = ts + , parents = [] } +fromForest [] = Nothing + +-- | Computes the tree containing this location. +toTree :: Cursor tag text -> Node tag text +toTree loc = current (root loc) + +-- | Computes the forest containing this location. +toForest :: Cursor tag text -> [Node tag text] +toForest loc = let r = root loc in combChildren (lefts r) (current r) (rights r) + + +-- Queries --------------------------------------------------------------------- + +-- | Are we at the top of the document? +isRoot :: Cursor tag text -> Bool +isRoot loc = null (parents loc) + +-- | Are we at the left end of the the document? +isFirst :: Cursor tag text -> Bool +isFirst loc = null (lefts loc) + +-- | Are we at the right end of the document? +isLast :: Cursor tag text -> Bool +isLast loc = null (rights loc) + +-- | Are we at the bottom of the document? +isLeaf :: Cursor tag text -> Bool +isLeaf loc = isNothing (downParents loc) + +-- | Do we have a parent? +isChild :: Cursor tag text -> Bool +isChild loc = not (isRoot loc) + +-- | Get the node index inside the sequence of children +getNodeIndex :: Cursor tag text -> Int +getNodeIndex loc = length (lefts loc) + +-- | Do we have children? +hasChildren :: Cursor tag text -> Bool +hasChildren loc = not (isLeaf loc) + + + +-- Updates --------------------------------------------------------------------- + +-- | Change the current content. +setContent :: Node tag text -> Cursor tag text -> Cursor tag text +setContent t loc = loc { current = t } + +-- | Modify the current content. +modifyContent :: (Node tag text -> Node tag text) -> Cursor tag text -> Cursor tag text +modifyContent f loc = setContent (f (current loc)) loc + +-- | Modify the current content. +modifyContentList :: (Node tag text -> [Node tag text]) -> Cursor tag text -> Maybe (Cursor tag text) +modifyContentList f loc = removeGoRight $ insertManyRight (f $ current loc) loc + +-- | Modify the current content, allowing for an effect. +modifyContentM :: Monad m => (Node tag text -> m (Node tag text)) -> Cursor tag text -> m (Cursor tag text) +modifyContentM f loc = do x <- f (current loc) + return (setContent x loc) + +-- | Insert content to the left of the current position. +insertLeft :: Node tag text -> Cursor tag text -> Cursor tag text +insertLeft t loc = loc { lefts = t : lefts loc } + +-- | Insert content to the right of the current position. +insertRight :: Node tag text -> Cursor tag text -> Cursor tag text +insertRight t loc = loc { rights = t : rights loc } + +-- | Insert content to the left of the current position. +insertManyLeft :: [Node tag text] -> Cursor tag text -> Cursor tag text +insertManyLeft t loc = loc { lefts = reverse t ++ lefts loc } + +-- | Insert content to the right of the current position. +insertManyRight :: [Node tag text] -> Cursor tag text -> Cursor tag text +insertManyRight t loc = loc { rights = t ++ rights loc } + +-- | Insert content as the first child of the current position. +mapChildren :: ([Node tag text] -> [Node tag text]) + -> Cursor tag text + -> Maybe (Cursor tag text) +mapChildren f loc = let e = current loc in + case e of + Text _ -> Nothing + Element _ _ c -> Just $ loc { current = e { eChildren = f c } } + +-- | Insert content as the first child of the current position. +insertFirstChild :: Node tag text -> Cursor tag text -> Maybe (Cursor tag text) +insertFirstChild t = mapChildren (t:) + +-- | Insert content as the first child of the current position. +insertLastChild :: Node tag text -> Cursor tag text -> Maybe (Cursor tag text) +insertLastChild t = mapChildren (++[t]) + +-- | Insert content as the first child of the current position. +insertManyFirstChild :: [Node tag text] -> Cursor tag text -> Maybe (Cursor tag text) +insertManyFirstChild t = mapChildren (t++) + +-- | Insert content as the first child of the current position. +insertManyLastChild :: [Node tag text] -> Cursor tag text -> Maybe (Cursor tag text) +insertManyLastChild t = mapChildren (++t) + +-- | Remove the content on the left of the current position, if any. +removeLeft :: Cursor tag text -> Maybe (Node tag text,Cursor tag text) +removeLeft loc = case lefts loc of + l : ls -> return (l,loc { lefts = ls }) + [] -> Nothing + +-- | Remove the content on the right of the current position, if any. +removeRight :: Cursor tag text -> Maybe (Node tag text,Cursor tag text) +removeRight loc = case rights loc of + l : ls -> return (l,loc { rights = ls }) + [] -> Nothing + + +-- | Insert content to the left of the current position. +-- The new content becomes the current position. +insertGoLeft :: Node tag text -> Cursor tag text -> Cursor tag text +insertGoLeft t loc = loc { current = t, rights = current loc : rights loc } + +-- | Insert content to the right of the current position. +-- The new content becomes the current position. +insertGoRight :: Node tag text -> Cursor tag text -> Cursor tag text +insertGoRight t loc = loc { current = t, lefts = current loc : lefts loc } + +-- | Remove the current element. +-- The new position is the one on the left. +removeGoLeft :: Cursor tag text -> Maybe (Cursor tag text) +removeGoLeft loc = case lefts loc of + l : ls -> Just loc { current = l, lefts = ls } + [] -> Nothing + +-- | Remove the current element. +-- The new position is the one on the right. +removeGoRight :: Cursor tag text -> Maybe (Cursor tag text) +removeGoRight loc = case rights loc of + l : ls -> Just loc { current = l, rights = ls } + [] -> Nothing + +-- | Remove the current element. +-- The new position is the parent of the old position. +removeGoUp :: Cursor tag text -> Maybe (Cursor tag text) +removeGoUp loc = + case parents loc of + (pls,v,prs) : ps -> Just + Cur { current = fromTag v (reverse (lefts loc) ++ rights loc) + , lefts = pls, rights = prs, parents = ps + } + [] -> Nothing + + +-- | private: Gets the given element of a list. +-- Also returns the preceding elements (reversed) and the following elements. +splitChildren :: [a] -> Int -> Maybe ([a],a,[a]) +splitChildren _ n | n < 0 = Nothing +splitChildren cs pos = loop [] cs pos + where loop acc (x:xs) 0 = Just (acc,x,xs) + loop acc (x:xs) n = loop (x:acc) xs $! n-1 + loop _ _ _ = Nothing + +-- | private: combChildren ls x ys = reverse ls ++ [x] ++ ys +combChildren :: [a] -> a -> [a] -> [a] +combChildren ls t rs = foldl (flip (:)) (t:rs) ls + 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 @@ -9,10 +9,13 @@ module Text.XML.Expat.Format ( -- * High level - formatTree, - formatTree', + format, + format', formatNode, formatNode', + -- * Deprecated names + formatTree, + formatTree', -- * Low level xmlHeader, treeToSAX, @@ -29,17 +32,29 @@ import qualified Data.Text.Encoding as TE import Data.Word --- | Format document with Node tag text -> L.ByteString -formatTree node = xmlHeader `L.append` formatNode node +formatTree = format --- | Format document with + Node tag text + -> L.ByteString +format node = xmlHeader `L.append` formatNode node + +-- | DEPRECATED: Renamed to 'format''. formatTree' :: (GenericXMLString tag, GenericXMLString text) => Node tag text -> B.ByteString formatTree' = B.concat . L.toChunks . formatTree + +-- | Format document with + Node tag text + -> B.ByteString +format' = B.concat . L.toChunks . formatTree -- | Format XML node with no header - lazy variant that returns lazy ByteString. formatNode :: (GenericXMLString tag, GenericXMLString text) => 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 @@ -4,9 +4,9 @@ -- Copyright (C) 2008 Evan Martin -- Copyright (C) 2009 Stephen Blackheath --- | Low-level interface to Expat. Unless speed is paramount, this --- should normally be avoided in favour of the interface provided by "Text-XML-Expat-Tree". --- Basic usage is: +-- | Low-level interface to Expat. Unless speed is paramount, this should +-- normally be avoided in favour of the interfaces provided by +-- 'Text.XML.Expat.SAX' and 'Text.XML.Expat.Tree'. Basic usage is: -- -- (1) Make a new parser: 'newParser'. -- @@ -24,10 +24,20 @@ XMLParseLocation(..), -- ** Parser Callbacks - StartElementHandler, EndElementHandler, CharacterDataHandler, - setStartElementHandler, setEndElementHandler, setCharacterDataHandler, + StartElementHandler, + EndElementHandler, + CharacterDataHandler, + ExternalEntityRefHandler, + SkippedEntityHandler, + setStartElementHandler, + setEndElementHandler, + setCharacterDataHandler, + setExternalEntityRefHandler, + setSkippedEntityHandler, + setUseForeignDTD, -- ** Lower-level interface + parseExternalEntityReference, unsafeParseChunk, withHandlers, unsafeSetHandlers, @@ -44,8 +54,8 @@ 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 Data.Int import Foreign import CForeign @@ -53,16 +63,19 @@ -- |Opaque parser type. type ParserPtr = Ptr () data Parser = Parser - (ForeignPtr ()) - (IORef CStartElementHandler) - (IORef CEndElementHandler) - (IORef CCharacterDataHandler) + { _parserObj :: ForeignPtr () + , _startElementHandler :: IORef CStartElementHandler + , _endElementHandler :: IORef CEndElementHandler + , _cdataHandler :: IORef CCharacterDataHandler + , _externalEntityRefHandler :: IORef (Maybe CExternalEntityRefHandler) + , _skippedEntityHandler :: IORef (Maybe CSkippedEntityHandler) + } instance Show Parser where - showsPrec _ (Parser fp _ _ _) = showsPrec 0 fp + showsPrec _ (Parser fp _ _ _ _ _) = showsPrec 0 fp withParser :: Parser -> (ParserPtr -> IO a) -> IO a -withParser (Parser fp _ _ _) = withForeignPtr fp +withParser (Parser fp _ _ _ _ _) = withForeignPtr fp -- |Encoding types available for the document encoding. data Encoding = ASCII | UTF8 | UTF16 | ISO88591 @@ -76,25 +89,33 @@ withOptEncoding Nothing f = f nullPtr withOptEncoding (Just enc) f = withCString (encodingToString enc) f + parserCreate :: Maybe Encoding -> IO (ParserPtr) parserCreate a1 = withOptEncoding a1 $ \a1' -> parserCreate'_ a1' >>= \res -> let {res' = id res} in return (res') -foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ()) --- |Create a 'Parser'. The encoding parameter, if provided, overrides the --- document's encoding declaration. +-- | Create a 'Parser'. newParser :: Maybe Encoding -> IO Parser newParser enc = do - ptr <- parserCreate enc - fptr <- newForeignPtr parserFree ptr + ptr <- parserCreate enc + fptr <- newForeignPtr parserFree ptr nullStartH <- newIORef nullCStartElementHandler - nullEndH <- newIORef nullCEndElementHandler - nullCharH <- newIORef nullCCharacterDataHandler - return $ Parser fptr nullStartH nullEndH nullCharH + nullEndH <- newIORef nullCEndElementHandler + nullCharH <- newIORef nullCCharacterDataHandler + extH <- newIORef Nothing + skipH <- newIORef Nothing + + return $ Parser fptr nullStartH nullEndH nullCharH extH skipH + +setUseForeignDTD :: Parser -> Bool -> IO () +setUseForeignDTD p b = withParser p $ \p' -> xmlUseForeignDTD p' b' + where + b' = if b then 1 else 0 + -- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt -- instead of an Int. withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a @@ -105,10 +126,10 @@ unStatus 0 = False unStatus _ = True --- |@parse data@ feeds /lazy/ ByteString data into a 'Parser'. It returns Nothing --- on success, or Just the parse error. +-- |@parse data@ feeds /lazy/ ByteString data into a 'Parser'. It returns +-- Nothing on success, or Just the parse error. parse :: Parser -> BSL.ByteString -> IO (Maybe XMLParseError) -parse parser@(Parser _ _ _ _) bs = withHandlers parser $ do +parse parser bs = withHandlers parser $ do ok <- doParseChunks (BSL.toChunks bs) if ok then return Nothing @@ -121,10 +142,10 @@ then doParseChunks cs else return False --- |@parse data@ feeds /strict/ ByteString data into a 'Parser'. It returns Nothing --- on success, or Just the parse error. +-- |@parse data@ feeds /strict/ ByteString data into a 'Parser'. It returns +-- Nothing on success, or Just the parse error. parse' :: Parser -> BS.ByteString -> IO (Maybe XMLParseError) -parse' parser@(Parser _ _ _ _) bs = withHandlers parser $ do +parse' parser bs = withHandlers parser $ do ok <- doParseChunk parser bs True if ok then return Nothing @@ -139,9 +160,23 @@ -> IO (Maybe XMLParseError) parseChunk parser xml final = withHandlers parser $ unsafeParseChunk parser xml final --- | This variant of 'parseChunk' must either be called inside 'withHandlers' (safest), or --- between 'unsafeSetHandlers' and 'unsafeReleaseHandlers', and this --- will give you better performance than 'parseChunk' if you process multiple chunks inside. +parseExternalEntityReference :: Parser + -> CString -- ^ context + -> Maybe Encoding -- ^ encoding + -> CStringLen -- ^ text + -> IO Bool +parseExternalEntityReference parser context encoding (text,sz) = + withParser parser $ \p -> do + extp <- withOptEncoding encoding $ + xmlExternalEntityParserCreate p context + e <- doParseChunk'_ extp text (fromIntegral sz) 1 + parserFree' extp + return $ e == 1 + +-- | This variant of 'parseChunk' must either be called inside 'withHandlers' +-- (safest), or between 'unsafeSetHandlers' and 'unsafeReleaseHandlers', and +-- this will give you better performance than 'parseChunk' if you process +-- multiple chunks inside. unsafeParseChunk :: Parser -> BS.ByteString -> Bool @@ -152,6 +187,7 @@ then return Nothing else Just `fmap` getError parser +getError :: Parser -> IO XMLParseError getError parser = withParser parser $ \p -> do code <- xmlGetErrorCode p cerr <- xmlErrorString code @@ -163,23 +199,43 @@ (FunPtr CStartElementHandler) (FunPtr CEndElementHandler) (FunPtr CCharacterDataHandler) + (Maybe (FunPtr CExternalEntityRefHandler)) + (Maybe (FunPtr CSkippedEntityHandler)) unsafeSetHandlers :: Parser -> IO ExpatHandlers -unsafeSetHandlers parser@(Parser fp startRef endRef charRef) = do +unsafeSetHandlers parser@(Parser _ startRef endRef charRef extRef skipRef) = + do cStartH <- mkCStartElementHandler =<< readIORef startRef cEndH <- mkCEndElementHandler =<< readIORef endRef cCharH <- mkCCharacterDataHandler =<< readIORef charRef + mExtH <- readIORef extRef >>= + maybe (return Nothing) + (\h -> liftM Just $ mkCExternalEntityRefHandler h) + + mSkipH <- readIORef skipRef >>= + maybe (return Nothing) + (\h -> liftM Just $ mkCSkippedEntityHandler h) + withParser parser $ \p -> do xmlSetstartelementhandler p cStartH xmlSetendelementhandler p cEndH xmlSetcharacterdatahandler p cCharH - return $ ExpatHandlers cStartH cEndH cCharH + maybe (return ()) + (xmlSetExternalEntityRefHandler p) + mExtH + maybe (return ()) + (xmlSetSkippedEntityHandler p) + mSkipH + return $ ExpatHandlers cStartH cEndH cCharH mExtH mSkipH + unsafeReleaseHandlers :: ExpatHandlers -> IO () -unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH) = do +unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH mcExtH mcSkipH) = do freeHaskellFunPtr cStartH freeHaskellFunPtr cEndH freeHaskellFunPtr cCharH + maybe (return ()) freeHaskellFunPtr mcExtH + maybe (return ()) freeHaskellFunPtr mcSkipH -- | 'unsafeParseChunk' is required to be called inside @withHandlers@. -- Safer than using 'unsafeSetHandlers' / 'unsafeReleaseHandlers'. @@ -224,6 +280,7 @@ instance NFData XMLParseLocation where rnf (XMLParseLocation lin col ind cou) = rnf (lin, col, ind, cou) +getParseLocation :: Parser -> IO XMLParseLocation getParseLocation parser = withParser parser $ \p -> do line <- xmlGetCurrentLineNumber p col <- xmlGetCurrentColumnNumber p @@ -236,123 +293,114 @@ xmlByteCount = fromIntegral count } --- |The type of the \"element started\" callback. The first parameter is --- the element name; the second are the (attribute, value) pairs. Return True --- to continue parsing as normal, or False to terminate the parse. +-- | The type of the \"element started\" callback. The first parameter is the +-- element name; the second are the (attribute, value) pairs. Return True to +-- continue parsing as normal, or False to terminate the parse. type StartElementHandler = CString -> [(CString, CString)] -> IO Bool --- |The type of the \"element ended\" callback. The parameter is --- the element name. Return True to continue parsing as normal, or False to --- terminate the parse. + +-- | The type of the \"element ended\" callback. The parameter is the element +-- name. Return True to continue parsing as normal, or False to terminate the +-- parse. type EndElementHandler = CString -> IO Bool --- |The type of the \"character data\" callback. The parameter is --- the character data processed. This callback may be called more than once --- while processing a single conceptual block of text. Return True to continue + +-- | The type of the \"character data\" callback. The parameter is the +-- character data processed. This callback may be called more than once while +-- processing a single conceptual block of text. Return True to continue -- parsing as normal, or False to terminate the parse. type CharacterDataHandler = CStringLen -> IO Bool -type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO () -nullCStartElementHandler _ _ _ = return () +-- | The type of the \"external entity reference\" callback. See the expat +-- documentation. +type ExternalEntityRefHandler = Parser + -> CString -- context + -> CString -- base + -> CString -- systemID + -> CString -- publicID + -> IO Bool --- Note on word sizes: --- --- on expat 2.0: --- XML_GetCurrentLineNumber returns XML_Size --- XML_GetCurrentColumnNumber returns XML_Size --- XML_GetCurrentByteIndex returns XML_Index --- These are defined in expat_external.h --- --- debian-i386 says XML_Size and XML_Index are 4 bytes. --- ubuntu-amd64 says XML_Size and XML_Index are 8 bytes. --- These two systems do NOT define XML_LARGE_SIZE, which would force these types --- to be 64-bit. +-- | Set a skipped entity handler. This is called in two situations: -- --- If we guess the word size too small, it shouldn't matter: We will just discard --- the most significant part. If we get the word size too large, we will get --- garbage (very bad). +-- 1. An entity reference is encountered for which no declaration has been read +-- and this is not an error. -- --- So - what I will do is use CLong and CULong, which correspond to what expat --- is using when XML_LARGE_SIZE is disabled, and give the correct sizes on the --- two machines mentioned above. At the absolute worst the word size will be too --- short. +-- 2. An internal entity reference is read, but not expanded, because +-- @XML_SetDefaultHandler@ has been called. +type SkippedEntityHandler = CString -- entityName + -> Int -- is a parameter entity? + -> IO Bool -foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode - :: ParserPtr -> IO CInt -foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber - :: ParserPtr -> IO CULong -foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber - :: ParserPtr -> IO CULong -foreign import ccall unsafe "expat.h XML_GetCurrentByteIndex" xmlGetCurrentByteIndex - :: ParserPtr -> IO CLong -foreign import ccall unsafe "expat.h XML_GetCurrentByteCount" xmlGetCurrentByteCount - :: ParserPtr -> IO CInt -foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString - :: CInt -> IO CString -foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser - :: ParserPtr -> CInt -> IO () +type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO () +nullCStartElementHandler :: CStartElementHandler +nullCStartElementHandler _ _ _ = return () + foreign import ccall safe "wrapper" mkCStartElementHandler :: CStartElementHandler -> IO (FunPtr CStartElementHandler) wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler -wrapStartElementHandler parser@(Parser _ _ _ _) handler = h +wrapStartElementHandler parser handler = h where - h ptr cname cattrs = do + h _ cname cattrs = do cattrlist <- peekArray0 nullPtr cattrs stillRunning <- handler cname (pairwise cattrlist) - unless stillRunning $ - withParser parser $ \p -> xmlStopParser p 0 + unless stillRunning $ stopParser parser --- |Attach a StartElementHandler to a Parser. +-- | Attach a StartElementHandler to a Parser. setStartElementHandler :: Parser -> StartElementHandler -> IO () -setStartElementHandler parser@(Parser _ startRef _ _) handler = - withParser parser $ \p -> do - writeIORef startRef $ wrapStartElementHandler parser handler +setStartElementHandler parser@(Parser _ startRef _ _ _ _) handler = + writeIORef startRef $ wrapStartElementHandler parser handler type CEndElementHandler = Ptr () -> CString -> IO () + +nullCEndElementHandler :: CEndElementHandler nullCEndElementHandler _ _ = return () foreign import ccall safe "wrapper" mkCEndElementHandler :: CEndElementHandler -> IO (FunPtr CEndElementHandler) wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler -wrapEndElementHandler parser@(Parser _ _ _ _) handler = h +wrapEndElementHandler parser handler = h where - h ptr cname = do + h _ cname = do stillRunning <- handler cname - unless stillRunning $ - withParser parser $ \p -> xmlStopParser p 0 + unless stillRunning $ stopParser parser --- |Attach an EndElementHandler to a Parser. +-- | Attach an EndElementHandler to a Parser. setEndElementHandler :: Parser -> EndElementHandler -> IO () -setEndElementHandler parser@(Parser _ _ endRef _) handler = - withParser parser $ \p -> do - writeIORef endRef $ wrapEndElementHandler parser handler +setEndElementHandler parser@(Parser _ _ endRef _ _ _) handler = + writeIORef endRef $ wrapEndElementHandler parser handler type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO () + +nullCCharacterDataHandler :: CCharacterDataHandler nullCCharacterDataHandler _ _ _ = return () foreign import ccall safe "wrapper" mkCCharacterDataHandler :: CCharacterDataHandler -> IO (FunPtr CCharacterDataHandler) wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler -wrapCharacterDataHandler parser@(Parser _ _ _ _) handler = h +wrapCharacterDataHandler parser handler = h where - h ptr cdata len = do + h _ cdata len = do stillRunning <- handler (cdata, fromIntegral len) - unless stillRunning $ - withParser parser $ \p -> xmlStopParser p 0 + unless stillRunning $ stopParser parser -- | Attach an CharacterDataHandler to a Parser. setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO () -setCharacterDataHandler parser@(Parser _ _ _ charRef) handler = - withParser parser $ \p -> do - writeIORef charRef $ wrapCharacterDataHandler parser handler +setCharacterDataHandler parser@(Parser _ _ _ charRef _ _) handler = + writeIORef charRef $ wrapCharacterDataHandler parser handler +pairwise :: [a] -> [(a,a)] pairwise (x1:x2:xs) = (x1,x2) : pairwise xs pairwise _ = [] +stopParser :: Parser -> IO () +stopParser parser = withParser parser $ \p -> xmlStopParser p 0 +------------------------------------------------------------------------------ +-- C imports + foreign import ccall unsafe "XML_ParserCreate" parserCreate'_ :: ((Ptr CChar) -> (IO (Ptr ()))) @@ -367,3 +415,121 @@ foreign import ccall safe "XML_Parse" doParseChunk'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt))))) + +foreign import ccall unsafe "XML_UseForeignDTD" + xmlUseForeignDTD :: ParserPtr -- ^ parser + -> CChar -- ^ use foreign DTD? (external entity ref + -- handler will be called with publicID & + -- systemID set to null + -> IO () + +foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ()) +foreign import ccall "XML_ParserFree" parserFree' :: ParserPtr -> IO () + +type CExternalEntityRefHandler = ParserPtr -- parser + -> Ptr CChar -- context + -> Ptr CChar -- base + -> Ptr CChar -- systemID + -> Ptr CChar -- publicID + -> IO () + +foreign import ccall safe "wrapper" + mkCExternalEntityRefHandler :: CExternalEntityRefHandler + -> IO (FunPtr CExternalEntityRefHandler) + + +foreign import ccall unsafe "XML_SetExternalEntityRefHandler" + xmlSetExternalEntityRefHandler :: ParserPtr + -> FunPtr CExternalEntityRefHandler + -> IO () + +foreign import ccall unsafe "XML_SetSkippedEntityHandler" + xmlSetSkippedEntityHandler :: ParserPtr + -> FunPtr CSkippedEntityHandler + -> IO () + +foreign import ccall unsafe "XML_ExternalEntityParserCreate" + xmlExternalEntityParserCreate :: ParserPtr + -> CString -- ^ context + -> CString -- ^ encoding + -> IO ParserPtr + +type CSkippedEntityHandler = Ptr () -- user data pointer + -> CString -- entity name + -> CInt -- is a parameter entity? + -> IO () + +foreign import ccall safe "wrapper" + mkCSkippedEntityHandler :: CSkippedEntityHandler + -> IO (FunPtr CSkippedEntityHandler) + + +wrapExternalEntityRefHandler :: Parser + -> ExternalEntityRefHandler + -> CExternalEntityRefHandler +wrapExternalEntityRefHandler parser handler = h + where + h _ context base systemID publicID = do + stillRunning <- handler parser context base systemID publicID + unless stillRunning $ stopParser parser + + +wrapSkippedEntityHandler :: Parser + -> SkippedEntityHandler + -> CSkippedEntityHandler +wrapSkippedEntityHandler parser handler = h + where + h _ entityName i = do + stillRunning <- handler entityName (fromIntegral i) + unless stillRunning $ stopParser parser + + +setExternalEntityRefHandler :: Parser -> ExternalEntityRefHandler -> IO () +setExternalEntityRefHandler parser h = + writeIORef ref $ Just $ wrapExternalEntityRefHandler parser h + where + ref = _externalEntityRefHandler parser + +setSkippedEntityHandler :: Parser -> SkippedEntityHandler -> IO () +setSkippedEntityHandler parser h = + writeIORef ref $ Just $ wrapSkippedEntityHandler parser h + where + ref = _skippedEntityHandler parser + +-- Note on word sizes: +-- +-- on expat 2.0: +-- XML_GetCurrentLineNumber returns XML_Size +-- XML_GetCurrentColumnNumber returns XML_Size +-- XML_GetCurrentByteIndex returns XML_Index +-- These are defined in expat_external.h +-- +-- debian-i386 says XML_Size and XML_Index are 4 bytes. +-- ubuntu-amd64 says XML_Size and XML_Index are 8 bytes. +-- These two systems do NOT define XML_LARGE_SIZE, which would force these types +-- to be 64-bit. +-- +-- If we guess the word size too small, it shouldn't matter: We will just discard +-- the most significant part. If we get the word size too large, we will get +-- garbage (very bad). +-- +-- So - what I will do is use CLong and CULong, which correspond to what expat +-- is using when XML_LARGE_SIZE is disabled, and give the correct sizes on the +-- two machines mentioned above. At the absolute worst the word size will be too +-- short. + +foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode + :: ParserPtr -> IO CInt +foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber + :: ParserPtr -> IO CULong +foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber + :: ParserPtr -> IO CULong +foreign import ccall unsafe "expat.h XML_GetCurrentByteIndex" xmlGetCurrentByteIndex + :: ParserPtr -> IO CLong +foreign import ccall unsafe "expat.h XML_GetCurrentByteCount" xmlGetCurrentByteCount + :: ParserPtr -> IO CInt +foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString + :: CInt -> IO CString +foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser + :: ParserPtr -> CInt -> IO () + 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 @@ -35,8 +35,11 @@ instance NFData text => NFData (NName text) where rnf (NName ns loc) = rnf (ns, loc) --- | Type shortcut for nodes where namespaced names are used for tags -type NNodes text = Nodes (NName text) text +-- | DEPRECATED: Use [NNode text] instead. +-- +-- Type shortcut for nodes where namespaced names are used for tags. +{-# DEPRECATED NNodes "use [NNode text] instead" #-} +type NNodes text = [Node (NName text) text] -- | Type shortcut for a single node where namespaced names are used for tags type NNode text = Node (NName text) text diff --git a/Text/XML/Expat/Proc.hs b/Text/XML/Expat/Proc.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Proc.hs @@ -0,0 +1,76 @@ +-- | This module ported from Text.XML.Light.Proc +module Text.XML.Expat.Proc where + +import Text.XML.Expat.Tree + +import Data.Maybe(listToMaybe) + +-- | Select only the elements from a list of XML content. +onlyElems :: [Node tag text] -> [Node tag text] +onlyElems xs = [ x | x@(Element _ _ _) <- xs ] + +-- | Select only the text from a list of XML content. +onlyText :: [Node tag text] -> [text] +onlyText xs = [ x | Text x <- xs ] + +-- | Find all immediate children with the given name. +findChildren :: (GenericXMLString tag) => tag -> Node tag text -> [Node tag text] +findChildren q e = filterChildren ((q ==) . eName) e + +-- | Filter all immediate children wrt a given predicate. +filterChildren :: (Node tag text -> Bool) -> Node tag text -> [Node tag text] +filterChildren _ (Text _) = [] +filterChildren p e = filter p (onlyElems (eChildren e)) + +-- | Filter all immediate children wrt a given predicate over their names. +filterChildrenName :: (tag -> Bool) -> Node tag text -> [Node tag text] +filterChildrenName _ (Text _) = [] +filterChildrenName p e = filter (p . eName) (onlyElems (eChildren e)) + +-- | Find an immediate child with the given name. +findChild :: (GenericXMLString tag) => tag -> Node tag text -> Maybe (Node tag text) +findChild q e = listToMaybe (findChildren q e) + +-- | Find an immediate child with the given name. +filterChild :: (Node tag text -> Bool) -> Node tag text -> Maybe (Node tag text) +filterChild p e = listToMaybe (filterChildren p e) + +-- | Find an immediate child with name matching a predicate. +filterChildName :: (tag -> Bool) -> Node tag text -> Maybe (Node tag text) +filterChildName p e = listToMaybe (filterChildrenName p e) + +-- | Find the left-most occurrence of an element matching given name. +findElement :: (GenericXMLString tag) => tag -> Node tag text -> Maybe (Node tag text) +findElement q e = listToMaybe (findElements q e) + +-- | Filter the left-most occurrence of an element wrt. given predicate. +filterElement :: (Node tag text -> Bool) -> Node tag text -> Maybe (Node tag text) +filterElement p e = listToMaybe (filterElements p e) + +-- | Filter the left-most occurrence of an element wrt. given predicate. +filterElementName :: (tag -> Bool) -> Node tag text -> Maybe (Node tag text) +filterElementName p e = listToMaybe (filterElementsName p e) + +-- | Find all non-nested occurances of an element. +-- (i.e., once we have found an element, we do not search +-- for more occurances among the element's children). +findElements :: (GenericXMLString tag) => tag -> Node tag text -> [Node tag text] +findElements qn e = filterElementsName (qn==) e + +-- | Find all non-nested occurrences of an element wrt. given predicate. +-- (i.e., once we have found an element, we do not search +-- for more occurances among the element's children). +filterElements :: (Node tag text -> Bool) -> Node tag text -> [Node tag text] +filterElements p e + | p e = [e] + | otherwise = case e of + Element n a c -> concatMap (filterElements p) $ onlyElems c + _ -> [] + +-- | Find all non-nested occurences of an element wrt a predicate over element names. +-- (i.e., once we have found an element, we do not search +-- for more occurances among the element's children). +filterElementsName :: (tag -> Bool) -> Node tag text -> [Node tag text] +filterElementsName _ (Text _) = [] +filterElementsName p e = filterElements (p.eName) e + 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 @@ -53,8 +53,11 @@ instance NFData text => NFData (QName text) where rnf (QName pre loc) = rnf (pre, loc) --- | Type shortcut for nodes where qualified names are used for tags -type QNodes text = Nodes (QName text) text +-- | DEPRECATED: Use [QNode text] instead. +-- +-- Type shortcut for nodes where qualified names are used for tags +{-# DEPRECATED QNodes "use [QNode text] instead" #-} +type QNodes text = [Node (QName text) text] -- | Type shortcut for a single node where qualified names are used for tags type QNode text = Node (QName text) text diff --git a/Text/XML/Expat/SAX.hs b/Text/XML/Expat/SAX.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/SAX.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-} + +-- 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 lazy +-- stream of SAX events. +-- + +module Text.XML.Expat.SAX ( + -- * XML primitives + Encoding(..), + XMLParseError(..), + XMLParseLocation(..), + + -- * SAX-style parse + ParserOptions(..), + SAXEvent(..), + + mkText, + parse, + parseLocations, + parseLocationsThrowing, + parseThrowing, + defaultParserOptions, + + -- * Variants that throw exceptions + XMLParseException(..), + + -- * Deprecated parse functions + parseSAX, + parseSAXLocations, + parseSAXLocationsThrowing, + parseSAXThrowing, + + -- * Abstraction of string types + GenericXMLString(..) +) where + +import Text.XML.Expat.IO hiding (parse) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Internal as I +import Data.IORef +import Data.ByteString.Internal (c2w, w2c, c_strlen) +import qualified Data.Monoid as M +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 +import Control.Parallel.Strategies +import Control.Monad +import System.IO.Unsafe +import Foreign.C.String +import Foreign.Ptr + + +data ParserOptions tag text = ParserOptions + { parserEncoding :: Maybe Encoding + -- ^ The encoding parameter, if provided, overrides the document's + -- encoding declaration. + , entityDecoder :: Maybe (tag -> Maybe text) + -- ^ If provided, entity references (i.e. @ @ and friends) will + -- be decoded into text using the supplied lookup function + } + +defaultParserOptions :: ParserOptions tag text +defaultParserOptions = ParserOptions Nothing Nothing + + +-- | An abstraction for any string type you want to use as xml text (that is, +-- attribute values or element text content). If you want to use a +-- new string type with /hexpat/, you must make it an instance of +-- 'GenericXMLString'. +class (M.Monoid s, Eq s) => GenericXMLString s where + gxNullString :: s -> Bool + gxToString :: s -> String + gxFromString :: String -> s + gxFromChar :: Char -> s + gxHead :: s -> Char + gxTail :: s -> s + gxBreakOn :: Char -> s -> (s, s) + gxFromCStringLen :: CStringLen -> IO s + gxToByteString :: s -> B.ByteString + +instance GenericXMLString String where + gxNullString = null + gxToString = id + gxFromString = id + gxFromChar c = [c] + gxHead = head + gxTail = tail + gxBreakOn c = break (==c) + gxFromCStringLen cstr = U8.decodeString <$> peekCStringLen cstr + gxToByteString = B.pack . map c2w . U8.encodeString + +instance GenericXMLString B.ByteString where + gxNullString = B.null + gxToString = U8.decodeString . map w2c . B.unpack + gxFromString = B.pack . map c2w . U8.encodeString + gxFromChar = B.singleton . c2w + gxHead = w2c . B.head + gxTail = B.tail + gxBreakOn c = B.break (== c2w c) + gxFromCStringLen = peekByteStringLen + gxToByteString = id + +instance GenericXMLString T.Text where + gxNullString = T.null + gxToString = T.unpack + gxFromString = T.pack + gxFromChar = T.singleton + gxHead = T.head + gxTail = T.tail + gxBreakOn c = T.breakBy (==c) + gxFromCStringLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr + gxToByteString = TE.encodeUtf8 + +peekByteStringLen :: CStringLen -> IO B.ByteString +{-# INLINE peekByteStringLen #-} +peekByteStringLen (cstr, len) = + I.create (fromIntegral len) $ \ptr -> + I.memcpy ptr (castPtr cstr) (fromIntegral len) + + +data SAXEvent tag text = + StartElement tag [(tag, text)] | + EndElement tag | + CharacterData text | + FailDocument XMLParseError + deriving (Eq, Show) + +instance (NFData tag, NFData text) => NFData (SAXEvent tag text) where + rnf (StartElement tag atts) = rnf (tag, atts) + rnf (EndElement tag) = rnf tag + rnf (CharacterData text) = rnf text + rnf (FailDocument err) = rnf err + + +-- | Converts a 'CString' to a 'GenericXMLString' type. +mkText :: GenericXMLString text => CString -> IO text +{-# INLINE mkText #-} +mkText cstr = do + len <- c_strlen cstr + gxFromCStringLen (cstr, fromIntegral len) + + +setEntityDecoder :: (GenericXMLString tag, GenericXMLString text) + => Parser + -> IORef [SAXEvent tag text] + -> (tag -> Maybe text) + -> IO () +setEntityDecoder parser queueRef decoder = do + setUseForeignDTD parser True + setExternalEntityRefHandler parser eh + setSkippedEntityHandler parser skip + + where + skip _ 1 = return False + skip entityName 0 = do + en <- mkText entityName + let mbt = decoder en + maybe (return False) + (\t -> do + modifyIORef queueRef (CharacterData t:) + return True) + mbt + skip _ _ = undefined + + eh p ctx _ systemID publicID = + if systemID == nullPtr && publicID == nullPtr + then withCStringLen "" $ \c -> do + parseExternalEntityReference p ctx Nothing c + else return False + + +setEntityDecoderLoc :: (GenericXMLString tag, GenericXMLString text) + => Parser + -> IORef [(SAXEvent tag text, XMLParseLocation)] + -> (tag -> Maybe text) + -> IO () +setEntityDecoderLoc parser queueRef decoder = do + setUseForeignDTD parser True + setExternalEntityRefHandler parser eh + setSkippedEntityHandler parser skip + + where + skip _ 1 = return False + skip entityName 0 = do + en <- mkText entityName + let mbt = decoder en + maybe (return False) + (\t -> do + loc <- getParseLocation parser + modifyIORef queueRef ((CharacterData t,loc):) + return True) + mbt + skip _ _ = undefined + + eh p ctx _ systemID publicID = + if systemID == nullPtr && publicID == nullPtr + then withCStringLen "" $ \c -> do + parseExternalEntityReference p ctx Nothing c + else return False + + +-- | Lazily parse XML to SAX events. In the event of an error, FailDocument is +-- the last element of the output list. +parse :: (GenericXMLString tag, GenericXMLString text) => + ParserOptions tag text -- ^ Parser options + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> [SAXEvent tag text] +parse opts input = unsafePerformIO $ do + let enc = parserEncoding opts + let mEntityDecoder = entityDecoder opts + + parser <- newParser enc + queueRef <- newIORef [] + + maybe (return ()) + (setEntityDecoder parser queueRef) + mEntityDecoder + + setStartElementHandler parser $ \cName cAttrs -> do + name <- mkText cName + attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do + attrName <- mkText cAttrName + attrValue <- mkText cAttrValue + return (attrName, attrValue) + modifyIORef queueRef (StartElement name attrs:) + return True + + setEndElementHandler parser $ \cName -> do + name <- mkText cName + modifyIORef queueRef (EndElement name:) + return True + + setCharacterDataHandler parser $ \cText -> do + txt <- gxFromCStringLen cText + modifyIORef queueRef (CharacterData txt:) + return True + + let runParser inp = unsafeInterleaveIO $ do + rema <- case inp of + (c:cs) -> do + mError <- parseChunk parser c False + case mError of + Just err -> return [FailDocument err] + Nothing -> runParser cs + [] -> do + mError <- parseChunk parser B.empty True + case mError of + Just err -> return [FailDocument err] + Nothing -> return [] + queue <- readIORef queueRef + writeIORef queueRef [] + return $ reverse queue ++ rema + + runParser $ L.toChunks input + + +-- | DEPRECATED: Use 'parse' instead. +-- +-- Lazily parse XML to SAX events. In the event of an error, FailDocument is +-- the last element of the output list. Deprecated in favour of new +-- 'Text.XML.Expat.SAX.parse' +parseSAX :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> [SAXEvent tag text] +{-# DEPRECATED parseSAX "use Text.XML.Expat.SAX.parse instead" #-} +parseSAX enc = parse (ParserOptions enc Nothing) + + +-- | An exception indicating an XML parse error, used by the /..Throwing/ variants. +data XMLParseException = XMLParseException XMLParseError + deriving (Eq, Show, Typeable) + +instance Exception XMLParseException where + + +-- | A variant of parseSAX that gives a document location with each SAX event. +parseLocations :: (GenericXMLString tag, GenericXMLString text) => + ParserOptions tag text -- ^ Parser options + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> [(SAXEvent tag text, XMLParseLocation)] +parseLocations opts input = unsafePerformIO $ do + let enc = parserEncoding opts + let mEntityDecoder = entityDecoder opts + + -- Done with cut & paste coding for maximum speed. + parser <- newParser enc + queueRef <- newIORef [] + + maybe (return ()) + (setEntityDecoderLoc parser queueRef) + mEntityDecoder + + setStartElementHandler parser $ \cName cAttrs -> do + name <- mkText cName + attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do + attrName <- mkText cAttrName + attrValue <- mkText cAttrValue + return (attrName, attrValue) + loc <- getParseLocation parser + modifyIORef queueRef ((StartElement name attrs,loc):) + return True + + setEndElementHandler parser $ \cName -> do + name <- mkText cName + loc <- getParseLocation parser + modifyIORef queueRef ((EndElement name, loc):) + return True + + setCharacterDataHandler parser $ \cText -> do + txt <- gxFromCStringLen cText + loc <- getParseLocation parser + modifyIORef queueRef ((CharacterData txt, loc):) + return True + + let runParser [] = return [] + runParser (c:cs) = unsafeInterleaveIO $ do + mError <- parseChunk parser c (null cs) + queue <- readIORef queueRef + writeIORef queueRef [] + rema <- case mError of + Just err -> do + loc <- getParseLocation parser + return [(FailDocument err, loc)] + Nothing -> runParser cs + return $ reverse queue ++ rema + + runParser $ L.toChunks input + + +-- | DEPRECATED: Use 'parseLocations' instead. +-- +-- A variant of parseSAX that gives a document location with each SAX event. +parseSAXLocations :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> [(SAXEvent tag text, XMLParseLocation)] +{-# DEPRECATED parseSAXLocations "use Text.XML.Expat.SAX.parseLocations instead" #-} +parseSAXLocations enc = parseLocations (ParserOptions enc Nothing) + + +-- | Lazily parse XML to SAX events. In the event of an error, throw +-- 'XMLParseException'. +-- +-- @parseThrowing@ can throw an exception from pure code, which is generally a bad +-- way to handle errors, because Haskell\'s lazy evaluation means it\'s hard to +-- predict where it will be thrown from. However, it may be acceptable in +-- situations where it's not expected during normal operation, depending on the +-- design of your program. +parseThrowing :: (GenericXMLString tag, GenericXMLString text) => + ParserOptions tag text -- ^ Parser options + -> L.ByteString -- ^ input text (a lazy ByteString) + -> [SAXEvent tag text] +parseThrowing opts bs = map freakOut $ parse opts bs + where + freakOut (FailDocument err) = Exc.throw $ XMLParseException err + freakOut other = other + + +-- | DEPRECATED: Use 'parseThrowing' instead. +-- +-- 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] +{-# DEPRECATED parseSAXThrowing "use Text.XML.Expat.SAX.parseThrowing instead" #-} +parseSAXThrowing mEnc = parseThrowing (ParserOptions mEnc Nothing) + + +-- | A variant of parseSAX that gives a document location with each SAX event. +-- In the event of an error, throw 'XMLParseException'. +-- +-- @parseLocationsThrowing@ can throw an exception from pure code, which is generally a bad +-- way to handle errors, because Haskell\'s lazy evaluation means it\'s hard to +-- predict where it will be thrown from. However, it may be acceptable in +-- situations where it's not expected during normal operation, depending on the +-- design of your program. +parseLocationsThrowing :: (GenericXMLString tag, GenericXMLString text) => + ParserOptions tag text -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> [(SAXEvent tag text, XMLParseLocation)] +parseLocationsThrowing opts bs = map freakOut $ parseLocations opts bs + where + freakOut (FailDocument err, _) = Exc.throw $ XMLParseException err + freakOut other = other + + +-- | DEPRECATED: Used 'parseLocationsThrowing' instead. +-- +-- 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)] +{-# DEPRECATED parseSAXLocationsThrowing "use Text.XML.Expat.SAX.parseLocationsThrowing instead" #-} +parseSAXLocationsThrowing mEnc = + parseLocationsThrowing (ParserOptions mEnc Nothing) 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 @@ -7,8 +7,8 @@ -- | 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. -- --- The GenericXMLString type class allows you to use any string type. Three --- string types are provided for here: @String@, @ByteString@ and @Text@. +-- The 'GenericXMLString' type class allows you to use any string type. Three +-- string types are provided for here: 'String', 'ByteString' and 'Text'. -- -- Here is a complete example to get you started: -- @@ -35,9 +35,9 @@ -- > inputText <- L.readFile filename -- > -- Note: Because we're not using the tree, Haskell can't infer the type of -- > -- strings we're using so we need to tell it explicitly with a type signature. --- > let (xml, mErr) = parseTree Nothing inputText :: (UNode String, Maybe XMLParseError) +-- > let (xml, mErr) = parse defaultParserOptions inputText :: (UNode String, Maybe XMLParseError) -- > -- Process document before handling error, so we get lazy processing. --- > L.hPutStr stdout $ formatTree xml +-- > L.hPutStr stdout $ format xml -- > putStrLn "" -- > case mErr of -- > Nothing -> return () @@ -57,16 +57,23 @@ -- > -- > -- This is the recommended way to handle errors in lazy parses -- > main = do --- > let (tree, mError) = parseTree Nothing (L.pack $ map c2w $ "") +-- > let (tree, mError) = parse defaultParserOptions +-- > (L.pack $ map c2w $ "") -- > print (tree :: UNode String) --- > -- Note: We check the error _after_ we have finished our processing on the tree. +-- > +-- > -- Note: We check the error _after_ we have finished our processing +-- > -- on the tree. -- > case mError of -- > Just err -> putStrLn $ "It failed : "++show err -- > Nothing -> putStrLn "Success!" -- -- Way no. 2 - Using exceptions -- --- Unless exceptions fit in with the design of your program, this way is less preferred. +-- 'parseThrowing' can throw an exception from pure code, which is generally a bad +-- way to handle errors, because Haskell\'s lazy evaluation means it\'s hard to +-- predict where it will be thrown from. However, it may be acceptable in +-- situations where it's not expected during normal operation, depending on the +-- design of your program. -- -- > ... -- > import Control.Exception.Extensible as E @@ -74,10 +81,11 @@ -- > -- This is not the recommended way to handle errors. -- > main = do -- > do --- > let tree = parseTreeThrowing Nothing (L.pack $ map c2w $ "") +-- > let tree = parseThrowing defaultParserOptions +-- > (L.pack $ map c2w $ "") -- > print (tree :: UNode String) --- > -- Because of lazy evaluation, you should not process the tree outside the 'do' block, --- > -- or exceptions could be thrown that won't get caught. +-- > -- Because of lazy evaluation, you should not process the tree outside +-- > -- the 'do' block, or exceptions could be thrown that won't get caught. -- > `E.catch` (\exc -> -- > case E.fromException exc of -- > Just (XMLParseException err) -> putStrLn $ "It failed : "++show err @@ -92,107 +100,82 @@ UNodes, UAttributes, textContent, - extractText, - -- * Parse to tree + isElement, + isNamed, + isText, + getAttribute, + getChildren, + modifyChildren, + + -- * Parse functions + ParserOptions(..), + defaultParserOptions, + parse, + parse', + parseThrowing, + + -- * Deprecated parse functions parseTree, parseTree', + + parseSAX, + parseSAXLocations, + + parseTreeThrowing, + parseSAXThrowing, + parseSAXLocationsThrowing, + + extractText, + + -- * Parse to tree 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.IO -import qualified Data.ByteString as B +------------------------------------------------------------------------------ +import Text.XML.Expat.IO hiding (parse,parse') +import qualified Text.XML.Expat.IO as IO + +import Text.XML.Expat.SAX ( Encoding(..) + , ParserOptions(..) + , XMLParseException(..) + , XMLParseError(..) + , XMLParseLocation(..) + , SAXEvent(..) + , defaultParserOptions + , mkText + , parseSAX + , parseSAXLocations + , parseSAXLocationsThrowing + , parseSAXThrowing + , GenericXMLString(..) ) +import qualified Text.XML.Expat.SAX as SAX + +------------------------------------------------------------------------------ +import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Internal as I import Data.IORef -import System.IO.Unsafe (unsafePerformIO) -import Data.ByteString.Internal (c2w, w2c, c_strlen) import qualified Data.Monoid as M -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 -import Control.Concurrent -import Control.Concurrent.MVar import Control.Parallel.Strategies import Control.Monad import System.IO.Unsafe -import System.Mem.Weak import Foreign.C.String import Foreign.Ptr --- | An abstraction for any string type you want to use as xml text (that is, --- attribute values or element text content). If you want to use a --- new string type with /hexpat/, you must make it an instance of --- 'GenericXMLString'. -class (M.Monoid s, Eq s) => GenericXMLString s where - gxNullString :: s -> Bool - gxToString :: s -> String - gxFromString :: String -> s - gxFromChar :: Char -> s - gxHead :: s -> Char - gxTail :: s -> s - gxBreakOn :: Char -> s -> (s, s) - gxFromCStringLen :: CStringLen -> IO s - gxToByteString :: s -> B.ByteString - -instance GenericXMLString String where - gxNullString = null - gxToString = id - gxFromString = id - gxFromChar c = [c] - gxHead = head - gxTail = tail - gxBreakOn c = break (==c) - gxFromCStringLen cstr = U8.decodeString <$> peekCStringLen cstr - gxToByteString = B.pack . map c2w . U8.encodeString - -instance GenericXMLString B.ByteString where - gxNullString = B.null - gxToString = U8.decodeString . map w2c . B.unpack - gxFromString = B.pack . map c2w . U8.encodeString - gxFromChar = B.singleton . c2w - gxHead = w2c . B.head - gxTail = B.tail - gxBreakOn c = B.break (== c2w c) - gxFromCStringLen = peekByteStringLen - gxToByteString = id - -instance GenericXMLString T.Text where - gxNullString = T.null - gxToString = T.unpack - gxFromString = T.pack - gxFromChar = T.singleton - gxHead = T.head - gxTail = T.tail - gxBreakOn c = T.breakBy (==c) - gxFromCStringLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr - gxToByteString = TE.encodeUtf8 - -peekByteStringLen :: CStringLen -> IO B.ByteString -{-# INLINE peekByteStringLen #-} -peekByteStringLen (cstr, len) = - I.create (fromIntegral len) $ \ptr -> - I.memcpy ptr (castPtr cstr) (fromIntegral len) - - -- | The tree representation of the XML document. data Node tag text = Element { @@ -210,12 +193,18 @@ -- | Type shortcut for attributes type Attributes tag text = [(tag, text)] --- | Type shortcut for nodes +-- | DEPRECATED: Use [Node tag text] instead. +-- +-- Type shortcut for nodes. type Nodes tag text = [Node tag text] +{-# DEPRECATED Nodes "use [Node tag text] instead" #-} --- | Type shortcut for nodes with unqualified tag names where tag and --- text are the same string type. +-- | DEPRECATED: Use [UNode text] instead. +-- +-- Type shortcut for nodes with unqualified tag names where tag and +-- text are the same string type. Deprecated type UNodes text = Nodes text text +{-# DEPRECATED UNodes "use [UNode text] instead" #-} -- | Type shortcut for a single node with unqualified tag names where tag and -- text are the same string type. @@ -231,34 +220,96 @@ textContent (Element _ _ children) = mconcat $ map textContent children textContent (Text txt) = txt --- | Deprecated - renamed to textContent. +-- | DEPRECATED: Renamed to 'textContent'. extractText :: Monoid text => Node tag text -> text {-# DEPRECATED extractText "renamed to textContent" #-} extractText = textContent +-- | Is the given node an element? +isElement :: Node tag text -> Bool +isElement (Element _ _ _) = True +isElement _ = False + +-- | Is the given node text? +isText :: Node tag text -> Bool +isText (Text _) = True +isText _ = False + +-- | 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' + +-- | 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 + +-- | 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 + +-- | Modify a node's children using the specified function. modifyChildren :: ([Node tag text] -> [Node tag text]) -> Node tag text -> Node tag text -modifyChildren f node = node { eChildren = f (eChildren node) } +modifyChildren _ node@(Text _) = node +modifyChildren f (Element n a c) = Element n a (f c) -mkText :: GenericXMLString text => CString -> IO text -{-# INLINE mkText #-} -mkText cstr = do - len <- c_strlen cstr - gxFromCStringLen (cstr, fromIntegral len) +setEntityDecoder :: (GenericXMLString tag, GenericXMLString text) + => Parser + -> IORef [Node tag text] + -> (tag -> Maybe text) + -> IO () +setEntityDecoder parser queueRef decoder = do + setUseForeignDTD parser True + setExternalEntityRefHandler parser eh + setSkippedEntityHandler parser skip + + where + text str (cur:rest) = modifyChildren (Text str:) cur : rest + text _ [] = undefined + + skip _ 1 = return False + skip entityName 0 = do + en <- mkText entityName + let mbt = decoder en + maybe (return False) + (\t -> do + modifyIORef queueRef $ text t + return True) + mbt + skip _ _ = undefined + + eh p ctx _ systemID publicID = + if systemID == nullPtr && publicID == nullPtr + then withCStringLen "" $ \c -> do + parseExternalEntityReference p ctx Nothing c + else return False + + -- | 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 (Node tag text) -parseTree' enc doc = unsafePerformIO $ runParse where +parse' :: (GenericXMLString tag, GenericXMLString text) => + ParserOptions tag text -- ^ Parser options + -> ByteString -- ^ Input text (a strict ByteString) + -> Either XMLParseError (Node tag text) +parse' opts doc = unsafePerformIO $ runParse where runParse = do + let enc = parserEncoding opts + let mEntityDecoder = entityDecoder opts + parser <- newParser enc + -- We maintain the invariant that the stack always has one element, -- whose only child at the end of parsing is the root of the actual tree. let emptyString = gxFromString "" stack <- newIORef [Element emptyString [] []] + + maybe (return ()) + (setEntityDecoder parser stack) + mEntityDecoder + setStartElementHandler parser $ \cName cAttrs -> do name <- mkText cName attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do @@ -267,16 +318,16 @@ return (attrName, attrValue) modifyIORef stack (start name attrs) return True - setEndElementHandler parser $ \cName -> do + setEndElementHandler parser $ \_ -> do modifyIORef stack end return True setCharacterDataHandler parser $ \cText -> do txt <- gxFromCStringLen cText modifyIORef stack (text txt) return True - mError <- parse' parser doc + mError <- IO.parse' parser doc case mError of - Just error -> return $ Left error + Just err -> return $ Left err Nothing -> do [Element _ _ [root]] <- readIORef stack return $ Right root @@ -288,135 +339,20 @@ let node = modifyChildren reverse cur in modifyChildren (node:) parent : rest end _ = impossible - impossible = error "parseTree' impossible" + impossible = error "parse' impossible" -data SAXEvent tag text = - StartElement tag [(tag, text)] | - EndElement tag | - CharacterData text | - FailDocument XMLParseError - deriving (Eq, Show) -instance (NFData tag, NFData text) => NFData (SAXEvent tag text) where - rnf (StartElement tag atts) = rnf (tag, atts) - rnf (EndElement tag) = rnf tag - rnf (CharacterData text) = rnf text - rnf (FailDocument err) = rnf err +-- | DEPRECATED: use 'parse' instead. +-- +-- Strictly parse XML to tree. Returns error message or valid parsed tree. +parseTree' :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> ByteString -- ^ Input text (a strict ByteString) + -> Either XMLParseError (Node tag text) +{-# DEPRECATED parseTree' "use Text.XML.Expat.parse' instead" #-} +parseTree' enc = parse' (ParserOptions enc Nothing) --- | Lazily parse XML to SAX events. In the event of an error, FailDocument is --- the last element of the output list. -parseSAX :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) - -> [SAXEvent tag text] -parseSAX enc input = unsafePerformIO $ do - parser <- newParser enc - queueRef <- newIORef [] - setStartElementHandler parser $ \cName cAttrs -> do - name <- mkText cName - attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do - attrName <- mkText cAttrName - attrValue <- mkText cAttrValue - return (attrName, attrValue) - modifyIORef queueRef (StartElement name attrs:) - return True - setEndElementHandler parser $ \cName -> do - name <- mkText cName - modifyIORef queueRef (EndElement name:) - return True - setCharacterDataHandler parser $ \cText -> do - txt <- gxFromCStringLen cText - modifyIORef queueRef (CharacterData txt:) - return True - let runParser input = unsafeInterleaveIO $ do - rem <- case input of - (c:cs) -> do - mError <- parseChunk parser c False - case mError of - Just error -> return [FailDocument error] - Nothing -> runParser cs - [] -> do - mError <- parseChunk parser B.empty True - case mError of - Just error -> return [FailDocument error] - Nothing -> return [] - queue <- readIORef queueRef - writeIORef queueRef [] - return $ reverse queue ++ rem - - runParser $ L.toChunks input - --- | An exception indicating an XML parse error, used by the /..Throwing/ variants. -data XMLParseException = XMLParseException XMLParseError - deriving (Eq, Show, Typeable) - -instance Exception XMLParseException where - --- | A variant of parseSAX that gives a document location with each SAX event. -parseSAXLocations :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) - -> [(SAXEvent tag text, XMLParseLocation)] -parseSAXLocations enc input = unsafePerformIO $ do - -- Done with cut & paste coding for maximum speed. - parser <- newParser enc - queueRef <- newIORef [] - setStartElementHandler parser $ \cName cAttrs -> do - name <- mkText cName - attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do - attrName <- mkText cAttrName - attrValue <- mkText cAttrValue - return (attrName, attrValue) - loc <- getParseLocation parser - modifyIORef queueRef ((StartElement name attrs,loc):) - return True - setEndElementHandler parser $ \cName -> do - name <- mkText cName - loc <- getParseLocation parser - modifyIORef queueRef ((EndElement name, loc):) - return True - setCharacterDataHandler parser $ \cText -> do - txt <- gxFromCStringLen cText - loc <- getParseLocation parser - modifyIORef queueRef ((CharacterData txt, loc):) - return True - - let runParser [] = return [] - runParser (c:cs) = unsafeInterleaveIO $ do - mError <- parseChunk parser c (null cs) - queue <- readIORef queueRef - writeIORef queueRef [] - rem <- case mError of - Just error -> do - loc <- getParseLocation parser - return [(FailDocument error, loc)] - Nothing -> runParser cs - 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 => [SAXEvent tag text] @@ -427,30 +363,62 @@ where safeHead (a:_) = a safeHead [] = Element (gxFromString "") [] [] - ptl (StartElement name attrs:rem) = - let (children, err1, rem') = ptl rem + ptl (StartElement name attrs:rema) = + let (children, err1, rema') = ptl rema elt = Element name attrs children - (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, []) + -- | 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. +parse :: (GenericXMLString tag, GenericXMLString text) => + ParserOptions tag text -- ^ Parser options + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> (Node tag text, Maybe XMLParseError) +parse opts bs = saxToTree $ SAX.parse opts bs + + +-- | DEPREACTED: Use 'parse' instead. +-- +-- 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) -> (Node tag text, Maybe XMLParseError) -parseTree mEnc bs = saxToTree $ parseSAX mEnc bs +{-# DEPRECATED parseTree "use Text.XML.Expat.Tree.parse instead" #-} +parseTree mEnc = parse (ParserOptions mEnc Nothing) + -- | Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'. +-- +-- @parseThrowing@ can throw an exception from pure code, which is generally a bad +-- way to handle errors, because Haskell\'s lazy evaluation means it\'s hard to +-- predict where it will be thrown from. However, it may be acceptable in +-- situations where it's not expected during normal operation, depending on the +-- design of your program. +parseThrowing :: (GenericXMLString tag, GenericXMLString text) => + ParserOptions tag text -- ^ Parser options + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> Node tag text +parseThrowing opts bs = fst $ saxToTree $ SAX.parseThrowing opts bs + + +-- | DEPRECATED: Use 'parseThrowing' instead. +-- +-- 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) -> Node tag text -parseTreeThrowing mEnc bs = fst $ saxToTree $ parseSAXThrowing mEnc bs +{-# DEPRECATED parseTreeThrowing "use Text.XML.Expat.Tree.parseThrowing instead" #-} +parseTreeThrowing mEnc = parseThrowing (ParserOptions mEnc Nothing) diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -1,44 +1,45 @@ Cabal-Version: >= 1.4 Name: hexpat -Version: 0.10 +Version: 0.11 Synopsis: wrapper for expat, the fast XML parser Description: - Expat () is a stream-oriented XML parser - written in C. + This package provides a general purpose Haskell XML library using the Expat do + 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. . - This package provides a Haskell binding for Expat, with a choice of /tree/ or - /SAX-style/ representation, and it includes an /XML formatter/. It is extensible - to any string type, with @String@, @ByteString@ and @Text@ provided out of the box. + Basic usage: Parsing a tree (/Tree/), formatting a tree (/Format/). . - The emphasis is on speed and simplicity. If you want more complete and powerful - XML libraries, consider using /HaXml/ or /HXT/ instead. + Other features: Helpers for processing XML trees (/Proc/), trees annotated with + XML source location (/Annotated/), XML cursors (/Cursor/), more intelligent + handling of qualified tag names (/Qualified/), tags qualified with namespaces + (/Namespaced/), SAX-style parse (/SAX/), and access to the low-level interface + in case speed is paramount (/IO/). . + The design goals are speed, speed, speed, interface simplicity and modular design. + . Examples and benchmarks: . DARCS repository: + . + Credits to the @xml@ (XML.Light) package for /Proc/ and /Cursor/. Category: XML License: BSD3 License-File: LICENSE -Author: Stephen Blackheath (blackh), Evan Martin, Matthew Pocock (drdozer) +Author: + Doug Beardsley, + Stephen Blackheath (blackh), + Gregory Collins, + Evan Martin, + Matthew Pocock (drdozer) Maintainer: http://blacksapphire.com/antispam/ Copyright: + (c) 2009 Doug Beardsley , (c) 2009 Stephen Blackheath , + (c) 2009 Gregory Collins, (c) 2008 Evan Martin , (c) 2009 Matthew Pocock Homepage: http://haskell.org/haskellwiki/Hexpat/ -Extra-Source-Files: - test/tests.hs, - test/test.xml, - test/benchmark.hs, - test/lazySAX.hs, - test/lazyTree.hs, - test/lazyTreeThrow.hs, - test/leak.hs, - test/errorHandlingWay1.hs, - test/errorHandlingWay2.hs, - test/helloworld.hs, - test/locations.hs, - test/Makefile Build-Type: Simple Stability: beta @@ -55,10 +56,13 @@ extensible-exceptions >= 0.1 && < 0.2 Exposed-Modules: Text.XML.Expat.Annotated, - Text.XML.Expat.Tree, + Text.XML.Expat.Cursor, Text.XML.Expat.Format, + Text.XML.Expat.IO, Text.XML.Expat.Namespaced, + Text.XML.Expat.Proc, Text.XML.Expat.Qualified, - Text.XML.Expat.IO + Text.XML.Expat.SAX, + Text.XML.Expat.Tree Extra-Libraries: expat - + --ghc-options: -Wall diff --git a/test/Makefile b/test/Makefile deleted file mode 100644 --- a/test/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -all: tests lazySAX lazyTree lazyTreeThrow benchmark leak helloworld locations - -tests: tests.hs - ghc -O2 --make -o tests tests.hs - -lazySAX: lazySAX.hs - ghc -O2 --make -o lazySAX lazySAX.hs - -lazyTree: lazyTree.hs - ghc -O2 --make -o lazyTree lazyTree.hs - -lazyTreeThrow: lazyTreeThrow.hs - ghc -O2 --make -o lazyTreeThrow lazyTreeThrow.hs - -benchmark: benchmark.hs - ghc -O2 --make -o benchmark benchmark.hs #-threaded - -leak: leak.hs - ghc -O2 --make -o leak leak.hs -threaded - -helloworld: helloworld.hs - ghc -O2 --make -o helloworld helloworld.hs - -locations: locations.hs - ghc -O2 --make -o locations locations.hs - -clean: - rm -f tests perf lazySAX lazyTree benchmark leak helloworld locations *.hi *.o diff --git a/test/benchmark.hs b/test/benchmark.hs deleted file mode 100644 --- a/test/benchmark.hs +++ /dev/null @@ -1,84 +0,0 @@ -import Text.XML.Expat.Tree -import Text.XML.Expat.Format -import Text.XML.Expat.Qualified -import Text.XML.Expat.IO -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.ByteString.Internal as I -import qualified Data.Text as T -import Data.Char -import Data.Maybe -import Control.Exception as E -import Control.Monad -import Control.Parallel.Strategies -import Test.HUnit hiding (Node) -import System.IO -import Foreign.ForeignPtr -import Foreign.Ptr -import Microbench -import Text.XML.HaXml as HaXml - -instance NFData B.ByteString where - rnf bs = () - -instance NFData T.Text where - rnf bs = () - -instance NFData Document where - rnf (Document _ _ root _) = rnf root - -instance NFData Element where - rnf (Elem name attrs content) = rnf (name, attrs, content) - -instance NFData AttValue where - rnf (AttValue val) = rnf val - -instance NFData Reference where - rnf ref = () - -instance NFData Content where - rnf content = () - -parseOnly :: B.ByteString -> String -> IO () -parseOnly xml _ = do - parser <- newParser Nothing - parse' parser xml - return () - -myParseTree enc xml = parseTree enc (L.fromChunks [xml]) - -fromRight :: Either XMLParseError a -> a -fromRight x = case x of - Right right -> right - Left err -> error (show err) - -tests :: [(String, B.ByteString -> String -> IO ())] -tests = [ - ("HaXml", \_ xml -> rnf (HaXml.xmlParse "input" xml) `seq` return ()), - ("low-level parse only, no tree", parseOnly), - ("lazy parseTree string", \xml _ -> rnf (fst $ myParseTree Nothing xml :: UNode String) `seq` return ()), - ("lazy parseTree byteString", \xml _ -> rnf (fst $ myParseTree Nothing xml :: UNode B.ByteString) `seq` return ()), - ("lazy parseTree text", \xml _ -> rnf (fst $ myParseTree Nothing xml :: UNode T.Text) `seq` return ()), - ("lazy parseTree qualifiedString", \xml _ -> rnf (toQualified $ fst $ myParseTree Nothing xml :: QNode String) `seq` return ()), - ("lazy parseTree qualifiedByteString", \xml _ -> rnf (toQualified $ fst $ myParseTree Nothing xml :: QNode B.ByteString) `seq` return ()), - ("lazy parseTree qualifiedText", \xml _ -> (toQualified $ fst $ myParseTree Nothing xml :: QNode T.Text) `seq` return ()), - ("strict parseTree' string", \xml _ -> rnf (fromRight $ parseTree' Nothing xml :: UNode String) `seq` return ()), - ("strict parseTree' byteString", \xml _ -> rnf (fromRight $ parseTree' Nothing xml :: UNode B.ByteString) `seq` return ()), - ("strict parseTree' text", \xml _ -> rnf (fromRight $ parseTree' Nothing xml :: UNode T.Text) `seq` return ()), - ("strict parseTree' qualifiedString", \xml _ -> rnf (toQualified $ fromRight $ parseTree' Nothing xml :: QNode String) `seq` return ()), - ("strict parseTree' qualifiedByteString", \xml _ -> rnf (toQualified $ fromRight $ parseTree' Nothing xml :: QNode B.ByteString) `seq` return ()), - ("strict parseTree' qualifiedText", \xml _ -> rnf (toQualified $ fromRight $ parseTree' Nothing xml :: QNode T.Text) `seq` return ()) - ] - -myCopy :: B.ByteString -> IO B.ByteString -myCopy (I.PS x s l) = I.create l $ \p -> withForeignPtr x $ \f -> - I.memcpy p (f `plusPtr` s) (fromIntegral l) - -main = do - xml <- B.readFile "test.xml" - forM_ tests $ \(a,b) -> microbench a $ do - copy <- myCopy xml - let xmlStr = map w2c $ B.unpack copy - b copy xmlStr - diff --git a/test/errorHandlingWay1.hs b/test/errorHandlingWay1.hs deleted file mode 100644 --- a/test/errorHandlingWay1.hs +++ /dev/null @@ -1,12 +0,0 @@ -import Text.XML.Expat.Tree -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Internal (c2w) - --- This is the recommended way to handle errors in lazy parses -main = do - let (tree, mError) = parseTree Nothing (L.pack $ map c2w $ "") - print (tree :: UNode String) - -- Note: We check the error _after_ we have finished our processing on the tree. - case mError of - Just err -> putStrLn $ "It failed : "++show err - Nothing -> putStrLn "Success!" diff --git a/test/errorHandlingWay2.hs b/test/errorHandlingWay2.hs deleted file mode 100644 --- a/test/errorHandlingWay2.hs +++ /dev/null @@ -1,16 +0,0 @@ -import Text.XML.Expat.Tree -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Internal (c2w) -import Control.Exception.Extensible as E - --- This is not the recommended way to handle errors. See errorHandlingWay1.hs -main = do - do - let tree = parseTreeThrowing Nothing (L.pack $ map c2w $ "") - print (tree :: UNode String) - -- Because of lazy evaluation, you should not process the tree outside the 'do' block, - -- or exceptions could be thrown that won't get caught. - `E.catch` (\exc -> - case E.fromException exc of - Just (XMLParseException err) -> putStrLn $ "It failed : "++show err - Nothing -> E.throwIO exc) diff --git a/test/helloworld.hs b/test/helloworld.hs deleted file mode 100644 --- a/test/helloworld.hs +++ /dev/null @@ -1,33 +0,0 @@ --- | A "hello world" example of hexpat that lazily parses a document, printing --- it to standard out. - -import Text.XML.Expat.Tree -import Text.XML.Expat.Format -import System.Environment -import System.Exit -import System.IO -import qualified Data.ByteString.Lazy as L - -main = do - args <- getArgs - case args of - [filename] -> process filename - otherwise -> do - hPutStrLn stderr "Usage: helloworld " - exitWith $ ExitFailure 1 - -process :: String -> IO () -process filename = do - inputText <- L.readFile filename - -- Note: Because we're not using the tree, Haskell can't infer the type of - -- strings we're using so we need to tell it explicitly with a type signature. - let (xml, mErr) = parseTree Nothing inputText :: (UNode String, Maybe XMLParseError) - -- Process document before handling error, so we get lazy processing. - L.hPutStr stdout $ formatTree xml - putStrLn "" - case mErr of - Nothing -> return () - Just err -> do - hPutStrLn stderr $ "XML parse failed: "++show err - exitWith $ ExitFailure 2 - diff --git a/test/lazySAX.hs b/test/lazySAX.hs deleted file mode 100644 --- a/test/lazySAX.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Main where - -import Text.XML.Expat.Tree -import qualified Data.ByteString as B -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.ByteString.Lazy as L -import Control.Monad - -infiniteDoc = ""++body 1 - where - body i = "\n "++body (i+1) - -toBL :: String -> L.ByteString -toBL = L.fromChunks . chunkify - where - chunkify [] = [] - chunkify str = - let (start, rem) = splitAt 1024 str - in (B.pack $ map c2w start):chunkify rem - -infiniteBL = toBL infiniteDoc - -main = do - mapM_ print (parseSAX Nothing infiniteBL :: [SAXEvent B.ByteString B.ByteString]) - diff --git a/test/lazyTree.hs b/test/lazyTree.hs deleted file mode 100644 --- a/test/lazyTree.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Main where - -import Text.XML.Expat.Tree -import qualified Data.ByteString as B -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.ByteString.Lazy as L -import Control.Monad - -infiniteDoc = ""++body 1 - where - body i = "\n "++body (i+1) - -toBL :: String -> L.ByteString -toBL = L.fromChunks . chunkify - where - chunkify [] = [] - chunkify str = - let (start, rem) = splitAt 1024 str - in (B.pack $ map c2w start):chunkify rem - -infiniteBL = toBL infiniteDoc - -main = do - print (fst $ parseTree Nothing infiniteBL :: UNode B.ByteString) - diff --git a/test/lazyTreeThrow.hs b/test/lazyTreeThrow.hs deleted file mode 100644 --- a/test/lazyTreeThrow.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Main where - -import Text.XML.Expat.Tree -import qualified Data.ByteString as B -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.ByteString.Lazy as L -import Control.Monad - -infiniteDoc = ""++body 1 - where - body i | i == 5000 = "" ++ body (i+1) - body i = "\n "++body (i+1) - -toBL :: String -> L.ByteString -toBL = L.fromChunks . chunkify - where - chunkify [] = [] - chunkify str = - let (start, rem) = splitAt 1024 str - in (B.pack $ map c2w start):chunkify rem - -infiniteBL = toBL infiniteDoc - --- This test passes if it raises an exception when it gets bad XML. - -main = do - print $ (parseTreeThrowing Nothing infiniteBL :: UNode B.ByteString) - diff --git a/test/leak.hs b/test/leak.hs deleted file mode 100644 --- a/test/leak.hs +++ /dev/null @@ -1,63 +0,0 @@ --- Memory leak test --- --- This test passes if you can leave it running for several minutes, and it --- does not leak memory or exhibit any other undesirable behaviour. - -module Main where - -import Text.XML.Expat.Tree -import qualified Data.ByteString as B -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Internal as I -import Control.Concurrent -import Control.Monad -import Control.Parallel.Strategies -import Foreign.ForeignPtr -import Foreign.Ptr - -longDoc = ""++body 1 - where - body 10000 = "" - body i = "\n "++body (i+1) - -toBL :: String -> L.ByteString -toBL = L.fromChunks . chunkify - where - chunkify [] = [] - chunkify str = - let (start, rem) = splitAt 1024 str - in (B.pack $ map c2w start):chunkify rem - -longBL = toBL longDoc - -instance NFData B.ByteString where - rnf bs = () - -myCopy :: B.ByteString -> IO B.ByteString -myCopy (I.PS x s l) = I.create l $ \p -> withForeignPtr x $ \f -> - I.memcpy p (f `plusPtr` s) (fromIntegral l) - -myLCopy :: L.ByteString -> IO L.ByteString -myLCopy bs = do - let cs = L.toChunks bs - cs' <- mapM myCopy cs - return $ L.fromChunks cs' - -{- -allocateStuff :: IO () -allocateStuff = do - x <- forM [1..1000] $ \idx -> return $ show idx - rnf x `seq` return () - -} - -gocrazy descr = forever $ do - putStrLn descr - c <- myLCopy longBL - let sax = parseSAX Nothing c :: [SAXEvent B.ByteString B.ByteString] - rnf (take 20 sax) `seq` return () - -main = do - forkIO $ gocrazy "one" - gocrazy "two" - diff --git a/test/locations.hs b/test/locations.hs deleted file mode 100644 --- a/test/locations.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | Parse to sax events with locations - -import Text.XML.Expat.Tree -import Text.XML.Expat.Format -import System.Environment -import System.Exit -import System.IO -import qualified Data.ByteString.Lazy as L - -main = do - args <- getArgs - case args of - [filename] -> process filename - otherwise -> do - hPutStrLn stderr "Usage: locations " - exitWith $ ExitFailure 1 - -process :: String -> IO () -process filename = do - inputText <- L.readFile filename - -- Note: Because we're not using the tree, Haskell can't infer the type of - -- strings we're using so we need to tell it explicitly with a type signature. - let events = parseSAXLocations Nothing inputText :: [(SAXEvent String String, XMLParseLocation)] - mapM_ print events - diff --git a/test/test.xml b/test/test.xml deleted file mode 100644 --- a/test/test.xml +++ /dev/null @@ -1,101 +0,0 @@ - - - - Gana Prajatantri Bangladesh - Bangladesci - Bangladesh - An Bhanglaidéis - Bangladesh - বাংলাদেশ - Bangladesia - ບັງກະລາເທດ - Bangladeş - Bangladesj - Bangladeša - Bangladešas - บังคลาเทศ - Бангладеш - బంగ్లాదేశ్ - பங்களாதேஷ் - Bangladesch - Bangladesh - བངྒ་ལ་དེཤ - Bangladesh - ಬಾಂಗ್ಲಾದೇಶ - বাংলাদেশ - Μπανγκλαντές - Bangladeŝo - Bangladesh - 孟加拉国 - Bangladesh - Bangladesh - Bangladesh - Бангладеш - Bangladesh - Бангладэш - Бангладеш - Bangladesh - Bangladesh - Gonaoprojatontri Bangladesh - Bangladeš - バングラデシュ - Bangladèsh - Bangladesch - Бангладеш - Bangla Desh - Bangladesh - Bangladéš - بنګله‌دیش - Bangladesh - Bangladesh - Bangladesz - Բանգլադեշ - Bangladeš - Bangladèch - Banglades - बंगलादेश - בנגלאדש - Bangladesh - ബംഗ്ലാദേശ് - Бангладеш - بنگلہ دیش - Bangladexx - Бангладеш - बांगलादेश - بېنگلا - Bangladesj - Bangladesh - Bangladess - ባንግላዲሽ - Bangladesh - Bangladesh - بنغلاديش - Bangladesh - Bangladesh - Bangladesh - बंगलादेश - Bangladesh - Bangladesh - Bangladesh - Bangladesh - Bangladesh - Bangaala-Deesh - Bangladesh - Bangladesh - Banglades - بنگلادش - Bangladesh - Bangladesj - ბანგლადეში - Бангладеш - Bangladeshi - 방글라데시 - Bangladesh - បង់ក្លាដេស្ហ - Bangladéš - Bangladeš - Bangladesh - Bangladeş - Bangladeš - Bangladesh - - diff --git a/test/tests.hs b/test/tests.hs deleted file mode 100644 --- a/test/tests.hs +++ /dev/null @@ -1,164 +0,0 @@ -import Text.XML.Expat.Tree -import Text.XML.Expat.IO -import Text.XML.Expat.Format -import Text.XML.Expat.Qualified -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.Text as T -import CForeign -import Data.ByteString.Internal (c2w, w2c) -import Data.Char -import Data.Maybe -import Data.IORef -import Control.Applicative -import Control.Exception as E -import Control.Monad -import Control.Parallel.Strategies -import Test.HUnit hiding (Node) -import System.IO - -toByteStringL :: String -> L.ByteString -toByteStringL = L.pack . map c2w - -fromByteStringL :: L.ByteString -> String -fromByteStringL = map w2c . L.unpack - -toByteString :: String -> B.ByteString -toByteString = B.pack . map c2w - -fromByteString :: B.ByteString -> String -fromByteString = map w2c . B.unpack - -testDoc :: (Show tag, Show text) => - (Maybe Encoding -> bs -> Either XMLParseError (Node tag text)) - -> (Node tag text -> L.ByteString) - -> (String -> bs) - -> String - -> Int - -> String - -> IO () -testDoc parse fmt toBS descr0 idx xml = do - let eTree = parse (Just UTF8) (toBS xml) - descr = descr0++" #"++show idx - case eTree of - Right tree -> do - let out = fromByteStringL $ fmt tree - assertEqual descr xml out - Left error -> do - hPutStrLn stderr $ "parse failed: "++show error - assertFailure descr - -simpleDocs = [ - "\n"++ - "Cat & mouseDog & bone", - - "\n"++ - "Cat & mouseDog & boneRose & Crown", - - "\nCat & mouse" - ] - -eitherify f mEnc bs = do - case f mEnc bs of - (_, Just err) -> Left err - (doc, Nothing) -> Right doc - -test_error1 :: IO () -test_error1 = do - let eDoc = parseTree' Nothing (toByteString "") :: Either XMLParseError (UNode String) - assertEqual "error1" (Left $ XMLParseError "mismatched tag" (XMLParseLocation 1 9 9 0)) eDoc - -test_error2 :: IO () -test_error2 = do - assertEqual "error2" ( - Element {eName = "hello", eAttrs = [], eChildren = []}, - Just (XMLParseError "mismatched tag" (XMLParseLocation 1 9 9 0)) - ) (parseTree Nothing - (toByteStringL "") :: (UNode String, Maybe XMLParseError)) - -test_error3 :: IO () -test_error3 = - assertEqual "error3" ( - Element {eName = "open", eAttrs = [], eChildren = [ - Element {eName = "test1", eAttrs = [], eChildren = [Text "Hello"]}, - Element {eName = "hello", eAttrs = [], eChildren = []} - ]}, - Just (XMLParseError "mismatched tag" (XMLParseLocation 1 35 35 0)) - ) $ parseTree Nothing - (toByteStringL "Hello") - -test_error4 :: IO () -test_error4 = do - let eDoc = parseTree' Nothing (toByteString "!") :: Either XMLParseError (UNode String) - assertEqual "error1" (Left $ XMLParseError "not well-formed (invalid token)" - (XMLParseLocation 1 0 0 0)) eDoc - -test_parse :: IO () -test_parse = do - ref <- newIORef [] - let lazy = L.fromChunks [ - toByteString "Hello"] - parser <- newParser Nothing - setStartElementHandler parser $ \cname cattrs -> do - name <- peekCString cname - ref <- modifyIORef ref $ \l -> ("start "++name):l - return True - setEndElementHandler parser $ \cname -> do - name <- peekCString cname - ref <- modifyIORef ref $ \l -> ("end "++name):l - return True - parse parser lazy - l <- reverse <$> readIORef ref - assertEqual "parse" - ["start open","start test1","end test1","start hello","end hello","end open"] - l - -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 "textContent" "You don't actually have any cheese at all, do you?" (textContent tree) - -main = do - testXML <- map w2c . B.unpack <$> B.readFile "test.xml" - -- Remove trailing newline - let testXML' = reverse . dropWhile (== '\n') . reverse $ testXML - docs = simpleDocs ++ [testXML'] - t (descr, parse, fmt) = do - forM_ (zip [1..] docs) $ \(idx, doc) -> - testDoc parse fmt toByteStringL descr idx doc - t' (descr, parse, fmt) = do - forM_ (zip [1..] docs) $ \(idx, doc) -> - testDoc parse fmt toByteString descr idx doc - runTestTT $ TestList [ - TestCase $ t' ("String", - parseTree' :: Maybe Encoding -> B.ByteString -> Either XMLParseError (Node String String), - formatTree), - TestCase $ t' ("ByteString", - parseTree' :: Maybe Encoding -> B.ByteString -> Either XMLParseError (Node B.ByteString B.ByteString), - formatTree), - TestCase $ t' ("Text", - parseTree' :: Maybe Encoding -> B.ByteString -> Either XMLParseError (Node T.Text T.Text), - formatTree), - TestCase $ t ("String/Lazy", - eitherify $ parseTree :: Maybe Encoding -> L.ByteString -> Either XMLParseError (Node String String), - formatTree), - TestCase $ t ("ByteString/Lazy", - eitherify $ parseTree :: Maybe Encoding -> L.ByteString -> Either XMLParseError (Node B.ByteString B.ByteString), - formatTree), - TestCase $ t ("Text/Lazy", - eitherify $ parseTree :: Maybe Encoding -> L.ByteString -> Either XMLParseError (Node T.Text T.Text), - formatTree), - TestCase $ test_error1, - TestCase $ test_error2, - TestCase $ test_error3, - TestCase $ test_error4, - TestCase $ test_parse, - TestCase $ test_textContent - ] -