xml-enumerator 0.2.1.3 → 0.3.0
raw patch · 8 files changed
+1569/−1859 lines, 8 filesdep ~xml-typessetup-changed
Dependency ranges changed: xml-types
Files
- LICENSE +25/−25
- Setup.lhs +7/−7
- Text/XML/Enumerator/Document.hs +252/−223
- Text/XML/Enumerator/Parse.hs +680/−879
- Text/XML/Enumerator/Render.hs +268/−155
- Text/XML/Enumerator/Token.hs +151/−132
- runtests.hs +139/−391
- xml-enumerator.cabal +47/−47
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,223 +1,252 @@-{-# 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+{-# LANGUAGE DeriveDataTypeable #-} +module Text.XML.Enumerator.Document + ( -- * Non-streaming functions + writeFile + , writePrettyFile + , readFile + , readFile_ + -- * Lazy bytestrings + , renderLBS + , prettyLBS + , parseLBS + , parseLBS_ + -- * Streaming functions + , toEvents + , fromEvents + , renderBuilder + , renderBytes + , renderText + -- ** Pretty versions + , prettyBuilder + , prettyBytes + , prettyText + -- * 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 + +-- | Pretty prints via 'prettyBytes'. +writePrettyFile :: FilePath -> Document -> IO () +writePrettyFile fn doc = SIO.withBinaryFile fn SIO.WriteMode $ \h -> + run_ $ prettyBytes doc $$ iterHandle h + +renderLBS :: Document -> L.ByteString +renderLBS doc = + L.fromChunks $ unsafePerformIO $ lazyConsume $ renderBytes doc + +-- | Pretty prints via 'prettyBytes'. +prettyLBS :: Document -> L.ByteString +prettyLBS doc = + L.fromChunks $ unsafePerformIO $ lazyConsume $ prettyBytes 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 + +prettyBuilder :: MonadIO m => Document -> Enumerator Builder m a +prettyBuilder doc = enumList 8 (toEvents doc) `joinE` R.prettyBuilder + +prettyBytes :: MonadIO m => Document -> Enumerator ByteString m a +prettyBytes doc = enumList 8 (toEvents doc) `joinE` R.prettyBytes + +prettyText :: MonadIO m => Document -> Enumerator Text m a +prettyText doc = enumList 8 (toEvents doc) `joinE` R.prettyText + +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 + -- Leaving the following line commented so that the intention of + -- this function stays clear. I figure in the future xml-types will + -- be expanded again to support some form of EventDeclaration + -- + -- 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,879 +1,680 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}--- | 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.------ 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 = tagName "person" (requireAttr "age") $ \age -> do--- > name <- content--- > return $ Person (read $ unpack age) name--- > --- > parsePeople = tagNoAttr "people" $ many parsePerson--- > --- > main = parseFile_ "people.xml" decodeEntities $ 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- , tagPredicate- , tagName- , tagNoAttr- , tags- , tagsPermute- , content- , contentMaybe- , processElem- , processSiblings- , ignoreElem- , ignoreSiblings- -- * Attribute parsing- , AttrParser- , requireAttr- , optionalAttr- , requireAttrRaw- , optionalAttrRaw- , ignoreAttrs- , skipAttrs- , parseAttrsT- , parseAttrsS- , parseAttrsST- -- * Combinators- , orE- , choose- , chooseSplit- , permute- , permuteFallback- , 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 Control.Arrow (second)-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 qualified Data.Set as Set-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, guard)-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 Control.Monad(liftM2)-import Control.Arrow((***))-import Data.Char (isSpace)-import Data.Maybe(fromJust)--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. This function skips over any--- comments and instructions and concatenates all content until the next start--- or end tag.-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'.--- This is simply a wrapper around 'contentMaybe'.-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'.------ This function automatically ignores comments, instructions and whitespace.-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 against boolean predicates.-tagPredicate :: Monad m => (Name -> Bool) -> AttrParser a -> (a -> Iteratee Event m b) -> Iteratee Event m (Maybe b)-tagPredicate p attrParser = tag (\x -> if p x then Just () else Nothing) (const attrParser)---- | 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 = tagPredicate (== name)---- | 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---- | Statefully and efficiently parse a list of tags.--- --- The first parameter is a function that, given state and an element name, returns--- either 'Nothing', to indicate that the element is invalid, or a pair of attribute--- and element content parsers in 'Just'. --- --- The second parameter is a function that, given the current state, returns a--- "fallback" parser to be executed when no valid element has been found.--- --- The third parameter is the initial state.--- --- This function updates the state as it goes along, but it also accumulates a list of--- elements as they occur.-tags :: (Monad m) - => (a -> Name -> Maybe (AttrParser b, b -> Iteratee Event m (a, Maybe c)))- -> (a -> Iteratee Event m (Maybe (a, Maybe c)))- -> a - -> Iteratee Event m (a, [c])-tags f fb s' = go s'- where go s = do- t <- tag (f s) (\(attr, sub) -> sub <$> attr) id `orE` fb s- case t of- Nothing -> return (s, [])- Just (s2, Nothing) -> go s2- Just (s2, Just a) -> second (a:) `fmap` go s2---- | Parse a permutation of tags.--- --- The first parameter is a function to preprocess Names for equality testing, because--- sometimes XML documents contain inconsistent naming. This allows the user to deal--- with it.--- --- The second parameter is a map of tags to attribute and element content parsers.--- --- The third parameter is a fallback parser.--- --- This function accumulates a list of elements for each step that produces one.-tagsPermute :: (Monad m, Ord a) - => (Name -> a) - -> Map.Map a (AttrParser b, b -> Iteratee Event m (Maybe c))- -> Iteratee Event m (Maybe c)- -> Iteratee Event m (Maybe [c])-tagsPermute f m fb = do- (rest, result) <- tags go (\s -> fmap (\a -> (s, Just a)) <$> fb) m- return (guard (Map.null rest) >> Just result)- where go s name = case Map.lookup k s of- Nothing -> Nothing- Just (attr, sub) -> Just (attr, fmap adaptSub . sub)- where k = f name- adaptSub Nothing = (s, Nothing)- adaptSub a = (Map.delete k s, a)---- | Get the value of the first parser which returns 'Just'. If no parsers--- succeed (i.e., return 'Just'), this function returns 'Nothing'.-orE :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a)-orE a b = do- x <- a- case x of- Nothing -> b- _ -> return x---- | Get the value of the first parser which returns 'Just'. If no parsers--- succeed (i.e., return 'Just'), this function 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---- | Like 'choose', but also returns the list of elements that were /not/ chosen.-chooseSplit :: (Monad m) - => (a -> Iteratee Event m (Maybe b)) -- ^ Element-specific parsers- -> [a] -- ^ Elements to choose from- -> Iteratee Event m (Maybe (b, [a]))-chooseSplit f xs = go xs []- where- go [] _ = return Nothing- go (i:is) is' = do- x <- f i- case x of- Nothing -> go is (i : is')- Just a -> return $ Just (a, is' ++ is)---- | Permute all parsers until none return 'Just'.-permute :: Monad m => (a -> Iteratee Event m (Maybe b)) -> [a] -> Iteratee Event m (Maybe [b])-permute _ [] = return (Just [])-permute f is = do- x <- chooseSplit f is- case x of- Nothing -> return Nothing- Just (a, is') -> fmap (a:) `fmap` permute f is'---- | Permute all parsers until none return 'Just', but always test some fallback parsers.-permuteFallback :: (Monad m)- => Iteratee Event m (Maybe [b])- -> (a -> Iteratee Event m (Maybe b))- -> [a]- -> Iteratee Event m (Maybe [b])-permuteFallback fb _ [] = return (Just [])-permuteFallback fb f is = do- x <- chooseSplit f is- case x of- Nothing -> do y <- fb- case y of- Nothing -> return Nothing- Just as -> fmap (as ++) `fmap` permuteFallback fb f is- Just (a, is') -> fmap (a:) `fmap` permuteFallback fb f is'---- | 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', and--- then hands 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---- | Parse an event stream from a lazy 'L.ByteString'.-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---- | Same as 'parseLBS', but throws exceptions.-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---- Internal Iteratee used in processSiblings and processElem-processNested :: (Monad m) => Bool -> Iteratee Event m b -> Iteratee Event m (Maybe b)-processNested isElem k0 = E.continue (loop (Just []) k0)- where- loop :: (Monad m) => Maybe [Name] -> Iteratee Event m b -> Stream Event -> Iteratee Event m (Maybe b)- loop ns k (Chunks xs) = - case (isElem, skipNames ns [] xs) of- (_, (Nothing, _, _)) -> E.yield Nothing (Chunks xs)- (True, (Just [], ts, xs')) -> yield ts xs'- (False, (ns', ts, [])) -> continue ns' ts- (False, (Just [], ts, xs')) -> yield ts xs'- (True, (ns', ts, [])) -> continue ns' ts- (_, (Just [n1,n2], _, _)) -> throwError $ XmlException ("Unbalanced xml-tree. Name '" ++ show n1 ++ "' is not corresponding to '" - ++ show n2 ++ "'. (Error in skipSiblings)") (Just $ EventEndElement n2)- _ -> throwError $ XmlException "Unknown error. (Error in skipSiblings)" Nothing- where- continue ns' ts = E.continue (loop ns' $ E.enumList 1 ts $$ k)- yield ts xs' = do- t <- E.Iteratee $ liftM (flip E.Yield (Chunks [])) $ E.run $ E.enumList 1 ts $$ k- case t of- Left err -> throwError err- Right t' -> E.yield (Just t') (Chunks xs')-- skipNames :: Maybe [Name] -> [Event] -> [Event] -> (Maybe [Name], [Event], [Event])- skipNames ns0 ts0 es0 = go ns0 ts0 es0- where- go ns ts [] = (ns,ts,[])- go Nothing _ _ = (ns0,ts0,es0)- go (Just ns) ts xxs@(x:xs) = - case x of- (EventBeginElement n _) -> go (Just $ n:ns) (ts ++ [x]) xs- (EventEndElement n)- | isElem && null (tail ns) -> (Just [], ts ++ [x], xs)- | isElem && null ns -> (Nothing, ts, xxs)- | not isElem && null ns -> (Just [], ts, xxs)- -- | null (if isElem then tail ns else ns) -> (Just [], if isElem then ts ++ [x] else ts, (f xxs))- | n == head ns -> go (Just $ tail ns) (ts ++ [x]) xs- | otherwise -> (Just [head ns, n], ts, xxs)- _ -> go (Just ns) (ts ++ [x]) xs- loop _ _ EOF = throwError $ XmlException "Unbalanced xml-tree. (Error in skipSiblings - EOF)" Nothing- - --- | Iteratee to process sibling elements in separate iteratee.-processSiblings :: (Monad m) => Iteratee Event m b -> Iteratee Event m b-processSiblings = liftM fromJust . processNested False---- | Iteratee to process sibling elements in separate iteratee.-processElem :: (Monad m) => Iteratee Event m b -> Iteratee Event m (Maybe b)-processElem = processNested True- -iterIgnore :: (Monad m) => Iteratee a m ()-iterIgnore = E.returnI $ E.Yield () EOF---- | Iteratee to skip sibling elements.-ignoreSiblings :: Monad m => Iteratee Event m ()-ignoreSiblings = processSiblings iterIgnore- --- | Iteratee to skip the next element. Skips all events before the next--- element as well. Returns False if an element's end event is encountered--- before any element's begin events.-ignoreElem :: Monad m => Iteratee Event m Bool-ignoreElem = liftM (maybe False $ const True) $ processElem iterIgnore---- | Skip the sibling elements until iteratee returns 'Just'.-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 >>= (\b -> if b then go else return Nothing)- _ -> return x---- | 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---- | Simple AttrParser utilities--- | Parse list of required and list of optional attributes into lists of Text-parseAttrsT :: [Name] -> [Name] -> AttrParser ([Text], [Maybe Text])-parseAttrsT reqs opts = liftM2 (,) (mapM requireAttr reqs) (mapM optionalAttr opts)---- | Parse list of required and list of optional attributes into lists of String-parseAttrsS :: [Name] -> [Name] -> AttrParser ([String], [Maybe String])-parseAttrsS reqs opts = fmap (map T.unpack *** map (fmap T.unpack)) (parseAttrsT reqs opts)---- | Parse part of atrributes into [String] and other part into [Text]-parseAttrsST :: [Name] -> [Name] -> [Name] -> [Name] -> AttrParser (([String], [Maybe String]), ([Text], [Maybe Text]))-parseAttrsST reqs opts reqst optst = liftM2 (,) (parseAttrsS reqs opts) (parseAttrsT reqst optst)--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+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +-- | 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. +-- +-- 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 = tagName "person" (requireAttr "age") $ \age -> do +-- > name <- content +-- > return $ Person (read $ unpack age) name +-- > +-- > parsePeople = tagNoAttr "people" $ many parsePerson +-- > +-- > main = parseFile_ "people.xml" decodeEntities $ force "people required" parsePeople +-- +-- will produce: +-- +-- > [Person {age = 25, name = "Michael"},Person {age = 2, name = "Eliezer"}] +-- +-- Previous versions of this module contained a number of more sophisticated +-- functions written by Aristid Breitkreuz and Dmitry Olshansky. To keep this +-- package simpler, those functions are being moved to a separate package. This +-- note will be updated with the name of the package(s) when available. +module Text.XML.Enumerator.Parse + ( -- * Parsing XML files + parseBytes + , parseText + , detectUtf + , parseFile + , parseFile_ + , parseLBS + , parseLBS_ + -- ** Entity decoding + , DecodeEntities + , decodeEntities + -- * Event parsing + , tag + , tagPredicate + , tagName + , tagNoAttr + , content + , contentMaybe + -- * Attribute parsing + , AttrParser + , requireAttr + , optionalAttr + , requireAttrRaw + , optionalAttrRaw + , ignoreAttrs + -- * Combinators + , orE + , choose + , many + , force + -- * 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 (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 0 + +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. This function skips over any +-- comments and instructions and concatenates all content until the next start +-- or end tag. +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 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'. +-- This is simply a wrapper around 'contentMaybe'. +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'. +-- +-- This function automatically ignores comments, instructions and whitespace. +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) 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 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 against boolean predicates. +tagPredicate :: Monad m => (Name -> Bool) -> AttrParser a -> (a -> Iteratee Event m b) -> Iteratee Event m (Maybe b) +tagPredicate p attrParser = tag (\x -> if p x then Just () else Nothing) (const attrParser) + +-- | 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 = tagPredicate (== name) + +-- | 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 no parsers +-- succeed (i.e., return 'Just'), this function returns 'Nothing'. +-- +-- > orE a b = choose [a, b] +orE :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a) +orE a b = do + x <- a + case x of + Nothing -> b + _ -> return x + +-- | Get the value of the first parser which returns 'Just'. If no parsers +-- succeed (i.e., return 'Just'), this function 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', and +-- then hands 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 + +-- | Parse an event stream from a lazy 'L.ByteString'. +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 + +-- | Same as 'parseLBS', but throws exceptions. +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 + +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,268 @@-{-# 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+{-# 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 + , prettyBuilder + , prettyBytes + , prettyText + ) 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 ((>>==), ($$), Iteratee, Step (..)) +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) +import Data.Char (isSpace) + +-- | Pretty prints a stream of 'Event's into a stream of 'Builder's. This +-- changes the meaning of some documents, by inserting/modifying whitespace. +prettyBuilder :: Monad m => E.Enumeratee Event Builder m b +prettyBuilder step0 = + E.joinI $ prettify 0 [] $$ loop [] step0 + 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 True stack name as + else go $ mkBeginToken True False stack name as + Just e -> go $ eventToToken stack e + where + go (ts, stack') = k (E.Chunks $ map tokenToBuilder $ ts []) >>== loop stack' + +-- | Same as 'prettyBuilder', but produces a stream of 'ByteString's. +prettyBytes :: MonadIO m => E.Enumeratee Event ByteString m b +prettyBytes s = E.joinI $ prettyBuilder $$ builderToByteString s + +-- | Same as 'prettyBuilder', but produces a stream of 'Text's. +prettyText :: MonadIO m => E.Enumeratee Event Text m b +prettyText s = E.joinI $ prettyBytes $$ ET.decode ET.utf8 s + +-- | 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 False True stack name as + else go $ mkBeginToken False 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 (EventCDATA t) = ((:) (TokenCDATA t), s) +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) +eventToToken _ EventBeginElement{} = error "eventToToken on EventBeginElement" -- mkBeginToken False s name attrs + +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 -- ^ pretty print attributes? + -> Bool -> Stack -> Name -> [(Name, [Content])] + -> ([Token] -> [Token], Stack) +mkBeginToken isPretty isClosed s name attrs = + ((:) (TokenBeginElement tname tattrs2 isClosed indent), + if isClosed then s else sl2 : s) + where + indent = if isPretty then 2 + 4 * length s else 0 + 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 :: (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 + +prettify :: Monad m => Int -> [Name] -> E.Enumeratee Event Event m a +prettify level names (Continue k) = do + mx <- eventHead + case mx of + Nothing -> return $ Continue k + Just x -> do + y <- E.peek + (chunks, level', names') <- + case (x, y) of + (Left contents, _) -> do + let es = map EventContent $ cleanWhite contents + let es' = if null es + then [] + else before level : es ++ [after] + return (es', level, names) + (Right (EventBeginElement name attrs), Just (EventEndElement _)) -> do + EL.drop 1 + return ([before level, EventBeginElement name attrs, EventEndElement name, after], level, names) + (Right (EventBeginElement name attrs), _) -> do + return ([before level, EventBeginElement name attrs, after], level + 1, name : names) + (Right (EventEndElement _), _) -> do + let newLevel = level - 1 + return ([before newLevel, EventEndElement $ head names, after], newLevel, tail names) + (Right EventBeginDocument, _) -> do + _ <- takeContents id + return ([EventBeginDocument], level, names) + (Right EventEndDocument, _) -> do + _ <- takeContents id + return ([EventEndDocument, after], level, names) + (Right (EventComment t), _) -> do + _ <- takeContents id + return ([before level, EventComment $ T.map normalSpace t, after], level, names) + (Right e, _) -> do + _ <- takeContents id + return ([before level, e, after], level, names) + k (E.Chunks chunks) >>== prettify level' names' + where + before l = EventContent $ ContentText $ T.replicate l " " + after = EventContent $ ContentText "\n" +prettify _ _ step = return step + +eventHead :: Monad m => Iteratee Event m (Maybe (Either [Content] Event)) +eventHead = do + x <- EL.head + case x of + Just (EventContent e) -> do + es <- takeContents id + return $ Just $ Left $ e : es + Nothing -> return Nothing + Just e -> return $ Just $ Right e + +takeContents :: Monad m => ([Content] -> [Content]) -> Iteratee Event m [Content] +takeContents front = do + x <- E.peek + case x of + Just (EventContent e) -> do + EL.drop 1 + takeContents $ front . (:) e + _ -> return $ front [] + +normalSpace :: Char -> Char +normalSpace c + | isSpace c = ' ' + | otherwise = c + +cleanWhite :: [Content] -> [Content] +cleanWhite x = + go True [] $ go True [] x + where + go _ end (ContentEntity e:rest) = go False (ContentEntity e : end) rest + go isFront end (ContentText t:rest) = + if T.null t' + then go isFront end rest + else go False (ContentText t' : end) rest + where + t' = (if isFront then T.dropWhile isSpace else id) $ T.map normalSpace t + go _ end [] = end
Text/XML/Enumerator/Token.hs view
@@ -1,132 +1,151 @@-{-# 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+{-# 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) +import qualified Blaze.ByteString.Builder.Char8 as BC8 + +oneSpace :: Builder +oneSpace = copyByteString " " + +data Token = TokenBeginDocument [TAttribute] + | TokenInstruction Instruction + | TokenBeginElement TName [TAttribute] Bool Int -- ^ indent + | TokenEndElement TName + | TokenContent Content + | TokenComment Text + | TokenDoctype Text (Maybe ExternalID) + | TokenCDATA Text + deriving Show +tokenToBuilder :: Token -> Builder +tokenToBuilder (TokenBeginDocument attrs) = + fromByteString "<?xml" + `mappend` foldAttrs oneSpace attrs (fromByteString "?>\n") +tokenToBuilder (TokenInstruction (Instruction target data_)) = mconcat + [ fromByteString "<?" + , fromText target + , fromByteString " " + , fromText data_ + , fromByteString "?>" + ] +tokenToBuilder (TokenBeginElement name attrs isEmpty indent) = + copyByteString "<" + `mappend` tnameToText name + `mappend` foldAttrs + (if indent == 0 || lessThan3 attrs + then oneSpace + else BC8.fromString ('\n' : replicate indent ' ')) + attrs + (if isEmpty then fromByteString "/>" else fromByteString ">") + where + lessThan3 [] = True + lessThan3 [_] = True + lessThan3 [_, _] = True + lessThan3 _ = False +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 :: Builder -- ^ before + -> [TAttribute] + -> Builder + -> Builder +foldAttrs before attrs rest' = + foldr go rest' attrs + where + go (key, val) rest = + before + `mappend` tnameToText key + `mappend` copyByteString "=\"" + `mappend` foldr go' (fromByteString "\"" `mappend` rest) val + go' (ContentText t) rest = + fromWriteList h (T.unpack t) `mappend` 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 "&" + `mappend` fromText t + `mappend` fromByteString ";" + `mappend` 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
@@ -1,391 +1,139 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}--import Control.Monad (guard)-import Control.Monad.IO.Class (liftIO)-import Data.Char (chr,ord)-import Data.String (fromString)-import Data.Text (toLower)-import Data.XML.Types-import Test.HUnit hiding (Test)-import Test.Hspec-import Test.Hspec.HUnit-import Text.XML.Enumerator.Parse (decodeEntities)-import qualified Control.Exception as C-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.Map as Map-import qualified Text.XML.Enumerator.Document as D-import qualified Text.XML.Enumerator.Parse as P--import Text.XML.Enumerator.Parse (decodeEntities)-import qualified Text.XML.Enumerator.Parse as P-import qualified Text.XML.Enumerator.Render as R-import qualified Data.Map as Map-import qualified Data.ByteString.Lazy.Char8 as L-import Control.Monad.IO.Class (liftIO)-import qualified Data.Enumerator as E-import Data.Enumerator(($$))-import qualified Data.Enumerator.List as EL-import Data.Monoid-import Data.Text(Text)-import Control.Monad.IO.Class(MonadIO)-import Control.Monad-import Control.Applicative((<$>), (<*>))--main :: IO ()-main = hspec $ fmap concat $ sequence [t0, t1]--t0 = describe "XML parsing and rendering"- [ it "is idempotent to parse and render a document" documentParseRender- , it "has valid parser combinators" combinators- , it "has working ignoreSiblings function" testIgnoreSiblings- , it "has working IgnoreElem function" testIgnoreElem- , it "has working skipTill function" testSkipTill- , it "has working choose function" testChoose- , it "has working many function" testMany- , it "has working orE" testOrE- , it "has working chooseSplit" testChooseSplit- , it "has working permute" testPermute- , it "has working permuteFallback" testPermuteFallback- , it "has working tags" testTags- , it "has working tagsPermute" testTagsPermute- ]- -t1 = fmap concat $ sequence [- describe "Checking dependency of chunk size for iteratees" [- it "doesn't depend for ignoreSiblings" testSib- , it "doesn't depend for ignoreElem" testElem- , it "doesn't depend for skipTill" testSkipTill- , it "doesn't depend for tag" testTag- ],- describe "Process nested iteratees. (Launch missiles?..)" [- it "can run nested iteratees for siblings. E.g. to render text" testProcSib- , it "can run nested iteratees for next element" testProcElem- ]- ]- where- testSib = testI P.ignoreSiblings $ drop 2 testData- testElem = testI P.ignoreElem $ drop 2 testData- testSkipTill = testI (P.skipTill $ P.tagNoAttr "E2" P.ignoreSiblings) $ drop 1 testData- testTag = testI (P.tagNoAttr "root" $ P.skipTill $ P.tagNoAttr "E2" P.contentMaybe) testData- testProcSib = join $ fmap (@?=("<E0><E1><E11/><E12/></E1><E3/></E0><E2/>", [EventEndElement "root"])) $ - resI (P.processSiblings renderTextI) (drop 1 testData) 1- testProcElem = join $ fmap (@?=(Just "<E0><E1><E11/><E12/></E1><E3/></E0>", dropWhile (/=EventBeginElement "E2" mempty) testData)) $ - resI (P.processElem renderTextI) (drop 1 testData) 1- renderTextI = E.joinI $ R.renderText $$ E.foldl' mappend mempty- - testData = [- EventBeginElement "root" mempty- , EventBeginElement "E0" mempty- , EventBeginElement "E1" mempty- , EventBeginElement "E11" mempty- , EventEndElement "E11"- , EventBeginElement "E12" mempty- , EventEndElement "E12"- , EventEndElement "E1"- , EventBeginElement "E3" mempty- , EventEndElement "E3"- , EventEndElement "E0"- , EventBeginElement "E2" mempty- , EventEndElement "E2"- , EventEndElement "root"- ]- resI i xs n = E.run_ $ E.enumList n xs $$ (i >>= \r-> EL.consume >>= \c -> return (r,c))- cmpI i xs n = liftM2 (==) (resI i xs n) (resI i xs $ n+1)- testI :: (Eq t, Eq a) => E.Iteratee a IO t -> [a] -> IO ()- testI i xs = assert $ fmap and $ mapM (cmpI i xs) [1..20] ---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>"- ]--testIgnoreSiblings = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- P.ignoreSiblings- return ()- -testIgnoreElem = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- P.ignoreElem- P.ignoreElem- return ()--testSkipTill = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- P.skipTill (P.tagNoAttr "ignore" P.ignoreSiblings)- return ()--- where-input = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "<ignore>"- , "<nested>"- , "<fail/>"- , "</nested>"- , "</ignore>\n"- , "</hello>"- ]- --testChoose = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.tagNoAttr "failure" $ return 1- , P.tagNoAttr "success" $ return 2- ]- liftIO $ x @?= Just 2- where- input = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "</hello>"- ]--testMany = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.many $ P.tagNoAttr "success" $ return ()- liftIO $ length x @?= 5- where- input = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "<success/>"- , "<success/>"- , "<success/>"- , "<success/>"- , "</hello>"- ]--testOrE = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.tagNoAttr "failure" (return 1) `P.orE`- P.tagNoAttr "success" (return 2)- liftIO $ x @?= Just 2- where- input = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "</hello>"- ]--testChooseSplit = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.chooseSplit (\t-> P.tagNoAttr t (return t)) ["a", "b", "c"]- liftIO $ x @?= Just ("b",["a","c"])- where- input = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<b/>"- , "</hello>"- ]--testPermute - = do- let frame input = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ - P.permute (\t -> P.tagNoAttr t (return t)) ["a", "b"]- frame input1 >>= \result1 -> result1 @?= Just ["a", "b"]- frame input2 >>= \result2 -> result2 @?= Just ["b", "a"]- frame input3 >>= \result3 -> result3 @?= Nothing- C.try (frame input4) >>= \result4 -> case result4 of- Left (P.XmlException { - P.xmlBadInput = Just (EventBeginElement - Name { - nameLocalName = "c"- , nameNamespace = Nothing- , namePrefix = Nothing - }- _) - }) -> return () -- right type of error- Left _ -> assertFailure "wrong error"- Right _ -> assertFailure "erroneous document requires an error"- where- input1 = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<a/>"- , "<b/>"- , "</hello>"- ]- input2 = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<b/>"- , "<a/>"- , "</hello>"- ]- input3 = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<a/>"- , "</hello>"- ]- input4 = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<a/>"- , "<c/>"- , "</hello>"- ]--testPermuteFallback- = do- let frame input = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ - P.permuteFallback (fmap return `fmap` P.contentMaybe) - (\t -> P.tagNoAttr t (return $ nameLocalName t)) - ["a", "b"]- frame input1 >>= \result1 -> result1 @?= Just ["a", "t", "b"]- frame input2 >>= \result2 -> result2 @?= Just ["t", "b", "a"]- frame input3 >>= \result3 -> result3 @?= Nothing- C.try (frame input4) >>= \result4 -> case result4 of- Left (P.XmlException { - P.xmlBadInput = Just (EventBeginElement - Name { - nameLocalName = "c"- , nameNamespace = Nothing- , namePrefix = Nothing - }- _) - }) -> return () -- right type of error- Left _ -> assertFailure "wrong error"- Right _ -> assertFailure "erroneous document requires an error"- where- input1 = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<a/>"- , "t"- , "<b/>"- , "</hello>"- ]- input2 = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "t"- , "<b/>"- , "<a/>"- , "</hello>"- ]- input3 = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<a/>"- , "</hello>"- ]- input4 = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<a/>"- , "<c/>"- , "</hello>"- ]--testTags = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.tags (\state name -> do - let n = nameLocalName name- guard (n == fromString [chr $ ord 'a' + state]) - Just (return (), \_ -> return (state + 1, Just n)))- (const $ return Nothing)- 0- liftIO $ x @?= (5, ["a", "b", "c", "d", "e"])- where- input = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<a/>"- , "<b/>"- , "<c/>"- , "<d/>"- , "<e/>"- , "</hello>"- ]---testTagsPermute = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- let p c = (return (), \_ -> return (Just c))- x <- P.tagsPermute (toLower . nameLocalName) - (Map.fromList $ map (\c -> (c, p c)) - ["a", "b", "c", "d", "e"])- (return Nothing)- liftIO $ x @?= Just ["d", "b", "e", "a", "c"]- where- input = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<d/>"- , "<b/>"- , "<E/>"- , "<a/>"- , "<C/>"- , "</hello>"- ]+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad (guard) +import Control.Monad.IO.Class (liftIO) +import Data.Char (chr,ord) +import Data.String (fromString) +import Data.Text (toLower) +import Data.XML.Types +import Test.HUnit hiding (Test) +import Test.Hspec +import Test.Hspec.HUnit +import Text.XML.Enumerator.Parse (decodeEntities) +import qualified Control.Exception as C +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Map as Map +import qualified Text.XML.Enumerator.Document as D +import qualified Text.XML.Enumerator.Parse as P + +import Text.XML.Enumerator.Parse (decodeEntities) +import qualified Text.XML.Enumerator.Parse as P +import qualified Text.XML.Enumerator.Render as R +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy.Char8 as L +import Control.Monad.IO.Class (liftIO) +import qualified Data.Enumerator as E +import Data.Enumerator(($$)) +import qualified Data.Enumerator.List as EL +import Data.Monoid +import Data.Text(Text) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad +import Control.Applicative((<$>), (<*>)) + +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 + , it "has working choose function" testChoose + , it "has working many function" testMany + , it "has working orE" testOrE + ] + +documentParseRender = + mapM_ go docs + where + go x = x @=? D.parseLBS_ (D.renderLBS x) decodeEntities + docs = + [ Document (Prologue [] Nothing []) + (Element "foo" [] []) + [] + , 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>" + ] + +testChoose = P.parseLBS_ input decodeEntities $ do + P.force "need hello" $ P.tagNoAttr "hello" $ do + x <- P.choose + [ P.tagNoAttr "failure" $ return 1 + , P.tagNoAttr "success" $ return 2 + ] + liftIO $ x @?= Just 2 + where + input = L.concat + [ "<?xml version='1.0'?>\n" + , "<!DOCTYPE foo []>\n" + , "<hello>" + , "<success/>" + , "</hello>" + ] + +testMany = P.parseLBS_ input decodeEntities $ do + P.force "need hello" $ P.tagNoAttr "hello" $ do + x <- P.many $ P.tagNoAttr "success" $ return () + liftIO $ length x @?= 5 + where + input = L.concat + [ "<?xml version='1.0'?>\n" + , "<!DOCTYPE foo []>\n" + , "<hello>" + , "<success/>" + , "<success/>" + , "<success/>" + , "<success/>" + , "<success/>" + , "</hello>" + ] + +testOrE = P.parseLBS_ input decodeEntities $ do + P.force "need hello" $ P.tagNoAttr "hello" $ do + x <- P.tagNoAttr "failure" (return 1) `P.orE` + P.tagNoAttr "success" (return 2) + liftIO $ x @?= Just 2 + where + input = L.concat + [ "<?xml version='1.0'?>\n" + , "<!DOCTYPE foo []>\n" + , "<hello>" + , "<success/>" + , "</hello>" + ]
xml-enumerator.cabal view
@@ -1,47 +1,47 @@-name: xml-enumerator-version: 0.2.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--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 && < 0.4- , 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+name: xml-enumerator +version: 0.3.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.3 && < 0.4 + , attoparsec-text-enumerator >= 0.2 && < 0.3 + , attoparsec-text >= 0.8.2 && < 0.9 + , blaze-builder >= 0.2 && < 0.4 + , 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