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,7 +9,9 @@ module Text.XML.Expat.Format ( formatTree, + formatTree', formatNode, + formatNode', putTree, putNode ) where @@ -24,53 +26,65 @@ import Data.Binary.Put import Control.Monad --- | Format document with Node tag text +-- | Format document with + Node tag text -> L.ByteString -formatTree flavour node = runPut $ putTree flavour node +formatTree node = runPut $ putTree node --- | Format XML node with no header. -formatNode :: TreeFlavor tag text - -> Node tag text +-- | Format document with + Node tag text + -> B.ByteString +formatTree' node = B.concat $ L.toChunks $ runPut $ putTree node + +-- | Format XML node with no header - lazy variant that returns lazy ByteString. +formatNode :: (GenericXMLString tag, GenericXMLString text) => + Node tag text -> L.ByteString -formatNode flavour node = runPut $ putNode flavour node +formatNode node = runPut $ putNode node +-- | Format XML node with no header - strict variant that returns strict ByteString. +formatNode' :: (GenericXMLString tag, GenericXMLString text) => + Node tag text + -> B.ByteString +formatNode' node = B.concat $ L.toChunks $ runPut $ putNode node + -- | 'Data.Binary.Put.Put' interface for formatting a tree with Node tag text +putTree :: (GenericXMLString tag, GenericXMLString text) => + Node tag text -> Put -putTree flavour node = do +putTree node = do putByteString $ pack "\n" - putNode flavour node + putNode node -- | 'Data.Binary.Put.Put' interface for formatting a node with no header. -putNode :: TreeFlavor tag text - -> Node tag text - -> Put -putNode flavour@(TreeFlavor _ _ putTag fmtText) (Element name attrs children) = do +putNode :: (GenericXMLString tag, GenericXMLString text) => + Node tag text + -> Put +putNode (Element name attrs children) = do putWord8 $ c2w '<' - let putThisTag = putTag name + let putThisTag = putByteString $ gxToByteString name putThisTag forM_ attrs $ \(aname, avalue) -> do putWord8 $ c2w ' ' - putTag aname + putByteString $ gxToByteString aname putByteString $ pack "=\"" - putXMLText $ fmtText avalue + putXMLText $ gxToByteString avalue putByteString $ pack "\"" if null children then putByteString $ pack "/>" else do putWord8 $ c2w '>' - forM_ children $ putNode flavour + forM_ children putNode putByteString $ pack "' -putNode (TreeFlavor _ _ putTag fmtText) (Text txt) = - putXMLText $ fmtText txt +putNode (Text txt) = + putXMLText $ gxToByteString txt pack :: String -> B.ByteString pack = B.pack . map c2w diff --git a/Text/XML/Expat/Namespaced.hs b/Text/XML/Expat/Namespaced.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Namespaced.hs @@ -0,0 +1,150 @@ +module Text.XML.Expat.Namespaced + ( NName (..) + , NNode + , NNodes + , NAttributes + , mkNName + , mkAnNName + , toNamespaced + , fromNamespaced + , xmlnsUri + , xmlns + ) where + +import Text.XML.Expat.Tree +import Text.XML.Expat.Qualified +import Control.Parallel.Strategies +import qualified Data.Map as M +import qualified Data.Maybe as DM +import qualified Data.List as L + +-- | A namespace-qualified tag. +-- +-- NName has two components, a local part and an optional namespace. The local part is the +-- name of the tag. The namespace is the URI identifying collections of declared tags. +-- Tags with the same local part but from different namespaces are distinct. Unqualified tags +-- are those with no namespace. They are in the default namespace, and all uses of an +-- unqualified tag are equivalent. +data NName text = + NName { + nnNamespace :: Maybe text, + nnLocalPart :: !text + } + deriving (Eq,Show) + +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 + +-- | Type shortcut for a single node where namespaced names are used for tags +type NNode text = Node (NName text) text + +-- | Type shortcut for attributes where namespaced names are used for tags +type NAttributes text = Attributes (NName text) text + +-- | Make a new NName from a prefix and localPart. +mkNName :: text -> text -> NName text +mkNName prefix localPart = NName (Just prefix) localPart + +-- | Make a new NName with no prefix. +mkAnNName :: text -> NName text +mkAnNName localPart = NName Nothing localPart + +type NsPrefixMap text = M.Map (Maybe text) (Maybe text) +type PrefixNsMap text = M.Map (Maybe text) (Maybe text) + +xmlUri :: (GenericXMLString text) => text +xmlUri = gxFromString "http://www.w3.org/XML/1998/namespace" +xml :: (GenericXMLString text) => text +xml = gxFromString "xml" + +xmlnsUri :: (GenericXMLString text) => text +xmlnsUri = gxFromString "http://www.w3.org/2000/xmlns/" +xmlns :: (GenericXMLString text) => text +xmlns = gxFromString "xmlns" + +baseNsBindings :: (GenericXMLString text, Ord text) + => NsPrefixMap text +baseNsBindings = M.fromList + [ (Nothing, Nothing) + , (Just xml, Just xmlUri) + , (Just xmlns, Just xmlnsUri) + ] + +basePfBindings :: (GenericXMLString text, Ord text) + => PrefixNsMap text +basePfBindings = M.fromList + [ (Nothing, Nothing) + , (Just xmlUri, Just xml) + , (Just xmlnsUri, Just xmlns) + ] + +toNamespaced :: (GenericXMLString text, Ord text, Show text) + => QNode text -> NNode text +toNamespaced = nodeWithNamespaces baseNsBindings + +nodeWithNamespaces :: (GenericXMLString text, Ord text, Show text) + => NsPrefixMap text -> QNode text -> NNode text +nodeWithNamespaces _ (Text t) = Text t +nodeWithNamespaces bindings (Element qname qattrs qchildren) = Element nname nattrs nchildren + where + for = flip map + (nsAtts, otherAtts) = L.partition ((== Just xmlns) . qnPrefix . fst) qattrs + (dfAtt, normalAtts) = L.partition ((== QName Nothing xmlns) . fst) otherAtts + nsMap = M.fromList $ for nsAtts $ \((QName _ lp), uri) -> (Just lp, Just uri) + dfMap = M.fromList $ for dfAtt $ \q -> (Nothing, Just $ snd q) + chldBs = M.unions [dfMap, nsMap, bindings] + trans (QName pref qual) = case pref `M.lookup` chldBs of + Nothing -> error + $ "Namespace prefix referenced but never bound: '" + ++ (show . DM.fromJust) pref + ++ "'" + Just mUri -> NName mUri qual + transAt (qn, v) = (trans qn, v) + + nname = trans qname + + nNsAtts = map transAt nsAtts + nDfAtt = map transAt dfAtt + nNormalAtts = map transAt normalAtts + nattrs = concat [nNsAtts, nDfAtt, nNormalAtts] + + nchildren = for qchildren $ nodeWithNamespaces chldBs + +fromNamespaced :: (GenericXMLString text, Ord text) => NNode text -> QNode text +fromNamespaced = nodeWithQualifiers 1 basePfBindings + +nodeWithQualifiers :: (GenericXMLString text, Ord text) + => Int -> PrefixNsMap text -> NNode text -> QNode text +nodeWithQualifiers _ _ (Text text) = Text text +nodeWithQualifiers cntr bindings (Element nname nattrs nchildren) = Element qname qattrs qchildren + where + for = flip map + (nsAtts, otherAtts) = L.partition ((== Just xmlnsUri) . nnNamespace . fst) nattrs + (dfAtt, normalAtts) = L.partition ((== NName Nothing xmlns) . fst) otherAtts + nsMap = M.fromList $ for nsAtts $ \((NName _ lp), uri) -> (Just uri, Just lp) + dfMap = M.fromList $ for dfAtt $ \(_, uri) -> (Just uri, Just xmlns) + chldBs = M.unions [dfMap, nsMap, bindings] + + trans (i, bs, as) (NName nspace qual) = + case nspace `M.lookup` bs of + Nothing -> let + pfx = gxFromString $ "ns" ++ show i + bs' = M.insert nspace (Just pfx) bs + as' = (NName (Just xmlnsUri) pfx, DM.fromJust nspace) : as + in trans (i+1, bs', as') (NName nspace qual) + Just pfx -> ((i, bs, as), QName pfx qual) + transAt ibs (nn, v) = let (ibs', qn) = trans ibs nn + in (ibs', (qn, v)) + + ((i', bs', as'), qname) = trans (cntr, chldBs, []) nname + + ((i'', bs'', as''), qNsAtts) = L.mapAccumL transAt (i', bs', as') nsAtts + ((i''', bs''', as'''), qDfAtt) = L.mapAccumL transAt (i'', bs'', as'') dfAtt + ((i'''', bs'''', as''''), qNormalAtts) = L.mapAccumL transAt (i''', bs''', as''') normalAtts + (_, qas) = L.mapAccumL transAt (i'''', bs'''', as'''') as'''' + qattrs = concat [qNsAtts, qDfAtt, qNormalAtts, qas] + + qchildren = for nchildren $ nodeWithQualifiers i'''' bs'''' 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 @@ -2,21 +2,22 @@ -- Copyright (C) 2008 Evan Martin -- Copyright (C) 2009 Stephen Blackheath --- | With the default flavors for 'Text.XML.Expat.Tree.parseTree' and --- 'Text.XML.Expat.Format.formatTree', qualified tag and attribute names such as +-- | In the default representation, qualified tag and attribute names such as -- \ are represented just as a string containing a colon, e.g. -- \"abc:hello\". -- --- This module provides flavors that handle these more intelligently, splitting +-- This module provides functionality to handle these more intelligently, splitting -- all tag and attribute names into their Prefix and LocalPart components. module Text.XML.Expat.Qualified ( QName(..), + QNode, + QNodes, + QAttributes, mkQName, - mkAnName, - qualifiedStringFlavor, - qualifiedByteStringFlavor, - qualifiedTextFlavor + mkAnQName, + toQualified, + fromQualified ) where import Text.XML.Expat.IO @@ -34,10 +35,15 @@ import Data.Monoid import Data.Binary.Put import qualified Codec.Binary.UTF8.String as U8 -import Foreign.C.String -import Foreign.Ptr - +-- | A qualified name. +-- +-- Qualified names have two parts, a prefix and a local part. The local part +-- is the name of the tag. The prefix scopes that name to a particular +-- group of legal tags. +-- +-- The prefix will usually be associated with a namespace URI. This is usually +-- achieved by using xmlns attributes to bind prefixes to URIs. data QName text = QName { qnPrefix :: Maybe text, @@ -48,77 +54,47 @@ 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 + +-- | Type shortcut for a single node where qualified names are used for tags +type QNode text = Node (QName text) text + +-- | Type shortcut for attributes where qualified names are used for tags +type QAttributes text = Attributes (QName text) text + -- | Make a new QName from a prefix and localPart. mkQName :: text -> text -> QName text mkQName prefix localPart = QName (Just prefix) localPart -- | Make a new QName with no prefix. -mkAnName :: text -> QName text -mkAnName localPart = QName Nothing localPart +mkAnQName :: text -> QName text +mkAnQName localPart = QName Nothing localPart --- | Flavor for qualified tags, using String data type. -qualifiedStringFlavor :: TreeFlavor (QName String) String -qualifiedStringFlavor = TreeFlavor (\t -> toQName <$> unpack t) unpackLen fromQName pack +toQualified :: (GenericXMLString text) => UNode text -> QNode text +toQualified (Text text) = Text text +toQualified (Element uname uatts uchldrn) = Element qname qatts qchldrn where - unpack cstr = U8.decodeString <$> peekCString cstr - unpackLen cstr = U8.decodeString <$> peekCStringLen cstr - toQName ident = - case break (== ':') ident of - (prefix, ':':local) -> QName (Just prefix) local - otherwise -> QName Nothing ident - pack = B.pack . map c2w . U8.encodeString - fromQName (QName (Just prefix) local) = do - mapM_ (putWord8 . c2w) prefix - putWord8 $ c2w ':' - mapM_ (putWord8 . c2w) local - fromQName (QName Nothing local) = mapM_ (putWord8 . c2w) local + qname = qual uname + qatts = map (\(tag, text) -> (qual tag, text)) uatts + qchldrn = map toQualified uchldrn --- | Flavor for qualified tags, using ByteString data type, containing UTF-8 encoded Unicode. -qualifiedByteStringFlavor :: TreeFlavor (QName B.ByteString) B.ByteString -qualifiedByteStringFlavor = TreeFlavor (\t -> toQName <$> unpack t) unpackLen fromQName id - where - unpack cstr = peekByteString cstr - unpackLen cstr = peekByteStringLen cstr - toQName ident = - case B.break (== c2w ':') ident of - (prefix, _local) | not (B.null _local) && B.head _local == c2w ':' -> - QName (Just prefix) (B.tail _local) - otherwise -> QName Nothing ident - fromQName (QName (Just prefix) local) = do - putByteString prefix - putWord8 $ c2w ':' - putByteString local - fromQName (QName Nothing local) = putByteString local - colon = B.singleton (c2w ':') + qual ident = + case gxBreakOn ':' ident of + (prefix, _local) | not (gxNullString _local) + && gxHead _local == ':' + -> QName (Just prefix) (gxTail _local) + otherwise -> QName Nothing ident --- | Flavor for qualified tags, using Text data type. -qualifiedTextFlavor :: TreeFlavor (QName T.Text) T.Text -qualifiedTextFlavor = TreeFlavor (\t -> toQName <$> unpack t) unpackLen fromQName TE.encodeUtf8 +fromQualified :: (GenericXMLString text) => QNode text -> UNode text +fromQualified (Text text) = Text text +fromQualified (Element qname qatts qchldrn) = Element uname uatts uchldrn where - unpack cstr = TE.decodeUtf8 <$> peekByteString cstr - unpackLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr - toQName ident = - case T.break (== ':') ident of - (prefix, _local) | not (T.null _local) && T.head _local == ':' -> - QName (Just prefix) (T.tail _local) - otherwise -> QName Nothing ident - fromQName (QName (Just prefix) local) = do - putByteString . TE.encodeUtf8 $ prefix - putWord8 $ c2w ':' - putByteString . TE.encodeUtf8 $ local - fromQName (QName Nothing local) = putByteString . TE.encodeUtf8 $ local - colon = T.singleton ':' - -peekByteString :: CString -> IO B.ByteString -{-# INLINE peekByteString #-} -peekByteString cstr = do - len <- I.c_strlen cstr - peekByteStringLen (castPtr cstr, fromIntegral len) + uname = tag qname + uatts = map (\(qual, text) -> (tag qual, text)) qatts + uchldrn = map fromQualified qchldrn -peekByteStringLen :: CStringLen -> IO B.ByteString -{-# INLINE peekByteStringLen #-} -peekByteStringLen (cstr, len) = - I.create (fromIntegral len) $ \ptr -> - I.memcpy ptr (castPtr cstr) (fromIntegral len) + tag (QName (Just prefix) local) = prefix `mappend` gxFromChar ':' `mappend` local + tag (QName Nothing local) = local diff --git a/Text/XML/Expat/Tree.hs b/Text/XML/Expat/Tree.hs --- a/Text/XML/Expat/Tree.hs +++ b/Text/XML/Expat/Tree.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-} + -- hexpat, a Haskell wrapper for expat -- Copyright (C) 2008 Evan Martin -- Copyright (C) 2009 Stephen Blackheath @@ -5,12 +7,54 @@ -- | 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. -- --- Extensible \"flavors\" give you the ability to use any string type. Three --- are provided 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@. +-- +-- Error handling in strict parses is very straight forward - just check the +-- 'Either' return value. Lazy parses are not so simple. Here are two working +-- examples that illustrate the ways to handle errors. Here they are: +-- +-- Way no. 1 +-- +-- > 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 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!" +-- +-- Way no. 2 +-- +-- > ... +-- > import Control.Exception.Extensible as E +-- > +-- > -- This is not the recommended way to handle errors. +-- > 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) module Text.XML.Expat.Tree ( -- * Tree structure Node(..), + Nodes, + Attributes, + UNode, + UNodes, + UAttributes, -- * Parse to tree parseTree, parseTree', @@ -19,11 +63,13 @@ -- * SAX-style parse parseSAX, SAXEvent(..), - -- * Flavors - TreeFlavor(..), - stringFlavor, - byteStringFlavor, - textFlavor + saxToTree, + -- * Variants that throw exceptions + XMLParseException(..), + parseSAXThrowing, + parseTreeThrowing, + -- * Abstraction of string types + GenericXMLString(..) ) where import Text.XML.Expat.IO @@ -33,10 +79,13 @@ 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.Binary.Put +import Data.Typeable +import Control.Exception.Extensible as Exc import Control.Applicative import Control.Concurrent import Control.Concurrent.MVar @@ -48,39 +97,53 @@ import Foreign.Ptr -data TreeFlavor tag text = TreeFlavor - (CString -> IO tag) - (CStringLen -> IO text) - (tag -> Put) - (text -> B.ByteString) - --- | Flavor for String data type. -stringFlavor :: TreeFlavor String String -stringFlavor = TreeFlavor unpack unpackLen (mapM_ (putWord8 . c2w)) pack - where - unpack cstr = U8.decodeString <$> peekCString cstr - unpackLen cstr = U8.decodeString <$> peekCStringLen cstr - pack = B.pack . map c2w . U8.encodeString +-- | 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 --- | Flavor for ByteString data type, containing UTF-8 encoded Unicode. -byteStringFlavor :: TreeFlavor B.ByteString B.ByteString -byteStringFlavor = TreeFlavor unpack unpackLen putByteString id - where - unpack cstr = peekByteString cstr - unpackLen cstr = peekByteStringLen cstr +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 --- | Flavor for Text data type. -textFlavor :: TreeFlavor T.Text T.Text -textFlavor = TreeFlavor unpack unpackLen (putByteString . TE.encodeUtf8) TE.encodeUtf8 - where - unpack cstr = TE.decodeUtf8 <$> peekByteString cstr - unpackLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr +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 -peekByteString :: CString -> IO B.ByteString -{-# INLINE peekByteString #-} -peekByteString cstr = do - len <- I.c_strlen cstr - peekByteStringLen (castPtr cstr, fromIntegral len) +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.break (==c) + gxFromCStringLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr + gxToByteString = TE.encodeUtf8 peekByteStringLen :: CStringLen -> IO B.ByteString {-# INLINE peekByteStringLen #-} @@ -88,6 +151,7 @@ I.create (fromIntegral len) $ \ptr -> I.memcpy ptr (castPtr cstr) (fromIntegral len) + -- | The tree representation of the XML document. data Node tag text = Element { @@ -102,44 +166,60 @@ rnf (Element nam att chi) = rnf (nam, att, chi) rnf (Text txt) = rnf txt +-- | Type shortcut for attributes +type Attributes tag text = [(tag, text)] + +-- | Type shortcut for nodes +type Nodes tag text = [Node tag text] + +-- | Type shortcut for nodes with unqualified tag names where tag and +-- text are the same string type. +type UNodes text = Nodes text text + +-- | Type shortcut for a single node with unqualified tag names where tag and +-- text are the same string type. +type UNode text = Node text text + +-- | Type shortcut for attributes with unqualified tag names where tag and +-- text are the same string type. +type UAttributes text = Attributes text text + modifyChildren :: ([Node tag text] -> [Node tag text]) -> Node tag text -> Node tag text modifyChildren f node = node { eChildren = f (eChildren node) } +mkText :: GenericXMLString text => CString -> IO text +{-# INLINE mkText #-} +mkText cstr = do + len <- c_strlen cstr + gxFromCStringLen (cstr, fromIntegral len) + -- | Strictly parse XML to tree. Returns error message or valid parsed tree. -parseTree' :: TreeFlavor tag text -- ^ Flavor, which determines the string type to use in the output - -> Maybe Encoding -- ^ Optional encoding override - -> B.ByteString -- ^ Input text (a lazy ByteString) +parseTree' :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> B.ByteString -- ^ Input text (a strict ByteString) -> Either XMLParseError (Node tag text) -{-# SPECIALIZE parseTree' :: TreeFlavor String String -> Maybe Encoding - -> B.ByteString -> Either XMLParseError (Node String String) #-} -{-# SPECIALIZE parseTree' :: TreeFlavor B.ByteString B.ByteString -> Maybe Encoding - -> B.ByteString -> Either XMLParseError (Node B.ByteString B.ByteString) #-} -{-# SPECIALIZE parseTree' :: TreeFlavor T.Text T.Text -> Maybe Encoding - -> B.ByteString -> Either XMLParseError (Node T.Text T.Text) #-} -parseTree' (TreeFlavor mkTag mkText _ _) enc doc = unsafePerformIO $ runParse where +parseTree' enc doc = unsafePerformIO $ runParse where runParse = do 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. - emptyString <- withCString "" mkTag + let emptyString = gxFromString "" stack <- newIORef [Element emptyString [] []] setStartElementHandler parser $ \cName cAttrs -> do - name <- mkTag cName + name <- mkText cName attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do - attrName <- mkTag cAttrName - len <- c_strlen cAttrValue - attrValue <- mkText (cAttrValue, fromIntegral len) + attrName <- mkText cAttrName + attrValue <- mkText cAttrValue return (attrName, attrValue) modifyIORef stack (start name attrs) return True setEndElementHandler parser $ \cName -> do - name <- mkTag cName - modifyIORef stack (end name) + modifyIORef stack end return True setCharacterDataHandler parser $ \cText -> do - txt <- mkText cText + txt <- gxFromCStringLen cText modifyIORef stack (text txt) return True mError <- parse parser doc @@ -151,7 +231,7 @@ start name attrs stack = Element name attrs [] : stack text str (cur:rest) = modifyChildren (Text str:) cur : rest - end name (cur:parent:rest) = + end (cur:parent:rest) = let node = modifyChildren reverse cur in modifyChildren (node:) parent : rest @@ -170,28 +250,27 @@ -- | Lazily parse XML to SAX events. In the event of an error, FailDocument is -- the last element of the output list. -parseSAX :: TreeFlavor tag text -- ^ Flavor, which determines the string type to use in the output - -> Maybe Encoding -- ^ Optional encoding override +parseSAX :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override -> L.ByteString -- ^ Input text (a lazy ByteString) -> [SAXEvent tag text] -parseSAX (TreeFlavor mkTag mkText _ _) enc input = unsafePerformIO $ do +parseSAX enc input = unsafePerformIO $ do parser <- newParser enc queueRef <- newIORef [] setStartElementHandler parser $ \cName cAttrs -> do - name <- mkTag cName + name <- mkText cName attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do - attrName <- mkTag cAttrName - len <- c_strlen cAttrValue - attrValue <- mkText (cAttrValue, fromIntegral len) + attrName <- mkText cAttrName + attrValue <- mkText cAttrValue return (attrName, attrValue) modifyIORef queueRef (StartElement name attrs:) return True setEndElementHandler parser $ \cName -> do - name <- mkTag cName + name <- mkText cName modifyIORef queueRef (EndElement name:) return True setCharacterDataHandler parser $ \cText -> do - txt <- mkText cText + txt <- gxFromCStringLen cText modifyIORef queueRef (CharacterData txt:) return True @@ -207,26 +286,32 @@ runParser $ L.toChunks input --- | 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 :: TreeFlavor tag text -- ^ Flavor, which determines the string type to use in the tree - -> Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) +-- | An exception indicating an XML parse error, used by the /..Throwing/ variants. +data XMLParseException = XMLParseException XMLParseError + deriving (Eq, Show, Typeable) + +instance Exception XMLParseException where + +-- | Lazily parse XML to SAX events. In the event of an error, throw 'XMLParseException'. +parseSAXThrowing :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> [SAXEvent tag text] +parseSAXThrowing mEnc bs = map freakOut $ parseSAX mEnc bs + where + freakOut (FailDocument err) = Exc.throw $ XMLParseException err + freakOut other = other + +-- | A lower level function that lazily converts a SAX stream into a tree structure. +saxToTree :: GenericXMLString tag => + [SAXEvent tag text] -> (Node tag text, Maybe XMLParseError) -{-# SPECIALIZE parseTree :: TreeFlavor String String -> Maybe Encoding - -> L.ByteString -> (Node String String, Maybe XMLParseError) #-} -{-# SPECIALIZE parseTree :: TreeFlavor B.ByteString B.ByteString -> Maybe Encoding - -> L.ByteString -> (Node B.ByteString B.ByteString, Maybe XMLParseError) #-} -{-# SPECIALIZE parseTree :: TreeFlavor T.Text T.Text -> Maybe Encoding - -> L.ByteString -> (Node T.Text T.Text, Maybe XMLParseError) #-} -parseTree flavor@(TreeFlavor mkTag _ _ _) mEnc bs = - let events = parseSAX flavor mEnc bs - (nodes, mError, _) = ptl events +saxToTree events = + let (nodes, mError, _) = ptl events in (safeHead nodes, mError) where safeHead (a:_) = a - safeHead [] = Element (unsafePerformIO $ withCString "" mkTag) [] [] + safeHead [] = Element (gxFromString "") [] [] ptl (StartElement name attrs:rem) = let (children, err1, rem') = ptl rem elt = Element name attrs children @@ -238,4 +323,20 @@ in (Text txt:out, err, rem') ptl (FailDocument err:_) = ([], Just err, []) ptl [] = ([], Nothing, []) + +-- | Lazily parse XML to tree. Note that forcing the XMLParseError return value +-- will force the entire parse. Therefore, to ensure lazy operation, don't +-- check the error status until you have processed the tree. +parseTree :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> (Node tag text, Maybe XMLParseError) +parseTree mEnc bs = saxToTree $ parseSAX mEnc bs + +-- | Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'. +parseTreeThrowing :: (GenericXMLString tag, GenericXMLString text) => + Maybe Encoding -- ^ Optional encoding override + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> Node tag text +parseTreeThrowing mEnc bs = fst $ saxToTree $ parseSAXThrowing mEnc bs diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -1,28 +1,28 @@ Cabal-Version: >= 1.2 Name: hexpat -Version: 0.4 +Version: 0.5 Synopsis: wrapper for expat, the fast XML parser Description: Expat () is a stream-oriented XML parser written in C. . - 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. + 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. . The emphasis is on speed and simplicity. If you want more complete and powerful - XML libraries, consider using HaXml or HXT instead. + XML libraries, consider using /HaXml/ or /HXT/ instead. . - Note that hexpat has undergone a major API change since 0.3.x. + Note that /hexpat/ has undergone a major API change since 0.3.x. . Benchmark results on ghc 6.10.1 against HaXml for parsing a 4K xml file with non-threading runtime: - HAXML: 2683 us, HEXPAT: low-level parse-no tree: 243 us, lazy-String: 1340 us, - lazy-Text: 814 us, strict-String: 1194 us, strict-Text: 732 us + HAXML: 2631 us, HEXPAT: low-level parse-no tree: 243 us, lazy-String: 1240 us, + lazy-Text: 782 us, strict-String: 1125 us, strict-Text: 770 us . With -threaded: - HAXML: 2691 us, HEXPAT: low-level parse-no tree: 472 us, - lazy-String: 1575 us, lazy-Text: 1068 us, strict-String: 1396 us, - strict-Text: 964 us + HAXML: 2667 us, HEXPAT: low-level parse-no tree: 472 us, + lazy-String: 1453 us, lazy-Text: 1057 us, strict-String: 1342 us, + strict-Text: 943 us Category: XML License: BSD3 License-File: LICENSE @@ -35,11 +35,13 @@ Homepage: http://code.haskell.org/hexpat/ Extra-Source-Files: test/tests.hs, - test/perf.hs, test/test.xml, test/benchmark.hs, test/lazySAX.hs, - test/lazyTree.hs + test/lazyTree.hs, + test/lazyTreeThrow.hs, + test/errorHandlingWay1.hs, + test/errorHandlingWay2.hs Build-Type: Simple Stability: beta @@ -52,10 +54,13 @@ text >= 0.1, binary >= 0.4, utf8-string >= 0.3.3, - parallel + parallel, + containers, + extensible-exceptions >= 0.1 && < 0.2 Exposed-Modules: Text.XML.Expat.Tree, Text.XML.Expat.Format, + Text.XML.Expat.Namespaced, Text.XML.Expat.Qualified, Text.XML.Expat.IO Extensions: ForeignFunctionInterface diff --git a/test/benchmark.hs b/test/benchmark.hs --- a/test/benchmark.hs +++ b/test/benchmark.hs @@ -46,24 +46,29 @@ parse parser xml return () -myParseTree flavor enc xml = parseTree flavor enc (L.fromChunks [xml]) +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 myParseTree stringFlavor", \xml _ -> rnf (myParseTree stringFlavor Nothing xml) `seq` return ()), - ("lazy myParseTree byteStringFlavor", \xml _ -> rnf (myParseTree byteStringFlavor Nothing xml) `seq` return ()), - ("lazy myParseTree textFlavor", \xml _ -> rnf (myParseTree textFlavor Nothing xml) `seq` return ()), - ("lazy myParseTree qualifiedStringFlavor", \xml _ -> rnf (myParseTree qualifiedStringFlavor Nothing xml) `seq` return ()), - ("lazy myParseTree qualifiedByteStringFlavor", \xml _ -> rnf (myParseTree qualifiedByteStringFlavor Nothing xml) `seq` return ()), - ("lazy myParseTree qualifiedTextFlavor", \xml _ -> rnf (myParseTree qualifiedTextFlavor Nothing xml) `seq` return ()), - ("strict parseTree' stringFlavor", \xml _ -> rnf (parseTree' stringFlavor Nothing xml) `seq` return ()), - ("strict parseTree' byteStringFlavor", \xml _ -> rnf (parseTree' byteStringFlavor Nothing xml) `seq` return ()), - ("strict parseTree' textFlavor", \xml _ -> rnf (parseTree' textFlavor Nothing xml) `seq` return ()), - ("strict parseTree' qualifiedStringFlavor", \xml _ -> rnf (parseTree' qualifiedStringFlavor Nothing xml) `seq` return ()), - ("strict parseTree' qualifiedByteStringFlavor", \xml _ -> rnf (parseTree' qualifiedByteStringFlavor Nothing xml) `seq` return ()), - ("strict parseTree' qualifiedTextFlavor", \xml _ -> rnf (parseTree' qualifiedTextFlavor Nothing xml) `seq` return ()) + ("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 diff --git a/test/errorHandlingWay1.hs b/test/errorHandlingWay1.hs new file mode 100644 --- /dev/null +++ b/test/errorHandlingWay1.hs @@ -0,0 +1,12 @@ +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 new file mode 100644 --- /dev/null +++ b/test/errorHandlingWay2.hs @@ -0,0 +1,16 @@ +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/lazySAX.hs b/test/lazySAX.hs --- a/test/lazySAX.hs +++ b/test/lazySAX.hs @@ -21,5 +21,5 @@ infiniteBL = toBL infiniteDoc main = do - mapM_ print $ parseSAX byteStringFlavor Nothing infiniteBL + mapM_ print (parseSAX Nothing infiniteBL :: [SAXEvent B.ByteString B.ByteString]) diff --git a/test/lazyTree.hs b/test/lazyTree.hs --- a/test/lazyTree.hs +++ b/test/lazyTree.hs @@ -21,5 +21,5 @@ infiniteBL = toBL infiniteDoc main = do - print $ fst $ parseTree stringFlavor Nothing infiniteBL + print (fst $ parseTree Nothing infiniteBL :: UNode B.ByteString) diff --git a/test/lazyTreeThrow.hs b/test/lazyTreeThrow.hs new file mode 100644 --- /dev/null +++ b/test/lazyTreeThrow.hs @@ -0,0 +1,28 @@ +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/perf.hs b/test/perf.hs deleted file mode 100644 --- a/test/perf.hs +++ /dev/null @@ -1,42 +0,0 @@ --- hexpat, a Haskell wrapper for expat --- Copyright (C) 2008 Evan Martin - --- This program microbenchmarks HaXml versus Expat parsing. --- The comparision is pretty unfair; HaXml does a whole lot more. --- However, if you just want to read all the XML tags in a file, --- this program demonstrates why Expat may be preferable. - -import Control.Exception -import qualified Data.ByteString.Lazy as BS -import Data.Char (ord) -import Data.IORef -import Microbench -import Text.XML.Expat.IO as Expat -import Text.XML.HaXml as HaXml - -parse_haxml :: String -> IO () -parse_haxml input = do - let Document _ _ root _ = HaXml.xmlParse "input" input - let Elem _ _ content = root - evaluate $ length content - return () - -parse_expat :: BS.ByteString -> IO () -parse_expat input = do - parser <- Expat.newParser Nothing - counter <- newIORef 0 - Expat.setStartElementHandler parser (elementHandler counter) - Expat.parse parser input - readIORef counter - return () - where - elementHandler counter tag attrs = modifyIORef counter (+1) - -main = do - xml <- readFile "test.xml" - let xmlbs = BS.pack (map (fromIntegral.ord) xml) - -- Force reading the entire file first. - putStrLn $ "input is " ++ show (BS.length xmlbs) ++ " bytes." - -- Start the races. - microbench "HaXml" (parse_haxml xml) - microbench "hexpat" (parse_expat xmlbs) diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -1,8 +1,9 @@ import Text.XML.Expat.Tree import Text.XML.Expat.Format import Text.XML.Expat.Qualified -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T import Data.ByteString.Internal (c2w, w2c) import Data.Char import Data.Maybe @@ -12,21 +13,21 @@ import Test.HUnit hiding (Node) import System.IO -toByteStringL :: String -> BSL.ByteString -toByteStringL = BSL.pack . map c2w +toByteStringL :: String -> L.ByteString +toByteStringL = L.pack . map c2w -fromByteStringL :: BSL.ByteString -> String -fromByteStringL = map w2c . BSL.unpack +fromByteStringL :: L.ByteString -> String +fromByteStringL = map w2c . L.unpack -toByteString :: String -> BS.ByteString -toByteString = BS.pack . map c2w +toByteString :: String -> B.ByteString +toByteString = B.pack . map c2w -fromByteString :: BS.ByteString -> String -fromByteString = map w2c . BS.unpack +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 -> BSL.ByteString) + -> (Node tag text -> L.ByteString) -> (String -> bs) -> String -> Int @@ -60,7 +61,7 @@ test_error1 :: IO () test_error1 = do - let eDoc = parseTree' stringFlavor Nothing (toByteString "") + let eDoc = parseTree' Nothing (toByteString "") :: Either XMLParseError (UNode String) assertEqual "error1" (Left $ XMLParseError "mismatched tag" 1 9) eDoc test_error2 :: IO () @@ -68,8 +69,8 @@ assertEqual "error2" ( Element {eName = "hello", eAttrs = [], eChildren = []}, Just (XMLParseError "mismatched tag" 1 9) - ) $ parseTree stringFlavor Nothing - (toByteStringL "") + ) (parseTree Nothing + (toByteStringL "") :: (UNode String, Maybe XMLParseError)) test_error3 :: IO () test_error3 = @@ -79,12 +80,12 @@ Element {eName = "hello", eAttrs = [], eChildren = []} ]}, Just (XMLParseError "mismatched tag" 1 35) - ) $ parseTree stringFlavor Nothing + ) $ parseTree Nothing (toByteStringL "Hello") test_error4 :: IO () test_error4 = do - let eDoc = parseTree' stringFlavor Nothing (toByteString "!") + let eDoc = parseTree' Nothing (toByteString "!") :: Either XMLParseError (UNode String) assertEqual "error1" (Left $ XMLParseError "not well-formed (invalid token)" 1 0) eDoc main = do @@ -99,18 +100,24 @@ forM_ (zip [1..] docs) $ \(idx, doc) -> testDoc parse fmt toByteString descr idx doc runTestTT $ TestList [ - TestCase $ t' ("String", parseTree' stringFlavor, formatTree stringFlavor), - TestCase $ t' ("ByteString", parseTree' byteStringFlavor, formatTree byteStringFlavor), - TestCase $ t' ("Text", parseTree' textFlavor, formatTree textFlavor), - TestCase $ t ("String/Lazy", eitherify $ parseTree stringFlavor, formatTree stringFlavor), - TestCase $ t ("ByteString/Lazy", eitherify $ parseTree byteStringFlavor, formatTree byteStringFlavor), - TestCase $ t ("Text/Lazy", eitherify $ parseTree textFlavor, formatTree textFlavor), - TestCase $ t' ("String/Qualified", parseTree' qualifiedStringFlavor, formatTree qualifiedStringFlavor), - TestCase $ t' ("ByteString/Qualified", parseTree' qualifiedByteStringFlavor, formatTree qualifiedByteStringFlavor), - TestCase $ t' ("Text/Qualified", parseTree' qualifiedTextFlavor, formatTree qualifiedTextFlavor), - TestCase $ t ("String/Qualified/Lazy", eitherify $ parseTree qualifiedStringFlavor, formatTree qualifiedStringFlavor), - TestCase $ t ("ByteString/Qualified/Lazy", eitherify $ parseTree qualifiedByteStringFlavor, formatTree qualifiedByteStringFlavor), - TestCase $ t ("Text/Qualified/Lazy", eitherify $ parseTree qualifiedTextFlavor, formatTree qualifiedTextFlavor), + 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,