diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,1 @@ +Parser combinators for xml-enumerator and compatible XML parsers. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/XML/Enumerator/Combinators/General.hs b/Text/XML/Enumerator/Combinators/General.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Enumerator/Combinators/General.hs @@ -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' diff --git a/Text/XML/Enumerator/Combinators/Tags.hs b/Text/XML/Enumerator/Combinators/Tags.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Enumerator/Combinators/Tags.hs @@ -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) diff --git a/runtests.hs b/runtests.hs new file mode 100644 --- /dev/null +++ b/runtests.hs @@ -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 + [ "\n" + , "\n" + , "" + , "" + , "" + ] + +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 + [ "\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" $ + 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 <- 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 + [ "\n" + , "\n" + , "" + , "" + , "" + , "" + , "" + , "" + , "" + ] + +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 + [ "\n" + , "\n" + , "" + , "" + , "" + , "" + , "" + , "" + , "" + ] + +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 + [ "\n" + , "\n" + , "" + , "" + , "" + , "" + , "" + , "" + , "" + , "" + , "" + ] diff --git a/xml-enumerator-combinators.cabal b/xml-enumerator-combinators.cabal new file mode 100644 --- /dev/null +++ b/xml-enumerator-combinators.cabal @@ -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