diff --git a/Text/XML/Expat/Format.hs b/Text/XML/Expat/Format.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Format.hs @@ -0,0 +1,54 @@ +module Text.XML.Expat.Format ( + formatDoc, + formatDocS, + formatNode, + formatNodeS + ) where + +import Text.XML.Expat.IO +import Text.XML.Expat.Tree + +enc :: String -> String +enc = id + +-- | Format document with Node -> String +formatDoc mEnc node = formatDocS mEnc 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 XML header. +formatNode :: Node -> String +formatNode node = formatNodeS 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)++) + +escapeXML :: String -> String +escapeXML = concatMap e + where + e '&' = "&" + e '<' = "<" + e '"' = """ + e '\'' = "'" + e ch = [ch] diff --git a/Text/XML/Expat/IO.chs b/Text/XML/Expat/IO.chs --- a/Text/XML/Expat/IO.chs +++ b/Text/XML/Expat/IO.chs @@ -22,12 +22,17 @@ setStartElementHandler, setEndElementHandler, setCharacterDataHandler, -- ** Lower-level Parsing Interface - parseChunk + 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 @@ -38,10 +43,14 @@ -- |Opaque parser type. type ParserPtr = Ptr () -newtype Parser = Parser (ForeignPtr ()) +data Parser = Parser + (ForeignPtr ()) + (IORef CStartElementHandler) + (IORef CEndElementHandler) + (IORef CCharacterDataHandler) withParser :: Parser -> (ParserPtr -> IO a) -> IO a -withParser (Parser fp) = withForeignPtr fp +withParser (Parser fp _ _ _) = withForeignPtr fp -- |Encoding types available for the document encoding. data Encoding = ASCII | UTF8 | UTF16 | ISO88591 @@ -65,7 +74,10 @@ newParser enc = do ptr <- parserCreate enc fptr <- newForeignPtr parserFree ptr - return $ Parser fptr + 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. @@ -79,7 +91,28 @@ -- |@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. -{#fun XML_Parse as parseChunk +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#} @@ -105,12 +138,13 @@ type CharacterDataHandler = String -> IO () type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO () +nullCStartElementHandler _ _ _ = return () + foreign import ccall "wrapper" mkCStartElementHandler :: CStartElementHandler -> IO (FunPtr CStartElementHandler) -wrapStartElementHandler :: StartElementHandler - -> IO (FunPtr CStartElementHandler) -wrapStartElementHandler handler = mkCStartElementHandler h where +wrapStartElementHandler :: StartElementHandler -> CStartElementHandler +wrapStartElementHandler handler = h where h ptr cname cattrs = do name <- peekCString cname cattrlist <- peekArray0 nullPtr cattrs @@ -118,45 +152,45 @@ handler name (pairwise attrlist) -- |Attach a StartElementHandler to a Parser. setStartElementHandler :: Parser -> StartElementHandler -> IO () -setStartElementHandler parser handler = do +setStartElementHandler parser@(Parser _ startRef _ _) handler = do withParser parser $ \p -> do - handler' <- wrapStartElementHandler handler - {#call unsafe XML_SetStartElementHandler as ^#} p handler' + writeIORef startRef $ wrapStartElementHandler handler type CEndElementHandler = Ptr () -> CString -> IO () +nullCEndElementHandler _ _ = return () + foreign import ccall "wrapper" mkCEndElementHandler :: CEndElementHandler -> IO (FunPtr CEndElementHandler) -wrapEndElementHandler :: EndElementHandler - -> IO (FunPtr CEndElementHandler) -wrapEndElementHandler handler = mkCEndElementHandler h where +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 handler = do +setEndElementHandler parser@(Parser _ _ endRef _) handler = do withParser parser $ \p -> do - handler' <- wrapEndElementHandler handler - {#call unsafe XML_SetEndElementHandler as ^#} p handler' + writeIORef endRef $ wrapEndElementHandler handler type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO () +nullCCharacterDataHandler _ _ _ = return () + foreign import ccall "wrapper" mkCCharacterDataHandler :: CCharacterDataHandler -> IO (FunPtr CCharacterDataHandler) -wrapCharacterDataHandler :: CharacterDataHandler - -> IO (FunPtr CCharacterDataHandler) -wrapCharacterDataHandler handler = mkCCharacterDataHandler h where +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 handler = do +setCharacterDataHandler parser@(Parser _ _ _ charRef) handler = do withParser parser $ \p -> do - handler' <- wrapCharacterDataHandler handler - {#call unsafe XML_SetCharacterDataHandler as ^#} p handler' + writeIORef charRef $ wrapCharacterDataHandler handler pairwise (x1:x2:xs) = (x1,x2) : pairwise xs pairwise [] = [] 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 @@ -43,7 +43,7 @@ if ok then do [Element _ _ [root]] <- readIORef stack - return $ Just $ modifyChildren reverse root + return $ Just root else return Nothing start name attrs stack = Element name attrs [] : stack text str (cur:rest) = modifyChildren (Text str:) cur : rest diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -1,6 +1,6 @@ Cabal-Version: >= 1.2 Name: hexpat -Version: 0.2 +Version: 0.3 Synopsis: wrapper for expat, the fast XML parser Description: Expat () is a stream-oriented XML parser @@ -16,16 +16,17 @@ Category: XML License: BSD3 License-File: LICENSE -Author: Evan Martin -Maintainer: martine@danga.com -Copyright: (c) 2008 Evan Martin -Homepage: http://neugierig.org/software/darcs/browse/?r=hexpat;a=summary -Extra-Source-Files: test.hs, perf.hs +Author: Evan Martin, Stephen Blackheath +Maintainer: http://blacksapphire.com/antispam/ +Copyright: (c) 2008 Evan Martin , (c) 2008 Stephen Blackheath +Homepage: http://code.haskell.org/hexpat/ +Extra-Source-Files: test.hs, perf.hs, test2.hs Build-Type: Simple +Stability: beta Library Build-Depends: base, haskell98, bytestring - Exposed-Modules: Text.XML.Expat.IO, Text.XML.Expat.Tree + Exposed-Modules: Text.XML.Expat.IO, Text.XML.Expat.Tree, Text.XML.Expat.Format Other-Modules: C2HS Extensions: ForeignFunctionInterface Extra-Libraries: expat diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -1,11 +1,16 @@ 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 True + EIO.parse parser doc putStrLn "ok" where startElement name attrs = putStrLn $ show name ++ " " ++ show attrs @@ -23,4 +28,4 @@ main = do let doc = "some & text" xml <- readFile "test.xml" - main_eio xml + main_eio (toByteString xml) diff --git a/test2.hs b/test2.hs new file mode 100644 --- /dev/null +++ b/test2.hs @@ -0,0 +1,29 @@ +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"