diff --git a/C2HS.hs b/C2HS.hs deleted file mode 100644 --- a/C2HS.hs +++ /dev/null @@ -1,220 +0,0 @@ --- C->Haskell Compiler: Marshalling library --- --- Copyright (c) [1999...2005] Manuel M T Chakravarty --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- 1. Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- 2. Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- 3. The name of the author may not be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR --- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES --- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN --- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED --- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- ---- Description --------------------------------------------------------------- --- --- Language: Haskell 98 --- --- This module provides the marshaling routines for Haskell files produced by --- C->Haskell for binding to C library interfaces. It exports all of the --- low-level FFI (language-independent plus the C-specific parts) together --- with the C->HS-specific higher-level marshalling routines. --- - -module C2HS ( - - -- * Re-export the language-independent component of the FFI - module Foreign, - - -- * Re-export the C language component of the FFI - module CForeign, - - -- * Composite marshalling functions - withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv, - peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum, - - -- * Conditional results using 'Maybe' - nothingIf, nothingIfNull, - - -- * Bit masks - combineBitMasks, containsBitMask, extractBitMasks, - - -- * Conversion between C and Haskell types - cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum -) where - - -import Foreign - hiding (Word) - -- Should also hide the Foreign.Marshal.Pool exports in - -- compilers that export them -import CForeign - -import Monad (when, liftM) - - --- Composite marshalling functions --- ------------------------------- - --- Strings with explicit length --- -withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n) -peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n) - --- Marshalling of numerals --- - -withIntConv :: (Storable b, Integral a, Integral b) - => a -> (Ptr b -> IO c) -> IO c -withIntConv = with . cIntConv - -withFloatConv :: (Storable b, RealFloat a, RealFloat b) - => a -> (Ptr b -> IO c) -> IO c -withFloatConv = with . cFloatConv - -peekIntConv :: (Storable a, Integral a, Integral b) - => Ptr a -> IO b -peekIntConv = liftM cIntConv . peek - -peekFloatConv :: (Storable a, RealFloat a, RealFloat b) - => Ptr a -> IO b -peekFloatConv = liftM cFloatConv . peek - --- Passing Booleans by reference --- - -withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b -withBool = with . fromBool - -peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool -peekBool = liftM toBool . peek - - --- Passing enums by reference --- - -withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c -withEnum = with . cFromEnum - -peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a -peekEnum = liftM cToEnum . peek - - --- Storing of 'Maybe' values --- ------------------------- - -instance Storable a => Storable (Maybe a) where - sizeOf _ = sizeOf (undefined :: Ptr ()) - alignment _ = alignment (undefined :: Ptr ()) - - peek p = do - ptr <- peek (castPtr p) - if ptr == nullPtr - then return Nothing - else liftM Just $ peek ptr - - poke p v = do - ptr <- case v of - Nothing -> return nullPtr - Just v' -> new v' - poke (castPtr p) ptr - - --- Conditional results using 'Maybe' --- --------------------------------- - --- Wrap the result into a 'Maybe' type. --- --- * the predicate determines when the result is considered to be non-existing, --- ie, it is represented by `Nothing' --- --- * the second argument allows to map a result wrapped into `Just' to some --- other domain --- -nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b -nothingIf p f x = if p x then Nothing else Just $ f x - --- |Instance for special casing null pointers. --- -nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b -nothingIfNull = nothingIf (== nullPtr) - - --- Support for bit masks --- --------------------- - --- Given a list of enumeration values that represent bit masks, combine these --- masks using bitwise disjunction. --- -combineBitMasks :: (Enum a, Bits b) => [a] -> b -combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum) - --- Tests whether the given bit mask is contained in the given bit pattern --- (i.e., all bits set in the mask are also set in the pattern). --- -containsBitMask :: (Bits a, Enum b) => a -> b -> Bool -bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm - in - bm' .&. bits == bm' - --- |Given a bit pattern, yield all bit masks that it contains. --- --- * This does *not* attempt to compute a minimal set of bit masks that when --- combined yield the bit pattern, instead all contained bit masks are --- produced. --- -extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b] -extractBitMasks bits = - [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm] - - --- Conversion routines --- ------------------- - --- |Integral conversion --- -cIntConv :: (Integral a, Integral b) => a -> b -cIntConv = fromIntegral - --- |Floating conversion --- -cFloatConv :: (RealFloat a, RealFloat b) => a -> b -cFloatConv = realToFrac --- As this conversion by default goes via `Rational', it can be very slow... -{-# RULES - "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; - "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x - #-} - --- |Obtain C value from Haskell 'Bool'. --- -cFromBool :: Num a => Bool -> a -cFromBool = fromBool - --- |Obtain Haskell 'Bool' from C value. --- -cToBool :: Num a => a -> Bool -cToBool = toBool - --- |Convert a C enumeration to Haskell. --- -cToEnum :: (Integral i, Enum e) => i -> e -cToEnum = toEnum . cIntConv - --- |Convert a Haskell enumeration to C. --- -cFromEnum :: (Enum e, Integral i) => e -> i -cFromEnum = cIntConv . fromEnum 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 @@ -1,54 +1,91 @@ +-- hexpat, a Haskell wrapper for expat +-- Copyright (C) 2008 Evan Martin +-- Copyright (C) 2009 Stephen Blackheath + +-- | This module provides lazy functions to format a tree +-- structure as UTF-8 encoded XML. + +{-# LANGUAGE FlexibleContexts #-} + module Text.XML.Expat.Format ( - formatDoc, - formatDocS, + formatTree, formatNode, - formatNodeS + putTree, + putNode ) where import Text.XML.Expat.IO import Text.XML.Expat.Tree - -enc :: String -> String -enc = id +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Binary.Put +import Control.Monad -- | Format document with Node -> String -formatDoc mEnc node = formatDocS mEnc node "" +formatTree :: TreeFlavor tag text + -> Node tag text + -> L.ByteString +formatTree flavour node = runPut $ putTree flavour node --- | Format document with Node -> ShowS -formatDocS mEnc node = ("\n"++) . formatNodeS node - where - putEnc (Just enc) = (" encoding=\""++) . (encodingToString enc++) . ("\""++) - putEnc Nothing = id +-- | Format XML node with no header. +formatNode :: TreeFlavor tag text + -> Node tag text + -> L.ByteString +formatNode flavour node = runPut $ putNode flavour node --- | Format XML node with no XML header. -formatNode :: Node -> String -formatNode node = formatNodeS node "" +-- | 'Data.Binary.Put.Put' interface for formatting a tree with Node tag text + -> Put +putTree flavour node = do + putByteString $ pack "\n" + putNode flavour node --- | Format XML node with no XML header returning as a ShowS. -formatNodeS :: Node -> ShowS -formatNodeS (Element name attrs children) = - ("<"++) . (enc name++) . - foldr (.) id (flip map attrs (\(name, value) -> - (" "++) . (enc name++) . ("=\""++) . - (enc (escapeXML value)++) . ("\""++) - )) . - (if null children - then - ("/>"++) - else - (">"++) . - foldr (.) id (map formatNodeS children) . - (""++) - ) -formatNodeS (Text txt) = (enc (escapeXML txt)++) +-- | '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 + putWord8 $ c2w '<' + let putThisTag = putTag name + putThisTag + forM_ attrs $ \(aname, avalue) -> do + putWord8 $ c2w ' ' + putTag aname + putByteString $ pack "=\"" + putXMLText $ fmtText avalue + putByteString $ pack "\"" + if null children + then + putByteString $ pack "/>" + else do + putWord8 $ c2w '>' + forM_ children $ putNode flavour + putByteString $ pack "' +putNode (TreeFlavor _ _ putTag fmtText) (Text txt) = + putXMLText $ fmtText txt -escapeXML :: String -> String -escapeXML = concatMap e - where - e '&' = "&" - e '<' = "<" - e '"' = """ - e '\'' = "'" - e ch = [ch] +pack :: String -> B.ByteString +pack = B.pack . map c2w + +unpack :: L.ByteString -> String +unpack = map w2c . L.unpack + +putXMLText :: B.ByteString -> Put +putXMLText str | B.null str = return () +putXMLText str = do + case w2c $ B.head str of + '&' -> putByteString $ pack "&" + '<' -> putByteString $ pack "<" + '"' -> putByteString $ pack """ + '\'' -> putByteString $ pack "'" + ch -> putWord8 (c2w ch) + putXMLText $ B.tail str + diff --git a/Text/XML/Expat/IO.chs b/Text/XML/Expat/IO.chs deleted file mode 100644 --- a/Text/XML/Expat/IO.chs +++ /dev/null @@ -1,196 +0,0 @@ --- hexpat, a Haskell wrapper for expat --- Copyright (C) 2008 Evan Martin - --- |This module wraps the Expat API directly with IO operations --- everywhere. Basic usage is: --- --- (1) Make a new parser: 'newParser'. --- --- (2) Set up callbacks on the parser: 'setStartElementHandler', etc. --- --- (3) Feed data into the parser: 'parse' or 'parseChunk'. - -module Text.XML.Expat.IO ( - -- ** Parser Setup - Parser, newParser, - - -- ** Parsing - parse, Encoding(..), - - -- ** Parser Callbacks - StartElementHandler, EndElementHandler, CharacterDataHandler, - setStartElementHandler, setEndElementHandler, setCharacterDataHandler, - - -- ** Lower-level Parsing Interface - parseChunk, - - -- ** Helpers - encodingToString -) where - -import Control.Exception (bracket) -import C2HS -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import Data.IORef - -#include - --- Expat functions start with "XML", but C2HS appears to ignore our "as" --- definitions if they only differ from the symbol in case. So we write out --- XML_* in most cases anyway... :( -{#context lib = "expat" prefix = "XML"#} - --- |Opaque parser type. -type ParserPtr = Ptr () -data Parser = Parser - (ForeignPtr ()) - (IORef CStartElementHandler) - (IORef CEndElementHandler) - (IORef CCharacterDataHandler) - -withParser :: Parser -> (ParserPtr -> IO a) -> IO a -withParser (Parser fp _ _ _) = withForeignPtr fp - --- |Encoding types available for the document encoding. -data Encoding = ASCII | UTF8 | UTF16 | ISO88591 -encodingToString :: Encoding -> String -encodingToString ASCII = "US-ASCII" -encodingToString UTF8 = "UTF-8" -encodingToString UTF16 = "UTF-16" -encodingToString ISO88591 = "ISO-8859-1" - -withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a -withOptEncoding Nothing f = f nullPtr -withOptEncoding (Just enc) f = withCString (encodingToString enc) f - -{#fun unsafe XML_ParserCreate as parserCreate - {withOptEncoding* `Maybe Encoding'} -> `ParserPtr' id#} -foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ()) - --- |Create a 'Parser'. The encoding parameter, if provided, overrides the --- document's encoding declaration. -newParser :: Maybe Encoding -> IO Parser -newParser enc = do - ptr <- parserCreate enc - fptr <- newForeignPtr parserFree ptr - nullStartH <- newIORef nullCStartElementHandler - nullEndH <- newIORef nullCEndElementHandler - nullCharH <- newIORef nullCCharacterDataHandler - return $ Parser fptr nullStartH nullEndH nullCharH - --- 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 -withBStringLen bs f = do - BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len) - -unStatus :: CInt -> Bool -unStatus 0 = False -unStatus 1 = True --- |@parseChunk data False@ feeds /strict/ ByteString data into a --- 'Parser'. The end of the data is indicated by passing @True@ for the --- final parameter. @parse@ returns @False@ on a parse error. -parseChunk :: Parser - -> BS.ByteString - -> Bool - -> IO Bool -parseChunk parser@(Parser fp startRef endRef charRef) xml final = do - bracket - (do - cStartH <- mkCStartElementHandler =<< readIORef startRef - cEndH <- mkCEndElementHandler =<< readIORef endRef - cCharH <- mkCCharacterDataHandler =<< readIORef charRef - withParser parser $ \p -> do - {#call unsafe XML_SetStartElementHandler as ^#} p cStartH - {#call unsafe XML_SetEndElementHandler as ^#} p cEndH - {#call unsafe XML_SetCharacterDataHandler as ^#} p cCharH - return (cStartH, cEndH, cCharH)) - (\(cStartH, cEndH, cCharH) -> do - freeHaskellFunPtr cStartH - freeHaskellFunPtr cEndH - freeHaskellFunPtr cCharH) - (\_ -> doParseChunk parser xml final) - -{#fun XML_Parse as doParseChunk - {withParser* `Parser', withBStringLen* `BS.ByteString' &, `Bool'} - -> `Bool' unStatus#} - --- |@parse data@ feeds /lazy/ bytestring data into a parser and returns --- @True@ if there was no parse error. -parse :: Parser -> BSL.ByteString -> IO Bool -parse parser bs = feedChunk (BSL.toChunks bs) where - feedChunk [] = return True - feedChunk [chunk] = parseChunk parser chunk True - feedChunk (c:cs) = do ok <- parseChunk parser c False - if ok then feedChunk cs - else return False - --- |The type of the \"element started\" callback. The first parameter is --- the element name; the second are the (attribute, value) pairs. -type StartElementHandler = String -> [(String,String)] -> IO () --- |The type of the \"element ended\" callback. The parameter is --- the element name. -type EndElementHandler = String -> IO () --- |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. -type CharacterDataHandler = String -> IO () - -type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO () -nullCStartElementHandler _ _ _ = return () - -foreign import ccall "wrapper" - mkCStartElementHandler :: CStartElementHandler - -> IO (FunPtr CStartElementHandler) -wrapStartElementHandler :: StartElementHandler -> CStartElementHandler -wrapStartElementHandler handler = h where - h ptr cname cattrs = do - name <- peekCString cname - cattrlist <- peekArray0 nullPtr cattrs - attrlist <- mapM peekCString cattrlist - handler name (pairwise attrlist) --- |Attach a StartElementHandler to a Parser. -setStartElementHandler :: Parser -> StartElementHandler -> IO () -setStartElementHandler parser@(Parser _ startRef _ _) handler = do - withParser parser $ \p -> do - writeIORef startRef $ wrapStartElementHandler handler - - -type CEndElementHandler = Ptr () -> CString -> IO () -nullCEndElementHandler _ _ = return () - -foreign import ccall "wrapper" - mkCEndElementHandler :: CEndElementHandler - -> IO (FunPtr CEndElementHandler) -wrapEndElementHandler :: EndElementHandler -> CEndElementHandler -wrapEndElementHandler handler = h where - h ptr cname = do - name <- peekCString cname - handler name - --- |Attach an EndElementHandler to a Parser. -setEndElementHandler :: Parser -> EndElementHandler -> IO () -setEndElementHandler parser@(Parser _ _ endRef _) handler = do - withParser parser $ \p -> do - writeIORef endRef $ wrapEndElementHandler handler - -type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO () -nullCCharacterDataHandler _ _ _ = return () - -foreign import ccall "wrapper" - mkCCharacterDataHandler :: CCharacterDataHandler - -> IO (FunPtr CCharacterDataHandler) -wrapCharacterDataHandler :: CharacterDataHandler -> CCharacterDataHandler -wrapCharacterDataHandler handler = h where - h ptr cdata len = do - data_ <- peekCStringLen (cdata, fromIntegral len) - handler data_ --- |Attach an CharacterDataHandler to a Parser. -setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO () -setCharacterDataHandler parser@(Parser _ _ _ charRef) handler = do - withParser parser $ \p -> do - writeIORef charRef $ wrapCharacterDataHandler handler - -pairwise (x1:x2:xs) = (x1,x2) : pairwise xs -pairwise [] = [] diff --git a/Text/XML/Expat/IO.hs b/Text/XML/Expat/IO.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/IO.hs @@ -0,0 +1,300 @@ +-- hexpat, a Haskell wrapper for expat +-- 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: +-- +-- (1) Make a new parser: 'newParser'. +-- +-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc. +-- +-- (3) Feed data into the parser: 'parse' or 'parseChunk'. + +module Text.XML.Expat.IO ( + -- ** Parser Setup + Parser, newParser, + + -- ** Parsing + parse, parseChunk, Encoding(..), XMLParseError(..), + + -- ** Parser Callbacks + StartElementHandler, EndElementHandler, CharacterDataHandler, + setStartElementHandler, setEndElementHandler, setCharacterDataHandler, + + -- ** Lower-level interface + unsafeParseChunk, + withHandlers, + unsafeSetHandlers, + unsafeReleaseHandlers, + ExpatHandlers, + + -- ** Helpers + encodingToString +) where + +import Control.Exception (bracket) +import Control.Parallel.Strategies +import Control.Monad +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Internal as BSI +import Data.IORef +import Foreign +import CForeign + + +-- |Opaque parser type. +type ParserPtr = Ptr () +data Parser = Parser + (ForeignPtr ()) + (IORef CStartElementHandler) + (IORef CEndElementHandler) + (IORef CCharacterDataHandler) + +instance Show Parser where + showsPrec _ (Parser fp _ _ _) = showsPrec 0 fp + +withParser :: Parser -> (ParserPtr -> IO a) -> IO a +withParser (Parser fp _ _ _) = withForeignPtr fp + +-- |Encoding types available for the document encoding. +data Encoding = ASCII | UTF8 | UTF16 | ISO88591 +encodingToString :: Encoding -> String +encodingToString ASCII = "US-ASCII" +encodingToString UTF8 = "UTF-8" +encodingToString UTF16 = "UTF-16" +encodingToString ISO88591 = "ISO-8859-1" + +withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a +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. +newParser :: Maybe Encoding -> IO Parser +newParser enc = do + ptr <- parserCreate enc + fptr <- newForeignPtr parserFree ptr + nullStartH <- newIORef nullCStartElementHandler + nullEndH <- newIORef nullCEndElementHandler + nullCharH <- newIORef nullCCharacterDataHandler + return $ Parser fptr nullStartH nullEndH nullCharH + +-- 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 +withBStringLen bs f = do + BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len) + +unStatus :: CInt -> Bool +unStatus 0 = False +unStatus 1 = True + +-- |@parse data@ feeds /lazy/ 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 + ok <- doParseChunk parser bs True + if ok + then return Nothing + else Just `fmap` getError parser + +-- |@parseChunk data False@ feeds /strict/ ByteString data into a +-- 'Parser'. The end of the data is indicated by passing @True@ for the +-- final parameter. It returns Nothing on success, or Just the parse error. +parseChunk :: Parser + -> BS.ByteString + -> Bool + -> 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. +unsafeParseChunk :: Parser + -> BS.ByteString + -> Bool + -> IO (Maybe XMLParseError) +unsafeParseChunk parser xml final = do + ok <- doParseChunk parser xml final + if ok + then return Nothing + else Just `fmap` getError parser + +getError parser = withParser parser $ \p -> do + code <- xmlGetErrorCode p + cerr <- xmlErrorString code + err <- peekCString cerr + line <- xmlGetCurrentLineNumber p + col <- xmlGetCurrentColumnNumber p + return $ XMLParseError err + (fromIntegral line) (fromIntegral col) + +data ExpatHandlers = ExpatHandlers + (FunPtr CStartElementHandler) + (FunPtr CEndElementHandler) + (FunPtr CCharacterDataHandler) + +unsafeSetHandlers :: Parser -> IO ExpatHandlers +unsafeSetHandlers parser@(Parser fp startRef endRef charRef) = do + cStartH <- mkCStartElementHandler =<< readIORef startRef + cEndH <- mkCEndElementHandler =<< readIORef endRef + cCharH <- mkCCharacterDataHandler =<< readIORef charRef + withParser parser $ \p -> do + xmlSetstartelementhandler p cStartH + xmlSetendelementhandler p cEndH + xmlSetcharacterdatahandler p cCharH + return $ ExpatHandlers cStartH cEndH cCharH + +unsafeReleaseHandlers :: ExpatHandlers -> IO () +unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH) = do + freeHaskellFunPtr cStartH + freeHaskellFunPtr cEndH + freeHaskellFunPtr cCharH + +-- | 'unsafeParseChunk' is required to be called inside @withHandlers@. +-- Safer than using 'unsafeSetHandlers' / 'unsafeReleaseHandlers'. +withHandlers :: Parser + -> IO a -- ^ Computation where unsafeParseChunk may be used + -> IO a +withHandlers parser code = do + bracket + (unsafeSetHandlers parser) + unsafeReleaseHandlers + (\_ -> code) + +-- |Obtain C value from Haskell 'Bool'. +-- +cFromBool :: Num a => Bool -> a +cFromBool = fromBool + +doParseChunk :: Parser -> BS.ByteString -> Bool -> IO (Bool) +doParseChunk a1 a2 a3 = + withParser a1 $ \a1' -> + withBStringLen a2 $ \(a2'1, a2'2) -> + let {a3' = cFromBool a3} in + doParseChunk'_ a1' a2'1 a2'2 a3' >>= \res -> + let {res' = unStatus res} in + return (res') + +-- | Parse error, consisting of message text, line number, and column number +data XMLParseError = XMLParseError String Integer Integer deriving (Eq, Show) + +instance NFData XMLParseError where + rnf (XMLParseError msg lin col) = rnf (msg, lin, col) + +-- |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. +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 +-- parsing as normal, or False to terminate the parse. +type CharacterDataHandler = CStringLen -> IO Bool + +type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO () +nullCStartElementHandler _ _ _ = return () + +foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode + :: ParserPtr -> IO CInt +foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber + :: ParserPtr -> IO CUInt -- to do: Get 64-bit value if supported (how?) +foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber + :: ParserPtr -> IO CUInt -- to do: Get 64-bit value if supported (how?) +foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString + :: CInt -> IO CString +foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser + :: ParserPtr -> CInt -> IO () + +foreign import ccall safe "wrapper" + mkCStartElementHandler :: CStartElementHandler + -> IO (FunPtr CStartElementHandler) + +wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler +wrapStartElementHandler parser@(Parser _ _ _ _) handler = h + where + h ptr cname cattrs = do + cattrlist <- peekArray0 nullPtr cattrs + stillRunning <- handler cname (pairwise cattrlist) + unless stillRunning $ + withParser parser $ \p -> xmlStopParser p 0 + +-- |Attach a StartElementHandler to a Parser. +setStartElementHandler :: Parser -> StartElementHandler -> IO () +setStartElementHandler parser@(Parser _ startRef _ _) handler = + withParser parser $ \p -> do + writeIORef startRef $ wrapStartElementHandler parser handler + +type CEndElementHandler = Ptr () -> CString -> IO () +nullCEndElementHandler _ _ = return () + +foreign import ccall safe "wrapper" + mkCEndElementHandler :: CEndElementHandler + -> IO (FunPtr CEndElementHandler) +wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler +wrapEndElementHandler parser@(Parser _ _ _ _) handler = h + where + h ptr cname = do + stillRunning <- handler cname + unless stillRunning $ + withParser parser $ \p -> xmlStopParser p 0 + +-- |Attach an EndElementHandler to a Parser. +setEndElementHandler :: Parser -> EndElementHandler -> IO () +setEndElementHandler parser@(Parser _ _ endRef _) handler = + withParser parser $ \p -> do + writeIORef endRef $ wrapEndElementHandler parser handler + +type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO () +nullCCharacterDataHandler _ _ _ = return () + +foreign import ccall safe "wrapper" + mkCCharacterDataHandler :: CCharacterDataHandler + -> IO (FunPtr CCharacterDataHandler) +wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler +wrapCharacterDataHandler parser@(Parser _ _ _ _) handler = h + where + h ptr cdata len = do + stillRunning <- handler (cdata, fromIntegral len) + unless stillRunning $ + withParser parser $ \p -> xmlStopParser p 0 + +-- | Attach an CharacterDataHandler to a Parser. +setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO () +setCharacterDataHandler parser@(Parser _ _ _ charRef) handler = + withParser parser $ \p -> do + writeIORef charRef $ wrapCharacterDataHandler parser handler + +pairwise (x1:x2:xs) = (x1,x2) : pairwise xs +pairwise [] = [] + + +foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_ParserCreate" + parserCreate'_ :: ((Ptr CChar) -> (IO (Ptr ()))) + +foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetStartElementHandler" + xmlSetstartelementhandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> ((Ptr (Ptr CChar)) -> (IO ()))))) -> (IO ()))) + +foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetEndElementHandler" + xmlSetendelementhandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> (IO ())))) -> (IO ()))) + +foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetCharacterDataHandler" + xmlSetcharacterdatahandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (IO ()))))) -> (IO ()))) + +foreign import ccall safe "Text/XML/Expat/IO.chs.h XML_Parse" + doParseChunk'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt))))) diff --git a/Text/XML/Expat/Qualified.hs b/Text/XML/Expat/Qualified.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Qualified.hs @@ -0,0 +1,124 @@ +-- hexpat, a Haskell wrapper for expat +-- 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 +-- \ are represented just as a string containing a colon, e.g. +-- \"abc:hello\". +-- +-- This module provides flavors that handle these more intelligently, splitting +-- all tag and attribute names into their Prefix and LocalPart components. + +module Text.XML.Expat.Qualified ( + QName(..), + mkQName, + mkAnName, + qualifiedStringFlavor, + qualifiedByteStringFlavor, + qualifiedTextFlavor + ) where + +import Text.XML.Expat.IO +import Text.XML.Expat.Tree +import Text.XML.Expat.Format +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Internal as I +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Control.Applicative +import Control.Monad.Writer +import Control.Parallel.Strategies +import Data.Monoid +import Data.Binary.Put +import qualified Codec.Binary.UTF8.String as U8 +import Foreign.C.String +import Foreign.Ptr + + +data QName text = + QName { + qnPrefix :: Maybe text, + qnLocalPart :: !text + } + deriving (Eq,Show) + +instance NFData text => NFData (QName text) where + rnf (QName pre loc) = rnf (pre, loc) + +-- | 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 + +-- | Flavor for qualified tags, using String data type. +qualifiedStringFlavor :: TreeFlavor (QName String) String +qualifiedStringFlavor = TreeFlavor (\t -> toQName <$> unpack t) unpackLen fromQName pack + 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 + +-- | 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 ':') + +-- | 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 + 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) + +peekByteStringLen :: CStringLen -> IO B.ByteString +{-# INLINE peekByteStringLen #-} +peekByteStringLen (cstr, len) = + I.create (fromIntegral len) $ \ptr -> + I.memcpy ptr (castPtr cstr) (fromIntegral len) + + 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,54 +1,241 @@ -- hexpat, a Haskell wrapper for expat -- Copyright (C) 2008 Evan Martin +-- Copyright (C) 2009 Stephen Blackheath --- |The Expat.Tree module provides a simplified interface to parsing, that --- returns a tree of the XML structure. It is written using the lower-level --- bindings in the "Text.XML.Expat.IO" module. (Note that this is not a lazy --- parse of the document: as soon as the root node is accessed, the entire --- document is parsed.) +-- | 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. module Text.XML.Expat.Tree ( - Text.XML.Expat.Tree.parse, Node(..), - EIO.Encoding(..) + -- * Tree structure + Node(..), + -- * Parse to tree + parseTree, + parseTree', + Encoding(..), + XMLParseError(..), + -- * SAX-style parse + parseSAX, + SAXEvent(..), + -- * Flavors + TreeFlavor(..), + stringFlavor, + byteStringFlavor, + textFlavor ) where -import qualified Text.XML.Expat.IO as EIO -import qualified Data.ByteString.Lazy as B +import Text.XML.Expat.IO +import qualified Data.ByteString as B +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.Text as T +import qualified Data.Text.Encoding as TE +import qualified Codec.Binary.UTF8.String as U8 +import Data.Binary.Put +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 --- |Simplistic XML tree representation. -data Node = Element { eName :: String, eAttrs :: [(String,String)], - eChildren :: [Node] } - | Text String - deriving Show -modifyChildren :: ([Node] -> [Node]) -> Node -> Node +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 + +-- | 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 + +-- | 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 + +peekByteString :: CString -> IO B.ByteString +{-# INLINE peekByteString #-} +peekByteString cstr = do + len <- I.c_strlen cstr + peekByteStringLen (castPtr cstr, fromIntegral len) + +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 { + eName :: !tag, + eAttrs :: ![(tag,text)], + eChildren :: [Node tag text] + } | + Text !text + deriving (Eq, Show) + +instance (NFData tag, NFData text) => NFData (Node tag text) where + rnf (Element nam att chi) = rnf (nam, att, chi) + rnf (Text txt) = rnf txt + +modifyChildren :: ([Node tag text] -> [Node tag text]) + -> Node tag text + -> Node tag text modifyChildren f node = node { eChildren = f (eChildren node) } --- |@parse enc doc@ parses /lazy/ bytestring XML content @doc@ with optional --- encoding override @enc@ and returns the root 'Node' of the document if there --- were no parsing errors. -parse :: Maybe EIO.Encoding -> B.ByteString -> Maybe Node -parse enc doc = unsafePerformIO $ runParse where +-- | 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) + -> 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 runParse = do - parser <- EIO.newParser enc + 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. - stack <- newIORef [Element "" [] []] - EIO.setStartElementHandler parser (\n a -> modifyIORef stack (start n a)) - EIO.setEndElementHandler parser (\n -> modifyIORef stack (end n)) - EIO.setCharacterDataHandler parser (\s -> modifyIORef stack (text s)) - ok <- EIO.parse parser doc - if ok - then do - [Element _ _ [root]] <- readIORef stack - return $ Just root - else return Nothing + emptyString <- withCString "" mkTag + stack <- newIORef [Element emptyString [] []] + setStartElementHandler parser $ \cName cAttrs -> do + name <- mkTag cName + attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do + attrName <- mkTag cAttrName + len <- c_strlen cAttrValue + attrValue <- mkText (cAttrValue, fromIntegral len) + return (attrName, attrValue) + modifyIORef stack (start name attrs) + return True + setEndElementHandler parser $ \cName -> do + name <- mkTag cName + modifyIORef stack (end name) + return True + setCharacterDataHandler parser $ \cText -> do + txt <- mkText cText + modifyIORef stack (text txt) + return True + mError <- parse parser doc + case mError of + Just error -> return $ Left error + Nothing -> do + [Element _ _ [root]] <- readIORef stack + return $ Right root + start name attrs stack = Element name attrs [] : stack text str (cur:rest) = modifyChildren (Text str:) cur : rest end name (cur:parent:rest) = - if eName cur /= name then error "name mismatch" else let node = modifyChildren reverse cur in modifyChildren (node:) parent : rest + +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 + +-- | 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 + -> L.ByteString -- ^ Input text (a lazy ByteString) + -> [SAXEvent tag text] +parseSAX (TreeFlavor mkTag mkText _ _) enc input = unsafePerformIO $ do + parser <- newParser enc + queueRef <- newIORef [] + setStartElementHandler parser $ \cName cAttrs -> do + name <- mkTag cName + attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do + attrName <- mkTag cAttrName + len <- c_strlen cAttrValue + attrValue <- mkText (cAttrValue, fromIntegral len) + return (attrName, attrValue) + modifyIORef queueRef (StartElement name attrs:) + return True + setEndElementHandler parser $ \cName -> do + name <- mkTag cName + modifyIORef queueRef (EndElement name:) + return True + setCharacterDataHandler parser $ \cText -> do + txt <- mkText cText + modifyIORef queueRef (CharacterData txt:) + 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 -> return [FailDocument error] + Nothing -> runParser cs + return $ reverse queue ++ rem + + 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) + -> (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 + in (safeHead nodes, mError) + where + safeHead (a:_) = a + safeHead [] = Element (unsafePerformIO $ withCString "" mkTag) [] [] + ptl (StartElement name attrs:rem) = + let (children, err1, rem') = ptl rem + 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') + ptl (FailDocument err:_) = ([], Just err, []) + ptl [] = ([], Nothing, []) diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -1,33 +1,63 @@ Cabal-Version: >= 1.2 Name: hexpat -Version: 0.3 +Version: 0.4 Synopsis: wrapper for expat, the fast XML parser Description: Expat () is a stream-oriented XML parser - written in C. It is known for being simple and fast. + written in C. . - There are already nice XML libraries in the Text.XML hierarchy. The - reason to use Expat is when speed is of concern. From a benchmark - that compares getting the length of the root node of a HaXml tree - (presumably forcing parsing the entire file) against running an Expat - parser with a registered start node handler, Expat is about 12 times - faster. This is not a fair benchmark; HaXml does a lot more than this - Expat library. But if Expat suffices, it is good for what it does. + 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. + . + 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 + . + 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 Category: XML License: BSD3 License-File: LICENSE -Author: Evan Martin, Stephen Blackheath +Author: Stephen Blackheath (blackh), Evan Martin, Matthew Pocock (drdozer) Maintainer: http://blacksapphire.com/antispam/ -Copyright: (c) 2008 Evan Martin , (c) 2008 Stephen Blackheath +Copyright: + (c) 2009 Stephen Blackheath , + (c) 2008 Evan Martin , + (c) 2009 Matthew Pocock Homepage: http://code.haskell.org/hexpat/ -Extra-Source-Files: test.hs, perf.hs, test2.hs +Extra-Source-Files: + test/tests.hs, + test/perf.hs, + test/test.xml, + test/benchmark.hs, + test/lazySAX.hs, + test/lazyTree.hs Build-Type: Simple Stability: beta Library - Build-Depends: base, haskell98, bytestring - Exposed-Modules: Text.XML.Expat.IO, Text.XML.Expat.Tree, Text.XML.Expat.Format - Other-Modules: C2HS + Build-Depends: + base, + haskell98, + bytestring, + mtl >= 1.1.0.0, + text >= 0.1, + binary >= 0.4, + utf8-string >= 0.3.3, + parallel + Exposed-Modules: + Text.XML.Expat.Tree, + Text.XML.Expat.Format, + Text.XML.Expat.Qualified, + Text.XML.Expat.IO Extensions: ForeignFunctionInterface Extra-Libraries: expat diff --git a/perf.hs b/perf.hs deleted file mode 100644 --- a/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.hs b/test.hs deleted file mode 100644 --- a/test.hs +++ /dev/null @@ -1,31 +0,0 @@ -import qualified Text.XML.Expat.IO as EIO -import qualified Text.XML.Expat.Tree as ETree -import qualified Data.ByteString.Lazy as B -import Data.Tree -import Data.Char - -toByteString :: String -> B.ByteString -toByteString = B.pack . map (fromIntegral . ord) - -main_eio doc = do - parser <- EIO.newParser Nothing - EIO.setStartElementHandler parser startElement - EIO.parse parser doc - putStrLn "ok" - where - startElement name attrs = putStrLn $ show name ++ " " ++ show attrs - -main_tree doc = do - let etree = ETree.parse Nothing doc - --let dtree = toDTree etree - --putStrLn (drawTree dtree) - etree `seq` putStrLn "ok" - where - toDTree (ETree.Element name attrs kids) = - Node ("<" ++ name ++ " " ++ show attrs ++ ">") (map toDTree kids) - toDTree (ETree.Text str) = Node (show str) [] - -main = do - let doc = "some & text" - xml <- readFile "test.xml" - main_eio (toByteString xml) diff --git a/test/benchmark.hs b/test/benchmark.hs new file mode 100644 --- /dev/null +++ b/test/benchmark.hs @@ -0,0 +1,79 @@ +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 flavor enc xml = parseTree flavor enc (L.fromChunks [xml]) + +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 ()) + ] + +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/lazySAX.hs b/test/lazySAX.hs new file mode 100644 --- /dev/null +++ b/test/lazySAX.hs @@ -0,0 +1,25 @@ +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 byteStringFlavor Nothing infiniteBL + diff --git a/test/lazyTree.hs b/test/lazyTree.hs new file mode 100644 --- /dev/null +++ b/test/lazyTree.hs @@ -0,0 +1,25 @@ +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 stringFlavor Nothing infiniteBL + diff --git a/test/perf.hs b/test/perf.hs new file mode 100644 --- /dev/null +++ b/test/perf.hs @@ -0,0 +1,42 @@ +-- 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/test.xml b/test/test.xml new file mode 100644 --- /dev/null +++ b/test/test.xml @@ -0,0 +1,101 @@ + + + + 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 new file mode 100644 --- /dev/null +++ b/test/tests.hs @@ -0,0 +1,119 @@ +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 Data.ByteString.Internal (c2w, w2c) +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 + +toByteStringL :: String -> BSL.ByteString +toByteStringL = BSL.pack . map c2w + +fromByteStringL :: BSL.ByteString -> String +fromByteStringL = map w2c . BSL.unpack + +toByteString :: String -> BS.ByteString +toByteString = BS.pack . map c2w + +fromByteString :: BS.ByteString -> String +fromByteString = map w2c . BS.unpack + +testDoc :: (Show tag, Show text) => + (Maybe Encoding -> bs -> Either XMLParseError (Node tag text)) + -> (Node tag text -> BSL.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' stringFlavor Nothing (toByteString "") + assertEqual "error1" (Left $ XMLParseError "mismatched tag" 1 9) eDoc + +test_error2 :: IO () +test_error2 = do + assertEqual "error2" ( + Element {eName = "hello", eAttrs = [], eChildren = []}, + Just (XMLParseError "mismatched tag" 1 9) + ) $ parseTree stringFlavor Nothing + (toByteStringL "") + +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" 1 35) + ) $ parseTree stringFlavor Nothing + (toByteStringL "Hello") + +test_error4 :: IO () +test_error4 = do + let eDoc = parseTree' stringFlavor Nothing (toByteString "!") + assertEqual "error1" (Left $ XMLParseError "not well-formed (invalid token)" 1 0) eDoc + +main = do + testXML <- 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' 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 $ test_error1, + TestCase $ test_error2, + TestCase $ test_error3, + TestCase $ test_error4 + ] + diff --git a/test2.hs b/test2.hs deleted file mode 100644 --- a/test2.hs +++ /dev/null @@ -1,29 +0,0 @@ -import Text.XML.Expat.IO -import Text.XML.Expat.Tree as T -import Text.XML.Expat.Format -import qualified Data.ByteString.Lazy as B -import Data.Char -import Data.Maybe - -toByteString :: String -> B.ByteString -toByteString = B.pack . map (fromIntegral . ord) - -test :: String -> IO () -test xml = do - let mTree = T.parse (Just UTF8) (toByteString xml) - --putStrLn $ show mTree - case mTree of - Just tree -> do - let out = formatDoc (Just UTF8) tree - if out == xml - then putStrLn "passed" - else do - putStrLn $ "FAILED: mismatch" - putStrLn $ "input="++xml - putStrLn $ "output="++out - Nothing -> - putStrLn "FAILED: parse failed" - -main = do - test "\nCat & mouseDog & bone" - test "\nCat & mouse"