hexpat-streamparser 0.0.2 → 0.1.0

raw patch · 3 files changed

+71/−26 lines, 3 filesdep +hexpat-streamparserdep +hspecdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: hexpat-streamparser, hspec

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• hexpat-streamparser.cabal +16/−1
• src/Text/XML/Expat/StreamParser.hs +36/−25
• tests/test.hs +19/−0

@@ -1,7 +1,7 @@ cabal-version: 1.12 name: hexpat-streamparser description: streaming xml parser combinators using hexpat-version: 0.0.2+version: 0.1.0 maintainer: kristof@resonata.be copyright: Kristof Bastiaensen 2020 license: BSD3@@ -28,3 +28,18 @@         parser-combinators >= 1.2 && < 1.3,         transformers >= 0.5 && < 0.6,         bytestring >= 0.10 && < 0.11+   default-extensions: OverloadedStrings++test-suite test+  type: exitcode-stdio-1.0+  default-language: Haskell2010        +  hs-source-dirs:+    tests+  main-is:+    test.hs+  build-depends:+    hexpat >= 0.20 && < 0.21,     +    hexpat-streamparser == 0.1.0,+    base >= 4 && < 5,+    hspec+  default-extensions: OverloadedStrings

@@ -56,7 +56,6 @@   , someEmptyTag   , emptyTag   , text-  , (<?>)     -- * Re-exports from "Control.Applicative.Combinators"   ,  (C.<|>)   , C.optional@@ -103,6 +102,7 @@ import qualified Data.Text as Text import Data.Text (Text) import Text.XML.Expat.SAX as Expat+import Data.List (nub)  newtype CPSExceptT e m a =   CPSExceptT { getCPSExceptT :: forall r. ((e -> m r) -> (a -> m r) -> m r) }@@ -159,28 +159,31 @@   UnMatchedTag |   ExpectedCloseTag |   XmlError XMLParseError |-  AttributeNotFound Text |+  AttributeNotFound (Maybe Text) Text |   UnknownAttributes [Text]|   Expected [Text] |   CustomError e-  deriving (Show)+  deriving (Show, Eq)  data AttrParserError e =   AttrRequired Text |   AttrEmpty |   CustomAttrError e+  deriving (Show, Eq)  attrErrorToEvent :: AttrParserError e -> EventParseError e attrErrorToEvent AttrEmpty = Empty-attrErrorToEvent (AttrRequired t) = AttributeNotFound t+attrErrorToEvent (AttrRequired t) = AttributeNotFound Nothing t attrErrorToEvent (CustomAttrError e) = CustomError e --- | semigroup instance concatenates Expected values if any, or--- returns the last error.  Xml parse errors take precedence.+-- | semigroup instance concatenates Expected tags. instance Semigroup (EventParseError e) where-  XmlError e <> _ = XmlError e+  e <> Empty = e   Expected t <> Expected s = Expected $ t ++ s-  Expected t <> _ = Expected t+  AttributeNotFound (Just t) _ <> Expected s = Expected $ t: s+  Expected t <> AttributeNotFound (Just s) _ = Expected $ t ++ [s]+  AttributeNotFound (Just s) _ <> AttributeNotFound (Just t) _ =+    Expected $ nub [s, t]   _ <> e = e  instance Monoid (EventParseError e) where@@ -243,11 +246,17 @@   put $ ParserState newState stream   pure oldState +-- combine old and new consumed state+updateConsumedState :: Monad m => Bool -> EventParser l e m ()+updateConsumedState oldState = EventParser $ do+  ParserState newState stream <- get+  put $ ParserState (oldState || newState) stream+ instance Monad m => Alternative (EventParser l e m) where   EventParser p <|> EventParser q = EventParser $ do     -- clear consumed state     oldConsumedState <- getEventParser $ setConsumedState False-    catchError p $ \err -> do+    res <- catchError p $ \err -> do       ParserState pConsumed _ <- get       if pConsumed         -- don't backtrack when already consumed some state@@ -259,8 +268,11 @@              else do              -- if nothing consumed, then reset consumed state and              -- combine error messages-             _ <- getEventParser $ setConsumedState oldConsumedState +             getEventParser $ updateConsumedState oldConsumedState              throwError (err <> err2)+    getEventParser $ updateConsumedState oldConsumedState+    pure res+   empty = EventParser $ throwError Empty  instance Monad m => MonadPlus (EventParser l e m) where@@ -307,12 +319,12 @@ -- | Lazily parse an xml file into a value.  This function ensures the --  input is consumed and the file handle closed, before returning the --  value.-parseXMLFile :: EventListParser e a-             -> Expat.ParseOptions Text Text-             -> FilePath+parseXMLFile :: Expat.ParseOptions Text Text              -> IOMode+             -> FilePath+             -> EventListParser e a              -> IO (Either (EventParseError e, Maybe XMLParseLocation) a)-parseXMLFile parser parseOptions fp mode =+parseXMLFile parseOptions mode fp parser =   withFile fp mode $ \h -> do   bs <- LazyBS.hGetContents h   pure $! parseXMLByteString parser parseOptions bs@@ -363,7 +375,7 @@                 StartElement _ _ -> throwError ExpectedCloseTag                 CharacterData t                   | not (Text.all (`elem` (" \t\r\n" :: String)) t) ->-                    error "unexpected text"+                    throwError ExpectedCloseTag                 FailDocument err -> do                   put $ ParserState consumed (Ordered list)                   throwError $ XmlError err@@ -419,10 +431,6 @@ noAttrs :: AttrParser e () noAttrs = pure () --- | Annotate the parser with a name for better parse errors-(<?>) :: Monad m => EventParser l e m a -> Text -> EventParser l e m a-parser <?> msg = parser <|> EventParser (throwError $ Expected [msg])- -- | Parse a tag that succeed on the given test function.  Parses the -- children in the order or the inner parser. someTag :: (Monad (ItemM l), List l)@@ -462,13 +470,12 @@ -- someUnorderedTag inner = _ -- | Skip next tag skipTag :: (Monad (ItemM l), List l) => EventParser l e (ItemM l) ()-skipTag = (someTag (const True) skipAttrs $ const skipTags)-          <?> "Any Tag"+skipTag = someTag (const True) skipAttrs $ const skipTags {-# INLINE skipTag #-}            -- | Skip remaining tags and text, if any. skipTags :: (Monad (ItemM l), List l) => EventParser l e(ItemM l) ()-skipTags = void $ many (skipTag <|> void text)+skipTags = optional text >> skipMany (skipTag >> void text)  -- | Skip zero or more tags until the given parser succeeds skipTagsTill ::@@ -484,9 +491,13 @@     -> AttrParser e b           -- ^ attribute parser     -> (b -> EventParser l e (ItemM l) a) -- ^ tag children parser     -> EventParser l e (ItemM l) a-tag name attrP children = someTag (== name) attrP children-                          <?> (name <> " Tag")-+tag name attrP children =+  catchError (someTag (== name) attrP children) $ \err ->+  case err of+    ExpectedTag -> throwError $ Expected [name]+    AttributeNotFound Nothing a -> throwError $ AttributeNotFound (Just name) a+    _ -> throwError err+     -- -- | Parse a tag with the given name, using the inner parser for the -- -- children tags.  The children tags can be in any order.  Note that -- -- this is less efficient than an orderedTag, since it has to keep

@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Test.Hspec+import Text.XML.Expat.StreamParser+import Text.XML.Expat.SAX++main :: IO ()+main = hspec spec++spec :: Spec+spec =+  describe "parse XML tests" $ do+  it "skips tags" $+    parseXMLByteString (tag "foo" skipAttrs $ const skipTags)+    (ParseOptions Nothing Nothing) "<foo></foo>"+    `shouldBe` (Right () :: Either (EventParseError String, Maybe XMLParseLocation) ())++