packages feed

xml-conduit-parse (empty) → 0.1.0.0

raw patch · 6 files changed

+431/−0 lines, 6 filesdep +basedep +conduitdep +conduit-parsesetup-changed

Dependencies added: base, conduit, conduit-parse, containers, data-default, exceptions, hlint, parsers, resourcet, tasty, tasty-hunit, text, xml-conduit, xml-conduit-parse, xml-types

Files

+ Data/Conduit/Parser/XML.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE OverloadedStrings #-}+-- | High-level primitives to parse a stream of XML 'Event's.+module Data.Conduit.Parser.XML+  ( -- * XML parsers+    -- ** Tags+    tag+  , tagName+  , tagPredicate+  , tagNoAttr+    -- ** Attributes+  , AttributeMap+  , AttrParser()+  , attr+  , ignoreAttrs+    -- ** Content+  , content+    -- * Re-exports+    -- ** Event producers+  , Reexport.parseBytes+  , Reexport.parseBytesPos+  , parseText+  , Reexport.parseTextPos+  , Reexport.detectUtf+  , Reexport.parseFile+  , Reexport.parseLBS+    -- ** Parser settings+  , Reexport.ParseSettings()+  , Reexport.DecodeEntities+  , Reexport.psDecodeEntities+  , Reexport.psRetainNamespaces+    -- ** Entity decoding+  , Reexport.decodeXmlEntities+  , Reexport.decodeHtmlEntities+    -- ** Exceptions+  , Reexport.XmlException(..)+  ) where++-- {{{ Imports+import           Control.Applicative+import           Control.Exception+import           Control.Monad+import           Control.Monad.Catch++import           Data.Char+import           Data.Conduit                     hiding (await)+import           Data.Conduit.Parser+import           Data.Conduit.Parser.XML.Internal+import           Data.Map                         as Map hiding (map)+import           Data.Text                        as Text (Text, all, unpack)+import           Data.XML.Types++import           Text.Parser.Combinators+import qualified Text.XML.Stream.Parse            as Reexport+-- }}}++-- | Parse an XML tag. This is the most generic tag parser.+--+-- Comments, instructions and whitespace are ignored.+tag :: (MonadCatch m)+    => (Name -> Maybe a)               -- ^ Tag name parser.+    -> (a -> AttrParser b)             -- ^ Attributes parser. It should consume all available attributes.+    -> (b -> ConduitParser Event m c)  -- ^ Children parser. It should consume all elements between the opening and closing tags.+    -> ConduitParser Event m c+tag checkName attrParser f = do+  skipMany ignored+  (name, attributes) <- beginElement+  a <- maybe (unexpected $ "Invalid element name: " ++ show name) return $ checkName name+  b <- either (unexpected . show) return $ runAttrParser' (attrParser a) attributes+  result <- f b+  skipMany ignored+  endName <- endElement+  when (endName /= name) . unexpected $ "Invalid closing tag: expected </" ++ unpack (nameLocalName name) ++ ">, got </" ++ unpack (nameLocalName endName) ++ ">"+  return result++  where ignored = beginDocument <|> endDocument <|> void beginDoctype <|> void endDoctype <|> void instruction <|> void comment <|> spaceContent+        spaceContent :: (MonadCatch m) => ConduitParser Event m ()+        spaceContent = do+          t <- contentText+          unless (Text.all isSpace t) . unexpected $ "Unexpected textual content: " ++ unpack t++        runAttrParser' parser attributes = case runAttrParser parser attributes of+          Left e -> Left e+          Right (a, x) -> if Map.null a then Right x else Left . toException $ Reexport.UnparsedAttributes (Map.toList a)++-- | Like 'tag', but use a predicate to select tag names.+tagPredicate :: (MonadCatch m) => (Name -> Bool) -> AttrParser a -> (a -> ConduitParser Event m b) -> ConduitParser Event m b+tagPredicate p attrParser = tag (guard . p) (const attrParser)++-- | Like 'tag', but match a single tag name.+tagName :: (MonadCatch m) => Name -> AttrParser a -> (a -> ConduitParser Event m b) -> ConduitParser Event m b+tagName name = tagPredicate (== name)++-- | Like 'tagName', but expect no attributes at all.+tagNoAttr :: MonadCatch m => Name -> ConduitParser Event m a -> ConduitParser Event m a+tagNoAttr name f = tagName name (return ()) $ const f++-- | Parse a tag content.+content :: MonadCatch m => ConduitParser Event m Text+content = do+  skipMany ignored+  mconcat <$> sepEndBy text ignored+  where ignored = beginDocument <|> endDocument <|> void beginDoctype <|> endDoctype <|> void instruction <|> void comment+++newtype AttrParser a = AttrParser { runAttrParser :: AttributeMap -> Either SomeException (AttributeMap, a) }++instance Monad AttrParser where+  return a = AttrParser $ \attributes -> Right (attributes, a)+  (AttrParser p) >>= f = AttrParser $ p >=> (\(attributes', a) -> runAttrParser (f a) attributes')++instance Functor AttrParser where+  fmap = liftM++instance Applicative AttrParser where+  pure = return+  (<*>) = ap++-- | Attribute parsers can be combined with @(\<|\>)@, 'some', 'many', 'optional', 'choice', etc.+instance Alternative AttrParser where+  empty = AttrParser $ const $ Left $ toException $ Reexport.XmlException "AttrParser.empty" Nothing+  AttrParser f <|> AttrParser g = AttrParser $ \x -> either (const $ g x) Right (f x)++instance MonadThrow AttrParser where+  throwM = AttrParser . const . throwM++-- | Single attribute parser.+attr :: Name -> AttrParser Text+attr name = AttrParser $ \attrs -> maybe raiseError (returnValue attrs) (Map.lookup name attrs)+  where raiseError = Left . toException $ Reexport.XmlException ("Missing attribute: " ++ show name) Nothing+        returnValue attrs contents = Right (Map.delete name attrs, contentsToText contents)++-- | Consume all remaining unparsed attributes.+ignoreAttrs :: AttrParser ()+ignoreAttrs = AttrParser . const $ Right (mempty, ())++contentsToText :: [Content] -> Text+contentsToText =+    mconcat . map toText+  where+    toText (ContentText t) = t+    toText (ContentEntity e) = mconcat ["&", e, ";"]++-- | Alias for 'Reexport.parseText''+parseText :: (MonadThrow m) => Reexport.ParseSettings -> Conduit Text m Event+parseText = Reexport.parseText'
+ Data/Conduit/Parser/XML/Internal.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Low-level primitives.+module Data.Conduit.Parser.XML.Internal where++-- {{{ Imports+import           Control.Applicative+import           Control.Monad.Catch++import           Data.Conduit.Parser+import           Data.Map                as Map hiding (map)+import           Data.Text               (Text)+import           Data.XML.Types++import           Text.Parser.Combinators+-- }}}++type AttributeMap = Map Name [Content]++-- | Parse an 'EventBeginDocument'.+beginDocument :: (MonadCatch m) => ConduitParser Event m ()+beginDocument = named "XML begin document" $ do+  event <- await+  case event of+   EventBeginDocument -> return ()+   _ -> unexpected $ "Expected XML begin document, got: " ++ show event++-- | Parse an 'EventEndDocument'.+endDocument :: (MonadCatch m) => ConduitParser Event m ()+endDocument = named "XML end document" $ do+  event <- await+  case event of+   EventEndDocument -> return ()+   _ -> unexpected $ "Expected XML end document, got: " ++ show event++-- | Parse an 'EventBeginDoctype'.+beginDoctype :: (MonadCatch m) => ConduitParser Event m (Text, Maybe ExternalID)+beginDoctype = named "XML begin doctype" $ do+  event <- await+  case event of+   EventBeginDoctype doctype externalID -> return (doctype, externalID)+   _ -> unexpected $ "Expected XML begin doctype, got: " ++ show event++-- | Parse an 'EventEndDoctype'.+endDoctype :: (MonadCatch m) => ConduitParser Event m ()+endDoctype = named "XML end doctype" $ do+  event <- await+  case event of+   EventEndDoctype -> return ()+   _ -> unexpected $ "Expected XML end doctype, got: " ++ show event++-- | Parse an 'EventInstruction'.+instruction :: (MonadCatch m) => ConduitParser Event m Instruction+instruction = named "XML instruction" $ do+  event <- await+  case event of+   EventInstruction i -> return i+   _ -> unexpected $ "Expected XML instruction, got: " ++ show event++-- | Parse an 'EventBeginElement'.+beginElement :: (MonadCatch m) => ConduitParser Event m (Name, AttributeMap)+beginElement = named "XML begin element" $ do+  event <- await+  case event of+   EventBeginElement n a -> return (n, Map.fromList a)+   _ -> unexpected $ "Expected XML begin element, got: " ++ show event++-- | Parse an 'EventEndElement'.+endElement :: (MonadCatch m) => ConduitParser Event m Name+endElement = named "XML end element" $ do+  event <- await+  case event of+   EventEndElement n -> return n+   _ -> unexpected $ "Expected XML end element, got: " ++ show event++-- | Parse a 'ContentEntity' (within an 'EventContent').+contentEntity :: (MonadCatch m) => ConduitParser Event m Text+contentEntity = named "XML entity content" $ do+  event <- await+  case event of+   EventContent (ContentEntity t) -> return t+   _ -> unexpected $ "Expected XML content entity, got: " ++ show event++-- | Parse a 'ContentText' (within an 'EventContent').+contentText :: (MonadCatch m) => ConduitParser Event m Text+contentText = named "XML text content" $ do+  event <- await+  case event of+   EventContent (ContentText t) -> return t+   _ -> unexpected $ "Expected XML textual content, got: " ++ show event++-- | Parse an 'EventComment'.+comment :: (MonadCatch m) => ConduitParser Event m Text+comment = named "XML comment" $ do+  event <- await+  case event of+   EventComment t -> return t+   _ -> unexpected $ "Expected XML comment, got: " ++ show event++-- | Parse an 'EventCDATA'.+cdata :: (MonadCatch m) => ConduitParser Event m Text+cdata = named "XML CDATA" $ do+  event <- await+  case event of+   EventCDATA t -> return t+   _ -> unexpected $ "Expected XML CDATA, got: " ++ show event++-- | Parse a textual 'EventContent' or an 'EventCDATA'.+text :: (MonadCatch m) => ConduitParser Event m Text+text = mconcat <$> some (contentText <|> cdata)
+ LICENSE view
@@ -0,0 +1,13 @@+DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+Version 2, December 2004++Copyright (C) 2015 koral <koral at mailoo dot org>++Everyone is permitted to copy and distribute verbatim or modified+copies of this license document, and changing it is allowed as long+as the name is changed.++DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++0. You just DO WHAT THE FUCK YOU WANT TO.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ test/Main.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings #-}+import           Control.Applicative+import           Control.Monad.Trans.Resource++import           Data.Conduit+import           Data.Conduit.List            (sourceList)+import           Data.Conduit.Parser+import           Data.Conduit.Parser.XML+import           Data.Default+import           Data.Foldable++import qualified Language.Haskell.HLint       as HLint (hlint)+import           Test.Tasty+import           Test.Tasty.HUnit+-- import           Test.Tasty.QuickCheck+++main :: IO ()+main = defaultMain $ testGroup "Tests"+  [ unitTests+  -- , properties+  , hlint+  ]++unitTests :: TestTree+unitTests = testGroup "Unit tests"+  [ combinatorsCase+  , choiceCase+  , manyCase+  , orCase+  ]+++combinatorsCase :: TestTree+combinatorsCase = testCase "Combinators" $ do+  (world, c) <- runResourceT . runConduit $ sourceList input =$= parseText def =$= runConduitParser parser+  world @?= "true"+  c @?= "combine <all> &content"+  where input =+          [ "<?xml version='1.0'?>"+          , "<!DOCTYPE foo []>\n"+          , "<hello world='true'>"+          , "<?this should be ignored?>"+          , "<child1 xmlns='mynamespace'/>"+          , "<!-- this should be ignored -->"+          , "<child2>   </child2>"+          , "<child3>combine &lt;all&gt; <![CDATA[&content]]></child3>\n"+          , "</hello>"+          ]+        parser = tagName "hello" (attr "world") $ \world -> do+          tagNoAttr "{mynamespace}child1" $ return ()+          tagNoAttr "child2" $ return ()+          x <- tagNoAttr "child3" content+          return (world, x)+++choiceCase :: TestTree+choiceCase = testCase "Choice" $ do+  x <- runResourceT . runConduit $ sourceList input =$= parseText def =$= runConduitParser parser+  x @?= (2 :: Int)+  where input =+          [ "<?xml version='1.0'?>"+          , "<!DOCTYPE foo []>\n"+          , "<hello>"+          , "<success/>"+          , "</hello>"+          ]+        parser = tagNoAttr "hello" $ asum+          [ tagNoAttr "failure" $ return 1+          , tagNoAttr "success" $ return 2+          ]+++manyCase :: TestTree+manyCase = testCase "Many" $ do+  x <- runResourceT . runConduit $ sourceList input =$= parseText def =$= runConduitParser parser+  length x @?= 5+  where input =+          [ "<?xml version='1.0'?>"+          , "<!DOCTYPE foo []>\n"+          , "<hello>"+          , "<success/>"+          , "<success/>"+          , "<success/>"+          , "<success/>"+          , "<success/>"+          , "</hello>"+          ]+        parser = tagNoAttr "hello" . many . tagNoAttr "success" $ return ()++orCase :: TestTree+orCase = testCase "<|>" $ do+  x <- runResourceT . runConduit $ sourceList input =$= parseText def =$= runConduitParser parser+  x @?= (2 :: Int)+  where input =+          [ "<?xml version='1.0'?>"+          , "<!DOCTYPE foo []>\n"+          , "<hello>"+          , "<success/>"+          , "</hello>"+          ]+        parser = tagNoAttr "hello" $ tagNoAttr "failure" (return 1) <|> tagNoAttr "success" (return 2)+++hlint :: TestTree+hlint = testCase "HLint check" $ do+  result <- HLint.hlint [ "test/", "Data/" ]+  null result @?= True
+ xml-conduit-parse.cabal view
@@ -0,0 +1,54 @@+name:                xml-conduit-parse+version:             0.1.0.0+synopsis:            Streaming XML parser based on conduits.+description:+  This library provides an alternative, hopefully higher-level implementation for the parsing part of @xml-conduit@.+homepage:            https://github.com/k0ral/xml-conduit-parse+license:             OtherLicense+license-file:        LICENSE+author:              koral <koral@mailoo.org>+maintainer:          koral <koral@mailoo.org>+category:            Conduit, Text, XML+build-type:          Simple+cabal-version:       >=1.10+-- data-files:++source-repository head+  type:     git+  location: git://github.com/k0ral/xml-conduit-parse.git++library+  exposed-modules:+    Data.Conduit.Parser.XML+    Data.Conduit.Parser.XML.Internal+  build-depends:+      base >= 4.8 && < 5+    , conduit+    , conduit-parse+    , containers+    , exceptions+    , parsers+    , text+    , xml-conduit >= 1.3+    , xml-types+  default-language: Haskell2010+  ghc-options: -Wall -fno-warn-unused-do-bind++test-suite tests+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+      base >= 4.8+    , conduit+    , conduit-parse+    , xml-conduit-parse+    , data-default+    , hlint+    , parsers+    , resourcet+    , tasty+    , tasty-hunit+    -- , tasty-quickcheck+  default-language:    Haskell2010+  ghc-options: -Wall