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