diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -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.
diff --git a/Setup.lhs b/Setup.lhs
--- a/Setup.lhs
+++ b/Setup.lhs
@@ -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
diff --git a/Text/XML/Enumerator/Document.hs b/Text/XML/Enumerator/Document.hs
--- a/Text/XML/Enumerator/Document.hs
+++ b/Text/XML/Enumerator/Document.hs
@@ -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
diff --git a/Text/XML/Enumerator/Parse.hs b/Text/XML/Enumerator/Parse.hs
--- a/Text/XML/Enumerator/Parse.hs
+++ b/Text/XML/Enumerator/Parse.hs
@@ -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:
---
--- >
--- >
--- > Michael
--- > Eliezer
--- >
---
--- 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 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:
+--
+-- >
+-- >
+-- > Michael
+-- > Eliezer
+-- >
+--
+-- 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 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
diff --git a/Text/XML/Enumerator/Render.hs b/Text/XML/Enumerator/Render.hs
--- a/Text/XML/Enumerator/Render.hs
+++ b/Text/XML/Enumerator/Render.hs
@@ -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
diff --git a/Text/XML/Enumerator/Token.hs b/Text/XML/Enumerator/Token.hs
--- a/Text/XML/Enumerator/Token.hs
+++ b/Text/XML/Enumerator/Token.hs
@@ -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 "\n"]
-tokenToBuilder (TokenInstruction (Instruction target data_)) = mconcat
- [ fromByteString ""
- ]
-tokenToBuilder (TokenBeginElement name attrs isEmpty) = mconcat
- $ fromByteString "<"
- : tnameToText name
- : foldAttrs attrs
- [ if isEmpty then fromByteString "/>" else fromByteString ">"
- ]
-tokenToBuilder (TokenEndElement name) = mconcat
- [ fromByteString ""
- ]
-tokenToBuilder (TokenContent c) = contentToText c
-tokenToBuilder (TokenCDATA t) =
- copyByteString ""
-tokenToBuilder (TokenComment t) = mconcat [fromByteString ""]
-tokenToBuilder (TokenDoctype name eid) = mconcat
- [ 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 "\n")
+tokenToBuilder (TokenInstruction (Instruction target data_)) = mconcat
+ [ 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 ""
+ ]
+tokenToBuilder (TokenContent c) = contentToText c
+tokenToBuilder (TokenCDATA t) =
+ copyByteString ""
+tokenToBuilder (TokenComment t) = mconcat [fromByteString ""]
+tokenToBuilder (TokenDoctype name eid) = mconcat
+ [ 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
diff --git a/runtests.hs b/runtests.hs
--- a/runtests.hs
+++ b/runtests.hs
@@ -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 (@?=("", [EventEndElement "root"])) $
- resI (P.processSiblings renderTextI) (drop 1 testData) 1
- testProcElem = join $ fmap (@?=(Just "", 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_
- "\n\n"
- decodeEntities
- , D.parseLBS_
- "\n\n&ignore;"
- decodeEntities
- , D.parseLBS_
- "]]>"
- decodeEntities
- , D.parseLBS_
- ""
- decodeEntities
- , D.parseLBS_
- ""
- decodeEntities
- , D.parseLBS_
- ""
- 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 &content"
- where
- input = L.concat
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- , ""
- , " "
- , "combine <all> \n"
- , ""
- ]
-
-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
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- , ""
- , ""
- , ""
- , "\n"
- , ""
- ]
-
-
-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
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- ]
-
-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
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- , ""
- , ""
- , ""
- , ""
- ]
-
-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
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- ]
-
-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
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- ]
-
-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
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- , ""
- ]
- input2 = L.concat
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- , ""
- ]
- input3 = L.concat
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- ]
- input4 = L.concat
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- , ""
- ]
-
-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
- [ "\n"
- , "\n"
- , ""
- , ""
- , "t"
- , ""
- , ""
- ]
- input2 = L.concat
- [ "\n"
- , "\n"
- , ""
- , "t"
- , ""
- , ""
- , ""
- ]
- input3 = L.concat
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- ]
- input4 = L.concat
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- , ""
- ]
-
-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
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- , ""
- , ""
- , ""
- , ""
- ]
-
-
-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
- [ "\n"
- , "\n"
- , ""
- , ""
- , ""
- , ""
- , ""
- , ""
- , ""
- ]
+{-# 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_
+ "\n\n"
+ decodeEntities
+ , D.parseLBS_
+ "\n\n&ignore;"
+ decodeEntities
+ , D.parseLBS_
+ "]]>"
+ decodeEntities
+ , D.parseLBS_
+ ""
+ decodeEntities
+ , D.parseLBS_
+ ""
+ decodeEntities
+ , D.parseLBS_
+ ""
+ 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 &content"
+ where
+ input = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ , ""
+ , " "
+ , "combine <all> \n"
+ , ""
+ ]
+
+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
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ ]
+
+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
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ ]
+
+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
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ ]
diff --git a/xml-enumerator.cabal b/xml-enumerator.cabal
--- a/xml-enumerator.cabal
+++ b/xml-enumerator.cabal
@@ -1,47 +1,47 @@
-name: xml-enumerator
-version: 0.2.1.3
-license: BSD3
-license-file: LICENSE
-author: Michael Snoyman
-maintainer: Michael Snoyman
-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
+maintainer: Michael Snoyman
+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