xml-enumerator-combinators (empty) → 0.1
raw patch · 7 files changed
+503/−0 lines, 7 filesdep +HUnitdep +basedep +bytestringsetup-changed
Dependencies added: HUnit, base, bytestring, containers, enumerator, hspec, text, transformers, xml-enumerator, xml-types
Files
- LICENSE +30/−0
- README +1/−0
- Setup.hs +2/−0
- Text/XML/Enumerator/Combinators/General.hs +41/−0
- Text/XML/Enumerator/Combinators/Tags.hs +136/−0
- runtests.hs +218/−0
- xml-enumerator-combinators.cabal +75/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Aristid Breitkreuz++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.++ * Neither the name of Aristid Breitkreuz nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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+OWNER OR CONTRIBUTORS 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.
+ README view
@@ -0,0 +1,1 @@+Parser combinators for xml-enumerator and compatible XML parsers.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/XML/Enumerator/Combinators/General.hs view
@@ -0,0 +1,41 @@+module Text.XML.Enumerator.Combinators.General+(+ chooseSplit+, permute+, permuteFallback+)+where+ +import Control.Monad (liftM)++-- | Like 'choose', but also returns the list of elements that were /not/ chosen.+chooseSplit :: (Monad m) => (a -> m (Maybe b)) -> [a] -> 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 -> m (Maybe b)) -> [a] -> 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:) `liftM` permute f is'++-- | Permute all parsers until none return 'Just', but always test some fallback parsers.+permuteFallback :: (Monad m) => m (Maybe [b]) -> (a -> m (Maybe b)) -> [a] -> m (Maybe [b])+permuteFallback _ _ [] = 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 ++) `liftM` permuteFallback fb f is+ Just (a, is') -> fmap (a:) `liftM` permuteFallback fb f is'
+ Text/XML/Enumerator/Combinators/Tags.hs view
@@ -0,0 +1,136 @@+module Text.XML.Enumerator.Combinators.Tags+(+ tags+, tagsPermute+, Repetition(..)+, repeatNever+, repeatOnce+, repeatOptional+, repeatMany+, repeatSome+, tagsPermuteRepetition+)+where++import Control.Applicative ((<$>))+import Control.Arrow (second)+import Control.Monad (guard, join)+import Data.XML.Types+import Data.Enumerator (Iteratee)+import qualified Data.Map as Map+import qualified Text.XML.Enumerator.Parse as P++-- | 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 (P.AttrParser b, b -> Iteratee Event m (Maybe (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 <- fmap join (P.tag (f s) (\(attr, sub) -> sub <$> attr) id) `P.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. The outer Maybe indicates whether it succeeds,+-- and the inner Maybe whether an element should be added to the output list.+-- +-- This function accumulates a list of elements for each step that produces one.+tagsPermute :: (Monad m, Ord k)+ => (Name -> k)+ -> Map.Map k (P.AttrParser a, a -> Iteratee Event m (Maybe b))+ -> Iteratee Event m (Maybe (Maybe b))+ -> Iteratee Event m (Maybe [b])+tagsPermute f m fb = do+ (rest, result) <- tags go (\s -> fmap (\a -> (s, 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 = Nothing+ adaptSub a = Just (Map.delete k s, a)++-- | Specifies how often an element may repeat.+data Repetition+ = Repeat { + repetitionNeedsMore :: Bool+ , repetitionAllowsMore :: Bool+ , repetitionConsume :: Repetition+ }++-- | Element may never occur.+repeatNever :: Repetition+repeatNever = Repeat False False repeatNever++-- | Element may occur exactly once.+repeatOnce :: Repetition+repeatOnce = Repeat True True repeatNever++-- | Element may occur up to once.+repeatOptional :: Repetition+repeatOptional = Repeat False True repeatNever++-- | Element may occur any number of times.+repeatMany :: Repetition+repeatMany = Repeat False True repeatMany++-- | Element may occur at least once.+repeatSome :: Repetition+repeatSome = Repeat True True repeatMany++-- | Parse a permutation of tags, with some repeating elements.+-- +-- 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.+-- It also specifies how often elements may repeat.+-- +-- The third parameter is a fallback parser. The outer Maybe indicates whether it succeeds,+-- and the inner Maybe whether an element should be added to the output list.+-- +-- This function accumulates a list of elements for each step that produces one.+tagsPermuteRepetition :: (Monad m, Ord k)+ => (Name -> k)+ -> Map.Map k (Repetition, P.AttrParser b, b -> Iteratee Event m (Maybe t))+ -> Iteratee Event m (Maybe (Maybe (k, t)))+ -> Iteratee Event m (Maybe [(k, t)])+tagsPermuteRepetition f m' fb = do+ let m = Map.filter (\(r, _, _) -> repetitionAllowsMore r) m'+ (rest, result) <- tags go (\s -> fmap (\a -> (s, a)) <$> fb) m+ return (guard (finished rest) >> Just result)+ where+ finished = Map.null . Map.filter (\(r, _, _) -> repetitionNeedsMore r)+ go s name = do+ let k = f name+ (rep, attr, sub) <- Map.lookup k s+ let adaptSub Nothing = Nothing+ adaptSub (Just v) = let s' = case repetitionConsume rep of+ rep' | repetitionAllowsMore rep' -> Map.insert k (rep', attr, sub) s+ | otherwise -> Map.delete k s+ in Just (s', Just (k, v))+ Just (attr, fmap adaptSub . sub)
+ runtests.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad+import Control.Monad.IO.Class+import Data.ByteString.Lazy.Char8 ({- IsString -})+import Data.Char (ord, chr)+import Data.String+import Data.Text (toLower)+import Data.XML.Types+import Test.HUnit hiding (Test)+import Test.Hspec+import Test.Hspec.HUnit+import Text.XML.Enumerator.Combinators.General+import Text.XML.Enumerator.Combinators.Tags+import Text.XML.Enumerator.Parse (decodeEntities)+import qualified Control.Exception as C+import qualified Data.ByteString.Lazy as L+import qualified Data.Map as Map+import qualified Text.XML.Enumerator.Parse as P++main :: IO ()+main = hspec $ describe "XML combinators"+ [ 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+ , it "has working tagsPermuteRepetition" testTagsPermuteRepetition+ ]++testChooseSplit = P.parseLBS_ input decodeEntities $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- 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" $ + 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" $ + 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 <- tags (\state name -> do + let n = nameLocalName name+ guard (n == fromString [chr $ ord 'a' + state]) + Just (return (), \_ -> return $ Just (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 <- 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>"+ ]++testTagsPermuteRepetition = P.parseLBS_ input decodeEntities $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ let p r c = (r, return (), \_ -> return (Just ()))+ x <- tagsPermuteRepetition (toLower . nameLocalName) + (Map.fromList $ map (\c -> (c, p repeatOnce c)) ["a", "b", "c", "d", "e"] +++ map (\c -> (c, p repeatMany c)) ["r"])+ (return Nothing)+ liftIO $ fmap (map fst) x @?= Just ["d", "r", "b", "e", "r", "a", "c"]+ where+ input = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<d/>"+ , "<r/>"+ , "<b/>"+ , "<E/>"+ , "<r/>"+ , "<a/>"+ , "<C/>"+ , "</hello>"+ ]
+ xml-enumerator-combinators.cabal view
@@ -0,0 +1,75 @@+-- xml-enumerator-combinators.cabal auto-generated by cabal init. For+-- additional options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: xml-enumerator-combinators++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.1++-- A short (one-line) description of the package.+Synopsis: Parser combinators for xml-enumerator and compatible XML parsers.++-- A longer description of the package.+Description: Parser combinators for xml-enumerator and compatible XML parsers. The aim is to provide advanced parser combinators to eliminate+ tiresome repetition of boilerplate in streaming XML parsers.++-- The license under which the package is released.+License: BSD3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Aristid Breitkreuz++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: aristidb@googlemail.com++-- A copyright notice.+-- Copyright: ++Category: XML, Enumerator++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+Extra-source-files: README++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.2++Flag test+ default: False++Library+ -- Modules exported by the library.+ Exposed-modules: Text.XML.Enumerator.Combinators.General,+ Text.XML.Enumerator.Combinators.Tags+ + -- Packages needed in order to build this package.+ Build-depends: base >=4.2 && <5,+ containers >=0.3 && <0.5,+ enumerator >=0.4.9 && <0.5,+ xml-types >=0.3 && <0.4,+ xml-enumerator >=0.3.0++ GHC-Options: -Wall+ + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: ++Executable runtests+ main-is: runtests.hs+ if flag(test)+ Buildable: True+ Build-depends: base, HUnit, hspec >= 0.3 && < 0.4, bytestring, text, transformers+ else+ Buildable: False