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,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE RankNTypes #-}
-- | This module provides both a native Haskell solution for parsing XML
-- documents into a stream of events, and a set of parser combinators for
-- dealing with a stream of events.
@@ -46,10 +47,15 @@
, decodeEntities
-- * Event parsing
, tag
+ , tagPredicate
, tagName
, tagNoAttr
+ , tags
+ , tagsPermute
, content
, contentMaybe
+ , processElem
+ , processSiblings
, ignoreElem
, ignoreSiblings
-- * Attribute parsing
@@ -60,8 +66,15 @@
, optionalAttrRaw
, ignoreAttrs
, skipAttrs
+ , parseAttrsT
+ , parseAttrsS
+ , parseAttrsST
-- * Combinators
+ , orE
, choose
+ , chooseSplit
+ , permute
+ , permuteFallback
, many
, force
, skipTill
@@ -80,6 +93,7 @@
, Instruction (..), ExternalID (..)
)
import Control.Applicative ((<|>), (<$>))
+import Control.Arrow (second)
import Data.Text (Text)
import qualified Data.Text as T
import Text.XML.Enumerator.Token
@@ -87,6 +101,7 @@
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
+import qualified Data.Set as Set
import Data.Enumerator
( Iteratee, Enumeratee, (>>==), Stream (..), run_, Enumerator, Step (..)
, checkDone, yield, ($$), joinI, run, throwError, returnI
@@ -95,7 +110,7 @@
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 Control.Monad (unless, ap, liftM, guard)
import qualified Data.Text as TS
import Data.List (foldl')
import Control.Applicative (Applicative (..))
@@ -103,7 +118,10 @@
import Control.Exception (Exception, throwIO, SomeException)
import Data.Enumerator.Binary (enumFile)
import Control.Monad.IO.Class (liftIO)
+import Control.Monad(liftM2)
+import Control.Arrow((***))
import Data.Char (isSpace)
+import Data.Maybe(fromJust)
tokenToEvent :: [NSLevel] -> Token -> ([NSLevel], [Event])
tokenToEvent n (TokenBeginDocument _) = (n, [])
@@ -464,6 +482,10 @@
Right ([], x) -> Right x
Right (attr, _) -> Left $ UnparsedAttributes attr
+-- | A simplified version of 'tag' which matches against boolean predicates.
+tagPredicate :: Monad m => (Name -> Bool) -> AttrParser a -> (a -> Iteratee Event m b) -> Iteratee Event m (Maybe b)
+tagPredicate p attrParser = tag (\x -> if p x then Just () else Nothing) (const attrParser)
+
-- | A simplified version of 'tag' which matches for specific tag names instead
-- of taking a predicate function. This is often sufficient, and when combined
-- with OverloadedStrings and the IsString instance of 'Name', can prove to be
@@ -473,16 +495,75 @@
-> 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)
+tagName name = tagPredicate (== name)
-- | A further simplified tag parser, which requires that no attributes exist.
tagNoAttr :: Monad m => Name -> Iteratee Event m a -> Iteratee Event m (Maybe a)
tagNoAttr name f = tagName name (return ()) $ const f
+-- | Statefully and efficiently parse a list of tags.
+--
+-- The first parameter is a function that, given state and an element name, returns
+-- either 'Nothing', to indicate that the element is invalid, or a pair of attribute
+-- and element content parsers in 'Just'.
+--
+-- The second parameter is a function that, given the current state, returns a
+-- "fallback" parser to be executed when no valid element has been found.
+--
+-- The third parameter is the initial state.
+--
+-- This function updates the state as it goes along, but it also accumulates a list of
+-- elements as they occur.
+tags :: (Monad m)
+ => (a -> Name -> Maybe (AttrParser b, b -> Iteratee Event m (a, Maybe c)))
+ -> (a -> Iteratee Event m (Maybe (a, Maybe c)))
+ -> a
+ -> Iteratee Event m (a, [c])
+tags f fb s' = go s'
+ where go s = do
+ t <- tag (f s) (\(attr, sub) -> sub <$> attr) id `orE` fb s
+ case t of
+ Nothing -> return (s, [])
+ Just (s2, Nothing) -> go s2
+ Just (s2, Just a) -> second (a:) `fmap` go s2
+
+-- | Parse a permutation of tags.
+--
+-- The first parameter is a function to preprocess Names for equality testing, because
+-- sometimes XML documents contain inconsistent naming. This allows the user to deal
+-- with it.
+--
+-- The second parameter is a map of tags to attribute and element content parsers.
+--
+-- The third parameter is a fallback parser.
+--
+-- This function accumulates a list of elements for each step that produces one.
+tagsPermute :: (Monad m, Ord a)
+ => (Name -> a)
+ -> Map.Map a (AttrParser b, b -> Iteratee Event m (Maybe c))
+ -> Iteratee Event m (Maybe c)
+ -> Iteratee Event m (Maybe [c])
+tagsPermute f m fb = do
+ (rest, result) <- tags go (\s -> fmap (\a -> (s, Just a)) <$> fb) m
+ return (guard (Map.null rest) >> Just result)
+ where go s name = case Map.lookup k s of
+ Nothing -> Nothing
+ Just (attr, sub) -> Just (attr, fmap adaptSub . sub)
+ where k = f name
+ adaptSub Nothing = (s, Nothing)
+ adaptSub a = (Map.delete k s, a)
+
-- | Get the value of the first parser which returns 'Just'. If no parsers
-- succeed (i.e., return 'Just'), this function returns 'Nothing'.
+orE :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a)
+orE a b = do
+ x <- a
+ case x of
+ Nothing -> b
+ _ -> return x
+
+-- | Get the value of the first parser which returns 'Just'. If no parsers
+-- succeed (i.e., return 'Just'), this function returns 'Nothing'.
choose :: Monad m
=> [Iteratee Event m (Maybe a)]
-> Iteratee Event m (Maybe a)
@@ -493,6 +574,45 @@
Nothing -> choose is
Just a -> return $ Just a
+-- | Like 'choose', but also returns the list of elements that were /not/ chosen.
+chooseSplit :: (Monad m)
+ => (a -> Iteratee Event m (Maybe b)) -- ^ Element-specific parsers
+ -> [a] -- ^ Elements to choose from
+ -> Iteratee Event m (Maybe (b, [a]))
+chooseSplit f xs = go xs []
+ where
+ go [] _ = return Nothing
+ go (i:is) is' = do
+ x <- f i
+ case x of
+ Nothing -> go is (i : is')
+ Just a -> return $ Just (a, is' ++ is)
+
+-- | Permute all parsers until none return 'Just'.
+permute :: Monad m => (a -> Iteratee Event m (Maybe b)) -> [a] -> Iteratee Event m (Maybe [b])
+permute _ [] = return (Just [])
+permute f is = do
+ x <- chooseSplit f is
+ case x of
+ Nothing -> return Nothing
+ Just (a, is') -> fmap (a:) `fmap` permute f is'
+
+-- | Permute all parsers until none return 'Just', but always test some fallback parsers.
+permuteFallback :: (Monad m)
+ => Iteratee Event m (Maybe [b])
+ -> (a -> Iteratee Event m (Maybe b))
+ -> [a]
+ -> Iteratee Event m (Maybe [b])
+permuteFallback fb _ [] = return (Just [])
+permuteFallback fb f is = do
+ x <- chooseSplit f is
+ case x of
+ Nothing -> do y <- fb
+ case y of
+ Nothing -> return Nothing
+ Just as -> fmap (as ++) `fmap` permuteFallback fb f is
+ Just (a, is') -> fmap (a:) `fmap` permuteFallback fb f is'
+
-- | Force an optional parser into a required parser. All of the 'tag'
-- functions, 'choose' and 'many' deal with 'Maybe' parsers. Use this when you
-- want to finally force something to happen.
@@ -622,65 +742,76 @@
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
+-- Internal Iteratee used in processSiblings and processElem
+processNested :: (Monad m) => Bool -> Iteratee Event m b -> Iteratee Event m (Maybe b)
+processNested isElem k0 = E.continue (loop (Just []) k0)
+ where
+ loop :: (Monad m) => Maybe [Name] -> Iteratee Event m b -> Stream Event -> Iteratee Event m (Maybe b)
+ loop ns k (Chunks xs) =
+ case (isElem, skipNames ns [] xs) of
+ (_, (Nothing, _, _)) -> E.yield Nothing (Chunks xs)
+ (True, (Just [], ts, xs')) -> yield ts xs'
+ (False, (ns', ts, [])) -> continue ns' ts
+ (False, (Just [], ts, xs')) -> yield ts xs'
+ (True, (ns', ts, [])) -> continue ns' ts
+ (_, (Just [n1,n2], _, _)) -> throwError $ XmlException ("Unbalanced xml-tree. Name '" ++ show n1 ++ "' is not corresponding to '"
+ ++ show n2 ++ "'. (Error in skipSiblings)") (Just $ EventEndElement n2)
+ _ -> throwError $ XmlException "Unknown error. (Error in skipSiblings)" Nothing
+ where
+ continue ns' ts = E.continue (loop ns' $ E.enumList 1 ts $$ k)
+ yield ts xs' = do
+ t <- E.Iteratee $ liftM (flip E.Yield (Chunks [])) $ E.run $ E.enumList 1 ts $$ k
+ case t of
+ Left err -> throwError err
+ Right t' -> E.yield (Just t') (Chunks xs')
--- | 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 ())
+ skipNames :: Maybe [Name] -> [Event] -> [Event] -> (Maybe [Name], [Event], [Event])
+ skipNames ns0 ts0 es0 = go ns0 ts0 es0
+ where
+ go ns ts [] = (ns,ts,[])
+ go Nothing _ _ = (ns0,ts0,es0)
+ go (Just ns) ts xxs@(x:xs) =
+ case x of
+ (EventBeginElement n _) -> go (Just $ n:ns) (ts ++ [x]) xs
+ (EventEndElement n)
+ | isElem && null (tail ns) -> (Just [], ts ++ [x], xs)
+ | isElem && null ns -> (Nothing, ts, xxs)
+ | not isElem && null ns -> (Just [], ts, xxs)
+ -- | null (if isElem then tail ns else ns) -> (Just [], if isElem then ts ++ [x] else ts, (f xxs))
+ | n == head ns -> go (Just $ tail ns) (ts ++ [x]) xs
+ | otherwise -> (Just [head ns, n], ts, xxs)
+ _ -> go (Just ns) (ts ++ [x]) xs
+ loop _ _ EOF = throwError $ XmlException "Unbalanced xml-tree. (Error in skipSiblings - EOF)" Nothing
+
+
+-- | Iteratee to process sibling elements in separate iteratee.
+processSiblings :: (Monad m) => Iteratee Event m b -> Iteratee Event m b
+processSiblings = liftM fromJust . processNested False
--- | Iteratee to skip the siblings element.
-ignoreSiblings' :: Monad m => Iteratee Event m [()]
-ignoreSiblings' = many (choose [ignoreElem', ignoreContent])
--}
+-- | Iteratee to process sibling elements in separate iteratee.
+processElem :: (Monad m) => Iteratee Event m b -> Iteratee Event m (Maybe b)
+processElem = processNested True
+
+iterIgnore :: (Monad m) => Iteratee a m ()
+iterIgnore = E.returnI $ E.Yield () EOF
-- | Iteratee to skip sibling elements.
ignoreSiblings :: Monad m => Iteratee Event m ()
-ignoreSiblings = 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:xs)) = case x of
- (EventBeginElement _ _) -> case xs of
- (EventEndElement _:_) -> E.continue (loop n)
- _ -> 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
-
+ignoreSiblings = processSiblings iterIgnore
+
-- | Iteratee to skip the next element. Skips all events before the next
--- element as well. Returns 'Nothing' if a element end event is encountered
--- before any element begin events.
-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 _ _) -> case xs of
- (EventEndElement _:_) -> E.continue (loop n)
- _ -> E.continue (loop (n+1))
- (EventEndElement _)
- | n == 0 -> yield Nothing chs -- FIXME in the future, it would probably make more sense to use Bool in place of Maybe ()
- | 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
-
+-- element as well. Returns False if an element's end event is encountered
+-- before any element's begin events.
+ignoreElem :: Monad m => Iteratee Event m Bool
+ignoreElem = liftM (maybe False $ const True) $ processElem iterIgnore
+
-- | Skip the sibling elements until iteratee returns 'Just'.
skipTill :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a)
skipTill i = go
- where
- go = i >>= \x -> case x of
- Nothing -> ignoreElem >>= (\y -> if y == Nothing then return Nothing else go)
- r -> return r
+ where
+ go = i >>= \x -> case x of
+ Nothing -> ignoreElem >>= (\b -> if b then go else return Nothing)
+ _ -> return x
-- | Combinator to skip the siblings element.
skipSiblings :: Monad m => Iteratee Event m a -> Iteratee Event m a
@@ -689,6 +820,19 @@
-- | Combinator to skip the attributes.
skipAttrs :: AttrParser a -> AttrParser a
skipAttrs i = i >>= \r -> ignoreAttrs >> return r
+
+-- | Simple AttrParser utilities
+-- | Parse list of required and list of optional attributes into lists of Text
+parseAttrsT :: [Name] -> [Name] -> AttrParser ([Text], [Maybe Text])
+parseAttrsT reqs opts = liftM2 (,) (mapM requireAttr reqs) (mapM optionalAttr opts)
+
+-- | Parse list of required and list of optional attributes into lists of String
+parseAttrsS :: [Name] -> [Name] -> AttrParser ([String], [Maybe String])
+parseAttrsS reqs opts = fmap (map T.unpack *** map (fmap T.unpack)) (parseAttrsT reqs opts)
+
+-- | Parse part of atrributes into [String] and other part into [Text]
+parseAttrsST :: [Name] -> [Name] -> [Name] -> [Name] -> AttrParser (([String], [Maybe String]), ([Text], [Maybe Text]))
+parseAttrsST reqs opts reqst optst = liftM2 (,) (parseAttrsS reqs opts) (parseAttrsT reqst optst)
type DecodeEntities = Text -> Content
diff --git a/runtests.hs b/runtests.hs
--- a/runtests.hs
+++ b/runtests.hs
@@ -1,25 +1,102 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
-import Test.Hspec
-import Test.Hspec.HUnit
-import Test.HUnit hiding (Test)
-import Data.XML.Types
+import Control.Monad (guard)
+import Control.Monad.IO.Class (liftIO)
+import Data.Char (chr,ord)
+import Data.String (fromString)
+import Data.Text (toLower)
+import Data.XML.Types
+import Test.HUnit hiding (Test)
+import Test.Hspec
+import Test.Hspec.HUnit
+import Text.XML.Enumerator.Parse (decodeEntities)
+import qualified Control.Exception as C
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.Map as Map
import qualified Text.XML.Enumerator.Document as D
+import qualified Text.XML.Enumerator.Parse as P
+
import Text.XML.Enumerator.Parse (decodeEntities)
import qualified Text.XML.Enumerator.Parse as P
+import qualified Text.XML.Enumerator.Render as R
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy.Char8 as L
import Control.Monad.IO.Class (liftIO)
+import qualified Data.Enumerator as E
+import Data.Enumerator(($$))
+import qualified Data.Enumerator.List as EL
+import Data.Monoid
+import Data.Text(Text)
+import Control.Monad.IO.Class(MonadIO)
+import Control.Monad
+import Control.Applicative((<$>), (<*>))
main :: IO ()
-main = hspec $ describe "XML parsing and rendering"
+main = hspec $ fmap concat $ sequence [t0, t1]
+
+t0 = describe "XML parsing and rendering"
[ it "is idempotent to parse and render a document" documentParseRender
, it "has valid parser combinators" combinators
, it "has working ignoreSiblings function" testIgnoreSiblings
+ , it "has working IgnoreElem function" testIgnoreElem
+ , it "has working skipTill function" testSkipTill
+ , it "has working choose function" testChoose
+ , it "has working many function" testMany
+ , it "has working orE" testOrE
+ , it "has working chooseSplit" testChooseSplit
+ , it "has working permute" testPermute
+ , it "has working permuteFallback" testPermuteFallback
+ , it "has working tags" testTags
+ , it "has working tagsPermute" testTagsPermute
]
+
+t1 = fmap concat $ sequence [
+ describe "Checking dependency of chunk size for iteratees" [
+ it "doesn't depend for ignoreSiblings" testSib
+ , it "doesn't depend for ignoreElem" testElem
+ , it "doesn't depend for skipTill" testSkipTill
+ , it "doesn't depend for tag" testTag
+ ],
+ describe "Process nested iteratees. (Launch missiles?..)" [
+ it "can run nested iteratees for siblings. E.g. to render text" testProcSib
+ , it "can run nested iteratees for next element" testProcElem
+ ]
+ ]
+ where
+ testSib = testI P.ignoreSiblings $ drop 2 testData
+ testElem = testI P.ignoreElem $ drop 2 testData
+ testSkipTill = testI (P.skipTill $ P.tagNoAttr "E2" P.ignoreSiblings) $ drop 1 testData
+ testTag = testI (P.tagNoAttr "root" $ P.skipTill $ P.tagNoAttr "E2" P.contentMaybe) testData
+ testProcSib = join $ fmap (@?=("", [EventEndElement "root"])) $
+ resI (P.processSiblings renderTextI) (drop 1 testData) 1
+ testProcElem = join $ fmap (@?=(Just "", dropWhile (/=EventBeginElement "E2" mempty) testData)) $
+ resI (P.processElem renderTextI) (drop 1 testData) 1
+ renderTextI = E.joinI $ R.renderText $$ E.foldl' mappend mempty
+
+ testData = [
+ EventBeginElement "root" mempty
+ , EventBeginElement "E0" mempty
+ , EventBeginElement "E1" mempty
+ , EventBeginElement "E11" mempty
+ , EventEndElement "E11"
+ , EventBeginElement "E12" mempty
+ , EventEndElement "E12"
+ , EventEndElement "E1"
+ , EventBeginElement "E3" mempty
+ , EventEndElement "E3"
+ , EventEndElement "E0"
+ , EventBeginElement "E2" mempty
+ , EventEndElement "E2"
+ , EventEndElement "root"
+ ]
+ resI i xs n = E.run_ $ E.enumList n xs $$ (i >>= \r-> EL.consume >>= \c -> return (r,c))
+ cmpI i xs n = liftM2 (==) (resI i xs n) (resI i xs $ n+1)
+ testI :: (Eq t, Eq a) => E.Iteratee a IO t -> [a] -> IO ()
+ testI i xs = assert $ fmap and $ mapM (cmpI i xs) [1..20]
+
documentParseRender =
mapM_ go docs
where
@@ -73,16 +150,242 @@
P.force "need hello" $ P.tagNoAttr "hello" $ do
P.ignoreSiblings
return ()
+
+testIgnoreElem = P.parseLBS_ input decodeEntities $ do
+ P.force "need hello" $ P.tagNoAttr "hello" $ do
+ P.ignoreElem
+ P.ignoreElem
+ return ()
+
+testSkipTill = P.parseLBS_ input decodeEntities $ do
+ P.force "need hello" $ P.tagNoAttr "hello" $ do
+ P.skipTill (P.tagNoAttr "ignore" P.ignoreSiblings)
+ return ()
+-- where
+input = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ , "\n"
+ , ""
+ ]
+
+
+testChoose = P.parseLBS_ input decodeEntities $ do
+ P.force "need hello" $ P.tagNoAttr "hello" $ do
+ x <- P.choose
+ [ P.tagNoAttr "failure" $ return 1
+ , P.tagNoAttr "success" $ return 2
+ ]
+ liftIO $ x @?= Just 2
where
input = L.concat
[ "\n"
, "\n"
, ""
, ""
- , ""
- , ""
- , ""
- , ""
- , "\n"
+ , ""
+ ]
+
+testMany = P.parseLBS_ input decodeEntities $ do
+ P.force "need hello" $ P.tagNoAttr "hello" $ do
+ x <- P.many $ P.tagNoAttr "success" $ return ()
+ liftIO $ length x @?= 5
+ where
+ input = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ ]
+
+testOrE = P.parseLBS_ input decodeEntities $ do
+ P.force "need hello" $ P.tagNoAttr "hello" $ do
+ x <- P.tagNoAttr "failure" (return 1) `P.orE`
+ P.tagNoAttr "success" (return 2)
+ liftIO $ x @?= Just 2
+ where
+ input = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ ]
+
+testChooseSplit = P.parseLBS_ input decodeEntities $ do
+ P.force "need hello" $ P.tagNoAttr "hello" $ do
+ x <- P.chooseSplit (\t-> P.tagNoAttr t (return t)) ["a", "b", "c"]
+ liftIO $ x @?= Just ("b",["a","c"])
+ where
+ input = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ ]
+
+testPermute
+ = do
+ let frame input = P.parseLBS_ input decodeEntities $ do
+ P.force "need hello" $ P.tagNoAttr "hello" $
+ P.permute (\t -> P.tagNoAttr t (return t)) ["a", "b"]
+ frame input1 >>= \result1 -> result1 @?= Just ["a", "b"]
+ frame input2 >>= \result2 -> result2 @?= Just ["b", "a"]
+ frame input3 >>= \result3 -> result3 @?= Nothing
+ C.try (frame input4) >>= \result4 -> case result4 of
+ Left (P.XmlException {
+ P.xmlBadInput = Just (EventBeginElement
+ Name {
+ nameLocalName = "c"
+ , nameNamespace = Nothing
+ , namePrefix = Nothing
+ }
+ _)
+ }) -> return () -- right type of error
+ Left _ -> assertFailure "wrong error"
+ Right _ -> assertFailure "erroneous document requires an error"
+ where
+ input1 = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ , ""
+ ]
+ input2 = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ , ""
+ ]
+ input3 = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ ]
+ input4 = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ , ""
+ ]
+
+testPermuteFallback
+ = do
+ let frame input = P.parseLBS_ input decodeEntities $ do
+ P.force "need hello" $ P.tagNoAttr "hello" $
+ P.permuteFallback (fmap return `fmap` P.contentMaybe)
+ (\t -> P.tagNoAttr t (return $ nameLocalName t))
+ ["a", "b"]
+ frame input1 >>= \result1 -> result1 @?= Just ["a", "t", "b"]
+ frame input2 >>= \result2 -> result2 @?= Just ["t", "b", "a"]
+ frame input3 >>= \result3 -> result3 @?= Nothing
+ C.try (frame input4) >>= \result4 -> case result4 of
+ Left (P.XmlException {
+ P.xmlBadInput = Just (EventBeginElement
+ Name {
+ nameLocalName = "c"
+ , nameNamespace = Nothing
+ , namePrefix = Nothing
+ }
+ _)
+ }) -> return () -- right type of error
+ Left _ -> assertFailure "wrong error"
+ Right _ -> assertFailure "erroneous document requires an error"
+ where
+ input1 = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , "t"
+ , ""
+ , ""
+ ]
+ input2 = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , "t"
+ , ""
+ , ""
+ , ""
+ ]
+ input3 = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ ]
+ input4 = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ , ""
+ ]
+
+testTags = P.parseLBS_ input decodeEntities $ do
+ P.force "need hello" $ P.tagNoAttr "hello" $ do
+ x <- P.tags (\state name -> do
+ let n = nameLocalName name
+ guard (n == fromString [chr $ ord 'a' + state])
+ Just (return (), \_ -> return (state + 1, Just n)))
+ (const $ return Nothing)
+ 0
+ liftIO $ x @?= (5, ["a", "b", "c", "d", "e"])
+ where
+ input = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ ]
+
+
+testTagsPermute = P.parseLBS_ input decodeEntities $ do
+ P.force "need hello" $ P.tagNoAttr "hello" $ do
+ let p c = (return (), \_ -> return (Just c))
+ x <- P.tagsPermute (toLower . nameLocalName)
+ (Map.fromList $ map (\c -> (c, p c))
+ ["a", "b", "c", "d", "e"])
+ (return Nothing)
+ liftIO $ x @?= Just ["d", "b", "e", "a", "c"]
+ where
+ input = L.concat
+ [ "\n"
+ , "\n"
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
, ""
]
diff --git a/xml-enumerator.cabal b/xml-enumerator.cabal
--- a/xml-enumerator.cabal
+++ b/xml-enumerator.cabal
@@ -1,5 +1,5 @@
name: xml-enumerator
-version: 0.2.0.2
+version: 0.2.1
license: BSD3
license-file: LICENSE
author: Michael Snoyman
@@ -25,7 +25,7 @@
, 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 >= 0.3 && < 0.4
, blaze-builder-enumerator >= 0.2 && < 0.3
, transformers >= 0.2 && < 0.3
exposed-modules: Text.XML.Enumerator.Parse