xml-enumerator 0.2.0.2 → 0.2.1
raw patch · 3 files changed
+513/−66 lines, 3 filesdep ~blaze-builder
Dependency ranges changed: blaze-builder
Files
- Text/XML/Enumerator/Parse.hs +198/−54
- runtests.hs +313/−10
- xml-enumerator.cabal +2/−2
Text/XML/Enumerator/Parse.hs view
@@ -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
runtests.hs view
@@ -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 (@?=("<E0><E1><E11/><E12/></E1><E3/></E0><E2/>", [EventEndElement "root"])) $ + resI (P.processSiblings renderTextI) (drop 1 testData) 1+ testProcElem = join $ fmap (@?=(Just "<E0><E1><E11/><E12/></E1><E3/></E0>", dropWhile (/=EventBeginElement "E2" mempty) testData)) $ + resI (P.processElem renderTextI) (drop 1 testData) 1+ renderTextI = E.joinI $ R.renderText $$ E.foldl' mappend mempty+ + testData = [+ EventBeginElement "root" mempty+ , EventBeginElement "E0" mempty+ , EventBeginElement "E1" mempty+ , EventBeginElement "E11" mempty+ , EventEndElement "E11"+ , EventBeginElement "E12" mempty+ , EventEndElement "E12"+ , EventEndElement "E1"+ , EventBeginElement "E3" mempty+ , EventEndElement "E3"+ , EventEndElement "E0"+ , EventBeginElement "E2" mempty+ , EventEndElement "E2"+ , EventEndElement "root"+ ]+ resI i xs n = E.run_ $ E.enumList n xs $$ (i >>= \r-> EL.consume >>= \c -> return (r,c))+ cmpI i xs n = liftM2 (==) (resI i xs n) (resI i xs $ n+1)+ testI :: (Eq t, Eq a) => E.Iteratee a IO t -> [a] -> IO ()+ testI i xs = assert $ fmap and $ mapM (cmpI i xs) [1..20] + documentParseRender = mapM_ go docs where@@ -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+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "<ignore>"+ , "<nested>"+ , "<fail/>"+ , "</nested>"+ , "</ignore>\n"+ , "</hello>"+ ]+ ++testChoose = P.parseLBS_ input decodeEntities $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.tagNoAttr "failure" $ return 1+ , P.tagNoAttr "success" $ return 2+ ]+ liftIO $ x @?= Just 2 where input = L.concat [ "<?xml version='1.0'?>\n" , "<!DOCTYPE foo []>\n" , "<hello>" , "<success/>"- , "<ignore>"- , "<nested>"- , "<fail/>"- , "</nested>"- , "</ignore>\n"+ , "</hello>"+ ]++testMany = P.parseLBS_ input decodeEntities $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.many $ P.tagNoAttr "success" $ return ()+ liftIO $ length x @?= 5+ where+ input = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "</hello>"+ ]++testOrE = P.parseLBS_ input decodeEntities $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.tagNoAttr "failure" (return 1) `P.orE`+ P.tagNoAttr "success" (return 2)+ liftIO $ x @?= Just 2+ where+ input = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "</hello>"+ ]++testChooseSplit = P.parseLBS_ input decodeEntities $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.chooseSplit (\t-> P.tagNoAttr t (return t)) ["a", "b", "c"]+ liftIO $ x @?= Just ("b",["a","c"])+ where+ input = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<b/>"+ , "</hello>"+ ]++testPermute + = do+ let frame input = P.parseLBS_ input decodeEntities $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ + P.permute (\t -> P.tagNoAttr t (return t)) ["a", "b"]+ frame input1 >>= \result1 -> result1 @?= Just ["a", "b"]+ frame input2 >>= \result2 -> result2 @?= Just ["b", "a"]+ frame input3 >>= \result3 -> result3 @?= Nothing+ C.try (frame input4) >>= \result4 -> case result4 of+ Left (P.XmlException { + P.xmlBadInput = Just (EventBeginElement + Name { + nameLocalName = "c"+ , nameNamespace = Nothing+ , namePrefix = Nothing + }+ _) + }) -> return () -- right type of error+ Left _ -> assertFailure "wrong error"+ Right _ -> assertFailure "erroneous document requires an error"+ where+ input1 = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<a/>"+ , "<b/>"+ , "</hello>"+ ]+ input2 = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<b/>"+ , "<a/>"+ , "</hello>"+ ]+ input3 = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<a/>"+ , "</hello>"+ ]+ input4 = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<a/>"+ , "<c/>"+ , "</hello>"+ ]++testPermuteFallback+ = do+ let frame input = P.parseLBS_ input decodeEntities $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ + P.permuteFallback (fmap return `fmap` P.contentMaybe) + (\t -> P.tagNoAttr t (return $ nameLocalName t)) + ["a", "b"]+ frame input1 >>= \result1 -> result1 @?= Just ["a", "t", "b"]+ frame input2 >>= \result2 -> result2 @?= Just ["t", "b", "a"]+ frame input3 >>= \result3 -> result3 @?= Nothing+ C.try (frame input4) >>= \result4 -> case result4 of+ Left (P.XmlException { + P.xmlBadInput = Just (EventBeginElement + Name { + nameLocalName = "c"+ , nameNamespace = Nothing+ , namePrefix = Nothing + }+ _) + }) -> return () -- right type of error+ Left _ -> assertFailure "wrong error"+ Right _ -> assertFailure "erroneous document requires an error"+ where+ input1 = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<a/>"+ , "t"+ , "<b/>"+ , "</hello>"+ ]+ input2 = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "t"+ , "<b/>"+ , "<a/>"+ , "</hello>"+ ]+ input3 = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<a/>"+ , "</hello>"+ ]+ input4 = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<a/>"+ , "<c/>"+ , "</hello>"+ ]++testTags = P.parseLBS_ input decodeEntities $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.tags (\state name -> do + let n = nameLocalName name+ guard (n == fromString [chr $ ord 'a' + state]) + Just (return (), \_ -> return (state + 1, Just n)))+ (const $ return Nothing)+ 0+ liftIO $ x @?= (5, ["a", "b", "c", "d", "e"])+ where+ input = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<a/>"+ , "<b/>"+ , "<c/>"+ , "<d/>"+ , "<e/>"+ , "</hello>"+ ]+++testTagsPermute = P.parseLBS_ input decodeEntities $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ let p c = (return (), \_ -> return (Just c))+ x <- P.tagsPermute (toLower . nameLocalName) + (Map.fromList $ map (\c -> (c, p c)) + ["a", "b", "c", "d", "e"])+ (return Nothing)+ liftIO $ x @?= Just ["d", "b", "e", "a", "c"]+ where+ input = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<d/>"+ , "<b/>"+ , "<E/>"+ , "<a/>"+ , "<C/>" , "</hello>" ]
xml-enumerator.cabal view
@@ -1,5 +1,5 @@ name: xml-enumerator-version: 0.2.0.2+version: 0.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michaels@suite-sol.com>@@ -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