xml-enumerator (empty) → 0.0.0
raw patch · 6 files changed
+1053/−0 lines, 6 filesdep +attoparsecdep +attoparsec-enumeratordep +basesetup-changed
Dependencies added: attoparsec, attoparsec-enumerator, base, blaze-builder, blaze-builder-enumerator, bytestring, containers, enumerator, text, transformers, xml-types
Files
- LICENSE +25/−0
- Setup.lhs +7/−0
- Text/XML/Enumerator/Parse.hs +728/−0
- Text/XML/Enumerator/Render.hs +132/−0
- Text/XML/Enumerator/Token.hs +126/−0
- xml-enumerator.cabal +35/−0
+ LICENSE view
@@ -0,0 +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.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ Text/XML/Enumerator/Parse.hs view
@@ -0,0 +1,728 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | This module provides both a native Haskell solution for parsing XML+-- documents into a stream of events, and a set of parser combinators for+-- dealing with a stream of events.+--+-- The important thing to know about the combinators is that they do /not/ work+-- on the fully-powered 'Event' datatype; rather, this module defines an+-- 'SEvent' datatype which only deals with tags, attributes and content. For+-- most uses, this is sufficient. If you need to parse doctypes, instructions+-- or contents, you will not be able to use the combinators.+--+-- As a simple example, if you have the following XML file:+--+-- > <?xml version="1.0" encoding="utf-8"?>+-- > <people>+-- > <person age="25">Michael</person>+-- > <person age="2">Eliezer</person>+-- > </people>+--+-- Then this code:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Text.XML.Enumerator.Parse+-- > import Data.Text.Lazy (Text, unpack)+-- > +-- > data Person = Person { age :: Int, name :: Text }+-- > deriving Show+-- > +-- > parsePerson = tag' "person" (requireAttr "age") $ \age -> do+-- > name <- content'+-- > return $ Person (read $ unpack age) name+-- > +-- > parsePeople = tag'' "people" $ many parsePerson+-- > +-- > main = parseFile_ "people.xml" (const Nothing) $ force "people required" parsePeople+--+-- will produce:+--+-- > [Person {age = 25, name = "Michael"},Person {age = 2, name = "Eliezer"}]+module Text.XML.Enumerator.Parse+ ( -- * Parsing XML files+ parseBytes+ , detectUtf+ -- * Simplified events+ , SEvent (..)+ , simplify+ , SAttr+ , parseFile+ , parseFile_+ -- * SEvent parsing+ , tag+ , tag'+ , tag''+ , content+ , content'+ -- * Attribute parsing+ , AttrParser+ , requireAttr+ , optionalAttr+ , requireAttrRaw+ , optionalAttrRaw+ , ignoreAttrs+ -- * Combinators+ , choose+ , many+ , force+ -- * Exceptions+ , XmlException (..)+ ) where+import Data.Attoparsec hiding (many)+import qualified Data.Attoparsec as A+import Data.Attoparsec.Enumerator+import Data.XML.Types+import Data.Word (Word8)+import Control.Applicative ((<|>), (<$>))+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Lazy (fromChunks, pack, Text)+import qualified Data.Text.Lazy as T+import Data.Text.Encoding.Error (lenientDecode)+import Text.XML.Enumerator.Token+import Prelude hiding (takeWhile)+import qualified Data.ByteString as S+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.Text as E+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.IO (enumFile)+import Control.Monad.IO.Class (liftIO)+import Data.Char (isSpace)++amp, hash, charx, semicolon, char0, char9, charA, charZ, chara, charz+ , colon, equal, squote, dquote, lt, gt, qmark, fslash, exmark, dash+ , lsquare, rsquare+ :: Word8+amp = 38+hash = 35+charx = 120+semicolon = 59+char0 = 48+char9 = 57+charA = 65+charZ = 90+chara = 97+charz = 122+colon = 58+equal = 61+squote = 39+dquote = 34+lt = 60+gt = 62+qmark = 63+fslash = 47+exmark = 33+dash = 45+lsquare = 91+rsquare = 93++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 isAttr (NSLevel def _) (TName Nothing name) =+ Name name (if isAttr then Nothing else def) Nothing+tnameToName _ (NSLevel _ m) (TName (Just pref) name) =+ case Map.lookup pref m of+ Just ns -> Name name (Just ns) (Just pref)+ Nothing -> Name name Nothing (Just pref) -- FIXME is this correct?++-- | Automatically determine which UTF variant is being used. This function+-- first checks for BOMs, removing them as necessary, and then check for the+-- equivalent of <?xml for each of UTF-8, UTF-16LE/BE, and UTF-32LE/BE. It+-- defaults to assuming UTF-8. The output byte stream is guaranteed to be valid+-- UTF-8 bytes.+detectUtf :: Monad m => Enumeratee S.ByteString S.ByteString m a+detectUtf param = do+ x <- takeFourBytes S.empty+ let (toDrop, mcodec) =+ case S.unpack x of+ [0x00, 0x00, 0xFE, 0xFF] -> (4, Just E.utf32_be)+ [0xFF, 0xFE, 0x00, 0x00] -> (4, Just E.utf32_le)+ 0xFE : 0xFF: _ -> (2, Just E.utf16_be)+ 0xFF : 0xFE: _ -> (2, Just E.utf16_le)+ 0xEF : 0xBB: 0xBF : _ -> (3, Nothing)+ [0x00, 0x00, 0x00, 0x3C] -> (0, Just E.utf32_be)+ [0x3C, 0x00, 0x00, 0x00] -> (0, Just E.utf32_le)+ [0x00, 0x3C, 0x00, 0x3F] -> (0, Just E.utf16_be)+ [0x3C, 0x00, 0x3F, 0x00] -> (0, Just E.utf16_le)+ _ -> (0, Nothing) -- Assuming UTF-8+ unless (toDrop == 4) $ yield () $ Chunks [S.drop toDrop x]+ iter <-+ case mcodec of+ Nothing -> return param+ Just codec -> (joinI $ E.decode codec $$ joinI $ E.encode E.utf8 param) >>== return+ E.map id iter+ where+ takeFourBytes front = do+ x <- E.head+ case x of+ Nothing -> return front+ Just y -> do+ let z = S.append front y+ if S.length z < 4+ then takeFourBytes z+ else do+ let (a, b) = S.splitAt 4 z+ E.yield a $ Chunks [b]++-- | Parses a UTF8-encoded byte stream into 'Event's. This function is+-- implemented fully in Haskell using attoparsec 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.+--+-- If you are uncertain of the character encoding, use the 'detectUtf'+-- enumeratee.+parseBytes :: Monad m => Enumeratee S.ByteString Event m a+parseBytes =+ 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 S.ByteString m (Maybe Token)+iterToken = iterParser ((endOfInput >> return Nothing) <|> fmap Just parseToken)++parseToken :: Parser Token+parseToken = do+ (word8 lt >> parseLt) <|> fmap TokenContent (parseContent False False)+ where+ parseLt =+ (word8 qmark >> parseInstr) <|>+ (word8 exmark >> (parseComment <|> parseCdata <|> parseDoctype)) <|>+ (word8 fslash >> parseEnd) <|>+ parseBegin+ parseInstr = do+ name <- parseIdent+ if name == "xml"+ then do+ as <- A.many parseAttribute+ skipSpace+ word8' qmark+ word8' gt+ newline <|> return ()+ return $ TokenBeginDocument as+ else do+ skipSpace+ x <- toText <$> takeWhile (/= qmark)+ word8' qmark+ word8' gt+ return $ TokenInstruction $ Instruction name x+ parseComment = do+ word8' dash+ word8' dash+ c <- toText . S.pack <$> manyTill anyWord8 (string "-->") -- FIXME use takeWhile instead+ return $ TokenComment c+ parseCdata = do+ _ <- string "[CDATA["+ t <- toText . S.pack <$> manyTill anyWord8 (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+ word8' lsquare+ skipWhile (/= rsquare)+ word8' rsquare+ skipSpace) <|> return ()+ word8' gt+ newline+ 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+ toText <$> (between dquote <|> between squote)+ between c = do+ word8' c+ x <- takeWhile (/=c)+ word8' c+ return x+ parseEnd = do+ skipSpace+ n <- parseName+ skipSpace+ word8' gt+ return $ TokenEndElement n+ parseBegin = do+ skipSpace+ n <- parseName+ as <- A.many parseAttribute+ skipSpace+ isClose <- (word8 fslash >> skipSpace >> return True) <|> return False+ word8' gt+ return $ TokenBeginElement n as isClose++parseAttribute :: Parser TAttribute+parseAttribute = do+ skipSpace+ key <- parseName+ skipSpace+ word8' equal+ skipSpace+ val <- squoted <|> dquoted+ return (key, val)+ where+ squoted = do+ word8' squote+ manyTill (parseContent False True) (word8 squote)+ dquoted = do+ word8' dquote+ manyTill (parseContent True False) (word8 dquote)++parseName :: Parser TName+parseName = do+ i1 <- parseIdent+ mi2 <- (word8 colon >> fmap Just parseIdent) <|> return Nothing+ return $+ case mi2 of+ Nothing -> TName Nothing i1+ Just i2 -> TName (Just i1) i2++parseIdent :: Parser Text+parseIdent =+ toText <$> takeWhile1 valid+ where+ valid 38 = False -- amp+ valid 60 = False -- lt+ valid 62 = False -- gt+ valid 58 = False -- colon+ valid 63 = False -- qmark+ valid 61 = False -- equal+ valid 34 = False -- dquote+ valid 39 = False -- squote+ valid 47 = False -- fslash+ valid c = not $ isSpaceW c++isSpaceW :: Word8 -> Bool+isSpaceW 0x09 = True+isSpaceW 0x0A = True+isSpaceW 0x0D = True+isSpaceW 0x20 = True+isSpaceW _ = False++parseContent :: Bool -- break on double quote+ -> Bool -- break on single quote+ -> Parser Content+parseContent breakDouble breakSingle =+ parseEntity <|> parseText+ where+ parseEntity = do+ word8' amp+ parseEntityNum <|> parseEntityWord+ parseEntityNum = do+ word8' hash+ w <- parseEntityHex <|> parseEntityDig+ return $ ContentText $ pack [toEnum w]+ parseEntityHex = do+ word8' charx+ res <- hexadecimal+ word8' semicolon+ return res+ hexadecimal = do+ x <- hex+ hexadecimal' $ fromIntegral x+ hexadecimal' x = (do+ y <- hex+ hexadecimal' $ x * 16 + fromIntegral y+ ) <|> return x+ hex = satisfyWith hex' (< 16)+ hex' w+ | char0 <= w && w <= char9 = w - char0+ | charA <= w && w <= charZ = w - charA + 10+ | chara <= w && w <= charz = w - chara + 10+ | otherwise = 16 -- failing case+ parseEntityDig = do+ res <- decimal+ word8' semicolon+ return res+ decimal = do+ x <- dig+ decimal' $ fromIntegral x+ decimal' x = (do+ y <- dig+ decimal' $ x * 10 + fromIntegral y+ ) <|> return x+ dig = satisfyWith dig' (< 10)+ dig' w+ | char0 <= w && w <= char9 = w - char0+ | otherwise = 10 -- failing case+ parseEntityWord = do+ s <- takeWhile1 (/= semicolon)+ word8' semicolon+ return $ case s of+ _+ | s == "amp" -> ContentText "&"+ | s == "gt" -> ContentText ">"+ | s == "lt" -> ContentText "<"+ | s == "apos" -> ContentText "'"+ | s == "quot" -> ContentText "\""+ | otherwise ->+ ContentEntity $ toText s+ parseText = do+ bs <- takeWhile1 valid+ return $ ContentText $ toText bs+ valid 34 = not breakDouble+ valid 39 = not breakSingle+ valid 38 = False -- amp+ valid 60 = False -- lt+ valid _ = True++toText :: S.ByteString -> Text+toText = fromChunks . return+ . TS.replace "\r\n" "\n" -- FIXME do this more efficiently+ . decodeUtf8With lenientDecode++skipSpace :: Parser ()+skipSpace = skipWhile isSpaceW++newline :: Parser ()+newline = ((word8 13 >> word8 10) <|> word8 10) >> return ()++word8' :: Word8 -> Parser ()+word8' c = word8 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) -> E.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+ E.drop 1+ z' <- f z+ a <- dropWS+ case a of+ Just SEndElement -> E.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 -> E.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' :: 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)++-- | A further simplified tag parser, which requires that no attributes exist.+tag'' :: Monad m => Name -> Iteratee SEvent m a -> Iteratee SEvent m (Maybe a)+tag'' name f = tag' name (return ()) $ const f++-- | 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 <- E.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+ E.drop 1+ t <- contentToText c+ takeContents $ front . (:) t+ Just EventBeginDocument -> takeContents front+ Just EventEndDocument -> takeContents front+ Just EventInstruction{} -> takeContents front+ Just EventDoctype{} -> takeContents front+ Just EventComment{} -> 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+ $ detectUtf $$ 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
+ Text/XML/Enumerator/Render.hs view
@@ -0,0 +1,132 @@+{-# 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+ ) where++import Data.XML.Types ( Event (..), Content (..), Name (..), Attribute (..)+ , Doctype (..))+import Text.XML.Enumerator.Token+import qualified Data.Enumerator as E+import Data.Enumerator ((>>==), ($$))+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.+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 '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 <- E.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+ E.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)) =+ (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 ppref nsmap ns =+ case Map.lookup ns nsmap of+ Just pref -> (pref, id)+ Nothing ->+ let pref = findUnused ppref $ Map.elems nsmap+ in (pref, (:) (TName (Just "xmlns") pref, [ContentText ns]))+ where+ findUnused x xs+ | x `elem` xs = findUnused (x `T.snoc` '_') xs+ | otherwise = x
+ Text/XML/Enumerator/Token.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.XML.Enumerator.Token+ ( tokenToBuilder+ , TName (..)+ , Token (..)+ , TAttribute+ , NSLevel (..)+ ) where++import Data.XML.Types (Instruction (..), Content (..), ExternalID (..))+import qualified Data.Text.Lazy as T+import Data.Text.Lazy (Text)+import Data.String (IsString (fromString))+import Blaze.ByteString.Builder (Builder, fromByteString, writeByteString)+import Blaze.ByteString.Builder.Internal.Write (fromWriteList)+import Blaze.ByteString.Builder.Char.Utf8 (writeChar, fromLazyText)+import Data.Monoid (mconcat, mempty)+import Data.ByteString.Char8 ()+import Data.Map (Map)++data Token = TokenBeginDocument [TAttribute]+ | TokenInstruction Instruction+ | TokenBeginElement TName [TAttribute] Bool+ | TokenEndElement TName+ | TokenContent Content+ | TokenComment Text+ | TokenDoctype Text (Maybe ExternalID)+ deriving Show+tokenToBuilder :: Token -> Builder+tokenToBuilder (TokenBeginDocument attrs) =+ mconcat $ fromByteString "<?xml" : foldAttrs attrs [fromByteString "?>\n"]+tokenToBuilder (TokenInstruction (Instruction target data_)) = mconcat+ [ fromByteString "<?"+ , fromLazyText target+ , fromByteString " "+ , fromLazyText data_+ , fromByteString "?>"+ ]+tokenToBuilder (TokenBeginElement name attrs isEmpty) = mconcat+ $ fromByteString "<"+ : tnameToText name+ : foldAttrs attrs+ [ if isEmpty then fromByteString "/>" else fromByteString ">"+ ]+tokenToBuilder (TokenEndElement name) = mconcat+ [ fromByteString "</"+ , tnameToText name+ , fromByteString ">"+ ]+tokenToBuilder (TokenContent c) = contentToText c+tokenToBuilder (TokenComment t) = mconcat [fromByteString "<!--", fromLazyText t, fromByteString "-->"]+tokenToBuilder (TokenDoctype name eid) = mconcat+ [ fromByteString "<!DOCTYPE "+ , fromLazyText name+ , go eid+ , fromByteString ">\n"+ ]+ where+ go Nothing = mempty+ go (Just (SystemID uri)) = mconcat+ [ fromByteString " SYSTEM \""+ , fromLazyText uri+ , fromByteString "\""+ ]+ go (Just (PublicID pid uri)) = mconcat+ [ fromByteString " PUBLIC \""+ , fromLazyText pid+ , fromByteString "\" \""+ , fromLazyText uri+ , fromByteString "\""+ ]++data TName = TName (Maybe Text) Text+ deriving Show++tnameToText :: TName -> Builder+tnameToText (TName Nothing name) = fromLazyText name+tnameToText (TName (Just prefix) name) = mconcat [fromLazyText prefix, fromByteString ":", fromLazyText name]++contentToText :: Content -> Builder+contentToText (ContentText t) =+ fromWriteList go $ T.unpack t+ where+ go '<' = writeByteString "<"+ go '>' = writeByteString ">"+ go '&' = writeByteString "&"+ -- Not escaping quotes, since this is only called outside of attributes+ go c = writeChar c+contentToText (ContentEntity e) = mconcat+ [ fromByteString "&"+ , fromLazyText e+ , fromByteString ";"+ ]++type TAttribute = (TName, [Content])++foldAttrs :: [TAttribute] -> [Builder] -> [Builder]+foldAttrs attrs rest' =+ foldr go rest' attrs+ where+ go (key, val) rest =+ fromByteString " "+ : tnameToText key+ : fromByteString "=\""+ : foldr go' (fromByteString "\"" : rest) val+ go' (ContentText t) rest =+ fromWriteList h (T.unpack t) : rest+ where+ h '<' = writeByteString "<"+ h '>' = writeByteString ">"+ h '&' = writeByteString "&"+ h '"' = writeByteString """+ -- Not escaping single quotes, since our attributes are always double+ -- quoted+ h c = writeChar c+ go' (ContentEntity t) rest =+ fromByteString "&" : fromLazyText t : fromByteString ";" : rest++instance IsString TName where+ fromString = TName Nothing . T.pack++data NSLevel = NSLevel+ { defaultNS :: Maybe Text+ , prefixes :: Map Text Text+ }+ deriving Show
+ xml-enumerator.cabal view
@@ -0,0 +1,35 @@+name: xml-enumerator+version: 0.0.0+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michaels@suite-sol.com>+maintainer: Michael Snoyman <michaels@suite-sol.com>+synopsis: Pure-Haskell utilities for dealing with XML with the enumerator package.+description:+ Provides the ability to parse and render XML in a streaming manner using the enumerator package.+category: Web+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 && < 0.5+ , bytestring >= 0.9 && < 0.10+ , text >= 0.7 && < 0.12+ , containers >= 0.2 && < 0.5+ , xml-types >= 0.1 && < 0.2+ , attoparsec-enumerator >= 0.2.0.3 && < 0.3+ , attoparsec >= 0.8 && < 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+ other-modules: Text.XML.Enumerator.Token+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/snoyberg/xml-enumerator.git