xml-enumerator 0.1.3 → 0.2.0
raw patch · 8 files changed
+1387/−1271 lines, 8 filesdep +HUnitdep +hspecdep ~basedep ~xml-typessetup-changednew-component:exe:runtests
Dependencies added: HUnit, hspec
Dependency ranges changed: base, xml-types
Files
- LICENSE +25/−25
- Setup.lhs +7/−7
- Text/XML/Enumerator/Document.hs +223/−187
- Text/XML/Enumerator/Parse.hs +729/−735
- Text/XML/Enumerator/Render.hs +155/−155
- Text/XML/Enumerator/Token.hs +132/−126
- runtests.hs +69/−0
- xml-enumerator.cabal +47/−36
LICENSE view
@@ -1,25 +1,25 @@-The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright 2010, Suite Solutions. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* 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. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 COPYRIGHT HOLDERS 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. +The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Suite Solutions. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* 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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 COPYRIGHT HOLDERS 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.
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
Text/XML/Enumerator/Document.hs view
@@ -1,187 +1,223 @@-{-# LANGUAGE DeriveDataTypeable #-} -module Text.XML.Enumerator.Document - ( -- * Non-streaming functions - writeFile - , readFile - , readFile_ - -- * Lazy bytestrings - , renderDocument - -- * Streaming functions - , toEvents - , fromEvents - , renderBuilder - , renderBytes - , renderText - -- * Exceptions - , InvalidEventStream (InvalidEventStream) - ) where - -import Prelude hiding (writeFile, readFile) -import Data.XML.Types -import Data.Enumerator - ( ($$), enumList, joinE, Enumerator, Iteratee, peek - , throwError, joinI, run, run_ - ) -import Control.Exception (Exception, SomeException) -import Data.Typeable (Typeable) -import qualified Data.Enumerator.List as EL -import Blaze.ByteString.Builder (Builder) -import Control.Monad.IO.Class (MonadIO) -import qualified Text.XML.Enumerator.Render as R -import qualified Text.XML.Enumerator.Parse as P -import Data.ByteString (ByteString) -import Data.Text (Text) -import Control.Applicative ((<$>), (<*>)) -import qualified System.IO as SIO -import Data.Enumerator.Binary (enumFile, iterHandle) -import qualified Data.Text.Lazy as T -import Data.Char (isSpace) -import qualified Data.ByteString.Lazy as L -import System.IO.Unsafe (unsafePerformIO) -import qualified Control.Concurrent.MVar as M -import System.IO.Unsafe (unsafeInterleaveIO) -import Control.Monad.IO.Class (liftIO) -import Control.Concurrent (forkIO) - -readFile :: FilePath -> IO (Either SomeException Document) -readFile fn = run $ enumFile fn $$ joinI $ P.parseBytes $$ fromEvents - -readFile_ :: FilePath -> IO Document -readFile_ fn = run_ $ enumFile fn $$ joinI $ P.parseBytes $$ fromEvents - -writeFile :: FilePath -> Document -> IO () -writeFile fn doc = SIO.withBinaryFile fn SIO.WriteMode $ \h -> - run_ $ renderBytes doc $$ iterHandle h - -renderDocument :: Document -> L.ByteString -renderDocument doc = - L.fromChunks $ unsafePerformIO $ lazyConsume $ renderBytes doc - -lazyConsume :: Enumerator a IO () -> IO [a] -lazyConsume enum = do - toGrabber <- M.newEmptyMVar - toFiller <- M.newMVar True - _ <- forkIO $ run_ $ enum $$ filler toGrabber toFiller - grabber toGrabber toFiller - where - grabber toGrabber toFiller = do - x <- M.takeMVar toGrabber - case x of - Nothing -> return [] - Just x' -> do - M.putMVar toFiller True - xs <- unsafeInterleaveIO $ grabber toGrabber toFiller - return $ x' : xs - filler toGrabber toFiller = do - cont <- liftIO $ M.takeMVar toFiller - if cont - then do - x <- EL.head - liftIO $ M.putMVar toGrabber x - case x of - Nothing -> return () - Just _ -> filler toGrabber toFiller - else liftIO $ M.putMVar toGrabber Nothing - -data InvalidEventStream = InvalidEventStream String - deriving (Show, Typeable) -instance Exception InvalidEventStream - -renderBuilder :: MonadIO m => Document -> Enumerator Builder m a -renderBuilder doc = enumList 8 (toEvents doc) `joinE` R.renderBuilder - -renderBytes :: MonadIO m => Document -> Enumerator ByteString m a -renderBytes doc = enumList 8 (toEvents doc) `joinE` R.renderBytes - -renderText :: MonadIO m => Document -> Enumerator Text m a -renderText doc = enumList 8 (toEvents doc) `joinE` R.renderText - -fromEvents :: Monad m => Iteratee Event m Document -fromEvents = do - skip EventBeginDocument - d <- Document <$> goP <*> require goE <*> goM - skip EventEndDocument - y <- EL.head - if y == Nothing - then return d - else throwError $ InvalidEventStream $ "Trailing matter after epilogue: " ++ show y - where - skip e = do - x <- peek - if x == Just e then EL.drop 1 else return () - many f = - go id - where - go front = do - x <- f - case x of - Nothing -> return $ front [] - Just y -> go (front . (:) y) - dropReturn x = EL.drop 1 >> return x - require f = do - x <- f - case x of - Just y -> return y - Nothing -> do - y <- EL.head - throwError $ InvalidEventStream $ "Document must have a single root element, got: " ++ show y - goP = Prologue <$> goM <*> goD <*> goM - goM = many goM' - goM' = do - x <- peek - case x of - Just (EventInstruction i) -> dropReturn $ Just $ MiscInstruction i - Just (EventComment t) -> dropReturn $ Just $ MiscComment t - Just (EventContent (ContentText t)) - | T.all isSpace t -> EL.drop 1 >> goM' - _ -> return Nothing - goD = do - x <- peek - case x of - Just (EventDoctype d) -> EL.drop 1 >> return (Just d) - _ -> return Nothing - goE = do - x <- peek - case x of - Just (EventBeginElement n as) -> Just <$> goE' n as - _ -> return Nothing - goE' n as = do - EL.drop 1 - ns <- many goN - y <- EL.head - if y == Just (EventEndElement n) - then return $ Element n as ns - else throwError $ InvalidEventStream $ "Missing end element for " ++ show n ++ ", got: " ++ show y - goN = do - x <- peek - case x of - Just (EventBeginElement n as) -> (Just . NodeElement) <$> goE' n as - Just (EventInstruction i) -> dropReturn $ Just $ NodeInstruction i - Just (EventContent c) -> dropReturn $ Just $ NodeContent c - Just (EventComment t) -> dropReturn $ Just $ NodeComment t - _ -> return Nothing - -toEvents :: Document -> [Event] -toEvents (Document prol root epi) = - (EventBeginDocument :) - . goP prol . goE root . goM epi $ [EventEndDocument] - where - goP (Prologue before doctype after) = - goM before . maybe id goD doctype . goM after - goM [] = id - goM [x] = (goM' x :) - goM (x:xs) = (goM' x :) . goM xs - goM' (MiscInstruction i) = EventInstruction i - goM' (MiscComment t) = EventComment t - goD = (:) . EventDoctype - goE (Element name as ns) = - (EventBeginElement name as :) - . goN ns - . (EventEndElement name :) - goN [] = id - goN [x] = goN' x - goN (x:xs) = goN' x . goN xs - goN' (NodeElement e) = goE e - goN' (NodeInstruction i) = (EventInstruction i :) - goN' (NodeContent c) = (EventContent c :) - goN' (NodeComment t) = (EventComment t :) +{-# LANGUAGE DeriveDataTypeable #-}+module Text.XML.Enumerator.Document+ ( -- * Non-streaming functions+ writeFile+ , readFile+ , readFile_+ -- * Lazy bytestrings+ , renderLBS+ , parseLBS+ , parseLBS_+ -- * Streaming functions+ , toEvents+ , fromEvents+ , renderBuilder+ , renderBytes+ , renderText+ -- * Exceptions+ , InvalidEventStream (InvalidEventStream)+ ) where++import Prelude hiding (writeFile, readFile)+import Data.XML.Types+import Data.Enumerator+ ( ($$), enumList, joinE, Enumerator, Iteratee, peek, returnI+ , throwError, joinI, run, run_, Step (Continue), Stream (Chunks)+ )+import Control.Exception (Exception, SomeException)+import Data.Typeable (Typeable)+import qualified Data.Enumerator.List as EL+import Blaze.ByteString.Builder (Builder)+import Control.Monad.IO.Class (MonadIO)+import qualified Text.XML.Enumerator.Render as R+import qualified Text.XML.Enumerator.Parse as P+import Data.ByteString (ByteString)+import Data.Text (Text)+import Control.Applicative ((<$>), (<*>))+import qualified System.IO as SIO+import Data.Enumerator.Binary (enumFile, iterHandle)+import qualified Data.Text as T+import Data.Char (isSpace)+import qualified Data.ByteString.Lazy as L+import System.IO.Unsafe (unsafePerformIO)+import qualified Control.Concurrent.MVar as M+import System.IO.Unsafe (unsafeInterleaveIO)+import Control.Monad.IO.Class (liftIO)+import Control.Concurrent (forkIO)+import Data.Functor.Identity (runIdentity)++readFile :: FilePath -> P.DecodeEntities -> IO (Either SomeException Document)+readFile fn de = run $ enumFile fn $$ joinI $ P.parseBytes de $$ fromEvents++readFile_ :: FilePath -> P.DecodeEntities -> IO Document+readFile_ fn de = run_ $ enumFile fn $$ joinI $ P.parseBytes de $$ fromEvents++writeFile :: FilePath -> Document -> IO ()+writeFile fn doc = SIO.withBinaryFile fn SIO.WriteMode $ \h ->+ run_ $ renderBytes doc $$ iterHandle h++renderLBS :: Document -> L.ByteString+renderLBS doc =+ L.fromChunks $ unsafePerformIO $ lazyConsume $ renderBytes doc++parseLBS :: L.ByteString -> P.DecodeEntities -> Either SomeException Document+parseLBS lbs de = runIdentity+ $ run $ enumSingle (L.toChunks lbs)+ $$ joinI $ P.parseBytes de $$ fromEvents++parseLBS_ :: L.ByteString -> P.DecodeEntities -> Document+parseLBS_ lbs de = runIdentity+ $ run_ $ enumSingle (L.toChunks lbs)+ $$ joinI $ P.parseBytes de $$ fromEvents++enumSingle :: Monad m => [a] -> Enumerator a m b+enumSingle as (Continue k) = k $ Chunks as+enumSingle _ step = returnI step++lazyConsume :: Enumerator a IO () -> IO [a]+lazyConsume enum = do+ toGrabber <- M.newEmptyMVar+ toFiller <- M.newMVar True+ _ <- forkIO $ run_ $ enum $$ filler toGrabber toFiller+ grabber toGrabber toFiller+ where+ grabber toGrabber toFiller = do+ x <- M.takeMVar toGrabber+ case x of+ Nothing -> return []+ Just x' -> do+ M.putMVar toFiller True+ xs <- unsafeInterleaveIO $ grabber toGrabber toFiller+ return $ x' : xs+ filler toGrabber toFiller = do+ cont <- liftIO $ M.takeMVar toFiller+ if cont+ then do+ x <- EL.head+ liftIO $ M.putMVar toGrabber x+ case x of+ Nothing -> return ()+ Just _ -> filler toGrabber toFiller+ else liftIO $ M.putMVar toGrabber Nothing++data InvalidEventStream = InvalidEventStream String+ deriving (Show, Typeable)+instance Exception InvalidEventStream++renderBuilder :: MonadIO m => Document -> Enumerator Builder m a+renderBuilder doc = enumList 8 (toEvents doc) `joinE` R.renderBuilder++renderBytes :: MonadIO m => Document -> Enumerator ByteString m a+renderBytes doc = enumList 8 (toEvents doc) `joinE` R.renderBytes++renderText :: MonadIO m => Document -> Enumerator Text m a+renderText doc = enumList 8 (toEvents doc) `joinE` R.renderText++fromEvents :: Monad m => Iteratee Event m Document+fromEvents = do+ skip EventBeginDocument+ d <- Document <$> goP <*> require goE <*> goM+ skip EventEndDocument+ y <- EL.head+ if y == Nothing+ then return d+ else throwError $ InvalidEventStream $ "Trailing matter after epilogue: " ++ show y+ where+ skip e = do+ x <- peek+ if x == Just e then EL.drop 1 else return ()+ many f =+ go id+ where+ go front = do+ x <- f+ case x of+ Nothing -> return $ front []+ Just y -> go (front . (:) y)+ dropReturn x = EL.drop 1 >> return x+ require f = do+ x <- f+ case x of+ Just y -> return y+ Nothing -> do+ y <- EL.head+ throwError $ InvalidEventStream $ "Document must have a single root element, got: " ++ show y+ goP = Prologue <$> goM <*> goD <*> goM+ goM = many goM'+ goM' = do+ x <- peek+ case x of+ Just (EventInstruction i) -> dropReturn $ Just $ MiscInstruction i+ Just (EventComment t) -> dropReturn $ Just $ MiscComment t+ Just (EventContent (ContentText t))+ | T.all isSpace t -> EL.drop 1 >> goM'+ _ -> return Nothing+ goD = do+ x <- peek+ case x of+ Just (EventBeginDoctype name meid) -> do+ EL.drop 1+ dropTillDoctype+ return (Just $ Doctype name meid [])+ _ -> return Nothing+ dropTillDoctype = do+ x <- EL.head+ case x of+ Just (EventDeclaration _) -> dropTillDoctype+ Just EventEndDoctype -> return ()+ _ -> throwError $ InvalidEventStream $ "Invalid event during doctype, got: " ++ show x+ goE = do+ x <- peek+ case x of+ Just (EventBeginElement n as) -> Just <$> goE' n as+ _ -> return Nothing+ goE' n as = do+ EL.drop 1+ ns <- many goN+ y <- EL.head+ if y == Just (EventEndElement n)+ then return $ Element n as $ compressNodes ns+ else throwError $ InvalidEventStream $ "Missing end element for " ++ show n ++ ", got: " ++ show y+ goN = do+ x <- peek+ case x of+ Just (EventBeginElement n as) -> (Just . NodeElement) <$> goE' n as+ Just (EventInstruction i) -> dropReturn $ Just $ NodeInstruction i+ Just (EventContent c) -> dropReturn $ Just $ NodeContent c+ Just (EventComment t) -> dropReturn $ Just $ NodeComment t+ Just (EventCDATA t) -> dropReturn $ Just $ NodeContent $ ContentText t+ _ -> return Nothing++toEvents :: Document -> [Event]+toEvents (Document prol root epi) =+ (EventBeginDocument :)+ . goP prol . goE root . goM epi $ [EventEndDocument]+ where+ goP (Prologue before doctype after) =+ goM before . maybe id goD doctype . goM after+ goM [] = id+ goM [x] = (goM' x :)+ goM (x:xs) = (goM' x :) . goM xs+ goM' (MiscInstruction i) = EventInstruction i+ goM' (MiscComment t) = EventComment t+ goD (Doctype name meid _) =+ (:) (EventBeginDoctype name meid)+ . (:) EventEndDoctype+ goE (Element name as ns) =+ (EventBeginElement name as :)+ . goN ns+ . (EventEndElement name :)+ goN [] = id+ goN [x] = goN' x+ goN (x:xs) = goN' x . goN xs+ goN' (NodeElement e) = goE e+ goN' (NodeInstruction i) = (EventInstruction i :)+ goN' (NodeContent c) = (EventContent c :)+ goN' (NodeComment t) = (EventComment t :)++compressNodes :: [Node] -> [Node]+compressNodes [] = []+compressNodes [x] = [x]+compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) =+ compressNodes $ NodeContent (ContentText $ x `T.append` y) : z+compressNodes (x:xs) = x : compressNodes xs
Text/XML/Enumerator/Parse.hs view
@@ -1,735 +1,729 @@-{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} --- | This module provides both a native Haskell solution for parsing XML --- documents into a stream of events, and a set of parser combinators for --- dealing with a stream of events. --- --- The important thing to know about the combinators is that they do /not/ work --- on the fully-powered 'Event' datatype; rather, this module defines an --- 'SEvent' datatype which only deals with tags, attributes and content. For --- most uses, this is sufficient. If you need to parse doctypes, instructions --- or contents, you will not be able to use the combinators. --- --- As a simple example, if you have the following XML file: --- --- > <?xml version="1.0" encoding="utf-8"?> --- > <people> --- > <person age="25">Michael</person> --- > <person age="2">Eliezer</person> --- > </people> --- --- Then this code: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > import Text.XML.Enumerator.Parse --- > import Data.Text.Lazy (Text, unpack) --- > --- > data Person = Person { age :: Int, name :: Text } --- > deriving Show --- > --- > parsePerson = tag' "person" (requireAttr "age") $ \age -> do --- > name <- content' --- > return $ Person (read $ unpack age) name --- > --- > parsePeople = tag'' "people" $ many parsePerson --- > --- > main = parseFile_ "people.xml" (const Nothing) $ force "people required" parsePeople --- --- will produce: --- --- > [Person {age = 25, name = "Michael"},Person {age = 2, name = "Eliezer"}] -module Text.XML.Enumerator.Parse - ( -- * Parsing XML files - parseBytes - , parseText - , detectUtf - -- * Simplified events - , SEvent (..) - , simplify - , SAttr - , parseFile - , parseFile_ - -- * SEvent parsing - , tag - , tag' - , tagName - , tag'' - , tagNoAttr - , content - , content' - , ignoreElem - , ignoreSiblings - -- * Attribute parsing - , AttrParser - , requireAttr - , optionalAttr - , requireAttrRaw - , optionalAttrRaw - , ignoreAttrs - -- * Combinators - , choose - , many - , force - , skipTill - , skipSiblings - -- * Exceptions - , XmlException (..) - ) where -import Data.Attoparsec.Text - ( char, Parser, takeWhile1, skipWhile, string - , manyTill, takeWhile, try, anyChar, endOfInput, hexadecimal, decimal - ) -import qualified Data.Attoparsec.Text as A -import Data.Attoparsec.Text.Enumerator (iterParser) -import Data.XML.Types - ( Name (..), Event (..), Content (..), Attribute (..) - , Doctype (..), Instruction (..), ExternalID (..) - ) -import Control.Applicative ((<|>), (<$>)) -import Data.Text.Lazy (pack, Text) -import qualified Data.Text.Lazy as T -import Text.XML.Enumerator.Token -import Prelude hiding (takeWhile) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import qualified Data.Map as Map -import Data.Enumerator (Iteratee, Enumeratee, (>>==), Stream (..), - checkDone, yield, ($$), joinI, run, throwError) -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL -import qualified Data.Enumerator.Text as ET -import qualified Data.Enumerator.Binary as EB -import Control.Monad (unless, ap, liftM) -import qualified Data.Text as TS -import Data.List (foldl') -import Control.Applicative (Applicative (..)) -import Data.Typeable (Typeable) -import Control.Exception (Exception, throwIO, SomeException) -import Data.Enumerator.Binary (enumFile) -import Control.Monad.IO.Class (liftIO) -import Data.Char (isSpace) - -tokenToEvent :: [NSLevel] -> Token -> ([NSLevel], [Event]) -tokenToEvent n (TokenBeginDocument _) = (n, []) -tokenToEvent n (TokenInstruction i) = (n, [EventInstruction i]) -tokenToEvent n (TokenBeginElement name as isClosed) = - (n', if isClosed then [begin, end] else [begin]) - where - l0 = case n of - [] -> NSLevel Nothing Map.empty - x:_ -> x - (as', l') = foldl' go (id, l0) as - go (front, l) a@(TName kpref kname, val) - | kpref == Just "xmlns" = - (front, l { prefixes = Map.insert kname (contentsToText val) - $ prefixes l }) - | kpref == Nothing && kname == "xmlns" = - (front, l { defaultNS = if T.null $ contentsToText val - then Nothing - else Just $ contentsToText val }) - | otherwise = (front . (:) a, l) - n' = if isClosed then n else l' : n - contentsToText = T.concat . map helper - helper (ContentText t) = t - helper (ContentEntity _) = T.empty -- FIXME - fixAttName level (name', val) = Attribute (tnameToName True level name') val - begin = EventBeginElement (tnameToName False l' name) $ map (fixAttName l') $ as' [] - end = EventEndElement $ tnameToName False l' name -tokenToEvent n (TokenEndElement name) = - (n', [EventEndElement $ tnameToName False l name]) - where - (l, n') = - case n of - [] -> (NSLevel Nothing Map.empty, []) - x:xs -> (x, xs) -tokenToEvent n (TokenContent c) = (n, [EventContent c]) -tokenToEvent n (TokenComment c) = (n, [EventComment c]) -tokenToEvent n (TokenDoctype t eid) = (n, [EventDoctype $ Doctype t eid []]) - -tnameToName :: Bool -> NSLevel -> TName -> Name -tnameToName _ _ (TName (Just "xml") name) = - Name name (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") -tnameToName isAttr (NSLevel def _) (TName Nothing name) = - Name name (if isAttr then Nothing else def) Nothing -tnameToName _ (NSLevel _ m) (TName (Just pref) name) = - case Map.lookup pref m of - Just ns -> Name name (Just ns) (Just pref) - Nothing -> Name name Nothing (Just pref) -- FIXME is this correct? - --- | Automatically determine which UTF variant is being used. This function --- first checks for BOMs, removing them as necessary, and then check for the --- equivalent of <?xml for each of UTF-8, UTF-16LE/BE, and UTF-32LE/BE. It --- defaults to assuming UTF-8. -detectUtf :: Monad m => Enumeratee S.ByteString TS.Text m a -detectUtf step = do - x <- EB.take 4 - let (toDrop, codec) = - case L.unpack x of - [0x00, 0x00, 0xFE, 0xFF] -> (4, ET.utf32_be) - [0xFF, 0xFE, 0x00, 0x00] -> (4, ET.utf32_le) - 0xFE : 0xFF: _ -> (2, ET.utf16_be) - 0xFF : 0xFE: _ -> (2, ET.utf16_le) - 0xEF : 0xBB: 0xBF : _ -> (3, ET.utf8) - [0x00, 0x00, 0x00, 0x3C] -> (0, ET.utf32_be) - [0x3C, 0x00, 0x00, 0x00] -> (0, ET.utf32_le) - [0x00, 0x3C, 0x00, 0x3F] -> (0, ET.utf16_be) - [0x3C, 0x00, 0x3F, 0x00] -> (0, ET.utf16_le) - _ -> (0, ET.utf8) -- Assuming UTF-8 - unless (toDrop == 4) $ yield () $ Chunks $ L.toChunks $ L.drop toDrop x - ET.decode codec step - --- | Parses a byte stream into 'Event's. This function is implemented fully in --- Haskell using attoparsec-text for parsing. The produced error messages do --- not give line/column information, so you may prefer to stick with the parser --- provided by libxml-enumerator. However, this has the advantage of not --- relying on any C libraries. --- --- This relies on 'detectUtf' to determine character encoding, and 'parseText' --- to do the actual parsing. -parseBytes :: Monad m => Enumeratee S.ByteString Event m a -parseBytes step = joinI $ detectUtf $$ parseText step - --- | Parses a character stream into 'Event's. This function is implemented --- fully in Haskell using attoparsec-text for parsing. The produced error --- messages do not give line/column information, so you may prefer to stick --- with the parser provided by libxml-enumerator. However, this has the --- advantage of not relying on any C libraries. -parseText :: Monad m => Enumeratee TS.Text Event m a -parseText = - checkDone $ \k -> k (Chunks [EventBeginDocument]) >>== loop [] - where - loop levels = checkDone $ go levels - go levels k = do - mtoken <- iterToken - case mtoken of - Nothing -> k (Chunks [EventEndDocument]) >>== return - Just token -> - let (levels', events) = tokenToEvent levels token - in k (Chunks events) >>== loop levels' - -iterToken :: Monad m => Iteratee TS.Text m (Maybe Token) -iterToken = iterParser ((endOfInput >> return Nothing) <|> fmap Just parseToken) - -parseToken :: Parser Token -parseToken = do - (char '<' >> parseLt) <|> fmap TokenContent (parseContent False False) - where - parseLt = - (char '?' >> parseInstr) <|> - (char '!' >> (parseComment <|> parseCdata <|> parseDoctype)) <|> - (char '/' >> parseEnd) <|> - parseBegin - parseInstr = do - name <- parseIdent - if name == "xml" - then do - as <- A.many parseAttribute - skipSpace - char' '?' - char' '>' - newline <|> return () - return $ TokenBeginDocument as - else do - skipSpace - x <- T.pack <$> manyTill anyChar (try $ string "?>") - return $ TokenInstruction $ Instruction name x - parseComment = do - char' '-' - char' '-' - c <- T.pack <$> manyTill anyChar (string "-->") -- FIXME use takeWhile instead - return $ TokenComment c - parseCdata = do - _ <- string "[CDATA[" - t <- T.pack <$> manyTill anyChar (string "]]>") -- FIXME use takeWhile instead - return $ TokenContent $ ContentText t - parseDoctype = do - _ <- string "DOCTYPE" - skipSpace - i <- parseIdent - skipSpace - eid <- fmap Just parsePublicID <|> - fmap Just parseSystemID <|> - return Nothing - skipSpace - (do - char' '[' - skipWhile (/= ']') - char' ']' - skipSpace) <|> return () - char' '>' - newline <|> return () - return $ TokenDoctype i eid - parsePublicID = do - _ <- string "PUBLIC" - x <- quotedText - y <- quotedText - return $ PublicID x y - parseSystemID = do - _ <- string "SYSTEM" - x <- quotedText - return $ SystemID x - quotedText = do - skipSpace - T.fromChunks . return <$> (between '"' <|> between '\'') - between c = do - char' c - x <- takeWhile (/=c) - char' c - return x - parseEnd = do - skipSpace - n <- parseName - skipSpace - char' '>' - return $ TokenEndElement n - parseBegin = do - skipSpace - n <- parseName - as <- A.many parseAttribute - skipSpace - isClose <- (char '/' >> skipSpace >> return True) <|> return False - char' '>' - return $ TokenBeginElement n as isClose - -parseAttribute :: Parser TAttribute -parseAttribute = do - skipSpace - key <- parseName - skipSpace - char' '=' - skipSpace - val <- squoted <|> dquoted - return (key, val) - where - squoted = do - char' '\'' - manyTill (parseContent False True) (char '\'') - dquoted = do - char' '"' - manyTill (parseContent True False) (char '"') - -parseName :: Parser TName -parseName = do - i1 <- parseIdent - mi2 <- (char ':' >> fmap Just parseIdent) <|> return Nothing - return $ - case mi2 of - Nothing -> TName Nothing i1 - Just i2 -> TName (Just i1) i2 - -parseIdent :: Parser Text -parseIdent = - T.fromChunks . return <$> takeWhile1 valid - where - valid '&' = False - valid '<' = False - valid '>' = False - valid ':' = False - valid '?' = False - valid '=' = False - valid '"' = False - valid '\'' = False - valid '/' = False - valid c = not $ isSpace c - -parseContent :: Bool -- break on double quote - -> Bool -- break on single quote - -> Parser Content -parseContent breakDouble breakSingle = - parseEntity <|> parseText' - where - parseEntity = do - char' '&' - parseEntityNum <|> parseEntityWord - parseEntityNum = do - char' '#' - w <- parseEntityHex <|> parseEntityDig - return $ ContentText $ pack [toEnum w] - parseEntityHex = do - char' 'x' - res <- hexadecimal - char' ';' - return res - parseEntityDig = do - res <- decimal - char' ';' - return res - parseEntityWord = do - s <- takeWhile1 (/= ';') - char' ';' - return $ case s of - _ - | s == "amp" -> ContentText "&" - | s == "gt" -> ContentText ">" - | s == "lt" -> ContentText "<" - | s == "apos" -> ContentText "'" - | s == "quot" -> ContentText "\"" - | otherwise -> - ContentEntity $ T.fromChunks [s] - parseText' = do - bs <- takeWhile1 valid - return $ ContentText $ T.fromChunks [bs] - valid '"' = not breakDouble - valid '\'' = not breakSingle - valid '&' = False -- amp - valid '<' = False -- lt - valid _ = True - -skipSpace :: Parser () -skipSpace = skipWhile isSpace - -newline :: Parser () -newline = ((char '\r' >> char '\n') <|> char '\n') >> return () - -char' :: Char -> Parser () -char' c = char c >> return () - --- | A simplified attribute, having all entities converted to text. -type SAttr = (Name, Text) - --- | A greatly simplified XML event datatype. The best way to produce these --- values is the 'simplify' enumeratee. -data SEvent = SBeginElement Name [SAttr] - | SEndElement - | SContent Text - deriving (Show, Eq) - --- | Grabs the next piece of content if available. -content :: Monad m => Iteratee SEvent m (Maybe Text) -content = do - x <- E.peek - case x of - Just (SContent t) -> EL.drop 1 >> return (Just t) - _ -> return Nothing - --- | Grabs the next piece of content. If none if available, returns 'T.empty'. -content' :: Monad m => Iteratee SEvent m Text -content' = do - x <- content - case x of - Nothing -> return T.empty - Just y -> return y - --- | The most generic way to parse a tag. It takes a predicate for checking if --- this is the correct tag name, an 'AttrParser' for handling attributes, and --- then a parser for dealing with content. --- --- This function automatically absorbs its balancing closing tag, and will --- throw an exception if not all of the attributes or child elements are --- consumed. If you want to allow extra attributes, see 'ignoreAttrs'. -tag :: Monad m - => (Name -> Maybe a) - -> (a -> AttrParser b) - -> (b -> Iteratee SEvent m c) - -> Iteratee SEvent m (Maybe c) -tag checkName attrParser f = do - x <- dropWS - case x of - Just (SBeginElement name as) -> - case checkName name of - Just y -> - case runAttrParser' (attrParser y) as of - Left e -> throwError e - Right z -> do - EL.drop 1 - z' <- f z - a <- dropWS - case a of - Just SEndElement -> EL.drop 1 >> return (Just z') - _ -> throwError $ SXmlException ("Expected end tag for: " ++ show name) a - Nothing -> return Nothing - _ -> return Nothing - where - dropWS = do - x <- E.peek - case x of - Just (SContent t) - | T.all isSpace t -> EL.drop 1 >> E.peek - _ -> return x - runAttrParser' p as = - case runAttrParser p as of - Left e -> Left e - Right ([], x) -> Right x - Right (attr, _) -> Left $ UnparsedAttributes attr - --- | A simplified version of 'tag' which matches for specific tag names instead --- of taking a predicate function. This is often sufficient, and when combined --- with OverloadedStrings and the IsString instance of 'Name', can prove to be --- very concise. -tag', tagName :: Monad m - => Name - -> AttrParser a - -> (a -> Iteratee SEvent m b) - -> Iteratee SEvent m (Maybe b) -tag' name attrParser = tag - (\x -> if x == name then Just () else Nothing) - (const attrParser) -tagName = tag' - -{-# DEPRECATED tag' "Use tagName instead" #-} - --- | A further simplified tag parser, which requires that no attributes exist. -tag'', tagNoAttr :: Monad m => Name -> Iteratee SEvent m a -> Iteratee SEvent m (Maybe a) -tag'' name f = tag' name (return ()) $ const f -tagNoAttr = tag'' - -{-# DEPRECATED tag'' "Use tagNoAttr instead" #-} - --- | Get the value of the first parser which returns 'Just'. If none return --- 'Just', returns 'Nothing'. -choose :: Monad m - => [Iteratee SEvent m (Maybe a)] - -> Iteratee SEvent m (Maybe a) -choose [] = return Nothing -choose (i:is) = do - x <- i - case x of - Nothing -> choose is - Just a -> return $ Just a - --- | Force an optional parser into a required parser. All of the 'tag' --- functions, 'choose' and 'many' deal with 'Maybe' parsers. Use this when you --- want to finally force something to happen. -force :: Monad m - => String -- ^ Error message - -> Iteratee SEvent m (Maybe a) - -> Iteratee SEvent m a -force msg i = do - x <- i - case x of - Nothing -> throwError $ XmlException msg Nothing - Just a -> return a - --- | Convert a stream of 'Event's into a stream 'SEvent's. The first argument --- is a function to decode character entity references. Some things to note --- about this function: --- --- * It drops events for document begin/end, comments, and instructions. --- --- * It concatenates all pieces of content together. The output of this --- function is guaranteed to not have two consecutive 'SContent's. --- --- * It automatically checks that tag beginnings and endings are well balanced, --- and throws an exception otherwise. --- --- * It also throws an exception if your supplied entity function does not know --- how to deal with a character entity. --- --- Please also note that you do /not/ need to handle the 5 XML-defined --- character entity references (lt, gt, amp, quot and apos), nor deal with --- numeric entities (decimal and hex). -simplify :: Monad m => (Text -> Maybe Text) -> Enumeratee Event SEvent m b -simplify renderEntity = - loop [] - where - loop stack = E.checkDone $ go stack - sattr (Attribute x y) = do - y' <- flip mapM y $ \z -> - case z of - ContentText t -> return t - ContentEntity t -> - case renderEntity t of - Just t' -> return t' - Nothing -> throwError $ InvalidEntity t - return (x, T.concat y') - go stack k = do - x <- EL.head - case x of - Nothing -> k EOF >>== return - Just EventBeginDocument -> go stack k - Just EventEndDocument -> - k EOF >>== return - Just EventInstruction{} -> go stack k - Just EventDoctype{} -> go stack k - Just (EventBeginElement n as) -> do - as' <- mapM sattr as - k (Chunks [SBeginElement n as']) >>== loop (n : stack) - Just (EventEndElement n) -> - case stack of - [] -> throwError $ InvalidEndElement n - n':rest - | n == n' -> k (Chunks [SEndElement]) >>== loop rest - | otherwise -> throwError $ InvalidEndElement n - Just (EventContent c) -> do - t <- contentToText c - ts <- takeContents $ (:) t - k (Chunks [SContent $ T.concat $ ts []]) >>== loop stack - Just EventComment{} -> go stack k - where - contentToText (ContentEntity e) = - case renderEntity e of - Nothing -> throwError $ InvalidEntity e - Just t -> return t - contentToText (ContentText t) = return t - takeContents front = do - x <- E.peek - case x of - Nothing -> return front - Just EventBeginElement{} -> return front - Just EventEndElement{} -> return front - Just (EventContent c) -> do - EL.drop 1 - t <- contentToText c - takeContents $ front . (:) t - Just EventBeginDocument -> helper - Just EventEndDocument -> helper - Just EventInstruction{} -> helper - Just EventDoctype{} -> helper - Just EventComment{} -> helper - where - helper = EL.drop 1 >> takeContents front - --- | The same as 'parseFile', but throws any exceptions. -parseFile_ :: String -> (Text -> Maybe Text) -> Iteratee SEvent IO a -> IO a -parseFile_ fn re p = - parseFile fn re p >>= go - where - go (Left e) = liftIO $ throwIO e - go (Right a) = return a - --- | A helper function which reads a file from disk using 'enumFile', detects --- character encoding using 'detectUtf', parses the XML using 'parseBytes', --- converts to an 'SEvent' stream using 'simplify' and then handing off control --- to your supplied parser. -parseFile :: String -> (Text -> Maybe Text) -> Iteratee SEvent IO a -> IO (Either SomeException a) -parseFile fn re p = - run $ enumFile fn $$ joinI - $ parseBytes $$ joinI - $ simplify re $$ p - -data XmlException = XmlException - { xmlErrorMessage :: String - , xmlBadInput :: Maybe Event - } - | InvalidEndElement Name - | InvalidEntity Text - | SXmlException - { xmlErrorMessage :: String - , sxmlBadInput :: Maybe SEvent - } - | UnparsedAttributes [SAttr] - deriving (Show, Typeable) -instance Exception XmlException - --- | A monad for parsing attributes. By default, it requires you to deal with --- all attributes present on an element, and will throw an exception if there --- are unhandled attributes. Use the 'requireAttr', 'optionalAttr' et al --- functions for handling an attribute, and 'ignoreAttrs' if you would like to --- skip the rest of the attributes on an element. -newtype AttrParser a = AttrParser { runAttrParser :: [SAttr] -> Either XmlException ([SAttr], a) } - -instance Monad AttrParser where - return a = AttrParser $ \as -> Right (as, a) - (AttrParser f) >>= g = AttrParser $ \as -> - case f as of - Left e -> Left e - Right (as', f') -> runAttrParser (g f') as' -instance Functor AttrParser where - fmap = liftM -instance Applicative AttrParser where - pure = return - (<*>) = ap - -optionalAttrRaw :: (SAttr -> Maybe b) -> AttrParser (Maybe b) -optionalAttrRaw f = - AttrParser $ go id - where - go front [] = Right (front [], Nothing) - go front (a:as) = - case f a of - Nothing -> go (front . (:) a) as - Just b -> Right (front as, Just b) - -requireAttrRaw :: String -> (SAttr -> Maybe b) -> AttrParser b -requireAttrRaw msg f = do - x <- optionalAttrRaw f - case x of - Just b -> return b - Nothing -> AttrParser $ const $ Left $ XmlException msg Nothing - --- | Require that a certain attribute be present and return its value. -requireAttr :: Name -> AttrParser Text -requireAttr n = requireAttrRaw - ("Missing attribute: " ++ show n) - (\(x, y) -> if x == n then Just y else Nothing) - --- | Return the value for an attribute if present. -optionalAttr :: Name -> AttrParser (Maybe Text) -optionalAttr n = optionalAttrRaw - (\(x, y) -> if x == n then Just y else Nothing) - --- | Skip the remaining attributes on an element. Since this will clear the --- list of attributes, you must call this /after/ any calls to 'requireAttr', --- 'optionalAttr', etc. -ignoreAttrs :: AttrParser () -ignoreAttrs = AttrParser $ \_ -> Right ([], ()) - --- | Keep parsing elements as long as the parser returns 'Just'. -many :: Monad m => Iteratee SEvent m (Maybe a) -> Iteratee SEvent m [a] -many i = - go id - where - go front = do - x <- i - case x of - Nothing -> return $ front [] - Just y -> go $ front . (:) y - -{- --- There is some possible realisations using higher interface --- ignoreSiblings' is about 30 percent slowly than ignoreSiblings --- if ignoreSiblings' uses ignoreElem (instead of ignoreElem') it is about 5 percent slowly than ignoreSiblings - --- | Ignore content if exists -ignoreContent :: Monad m => Iteratee SEvent m (Maybe ()) -ignoreContent = fmap (fmap $ const ()) content --- | Iteratee to skip the next element. -ignoreElem' :: Monad m => Iteratee SEvent m (Maybe ()) -ignoreElem' = tag (const $ Just ()) (const ignoreAttrs) (const $ ignoreSiblings' >> return ()) - --- | Iteratee to skip the siblings element. -ignoreSiblings' :: Monad m => Iteratee SEvent m [()] -ignoreSiblings' = many (choose [ignoreElem', ignoreContent]) --} - --- | Iteratee to skip the siblings element. -ignoreSiblings :: Monad m => Iteratee SEvent m () -ignoreSiblings = E.continue (loop 0) - where - loop :: Monad m => Int -> Stream SEvent -> Iteratee SEvent m () - loop n (Chunks []) = E.continue (loop n) - loop n chs@(Chunks (x:_)) = case x of - (SBeginElement _ _) -> E.continue (loop (n+1)) - SEndElement - | n == 0 -> yield () chs - | otherwise -> E.continue (loop (n-1)) - _ -> E.continue (loop n) - loop _ EOF = throwError $ XmlException "Unbalanced xml-tree. (Error in skipSiblings)" Nothing - --- | Iteratee to skip the next element. -ignoreElem :: Monad m => Iteratee SEvent m (Maybe ()) -ignoreElem = E.continue (loop 0) - where - loop :: Monad m => Int -> Stream SEvent -> Iteratee SEvent m (Maybe ()) - loop n (Chunks []) = E.continue (loop n) - loop n chs@(Chunks (x:xs)) = case x of - (SBeginElement _ _) -> E.continue (loop (n+1)) - SEndElement - | n == 0 -> yield Nothing chs - | n == 1 -> yield (Just ()) (Chunks xs) - | otherwise -> E.continue (loop (n-1)) - _ -> E.continue (loop n) - loop _ EOF = throwError $ XmlException "Unbalanced xml-tree. (Error in skipSiblings)" Nothing - --- | Skip the siblings elements until iteratee not right. -skipTill :: Monad m => Iteratee SEvent m (Maybe a) -> Iteratee SEvent m (Maybe a) -skipTill i = go - where - go = i >>= \x -> case x of - Nothing -> ignoreElem >>= (\x -> if x == Nothing then return Nothing else go) - r -> return r - --- | Combinator to skip the siblings element. -skipSiblings :: Monad m => Iteratee SEvent m a -> Iteratee SEvent m a -skipSiblings i = i >>= \r -> ignoreSiblings >> return r - +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | This module provides both a native Haskell solution for parsing XML+-- documents into a stream of events, and a set of parser combinators for+-- dealing with a stream of events.+--+-- The important thing to know about the combinators is that they do /not/ work+-- on the fully-powered 'Event' datatype; rather, this module defines an+-- 'SEvent' datatype which only deals with tags, attributes and content. For+-- most uses, this is sufficient. If you need to parse doctypes, instructions+-- or contents, you will not be able to use the combinators.+--+-- As a simple example, if you have the following XML file:+--+-- > <?xml version="1.0" encoding="utf-8"?>+-- > <people>+-- > <person age="25">Michael</person>+-- > <person age="2">Eliezer</person>+-- > </people>+--+-- Then this code:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Text.XML.Enumerator.Parse+-- > import Data.Text.Lazy (Text, unpack)+-- > +-- > data Person = Person { age :: Int, name :: Text }+-- > deriving Show+-- > +-- > parsePerson = tag' "person" (requireAttr "age") $ \age -> do+-- > name <- content'+-- > return $ Person (read $ unpack age) name+-- > +-- > parsePeople = tag'' "people" $ many parsePerson+-- > +-- > main = parseFile_ "people.xml" (const Nothing) $ force "people required" parsePeople+--+-- will produce:+--+-- > [Person {age = 25, name = "Michael"},Person {age = 2, name = "Eliezer"}]+module Text.XML.Enumerator.Parse+ ( -- * Parsing XML files+ parseBytes+ , parseText+ , detectUtf+ , parseFile+ , parseFile_+ , parseLBS+ , parseLBS_+ -- ** Entity decoding+ , DecodeEntities+ , decodeEntities+ -- * Event parsing+ , tag+ , tagName+ , tagNoAttr+ , content+ , contentMaybe+ , ignoreElem+ , ignoreSiblings+ -- * Attribute parsing+ , AttrParser+ , requireAttr+ , optionalAttr+ , requireAttrRaw+ , optionalAttrRaw+ , ignoreAttrs+ , skipAttrs+ -- * Combinators+ , choose+ , many+ , force+ , skipTill+ , skipSiblings+ -- * Exceptions+ , XmlException (..)+ ) where+import Data.Attoparsec.Text+ ( char, Parser, takeWhile1, skipWhile, string+ , manyTill, takeWhile, try, anyChar, endOfInput+ )+import qualified Data.Attoparsec.Text as A+import Data.Attoparsec.Text.Enumerator (iterParser)+import Data.XML.Types+ ( Name (..), Event (..), Content (..)+ , Instruction (..), ExternalID (..)+ )+import Control.Applicative ((<|>), (<$>))+import Data.Text (Text)+import qualified Data.Text as T+import Text.XML.Enumerator.Token+import Prelude hiding (takeWhile)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Map as Map+import Data.Enumerator+ ( Iteratee, Enumeratee, (>>==), Stream (..), run_, Enumerator, Step (..)+ , checkDone, yield, ($$), joinI, run, throwError, returnI+ )+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import qualified Data.Enumerator.Text as ET+import qualified Data.Enumerator.Binary as EB+import Control.Monad (unless, ap, liftM)+import qualified Data.Text as TS+import Data.List (foldl')+import Control.Applicative (Applicative (..))+import Data.Typeable (Typeable)+import Control.Exception (Exception, throwIO, SomeException)+import Data.Enumerator.Binary (enumFile)+import Control.Monad.IO.Class (liftIO)+import Data.Char (isSpace)++tokenToEvent :: [NSLevel] -> Token -> ([NSLevel], [Event])+tokenToEvent n (TokenBeginDocument _) = (n, [])+tokenToEvent n (TokenInstruction i) = (n, [EventInstruction i])+tokenToEvent n (TokenBeginElement name as isClosed) =+ (n', if isClosed then [begin, end] else [begin])+ where+ l0 = case n of+ [] -> NSLevel Nothing Map.empty+ x:_ -> x+ (as', l') = foldl' go (id, l0) as+ go (front, l) a@(TName kpref kname, val)+ | kpref == Just "xmlns" =+ (front, l { prefixes = Map.insert kname (contentsToText val)+ $ prefixes l })+ | kpref == Nothing && kname == "xmlns" =+ (front, l { defaultNS = if T.null $ contentsToText val+ then Nothing+ else Just $ contentsToText val })+ | otherwise = (front . (:) a, l)+ n' = if isClosed then n else l' : n+ fixAttName level (name', val) = (tnameToName True level name', val)+ begin = EventBeginElement (tnameToName False l' name)+ $ Map.fromList+ $ map (fixAttName l')+ $ as' []+ end = EventEndElement $ tnameToName False l' name+tokenToEvent n (TokenEndElement name) =+ (n', [EventEndElement $ tnameToName False l name])+ where+ (l, n') =+ case n of+ [] -> (NSLevel Nothing Map.empty, [])+ x:xs -> (x, xs)+tokenToEvent n (TokenContent c) = (n, [EventContent c])+tokenToEvent n (TokenComment c) = (n, [EventComment c])+tokenToEvent n (TokenDoctype t eid) = (n, [EventBeginDoctype t eid, EventEndDoctype])+tokenToEvent n (TokenCDATA t) = (n, [EventCDATA t])++tnameToName :: Bool -> NSLevel -> TName -> Name+tnameToName _ _ (TName (Just "xml") name) =+ Name name (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")+tnameToName isAttr (NSLevel def _) (TName Nothing name) =+ Name name (if isAttr then Nothing else def) Nothing+tnameToName _ (NSLevel _ m) (TName (Just pref) name) =+ case Map.lookup pref m of+ Just ns -> Name name (Just ns) (Just pref)+ Nothing -> Name name Nothing (Just pref) -- FIXME is this correct?++-- | Automatically determine which UTF variant is being used. This function+-- first checks for BOMs, removing them as necessary, and then check for the+-- equivalent of <?xml for each of UTF-8, UTF-16LE/BE, and UTF-32LE/BE. It+-- defaults to assuming UTF-8.+detectUtf :: Monad m => Enumeratee S.ByteString TS.Text m a+detectUtf step = do+ x <- EB.take 4+ let (toDrop, codec) =+ case L.unpack x of+ [0x00, 0x00, 0xFE, 0xFF] -> (4, ET.utf32_be)+ [0xFF, 0xFE, 0x00, 0x00] -> (4, ET.utf32_le)+ 0xFE : 0xFF: _ -> (2, ET.utf16_be)+ 0xFF : 0xFE: _ -> (2, ET.utf16_le)+ 0xEF : 0xBB: 0xBF : _ -> (3, ET.utf8)+ [0x00, 0x00, 0x00, 0x3C] -> (0, ET.utf32_be)+ [0x3C, 0x00, 0x00, 0x00] -> (0, ET.utf32_le)+ [0x00, 0x3C, 0x00, 0x3F] -> (0, ET.utf16_be)+ [0x3C, 0x00, 0x3F, 0x00] -> (0, ET.utf16_le)+ _ -> (0, ET.utf8) -- Assuming UTF-8+ unless (toDrop == 4) $ yield () $ Chunks $ L.toChunks $ L.drop toDrop x+ ET.decode codec step++-- | Parses a byte stream into 'Event's. This function is implemented fully in+-- Haskell using attoparsec-text for parsing. The produced error messages do+-- not give line/column information, so you may prefer to stick with the parser+-- provided by libxml-enumerator. However, this has the advantage of not+-- relying on any C libraries.+--+-- This relies on 'detectUtf' to determine character encoding, and 'parseText'+-- to do the actual parsing.+parseBytes :: Monad m => DecodeEntities -> Enumeratee S.ByteString Event m a+parseBytes de step = joinI $ detectUtf $$ parseText de step++-- | Parses a character stream into 'Event's. This function is implemented+-- fully in Haskell using attoparsec-text for parsing. The produced error+-- messages do not give line/column information, so you may prefer to stick+-- with the parser provided by libxml-enumerator. However, this has the+-- advantage of not relying on any C libraries.+parseText :: Monad m => DecodeEntities -> Enumeratee TS.Text Event m a+parseText de =+ checkDone $ \k -> k (Chunks [EventBeginDocument]) >>== loop []+ where+ loop levels = checkDone $ go levels+ go levels k = do+ mtoken <- iterToken de+ case mtoken of+ Nothing -> k (Chunks [EventEndDocument]) >>== return+ Just token ->+ let (levels', events) = tokenToEvent levels token+ in k (Chunks events) >>== loop levels'++iterToken :: Monad m => DecodeEntities -> Iteratee TS.Text m (Maybe Token)+iterToken de = iterParser ((endOfInput >> return Nothing) <|> fmap Just (parseToken de))++parseToken :: DecodeEntities -> Parser Token+parseToken de = do+ (char '<' >> parseLt) <|> fmap TokenContent (parseContent de False False)+ where+ parseLt =+ (char '?' >> parseInstr) <|>+ (char '!' >> (parseComment <|> parseCdata <|> parseDoctype)) <|>+ (char '/' >> parseEnd) <|>+ parseBegin+ parseInstr = do+ name <- parseIdent+ if name == "xml"+ then do+ as <- A.many $ parseAttribute de+ skipSpace+ char' '?'+ char' '>'+ newline <|> return ()+ return $ TokenBeginDocument as+ else do+ skipSpace+ x <- T.pack <$> manyTill anyChar (try $ string "?>")+ return $ TokenInstruction $ Instruction name x+ parseComment = do+ char' '-'+ char' '-'+ c <- T.pack <$> manyTill anyChar (string "-->") -- FIXME use takeWhile instead+ return $ TokenComment c+ parseCdata = do+ _ <- string "[CDATA["+ t <- T.pack <$> manyTill anyChar (string "]]>") -- FIXME use takeWhile instead+ return $ TokenCDATA t+ parseDoctype = do+ _ <- string "DOCTYPE"+ skipSpace+ i <- parseIdent+ skipSpace+ eid <- fmap Just parsePublicID <|>+ fmap Just parseSystemID <|>+ return Nothing+ skipSpace+ (do+ char' '['+ skipWhile (/= ']')+ char' ']'+ skipSpace) <|> return ()+ char' '>'+ newline <|> return ()+ return $ TokenDoctype i eid+ parsePublicID = do+ _ <- string "PUBLIC"+ x <- quotedText+ y <- quotedText+ return $ PublicID x y+ parseSystemID = do+ _ <- string "SYSTEM"+ x <- quotedText+ return $ SystemID x+ quotedText = do+ skipSpace+ between '"' <|> between '\''+ between c = do+ char' c+ x <- takeWhile (/=c)+ char' c+ return x+ parseEnd = do+ skipSpace+ n <- parseName+ skipSpace+ char' '>'+ return $ TokenEndElement n+ parseBegin = do+ skipSpace+ n <- parseName+ as <- A.many $ parseAttribute de+ skipSpace+ isClose <- (char '/' >> skipSpace >> return True) <|> return False+ char' '>'+ return $ TokenBeginElement n as isClose++parseAttribute :: DecodeEntities -> Parser TAttribute+parseAttribute de = do+ skipSpace+ key <- parseName+ skipSpace+ char' '='+ skipSpace+ val <- squoted <|> dquoted+ return (key, val)+ where+ squoted = do+ char' '\''+ manyTill (parseContent de False True) (char '\'')+ dquoted = do+ char' '"'+ manyTill (parseContent de True False) (char '"')++parseName :: Parser TName+parseName = do+ i1 <- parseIdent+ mi2 <- (char ':' >> fmap Just parseIdent) <|> return Nothing+ return $+ case mi2 of+ Nothing -> TName Nothing i1+ Just i2 -> TName (Just i1) i2++parseIdent :: Parser Text+parseIdent =+ takeWhile1 valid+ where+ valid '&' = False+ valid '<' = False+ valid '>' = False+ valid ':' = False+ valid '?' = False+ valid '=' = False+ valid '"' = False+ valid '\'' = False+ valid '/' = False+ valid c = not $ isSpace c++parseContent :: DecodeEntities+ -> Bool -- break on double quote+ -> Bool -- break on single quote+ -> Parser Content+parseContent de breakDouble breakSingle =+ parseEntity <|> parseText'+ where+ parseEntity = do+ char' '&'+ t <- takeWhile1 (/= ';')+ char' ';'+ return $ de t+ parseText' = do+ bs <- takeWhile1 valid+ return $ ContentText bs+ valid '"' = not breakDouble+ valid '\'' = not breakSingle+ valid '&' = False -- amp+ valid '<' = False -- lt+ valid _ = True++skipSpace :: Parser ()+skipSpace = skipWhile isSpace++newline :: Parser ()+newline = ((char '\r' >> char '\n') <|> char '\n') >> return ()++char' :: Char -> Parser ()+char' c = char c >> return ()++data ContentType =+ Ignore | IsContent Text | IsError String | NotContent++-- | Grabs the next piece of content if available.+contentMaybe :: Monad m => Iteratee Event m (Maybe Text)+contentMaybe = do+ x <- E.peek+ case pc' x of+ Ignore -> EL.drop 1 >> contentMaybe+ IsContent t -> EL.drop 1 >> fmap Just (takeContents (t:))+ IsError e -> throwError $ XmlException e x+ NotContent -> return Nothing+ where+ pc' Nothing = NotContent+ pc' (Just x) = pc x+ pc (EventContent (ContentText t)) = IsContent t+ pc (EventContent (ContentEntity e)) = IsError $ "Unknown entity: " ++ show e+ pc (EventCDATA t) = IsContent t+ pc EventBeginElement{} = NotContent+ pc EventEndElement{} = NotContent+ pc EventBeginDocument{} = Ignore+ pc EventEndDocument = Ignore+ pc EventBeginDoctype{} = Ignore+ pc EventDeclaration{} = Ignore+ pc EventEndDoctype = Ignore+ pc EventInstruction{} = Ignore+ pc EventComment{} = Ignore+ takeContents front = do+ x <- E.peek+ case pc' x of+ Ignore -> EL.drop 1 >> takeContents front+ IsContent t -> EL.drop 1 >> takeContents (front . (:) t)+ IsError e -> throwError $ XmlException e x+ NotContent -> return $ T.concat $ front []++-- | Grabs the next piece of content. If none if available, returns 'T.empty'.+content :: Monad m => Iteratee Event m Text+content = do+ x <- contentMaybe+ case x of+ Nothing -> return T.empty+ Just y -> return y++-- | The most generic way to parse a tag. It takes a predicate for checking if+-- this is the correct tag name, an 'AttrParser' for handling attributes, and+-- then a parser for dealing with content.+--+-- This function automatically absorbs its balancing closing tag, and will+-- throw an exception if not all of the attributes or child elements are+-- consumed. If you want to allow extra attributes, see 'ignoreAttrs'.+tag :: Monad m+ => (Name -> Maybe a)+ -> (a -> AttrParser b)+ -> (b -> Iteratee Event m c)+ -> Iteratee Event m (Maybe c)+tag checkName attrParser f = do+ x <- dropWS+ case x of+ Just (EventBeginElement name as) ->+ case checkName name of+ Just y ->+ case runAttrParser' (attrParser y) $ Map.toList as of+ Left e -> throwError e+ Right z -> do+ EL.drop 1+ z' <- f z+ a <- dropWS+ case a of+ Just (EventEndElement name')+ | name == name' -> EL.drop 1 >> return (Just z')+ _ -> throwError $ XmlException ("Expected end tag for: " ++ show name) a+ Nothing -> return Nothing+ _ -> return Nothing+ where+ dropWS = do+ x <- E.peek+ let isWS =+ case x of+ Just EventBeginDocument -> True+ Just EventEndDocument -> True+ Just EventBeginDoctype{} -> True+ Just EventDeclaration{} -> True+ Just EventEndDoctype -> True+ Just EventInstruction{} -> True+ Just EventBeginElement{} -> False+ Just EventEndElement{} -> False+ Just (EventContent (ContentText t))+ | T.all isSpace t -> True+ | otherwise -> False+ Just (EventContent ContentEntity{}) -> False+ Just EventComment{} -> True+ Just EventCDATA{} -> False+ Nothing -> False+ if isWS then EL.drop 1 >> dropWS else return x+ runAttrParser' p as =+ case runAttrParser p as of+ Left e -> Left e+ Right ([], x) -> Right x+ Right (attr, _) -> Left $ UnparsedAttributes attr++-- | A simplified version of 'tag' which matches for specific tag names instead+-- of taking a predicate function. This is often sufficient, and when combined+-- with OverloadedStrings and the IsString instance of 'Name', can prove to be+-- very concise.+tagName :: Monad m+ => Name+ -> AttrParser a+ -> (a -> Iteratee Event m b)+ -> Iteratee Event m (Maybe b)+tagName name attrParser = tag+ (\x -> if x == name then Just () else Nothing)+ (const attrParser)++-- | A further simplified tag parser, which requires that no attributes exist.+tagNoAttr :: Monad m => Name -> Iteratee Event m a -> Iteratee Event m (Maybe a)+tagNoAttr name f = tagName name (return ()) $ const f++-- | Get the value of the first parser which returns 'Just'. If none return+-- 'Just', returns 'Nothing'.+choose :: Monad m+ => [Iteratee Event m (Maybe a)]+ -> Iteratee Event m (Maybe a)+choose [] = return Nothing+choose (i:is) = do+ x <- i+ case x of+ Nothing -> choose is+ Just a -> return $ Just a++-- | Force an optional parser into a required parser. All of the 'tag'+-- functions, 'choose' and 'many' deal with 'Maybe' parsers. Use this when you+-- want to finally force something to happen.+force :: Monad m+ => String -- ^ Error message+ -> Iteratee Event m (Maybe a)+ -> Iteratee Event m a+force msg i = do+ x <- i+ case x of+ Nothing -> throwError $ XmlException msg Nothing+ Just a -> return a++-- | The same as 'parseFile', but throws any exceptions.+parseFile_ :: FilePath -> DecodeEntities -> Iteratee Event IO a -> IO a+parseFile_ fn de p =+ parseFile fn de p >>= go+ where+ go (Left e) = liftIO $ throwIO e+ go (Right a) = return a++-- | A helper function which reads a file from disk using 'enumFile', detects+-- character encoding using 'detectUtf', parses the XML using 'parseBytes',+-- converts to an 'SEvent' stream using 'simplify' and then handing off control+-- to your supplied parser.+parseFile :: FilePath+ -> DecodeEntities+ -> Iteratee Event IO a+ -> IO (Either SomeException a)+parseFile fn de p =+ run $ enumFile fn $$ joinI+ $ parseBytes de $$ p++parseLBS :: L.ByteString -> DecodeEntities -> Iteratee Event IO a -> IO (Either SomeException a)+parseLBS lbs de p =+ run $ enumSingle (L.toChunks lbs) $$ joinI+ $ parseBytes de $$ p++parseLBS_ :: L.ByteString -> DecodeEntities -> Iteratee Event IO a -> IO a+parseLBS_ lbs de p =+ run_ $ enumSingle (L.toChunks lbs) $$ joinI+ $ parseBytes de $$ p++enumSingle :: Monad m => [a] -> Enumerator a m b+enumSingle as (Continue k) = k $ Chunks as+enumSingle _ step = returnI step++data XmlException = XmlException+ { xmlErrorMessage :: String+ , xmlBadInput :: Maybe Event+ }+ | InvalidEndElement Name+ | InvalidEntity Text+ | UnparsedAttributes [(Name, [Content])]+ deriving (Show, Typeable)+instance Exception XmlException++-- | A monad for parsing attributes. By default, it requires you to deal with+-- all attributes present on an element, and will throw an exception if there+-- are unhandled attributes. Use the 'requireAttr', 'optionalAttr' et al+-- functions for handling an attribute, and 'ignoreAttrs' if you would like to+-- skip the rest of the attributes on an element.+newtype AttrParser a = AttrParser { runAttrParser :: [(Name, [Content])] -> Either XmlException ([(Name, [Content])], a) }++instance Monad AttrParser where+ return a = AttrParser $ \as -> Right (as, a)+ (AttrParser f) >>= g = AttrParser $ \as ->+ case f as of+ Left e -> Left e+ Right (as', f') -> runAttrParser (g f') as'+instance Functor AttrParser where+ fmap = liftM+instance Applicative AttrParser where+ pure = return+ (<*>) = ap++optionalAttrRaw :: ((Name, [Content]) -> Maybe b) -> AttrParser (Maybe b)+optionalAttrRaw f =+ AttrParser $ go id+ where+ go front [] = Right (front [], Nothing)+ go front (a:as) =+ case f a of+ Nothing -> go (front . (:) a) as+ Just b -> Right (front as, Just b)++requireAttrRaw :: String -> ((Name, [Content]) -> Maybe b) -> AttrParser b+requireAttrRaw msg f = do+ x <- optionalAttrRaw f+ case x of+ Just b -> return b+ Nothing -> AttrParser $ const $ Left $ XmlException msg Nothing++-- | Require that a certain attribute be present and return its value.+requireAttr :: Name -> AttrParser Text+requireAttr n = requireAttrRaw+ ("Missing attribute: " ++ show n)+ (\(x, y) -> if x == n then Just (contentsToText y) else Nothing)++-- | Return the value for an attribute if present.+optionalAttr :: Name -> AttrParser (Maybe Text)+optionalAttr n = optionalAttrRaw+ (\(x, y) -> if x == n then Just (contentsToText y) else Nothing)++contentsToText :: [Content] -> Text+contentsToText =+ T.concat . map toText+ where+ toText (ContentText t) = t+ toText (ContentEntity e) = T.concat ["&", e, ";"]++-- | Skip the remaining attributes on an element. Since this will clear the+-- list of attributes, you must call this /after/ any calls to 'requireAttr',+-- 'optionalAttr', etc.+ignoreAttrs :: AttrParser ()+ignoreAttrs = AttrParser $ \_ -> Right ([], ())++-- | Keep parsing elements as long as the parser returns 'Just'.+many :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m [a]+many i =+ go id+ where+ go front = do+ x <- i+ case x of+ Nothing -> return $ front []+ Just y -> go $ front . (:) y++{-+-- There is some possible realisations using higher interface+-- ignoreSiblings' is about 30 percent slowly than ignoreSiblings+-- if ignoreSiblings' uses ignoreElem (instead of ignoreElem') it is about 5 percent slowly than ignoreSiblings ++-- | Ignore content if exists+ignoreContent :: Monad m => Iteratee SEvent m (Maybe ())+ignoreContent = fmap (fmap $ const ()) content+-- | Iteratee to skip the next element. +ignoreElem' :: Monad m => Iteratee Event m (Maybe ())+ignoreElem' = tag (const $ Just ()) (const ignoreAttrs) (const $ ignoreSiblings' >> return ())++-- | Iteratee to skip the siblings element. +ignoreSiblings' :: Monad m => Iteratee Event m [()]+ignoreSiblings' = many (choose [ignoreElem', ignoreContent])+-}++-- | Iteratee to skip the siblings element. +ignoreSiblings :: Monad m => Iteratee Event m ()+ignoreSiblings = E.continue (loop 0) + where+ loop :: Monad m => Int -> Stream Event -> Iteratee Event m ()+ loop n (Chunks []) = E.continue (loop n)+ loop n chs@(Chunks (x:_)) = case x of+ (EventBeginElement _ _) -> E.continue (loop (n+1))+ (EventEndElement _)+ | n == 0 -> yield () chs + | otherwise -> E.continue (loop (n-1))+ _ -> E.continue (loop n)+ loop _ EOF = throwError $ XmlException "Unbalanced xml-tree. (Error in skipSiblings)" Nothing++-- | Iteratee to skip the next element. +ignoreElem :: Monad m => Iteratee Event m (Maybe ())+ignoreElem = E.continue (loop 0) + where+ loop :: Monad m => Int -> Stream Event -> Iteratee Event m (Maybe ())+ loop n (Chunks []) = E.continue (loop n)+ loop n chs@(Chunks (x:xs)) = case x of+ (EventBeginElement _ _) -> E.continue (loop (n+1))+ (EventEndElement _)+ | n == 0 -> yield Nothing chs + | n == 1 -> yield (Just ()) (Chunks xs) + | otherwise -> E.continue (loop (n-1))+ _ -> E.continue (loop n)+ loop _ EOF = throwError $ XmlException "Unbalanced xml-tree. (Error in skipSiblings)" Nothing+ +-- | Skip the siblings elements until iteratee not right. +skipTill :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a)+skipTill i = go+ where+ go = i >>= \x -> case x of+ Nothing -> ignoreElem >>= (\y -> if y == Nothing then return Nothing else go)+ r -> return r++-- | Combinator to skip the siblings element. +skipSiblings :: Monad m => Iteratee Event m a -> Iteratee Event m a+skipSiblings i = i >>= \r -> ignoreSiblings >> return r++-- | Combinator to skip the attributes.+skipAttrs :: AttrParser a -> AttrParser a+skipAttrs i = i >>= \r -> ignoreAttrs >> return r++type DecodeEntities = Text -> Content++-- | Default implementation of 'DecodeEntities': handles numeric entities and+-- the five standard character entities (lt, gt, amp, quot, apos).+decodeEntities :: DecodeEntities+decodeEntities "lt" = ContentText "<"+decodeEntities "gt" = ContentText ">"+decodeEntities "amp" = ContentText "&"+decodeEntities "quot" = ContentText "\""+decodeEntities "apos" = ContentText "'"+decodeEntities t =+ case T.uncons t of+ Just ('#', t') ->+ case T.uncons t' of+ Just ('x', t'') -> decodeHex (ContentEntity t) t''+ _ -> decodeDec (ContentEntity t) t'+ _ -> ContentEntity t++decodeHex :: Content -> Text -> Content+decodeHex backup val+ | T.null val = backup+decodeHex backup val =+ go (T.unpack val) 0+ where+ go [] i = ContentText $ T.singleton $ toEnum i+ go (c:cs) i = maybe backup (go cs . ((i * 16) +)) $ getHex c+ getHex c+ | '0' <= c && c <= '9' = Just $ fromEnum c - fromEnum '0'+ | 'A' <= c && c <= 'F' = Just $ fromEnum c - fromEnum 'A' + 10+ | 'a' <= c && c <= 'f' = Just $ fromEnum c - fromEnum 'a' + 10+ | otherwise = Nothing++decodeDec :: Content -> Text -> Content+decodeDec backup val+ | T.null val = backup+decodeDec backup val =+ go (T.unpack val) 0+ where+ go [] i = ContentText $ T.singleton $ toEnum i+ go (c:cs) i = maybe backup (go cs . ((i * 10) +)) $ getHex c+ getHex c+ | '0' <= c && c <= '9' = Just $ fromEnum c - fromEnum '0'+ | otherwise = Nothing
Text/XML/Enumerator/Render.hs view
@@ -1,155 +1,155 @@-{-# LANGUAGE OverloadedStrings #-} --- | 'Enumeratee's to render XML 'Event's. Unlike libxml-enumerator and --- expat-enumerator, this module does not provide IO and ST variants, since the --- underlying rendering operations are pure functions. -module Text.XML.Enumerator.Render - ( renderBuilder - , renderBytes - , renderText - ) where - -import Data.XML.Types ( Event (..), Content (..), Name (..), Attribute (..) - , Doctype (..)) -import Text.XML.Enumerator.Token -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL -import qualified Data.Enumerator.Text as ET -import Data.Enumerator ((>>==), ($$)) -import qualified Data.Text as TS -import qualified Data.Text.Lazy as T -import Data.Text.Lazy (Text) -import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Enumerator (builderToByteString) -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Maybe (fromMaybe) -import Data.ByteString (ByteString) -import Control.Monad.IO.Class (MonadIO) - --- | Render a stream of 'Event's into a stream of 'ByteString's. This function --- wraps around 'renderBuilder' and 'builderToByteString', so it produces --- optimally sized 'ByteString's with minimal buffer copying. --- --- The output is UTF8 encoded. -renderBytes :: MonadIO m => E.Enumeratee Event ByteString m b -renderBytes s = E.joinI $ renderBuilder $$ builderToByteString s - --- | Render a stream of 'Event's into a stream of 'ByteString's. This function --- wraps around 'renderBuilder', 'builderToByteString' and 'renderBytes', so it --- produces optimally sized 'ByteString's with minimal buffer copying. -renderText :: MonadIO m => E.Enumeratee Event TS.Text m b -renderText s = E.joinI $ renderBytes $$ ET.decode ET.utf8 s - --- | Render a stream of 'Event's into a stream of 'Builder's. Builders are from --- the blaze-builder package, and allow the create of optimally sized --- 'ByteString's with minimal buffer copying. -renderBuilder :: Monad m => E.Enumeratee Event Builder m b -renderBuilder = - loop [] - where - loop stack = E.checkDone $ step stack - step stack k = do - x <- EL.head - case x of - Nothing -> E.yield (E.Continue k) E.EOF - Just (EventBeginElement name as) -> do - x' <- E.peek - if x' == Just (EventEndElement name) - then do - EL.drop 1 - go $ mkBeginToken True stack name as - else go $ mkBeginToken False stack name as - Just e -> go $ eventToToken stack e - where - go (ts, stack') = k (E.Chunks $ map tokenToBuilder $ ts []) >>== loop stack' - -eventToToken :: Stack -> Event -> ([Token] -> [Token], [NSLevel]) -eventToToken s EventBeginDocument = - ((:) (TokenBeginDocument - [ ("version", [ContentText "1.0"]) - , ("encoding", [ContentText "UTF-8"]) - ]) - , s) -eventToToken s EventEndDocument = (id, s) -eventToToken s (EventInstruction i) = ((:) (TokenInstruction i), s) -eventToToken s (EventDoctype (Doctype n meid _)) = - ((:) (TokenDoctype n meid), s) -eventToToken s (EventBeginElement name attrs) = mkBeginToken False s name attrs -eventToToken s (EventEndElement name) = - ((:) (TokenEndElement $ nameToTName sl name), s') - where - (sl:s') = s -eventToToken s (EventContent c) = ((:) (TokenContent c), s) -eventToToken s (EventComment t) = ((:) (TokenComment t), s) - -type Stack = [NSLevel] - -nameToTName :: NSLevel -> Name -> TName -nameToTName _ (Name name _ (Just pref)) - | pref == "xml" = TName (Just "xml") name -nameToTName _ (Name name Nothing _) = TName Nothing name -- invariant that this is true -nameToTName (NSLevel def sl) (Name name (Just ns) _) - | def == Just ns = TName Nothing name - | otherwise = - case Map.lookup ns sl of - Nothing -> error "nameToTName" - Just pref -> TName (Just pref) name - -mkBeginToken :: Bool -> Stack -> Name -> [Attribute] - -> ([Token] -> [Token], Stack) -mkBeginToken isClosed s name attrs = - ((:) (TokenBeginElement tname tattrs2 isClosed), - if isClosed then s else sl2 : s) - where - prevsl = case s of - [] -> NSLevel Nothing Map.empty - sl':_ -> sl' - (sl1, tname, tattrs1) = newElemStack prevsl name - (sl2, tattrs2) = foldr newAttrStack (sl1, tattrs1) attrs - -newElemStack :: NSLevel -> Name -> (NSLevel, TName, [TAttribute]) -newElemStack nsl@(NSLevel def _) (Name local ns _) - | def == ns = (nsl, TName Nothing local, []) -newElemStack (NSLevel _ nsmap) (Name local Nothing _) = - (NSLevel Nothing nsmap, TName Nothing local, [(TName Nothing "xmlns", [])]) -newElemStack (NSLevel _ nsmap) (Name local (Just ns) Nothing) = - (NSLevel (Just ns) nsmap, TName Nothing local, [(TName Nothing "xmlns", [ContentText ns])]) -newElemStack (NSLevel def nsmap) (Name local (Just ns) (Just pref)) = - case Map.lookup ns nsmap of - Just pref' - | pref == pref' -> - ( NSLevel def nsmap - , TName (Just pref) local - , [] - ) - _ -> ( NSLevel def nsmap' - , TName (Just pref) local - , [(TName (Just "xmlns") pref, [ContentText ns])] - ) - where - nsmap' = Map.insert ns pref nsmap - -newAttrStack :: Attribute -> (NSLevel, [TAttribute]) -> (NSLevel, [TAttribute]) -newAttrStack (Attribute name value) (NSLevel def nsmap, attrs) = - (NSLevel def nsmap', addNS $ (tname, value) : attrs) - where - (nsmap', tname, addNS) = - case name of - Name local Nothing _ -> (nsmap, TName Nothing local, id) - Name local (Just ns) mpref -> - let ppref = fromMaybe "ns" mpref - (pref, addNS') = getPrefix ppref nsmap ns - in (Map.insert ns pref nsmap, TName (Just pref) local, addNS') - -getPrefix :: Text -> Map Text Text -> Text -> (Text, [TAttribute] -> [TAttribute]) -getPrefix _ _ "http://www.w3.org/XML/1998/namespace" = ("xml", id) -getPrefix ppref nsmap ns = - case Map.lookup ns nsmap of - Just pref -> (pref, id) - Nothing -> - let pref = findUnused ppref $ Map.elems nsmap - in (pref, (:) (TName (Just "xmlns") pref, [ContentText ns])) - where - findUnused x xs - | x `elem` xs = findUnused (x `T.snoc` '_') xs - | otherwise = x +{-# LANGUAGE OverloadedStrings #-}+-- | 'Enumeratee's to render XML 'Event's. Unlike libxml-enumerator and+-- expat-enumerator, this module does not provide IO and ST variants, since the+-- underlying rendering operations are pure functions.+module Text.XML.Enumerator.Render+ ( renderBuilder+ , renderBytes+ , renderText+ ) where++import Data.XML.Types (Event (..), Content (..), Name (..))+import Text.XML.Enumerator.Token+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import qualified Data.Enumerator.Text as ET+import Data.Enumerator ((>>==), ($$))+import qualified Data.Text as T+import Data.Text (Text)+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Enumerator (builderToByteString)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.ByteString (ByteString)+import Control.Monad.IO.Class (MonadIO)++-- | Render a stream of 'Event's into a stream of 'ByteString's. This function+-- wraps around 'renderBuilder' and 'builderToByteString', so it produces+-- optimally sized 'ByteString's with minimal buffer copying.+--+-- The output is UTF8 encoded.+renderBytes :: MonadIO m => E.Enumeratee Event ByteString m b+renderBytes s = E.joinI $ renderBuilder $$ builderToByteString s++-- | Render a stream of 'Event's into a stream of 'ByteString's. This function+-- wraps around 'renderBuilder', 'builderToByteString' and 'renderBytes', so it+-- produces optimally sized 'ByteString's with minimal buffer copying.+renderText :: MonadIO m => E.Enumeratee Event Text m b+renderText s = E.joinI $ renderBytes $$ ET.decode ET.utf8 s++-- | Render a stream of 'Event's into a stream of 'Builder's. Builders are from+-- the blaze-builder package, and allow the create of optimally sized+-- 'ByteString's with minimal buffer copying.+renderBuilder :: Monad m => E.Enumeratee Event Builder m b+renderBuilder =+ loop []+ where+ loop stack = E.checkDone $ step stack+ step stack k = do+ x <- EL.head+ case x of+ Nothing -> E.yield (E.Continue k) E.EOF+ Just (EventBeginElement name as) -> do+ x' <- E.peek+ if x' == Just (EventEndElement name)+ then do+ EL.drop 1+ go $ mkBeginToken True stack name as+ else go $ mkBeginToken False stack name as+ Just e -> go $ eventToToken stack e+ where+ go (ts, stack') = k (E.Chunks $ map tokenToBuilder $ ts []) >>== loop stack'++eventToToken :: Stack -> Event -> ([Token] -> [Token], [NSLevel])+eventToToken s EventBeginDocument =+ ((:) (TokenBeginDocument+ [ ("version", [ContentText "1.0"])+ , ("encoding", [ContentText "UTF-8"])+ ])+ , s)+eventToToken s EventEndDocument = (id, s)+eventToToken s (EventInstruction i) = ((:) (TokenInstruction i), s)+eventToToken s (EventBeginDoctype n meid) = ((:) (TokenDoctype n meid), s)+eventToToken s EventEndDoctype = (id, s)+eventToToken s (EventDeclaration _) = (id, s)+eventToToken s (EventCDATA t) = ((:) (TokenCDATA t), s)+eventToToken s (EventBeginElement name attrs) = mkBeginToken False s name attrs+eventToToken s (EventEndElement name) =+ ((:) (TokenEndElement $ nameToTName sl name), s')+ where+ (sl:s') = s+eventToToken s (EventContent c) = ((:) (TokenContent c), s)+eventToToken s (EventComment t) = ((:) (TokenComment t), s)++type Stack = [NSLevel]++nameToTName :: NSLevel -> Name -> TName+nameToTName _ (Name name _ (Just pref))+ | pref == "xml" = TName (Just "xml") name+nameToTName _ (Name name Nothing _) = TName Nothing name -- invariant that this is true+nameToTName (NSLevel def sl) (Name name (Just ns) _)+ | def == Just ns = TName Nothing name+ | otherwise =+ case Map.lookup ns sl of+ Nothing -> error "nameToTName"+ Just pref -> TName (Just pref) name++mkBeginToken :: Bool -> Stack -> Name -> Map Name [Content]+ -> ([Token] -> [Token], Stack)+mkBeginToken isClosed s name attrs =+ ((:) (TokenBeginElement tname tattrs2 isClosed),+ if isClosed then s else sl2 : s)+ where+ prevsl = case s of+ [] -> NSLevel Nothing Map.empty+ sl':_ -> sl'+ (sl1, tname, tattrs1) = newElemStack prevsl name+ (sl2, tattrs2) = foldr newAttrStack (sl1, tattrs1) $ Map.toList attrs++newElemStack :: NSLevel -> Name -> (NSLevel, TName, [TAttribute])+newElemStack nsl@(NSLevel def _) (Name local ns _)+ | def == ns = (nsl, TName Nothing local, [])+newElemStack (NSLevel _ nsmap) (Name local Nothing _) =+ (NSLevel Nothing nsmap, TName Nothing local, [(TName Nothing "xmlns", [])])+newElemStack (NSLevel _ nsmap) (Name local (Just ns) Nothing) =+ (NSLevel (Just ns) nsmap, TName Nothing local, [(TName Nothing "xmlns", [ContentText ns])])+newElemStack (NSLevel def nsmap) (Name local (Just ns) (Just pref)) =+ case Map.lookup ns nsmap of+ Just pref'+ | pref == pref' ->+ ( NSLevel def nsmap+ , TName (Just pref) local+ , []+ )+ _ -> ( NSLevel def nsmap'+ , TName (Just pref) local+ , [(TName (Just "xmlns") pref, [ContentText ns])]+ )+ where+ nsmap' = Map.insert ns pref nsmap++newAttrStack :: (Name, [Content]) -> (NSLevel, [TAttribute]) -> (NSLevel, [TAttribute])+newAttrStack (name, value) (NSLevel def nsmap, attrs) =+ (NSLevel def nsmap', addNS $ (tname, value) : attrs)+ where+ (nsmap', tname, addNS) =+ case name of+ Name local Nothing _ -> (nsmap, TName Nothing local, id)+ Name local (Just ns) mpref ->+ let ppref = fromMaybe "ns" mpref+ (pref, addNS') = getPrefix ppref nsmap ns+ in (Map.insert ns pref nsmap, TName (Just pref) local, addNS')++getPrefix :: Text -> Map Text Text -> Text -> (Text, [TAttribute] -> [TAttribute])+getPrefix _ _ "http://www.w3.org/XML/1998/namespace" = ("xml", id)+getPrefix ppref nsmap ns =+ case Map.lookup ns nsmap of+ Just pref -> (pref, id)+ Nothing ->+ let pref = findUnused ppref $ Map.elems nsmap+ in (pref, (:) (TName (Just "xmlns") pref, [ContentText ns]))+ where+ findUnused x xs+ | x `elem` xs = findUnused (x `T.snoc` '_') xs+ | otherwise = x
Text/XML/Enumerator/Token.hs view
@@ -1,126 +1,132 @@-{-# LANGUAGE OverloadedStrings #-} -module Text.XML.Enumerator.Token - ( tokenToBuilder - , TName (..) - , Token (..) - , TAttribute - , NSLevel (..) - ) where - -import Data.XML.Types (Instruction (..), Content (..), ExternalID (..)) -import qualified Data.Text.Lazy as T -import Data.Text.Lazy (Text) -import Data.String (IsString (fromString)) -import Blaze.ByteString.Builder (Builder, fromByteString, writeByteString) -import Blaze.ByteString.Builder.Internal.Write (fromWriteList) -import Blaze.ByteString.Builder.Char.Utf8 (writeChar, fromLazyText) -import Data.Monoid (mconcat, mempty) -import Data.ByteString.Char8 () -import Data.Map (Map) - -data Token = TokenBeginDocument [TAttribute] - | TokenInstruction Instruction - | TokenBeginElement TName [TAttribute] Bool - | TokenEndElement TName - | TokenContent Content - | TokenComment Text - | TokenDoctype Text (Maybe ExternalID) - deriving Show -tokenToBuilder :: Token -> Builder -tokenToBuilder (TokenBeginDocument attrs) = - mconcat $ fromByteString "<?xml" : foldAttrs attrs [fromByteString "?>\n"] -tokenToBuilder (TokenInstruction (Instruction target data_)) = mconcat - [ fromByteString "<?" - , fromLazyText target - , fromByteString " " - , fromLazyText data_ - , fromByteString "?>" - ] -tokenToBuilder (TokenBeginElement name attrs isEmpty) = mconcat - $ fromByteString "<" - : tnameToText name - : foldAttrs attrs - [ if isEmpty then fromByteString "/>" else fromByteString ">" - ] -tokenToBuilder (TokenEndElement name) = mconcat - [ fromByteString "</" - , tnameToText name - , fromByteString ">" - ] -tokenToBuilder (TokenContent c) = contentToText c -tokenToBuilder (TokenComment t) = mconcat [fromByteString "<!--", fromLazyText t, fromByteString "-->"] -tokenToBuilder (TokenDoctype name eid) = mconcat - [ fromByteString "<!DOCTYPE " - , fromLazyText name - , go eid - , fromByteString ">\n" - ] - where - go Nothing = mempty - go (Just (SystemID uri)) = mconcat - [ fromByteString " SYSTEM \"" - , fromLazyText uri - , fromByteString "\"" - ] - go (Just (PublicID pid uri)) = mconcat - [ fromByteString " PUBLIC \"" - , fromLazyText pid - , fromByteString "\" \"" - , fromLazyText uri - , fromByteString "\"" - ] - -data TName = TName (Maybe Text) Text - deriving Show - -tnameToText :: TName -> Builder -tnameToText (TName Nothing name) = fromLazyText name -tnameToText (TName (Just prefix) name) = mconcat [fromLazyText prefix, fromByteString ":", fromLazyText name] - -contentToText :: Content -> Builder -contentToText (ContentText t) = - fromWriteList go $ T.unpack t - where - go '<' = writeByteString "<" - go '>' = writeByteString ">" - go '&' = writeByteString "&" - -- Not escaping quotes, since this is only called outside of attributes - go c = writeChar c -contentToText (ContentEntity e) = mconcat - [ fromByteString "&" - , fromLazyText e - , fromByteString ";" - ] - -type TAttribute = (TName, [Content]) - -foldAttrs :: [TAttribute] -> [Builder] -> [Builder] -foldAttrs attrs rest' = - foldr go rest' attrs - where - go (key, val) rest = - fromByteString " " - : tnameToText key - : fromByteString "=\"" - : foldr go' (fromByteString "\"" : rest) val - go' (ContentText t) rest = - fromWriteList h (T.unpack t) : rest - where - h '<' = writeByteString "<" - h '>' = writeByteString ">" - h '&' = writeByteString "&" - h '"' = writeByteString """ - -- Not escaping single quotes, since our attributes are always double - -- quoted - h c = writeChar c - go' (ContentEntity t) rest = - fromByteString "&" : fromLazyText t : fromByteString ";" : rest - -instance IsString TName where - fromString = TName Nothing . T.pack - -data NSLevel = NSLevel - { defaultNS :: Maybe Text - , prefixes :: Map Text Text - } - deriving Show +{-# LANGUAGE OverloadedStrings #-}+module Text.XML.Enumerator.Token+ ( tokenToBuilder+ , TName (..)+ , Token (..)+ , TAttribute+ , NSLevel (..)+ ) where++import Data.XML.Types (Instruction (..), Content (..), ExternalID (..))+import qualified Data.Text as T+import Data.Text (Text)+import Data.String (IsString (fromString))+import Blaze.ByteString.Builder+ (Builder, fromByteString, writeByteString, copyByteString)+import Blaze.ByteString.Builder.Internal.Write (fromWriteList)+import Blaze.ByteString.Builder.Char.Utf8 (writeChar, fromText)+import Data.Monoid (mconcat, mempty, mappend)+import Data.ByteString.Char8 ()+import Data.Map (Map)++data Token = TokenBeginDocument [TAttribute]+ | TokenInstruction Instruction+ | TokenBeginElement TName [TAttribute] Bool+ | TokenEndElement TName+ | TokenContent Content+ | TokenComment Text+ | TokenDoctype Text (Maybe ExternalID)+ | TokenCDATA Text+ deriving Show+tokenToBuilder :: Token -> Builder+tokenToBuilder (TokenBeginDocument attrs) =+ mconcat $ fromByteString "<?xml" : foldAttrs attrs [fromByteString "?>\n"]+tokenToBuilder (TokenInstruction (Instruction target data_)) = mconcat+ [ fromByteString "<?"+ , fromText target+ , fromByteString " "+ , fromText data_+ , fromByteString "?>"+ ]+tokenToBuilder (TokenBeginElement name attrs isEmpty) = mconcat+ $ fromByteString "<"+ : tnameToText name+ : foldAttrs attrs+ [ if isEmpty then fromByteString "/>" else fromByteString ">"+ ]+tokenToBuilder (TokenEndElement name) = mconcat+ [ fromByteString "</"+ , tnameToText name+ , fromByteString ">"+ ]+tokenToBuilder (TokenContent c) = contentToText c+tokenToBuilder (TokenCDATA t) =+ copyByteString "<![CDATA["+ `mappend` fromText t+ `mappend` copyByteString "]]>"+tokenToBuilder (TokenComment t) = mconcat [fromByteString "<!--", fromText t, fromByteString "-->"]+tokenToBuilder (TokenDoctype name eid) = mconcat+ [ fromByteString "<!DOCTYPE "+ , fromText name+ , go eid+ , fromByteString ">\n"+ ]+ where+ go Nothing = mempty+ go (Just (SystemID uri)) = mconcat+ [ fromByteString " SYSTEM \""+ , fromText uri+ , fromByteString "\""+ ]+ go (Just (PublicID pid uri)) = mconcat+ [ fromByteString " PUBLIC \""+ , fromText pid+ , fromByteString "\" \""+ , fromText uri+ , fromByteString "\""+ ]++data TName = TName (Maybe Text) Text+ deriving Show++tnameToText :: TName -> Builder+tnameToText (TName Nothing name) = fromText name+tnameToText (TName (Just prefix) name) = mconcat [fromText prefix, fromByteString ":", fromText name]++contentToText :: Content -> Builder+contentToText (ContentText t) =+ fromWriteList go $ T.unpack t+ where+ go '<' = writeByteString "<"+ go '>' = writeByteString ">"+ go '&' = writeByteString "&"+ -- Not escaping quotes, since this is only called outside of attributes+ go c = writeChar c+contentToText (ContentEntity e) = mconcat+ [ fromByteString "&"+ , fromText e+ , fromByteString ";"+ ]++type TAttribute = (TName, [Content])++foldAttrs :: [TAttribute] -> [Builder] -> [Builder]+foldAttrs attrs rest' =+ foldr go rest' attrs+ where+ go (key, val) rest =+ fromByteString " "+ : tnameToText key+ : fromByteString "=\""+ : foldr go' (fromByteString "\"" : rest) val+ go' (ContentText t) rest =+ fromWriteList h (T.unpack t) : rest+ where+ h '<' = writeByteString "<"+ h '>' = writeByteString ">"+ h '&' = writeByteString "&"+ h '"' = writeByteString """+ -- Not escaping single quotes, since our attributes are always double+ -- quoted+ h c = writeChar c+ go' (ContentEntity t) rest =+ fromByteString "&" : fromText t : fromByteString ";" : rest++instance IsString TName where+ fromString = TName Nothing . T.pack++data NSLevel = NSLevel+ { defaultNS :: Maybe Text+ , prefixes :: Map Text Text+ }+ deriving Show
+ runtests.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+import Test.Hspec+import Test.Hspec.HUnit+import Test.HUnit hiding (Test)++import Data.XML.Types+import qualified Text.XML.Enumerator.Document as D+import Text.XML.Enumerator.Parse (decodeEntities)+import qualified Text.XML.Enumerator.Parse as P+import qualified Data.Map as Map+import qualified Data.ByteString.Lazy.Char8 as L+import Control.Monad.IO.Class (liftIO)++main :: IO ()+main = hspec $ describe "XML parsing and rendering"+ [ it "is idempotent to parse and render a document" documentParseRender+ , it "has valid parser combinators" combinators+ ]++documentParseRender =+ mapM_ go docs+ where+ go x = x @=? D.parseLBS_ (D.renderLBS x) decodeEntities+ docs =+ [ Document (Prologue [] Nothing [])+ (Element "foo" Map.empty [])+ []+ , D.parseLBS_+ "<?xml version=\"1.0\"?>\n<!DOCTYPE foo>\n<foo/>"+ decodeEntities+ , D.parseLBS_+ "<?xml version=\"1.0\"?>\n<!DOCTYPE foo>\n<foo><nested>&ignore;</nested></foo>"+ decodeEntities+ , D.parseLBS_+ "<foo><![CDATA[this is some<CDATA content>]]></foo>"+ decodeEntities+ , D.parseLBS_+ "<foo bar='baz&bin'/>"+ decodeEntities+ , D.parseLBS_+ "<foo><?instr this is a processing instruction?></foo>"+ decodeEntities+ , D.parseLBS_+ "<foo><!-- this is a comment --></foo>"+ decodeEntities+ ]++combinators = P.parseLBS_ input decodeEntities $ do+ P.force "need hello" $ P.tagName "hello" (P.requireAttr "world") $ \world -> do+ liftIO $ world @?= "true"+ P.force "need child1" $ P.tagNoAttr "{mynamespace}child1" $ return ()+ P.force "need child2" $ P.tagNoAttr "child2" $ return ()+ P.force "need child3" $ P.tagNoAttr "child3" $ do+ x <- P.contentMaybe+ liftIO $ x @?= Just "combine <all> &content"+ where+ input = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello world='true'>"+ , "<?this should be ignored?>"+ , "<child1 xmlns='mynamespace'/>"+ , "<!-- this should be ignored -->"+ , "<child2> </child2>"+ , "<child3>combine <all> <![CDATA[&content]]></child3>\n"+ , "</hello>"+ ]
xml-enumerator.cabal view
@@ -1,36 +1,47 @@-name: xml-enumerator -version: 0.1.3 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman <michaels@suite-sol.com> -maintainer: Michael Snoyman <michaels@suite-sol.com> -synopsis: Pure-Haskell utilities for dealing with XML with the enumerator package. -description: - Provides the ability to parse and render XML in a streaming manner using the enumerator package. -category: XML, Enumerator -stability: Stable -cabal-version: >= 1.6 -build-type: Simple -homepage: http://github.com/snoyberg/xml-enumerator - -library - build-depends: base >= 4 && < 5 - , enumerator >= 0.4.5 && < 0.5 - , bytestring >= 0.9 && < 0.10 - , text >= 0.7 && < 0.12 - , containers >= 0.2 && < 0.5 - , xml-types >= 0.1 && < 0.2 - , attoparsec-text-enumerator >= 0.2 && < 0.3 - , attoparsec-text >= 0.8.2 && < 0.9 - , blaze-builder >= 0.2.1.0 && < 0.3 - , blaze-builder-enumerator >= 0.2 && < 0.3 - , transformers >= 0.2 && < 0.3 - exposed-modules: Text.XML.Enumerator.Parse - Text.XML.Enumerator.Render - Text.XML.Enumerator.Document - other-modules: Text.XML.Enumerator.Token - ghc-options: -Wall - -source-repository head - type: git - location: git://github.com/snoyberg/xml-enumerator.git +name: xml-enumerator+version: 0.2.0+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michaels@suite-sol.com>+maintainer: Michael Snoyman <michaels@suite-sol.com>+synopsis: Pure-Haskell utilities for dealing with XML with the enumerator package.+description:+ Provides the ability to parse and render XML in a streaming manner using the enumerator package.+category: XML, Enumerator+stability: Stable+cabal-version: >= 1.6+build-type: Simple+homepage: http://github.com/snoyberg/xml-enumerator++flag test+ default: False++library+ build-depends: base >= 4 && < 5+ , enumerator >= 0.4.5 && < 0.5+ , bytestring >= 0.9 && < 0.10+ , text >= 0.7 && < 0.12+ , containers >= 0.2 && < 0.5+ , xml-types >= 0.2 && < 0.3+ , attoparsec-text-enumerator >= 0.2 && < 0.3+ , attoparsec-text >= 0.8.2 && < 0.9+ , blaze-builder >= 0.2.1.0 && < 0.3+ , blaze-builder-enumerator >= 0.2 && < 0.3+ , transformers >= 0.2 && < 0.3+ exposed-modules: Text.XML.Enumerator.Parse+ Text.XML.Enumerator.Render+ Text.XML.Enumerator.Document+ other-modules: Text.XML.Enumerator.Token+ ghc-options: -Wall++executable runtests+ main-is: runtests.hs+ if flag(test)+ Buildable: True+ Build-depends: base, HUnit, hspec >= 0.3 && < 0.4+ else+ Buildable: False++source-repository head+ type: git+ location: git://github.com/snoyberg/xml-enumerator.git