xmlbf 0.6.2 → 0.7
raw patch · 4 files changed
+553/−247 lines, 4 filesdep +exceptionsdep +mmorphdep +mtl
Dependencies added: exceptions, mmorph, mtl
Files
- ChangeLog.md +19/−0
- lib/Xmlbf.hs +444/−195
- test/Test.hs +86/−51
- xmlbf.cabal +4/−1
ChangeLog.md view
@@ -1,3 +1,22 @@+# 0.7++* COMPILER ASSISTED BREAKING CHANGE. `Parser` is now a type synonym+ for `ParserT Identity`.++* COMPILER ASSISTED BREAKING CHANGE. `runParser` renamed to `parse`.++* COMPILER ASSISTED BREAKING CHANGE. `Text`, `text` and `text'` are+ now named `TextLazy`, `textLazy` and `textLazy`. The previous names+ are now used with strict `Text`.++* Introduced `ParserT`, `parse`, `parseM`, `runParserT`, `parserT`,+ `ParserState`, `initialParserState`, `pTextLazy`.++* Fixed exhaustivenes checks for `Node` patterns.++* New dependencies: `exceptions`, `mmorph`, `mtl`.++ # 0.6.2 * `encode` now renders attributes in alphabetical order.
lib/Xmlbf.hs view
@@ -1,7 +1,14 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UndecidableInstances #-} -- | XML back and forth! --@@ -15,14 +22,24 @@ -- package. -- -- @xmlbf@ doesn't do any parsing of raw XML on its own. Instead, one should--- use @xmlbf@ together with libraries like+-- use+-- [xmlbf](https://hackage.haskell.org/package/xmlbf)+-- together with libraries like -- [xmlbf-xeno](https://hackage.haskell.org/package/xmlbf-xeno) or -- [xmlbf-xmlhtml](https://hackage.haskell.org/package/xmlbf-xmlhtml) for -- this. module Xmlbf {--} ( -- * Parsing- runParser+ parse+ , parseM+ -- ** Low-level , Parser+ , ParserT+ , parserT+ , runParserT+ , ParserState+ , initialParserState+ -- * Parsers , pElement , pAnyElement@@ -31,6 +48,7 @@ , pAttrs , pChildren , pText+ , pTextLazy , pEndOfInput -- * Rendering@@ -40,14 +58,21 @@ , Node , node + -- ** Element , pattern Element , element , element' + -- ** Text (strict) , pattern Text , text , text' + -- ** Text (lazy)+ , pattern TextLazy+ , textLazy+ , textLazy'+ -- * Fixpoints , dfpos , dfposM@@ -62,19 +87,26 @@ import Control.Applicative (Alternative(empty, (<|>)), liftA2) import Control.DeepSeq (NFData(rnf))-import Control.Monad (MonadPlus(mplus, mzero), join, when)+import Control.Monad (MonadPlus(mplus, mzero), join, when, ap)+import qualified Control.Monad.Catch as Ex+import Control.Monad.Error.Class (MonadError(catchError, throwError)) import qualified Control.Monad.Fail import Control.Monad.Fix (MonadFix(mfix))+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Morph (MFunctor(hoist))+import Control.Monad.Reader.Class (MonadReader(local, ask))+import Control.Monad.State.Class (MonadState(state))+import Control.Monad.Trans (MonadTrans(lift)) import Control.Monad.Zip (MonadZip(mzipWith)) import Control.Selective (Selective(select)) import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Builder.Prim as BBP import qualified Data.Char as Char import Data.Foldable (for_, toList)-import Data.Function (fix) import Data.Functor.Identity (Identity(Identity), runIdentity)-import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as Map+import qualified Data.HashMap.Strict as HM+import Data.Kind (Type) import Data.Sequence (Seq) import qualified Data.Sequence as Seq import qualified Data.Text as T@@ -88,49 +120,87 @@ -- | Either a text or an element node in an XML fragment body. ----- Construct with 'text' or 'element'. Destruct with 'Text' or 'Element'.+-- Construct with 'text', 'textLazy' or 'element'.+--+-- Destruct with 'Text', 'TextLazy' or 'Element'. data Node- = Element' !T.Text !(HM.HashMap T.Text T.Text) ![Node]- | Text' !TL.Text+ = Node_Element !T.Text !(HM.HashMap T.Text T.Text) ![Node]+ | Node_Text !TL.Text deriving (Eq) instance NFData Node where rnf = \case- Element' n as cs -> rnf n `seq` rnf as `seq` rnf cs `seq` ()- Text' t -> rnf t `seq` ()+ Node_Element n as cs -> rnf n `seq` rnf as `seq` rnf cs `seq` ()+ Node_Text t -> rnf t `seq` () {-# INLINABLE rnf #-} instance Show Node where showsPrec n = \x -> showParen (n > 10) $ case x of- Text' t -> showString "Text " . showsPrec 0 t- Element' t as cs ->+ Node_Text t -> showString "Text " . showsPrec 0 t+ Node_Element t as cs -> showString "Element " . showsPrec 0 t . showChar ' ' . showsPrec 0 (HM.toList as) . showChar ' ' . showsPrec 0 cs -- | Destruct an element 'Node'.-pattern Element :: T.Text -> HM.HashMap T.Text T.Text -> [Node] -> Node-pattern Element t as cs <- Element' t as cs-{-# COMPLETE Element #-} -- TODO this leads to silly pattern matching warnings+--+-- @+-- case n :: Node of+-- 'Element' t as cs -> ...+-- _ -> ...+-- @+pattern Element+ :: T.Text -- ^ Element name as strict 'T.Text'.+ -> HM.HashMap T.Text T.Text+ -- ^ Pairs of attribute names and possibly 'T.empty' values, as strict+ -- 'T.Text'.+ -> [Node] -- ^ Element children.+ -> Node+pattern Element t as cs <- Node_Element t as cs --- | Destruct a text 'Node'.-pattern Text :: TL.Text -> Node-pattern Text t <- Text' t-{-# COMPLETE Text #-} -- TODO this leads to silly pattern matching warnings+-- | Destruct a text 'Node' into a lazy 'TL.Text'.+--+-- @+-- case n :: Node of+-- 'TextLazy' tl -> ...+-- _ -> ...+-- @+pattern TextLazy+ :: TL.Text -- ^ Lazy 'TL.Text'.+ -> Node+pattern TextLazy tl <- Node_Text tl +-- | Destruct a text 'Node' into a strict 'T.Text'.+--+-- @+-- case n :: Node of+-- 'Text' t -> ...+-- _ -> ...+-- @+pattern Text+ :: T.Text -- ^ Strict 'T.Text'.+ -> Node+pattern Text t <- Node_Text (TL.toStrict -> t)++{-# COMPLETE Text, Element :: Node #-}+{-# COMPLETE TextLazy, Element :: Node #-}+{-# COMPLETE Node_Text, Element :: Node #-}+{-# COMPLETE Text, Node_Element :: Node #-}+{-# COMPLETE TextLazy, Node_Element :: Node #-}+ -- | Case analysis for a 'Node'. node :: (T.Text -> HM.HashMap T.Text T.Text -> [Node] -> a) -- ^ Transform an 'Element' node. -> (TL.Text -> a)- -- ^ Transform a 'Text' node.+ -- ^ Transform a 'TextLazy' node. -> Node -> a {-# INLINE node #-} node fe ft = \case- Text' t -> ft t- Element' t as cs -> fe t as cs+ Node_Text t -> ft t+ Node_Element t as cs -> fe t as cs -- | Normalizes 'Node's by concatenating consecutive 'Text' nodes. normalize :: [Node] -> [Node]@@ -138,14 +208,14 @@ normalize = \case -- Note that @'Text' ""@ is forbidden by construction, actually. But we do -- take care of it in case the 'Node' was constructed unsafely somehow.- Text' "" : ns -> normalize ns- Text' a : Text' b : ns -> normalize (text (a <> b) <> ns)- Text' a : ns -> Text' a : normalize ns- Element' t as cs : ns -> Element' t as (normalize cs) : normalize ns+ Node_Text "" : ns -> normalize ns+ Node_Text a : Node_Text b : ns -> normalize (textLazy (a <> b) <> ns)+ Node_Text a : ns -> Node_Text a : normalize ns+ Node_Element t as cs : ns -> Node_Element t as (normalize cs) : normalize ns [] -> [] --- | Construct a XML fragment body containing a single 'Text' 'Node', if--- possible.+-- | Construct a XML fragment body containing a single text 'Node', if given+-- 'T.Text' not empty. -- -- This function will return empty list if it is not possible to construct the -- 'Text' with the given input. To learn more about /why/ it was not possible to@@ -156,25 +226,38 @@ -- times more convenient to use. For example, when you know statically the input -- is valid. text- :: TL.Text -- ^ Lazy 'TL.Text'.+ :: T.Text -- ^ Strict 'T.Text'. -> [Node] {-# INLINE text #-}-text t = case text' t of- Right x -> [x]- Left _ -> []+text = textLazy . TL.fromStrict --- | Construct a 'Text' 'Node', if possible.+-- | Construct a text 'Node', if given 'T.Text' not empty. -- -- Returns 'Left' if the 'Text' 'Node' can't be created, with an explanation -- of why. text'- :: TL.Text -- ^ Lazy 'TL.Text'.+ :: T.Text -- ^ Strict 'T.Text'. -> Either String Node {-# INLINE text' #-}-text' = \case+text' = textLazy' . TL.fromStrict++-- | A version of 'text' working with lazy 'TL.Text'.+textLazy+ :: TL.Text -- ^ Lazy 'TL.Text'.+ -> [Node]+{-# INLINE textLazy #-}+textLazy = either (\_ -> []) (\x -> [x]) . textLazy'++-- | A version of 'text'' working with lazy 'TL.Text'.+textLazy'+ :: TL.Text -- ^ Lazy 'TL.Text'.+ -> Either String Node+{-# INLINE textLazy' #-}+textLazy' = \case "" -> Left "Empty text"- t -> Right (Text' t)+ t -> Right (Node_Text t) + -- | Construct a XML fragment body containing a single 'Element' 'Node', if -- possible. --@@ -186,8 +269,10 @@ -- to acknowledge a failing situation in case it happens. However, 'element' is -- at times more convenient to use, whenever you know the input is valid. element- :: T.Text -- ^ Element' name as a strict 'T.Text'.- -> HM.HashMap T.Text T.Text -- ^ Attributes as strict 'T.Text' pairs.+ :: T.Text -- ^ Element name as a strict 'T.Text'.+ -> HM.HashMap T.Text T.Text+ -- ^ Pairs of attribute names and possibly 'T.empty' values, as strict+ -- 'T.Text'. -> [Node] -- ^ Children. -> [Node] {-# INLINE element #-}@@ -200,21 +285,21 @@ -- Returns 'Left' if the 'Element' 'Node' can't be created, with an explanation -- of why. element'- :: T.Text -- ^ Element' name as a strict 'T.Text'.- -> HM.HashMap T.Text T.Text -- ^ Attributes as strict 'T.Text' pairs.+ :: T.Text -- ^ Element name as a strict 'T.Text'.+ -> HM.HashMap T.Text T.Text+ -- ^ Pairs of attribute names and possibly 'T.empty' values, as strict+ -- 'T.Text'. -> [Node] -- ^ Children. -> Either String Node element' t0 hm0 ns0 = do when (t0 /= T.strip t0) (Left ("Element name has surrounding whitespace: " ++ show t0))- when (T.null t0)- (Left ("Element name is blank: " ++ show t0))+ when (T.null t0) (Left "Element name is blank") for_ (HM.keys hm0) $ \k -> do when (k /= T.strip k) (Left ("Attribute name has surrounding whitespace: " ++ show k))- when (T.null k)- (Left ("Attribute name is blank: " ++ show k))- Right (Element' t0 hm0 (normalize ns0))+ when (T.null k) (Left "Attribute name is blank")+ Right (Node_Element t0 hm0 (normalize ns0)) -------------------------------------------------------------------------------- --------------------------------------------------------------------------------@@ -226,54 +311,116 @@ -- If a 'ToXml' instance for @a@ exists, then: -- -- @- -- 'runParser' 'fromXml' ('toXml' a) == pure ('Right' a)+ -- 'parse' 'fromXml' ('toXml' a) == 'Right' a -- @- fromXml :: Parser a+ fromXml :: Monad m => ParserT m a -- | Internal parser state.-data S+data ParserState = STop ![Node] -- ^ Parsing the top-level nodes. | SReg !T.Text !(HM.HashMap T.Text T.Text) ![Node] -- ^ Parsing a particular root element.+ deriving (Eq) --- | Construct an initial parser state to use with 'unParser' from zero or+-- | Construct an initial 'ParserState' to use with 'runParserT' from zero or -- more top-level 'Node's.-initialS :: [Node] -> S-initialS = STop . normalize-{-# INLINE initialS #-}+initialParserState :: [Node] -> ParserState+initialParserState = STop . normalize+{-# INLINE initialParserState #-} -- | XML parser for a value of type @a@. ----- You can build a 'Parser' using 'pElement', 'pAnyElement', 'pName',+-- This parser runs on top of some 'Monad' @m@,+-- making 'ParserT' a suitable monad transformer.+--+-- You can build a 'ParserT' using 'pElement', 'pAnyElement', 'pName', -- 'pAttr', 'pAttrs', 'pChildren', 'pText', 'pEndOfInput', any of the--- 'Applicative', 'Alternative', 'Monad' or related combinators.+-- 'Applicative', 'Alternative' or 'Monad' combinators, or you can+-- use 'parserT' directly. ----- Run a 'Parser' using 'runParser'.-newtype Parser a = Parser { unParser :: S -> Either String (S, a) }+-- Run a 'ParserT' using 'parse', 'parseM' or 'runParserT'+newtype ParserT (m :: Type -> Type) (a :: Type)+ = ParserT (ParserState -> m (ParserState, Either String a)) --- | Run a 'Parser' on an XML fragment body.+-- | @'Parser' a@ is a type synonym for @'Parser' 'Identity' a@.+type Parser = ParserT Identity :: Type -> Type++-- | 'parserT' is the most general way or building a 'ParserT'. --+-- Notice that 'ParserState''s internals are not exported, so you won't be+-- able to do much with it other than pass it around.+--+-- @+-- 'runParserT' . 'parserT' == 'id'+-- @+parserT+ :: (ParserState -> m (ParserState, Either String a))+ -- ^ Given a parser's internal state, obtain an @a@ if possible, otherwise+ -- return a 'String' describing the parsing failure. A new state with+ -- leftovers is returned.+ -> ParserT m a+parserT = ParserT+{-# INLINE parserT #-}++-- | 'runParserT' is the most general way or running a 'ParserT'.+--+-- As a simpler alternative to 'runParserT', consider using 'parseM', or even 'parse'+-- if you don't need transformer functionality.+--+-- Notice that 'ParserState''s internals are not exported, so you won't be+-- able to do much with it other than pass it around.+--+-- @+-- 'runParserT' . 'parserT' == 'id'+-- @+runParserT+ :: ParserT m a+ -- ^ Parser to run.+ -> ParserState+ -- ^ Initial parser state. You can obtain this from+ -- 'initialParserState' or from a previous execution of 'runParserT'.+ -> m (ParserState, Either String a)+ -- ^ Returns the leftover parser state, as well as an @a@ in case parsing was+ -- successful, or a 'String' with an error message otherwise.+runParserT (ParserT f) = f+{-# INLINE runParserT #-}++-- | Run a 'ParserT' on an XML fragment body.+-- -- Notice that this function doesn't enforce that all input is consumed. If you--- want that behavior, then please use 'pEndOfInput' in the given 'Parser'.-runParser+-- want that behavior, then please use 'pEndOfInput' in the given 'ParserT'.+parseM+ :: Applicative m+ => ParserT m a+ -- ^ Parser to run.+ -> [Node]+ -- ^ XML fragment body to parse. That is, top-level XML 'Node's.+ -> m (Either String a)+ -- ^ If parsing fails, a 'String' with an error message is returned.+ -- Otherwise, the parser output @a@ is returned.+parseM p = fmap snd . runParserT p . initialParserState+{-# INLINE parseM #-}++-- | Pure version of 'parseM'.+parse :: Parser a -- ^ Parser to run. -> [Node] -- ^ XML fragment body to parse. That is, top-level XML 'Node's. -> Either String a -- ^ If parsing fails, a 'String' with an error message is returned.- -- Otherwise, we the parser output @a@ is returned.-runParser p = fmap snd . unParser p . initialS-{-# INLINE runParser #-}+ -- Otherwise, the parser output @a@ is returned.+parse p = runIdentity . parseM p+{-# INLINE parse #-} #if MIN_VERSION_base(4,9,0)-instance Semigroup a => Semigroup (Parser a) where+instance (Monad m, Semigroup a) => Semigroup (ParserT m a) where (<>) = liftA2 (<>) {-# INLINE (<>) #-} #endif -instance Monoid a => Monoid (Parser a) where+instance (Monad m, Monoid a) => Monoid (ParserT m a) where mempty = pure mempty {-# INLINE mempty #-} #if MIN_VERSION_base(4,9,0)@@ -283,83 +430,173 @@ #endif {-# INLINE mappend #-} -instance Functor Parser where- fmap f = \pa -> Parser (\s -> fmap (fmap f) (unParser pa s))+instance Functor m => Functor (ParserT m) where+ fmap f = \pa -> ParserT (\s -> fmap (fmap (fmap f)) (runParserT pa s)) {-# INLINE fmap #-} -instance Applicative Parser where- pure = \a -> Parser (\s -> Right (s, a))+-- | The 'Monad' superclass is necessary because 'ParserT' shortcircuits like+-- 'Control.Monad.Trans.Except.ExceptT'.+instance Monad m => Applicative (ParserT m) where+ pure = \a -> ParserT (\s -> pure (s, Right a)) {-# INLINE pure #-}- pf <*> pa = Parser (\s0 -> do- (s1, f) <- unParser pf s0- (s2, a) <- unParser pa s1- Right (s2, f a))- {-# INLINABLE (<*>) #-}+ (<*>) = ap+ {-# INLINE (<*>) #-} -- | @ma '<|>' mb@ backtracks the internal parser state before running @mb@.-instance Alternative Parser where+instance Monad m => Alternative (ParserT m) where empty = pFail "empty" {-# INLINE empty #-}- pa <|> pb = Parser (\s0 ->- case unParser pa s0 of- Right (s1, a) -> Right (s1, a)- Left _ -> unParser pb s0)+ pa <|> pb = ParserT (\s0 -> do+ (s1, ea) <- runParserT pa s0+ case ea of+ Right a -> pure (s1, Right a)+ Left _ -> runParserT pb s0) {-# INLINABLE (<|>) #-} -instance Selective Parser where- select pe pf = Parser (\s0 -> do- (s1, ea) <- unParser pe s0- case ea of- Right b -> Right (s1, b)- Left a -> do- (s2, f) <- unParser pf s1- Right (s2, f a))+instance Monad m => Selective (ParserT m) where+ select pe pf = ParserT (\s0 -> do+ (s1, eeab) <- runParserT pe s0+ case eeab of+ Right (Right b) -> pure (s1, Right b)+ Right (Left a) -> runParserT (pf <*> pure a) s1+ Left msg -> pure (s1, Left msg)) {-# INLINABLE select #-} -instance Monad Parser where+instance Monad m => Monad (ParserT m) where return = pure {-# INLINE return #-}- pa >>= kpb = Parser (\s0 -> do- (s1, a) <- unParser pa s0- unParser (kpb a) s1)+ pa >>= kpb = ParserT (\s0 -> do+ (s1, ea) <- runParserT pa s0+ case ea of+ Right a -> runParserT (kpb a) s1+ Left msg -> pure (s1, Left msg)) {-# INLINABLE (>>=) #-}-#if !MIN_VERSION_base(4,13,0)+#if !MIN_VERSION_base(4,9,0) fail = pFail {-# INLINE fail #-} #endif #if MIN_VERSION_base(4,9,0)-instance Control.Monad.Fail.MonadFail Parser where+instance Monad m => Control.Monad.Fail.MonadFail (ParserT m) where fail = pFail {-# INLINE fail #-} #endif --- | A 'Parser' that always fails with the given error message.-pFail :: String -> Parser a-pFail = \msg -> Parser (\_ -> Left msg)+-- | A 'ParserT' that always fails with the given error message.+pFail :: Applicative m => String -> ParserT m a+pFail = \msg -> ParserT (\s -> pure (s, Left msg)) {-# INLINE pFail #-} -- | @'mplus' ma mb@ backtracks the internal parser state before running @mb@.-instance MonadPlus Parser where+instance Monad m => MonadPlus (ParserT m) where mzero = empty {-# INLINE mzero #-} mplus = (<|>) {-# INLINE mplus #-} -instance MonadFix Parser where+instance MonadFix m => MonadFix (ParserT m) where mfix f =- let die = \msg -> error ("mfix (Parser): " <> msg)- in Parser (\s0 -> fix (flip unParser s0 . f . either die snd))- {-# INLINABLE mfix #-}+ let die = \msg -> error ("mfix (ParserT): " <> msg)+ in ParserT (\s0 ->+ mfix (\ ~(_s1, ea) -> runParserT (f (either die id ea)) s0)) -instance MonadZip Parser where- mzipWith = liftA2- {-# INLINE mzipWith #-}+instance MonadZip m => MonadZip (ParserT m) where+ mzipWith f pa pb = ParserT (\s0 -> do+ (s1, ea) <- runParserT pa s0+ case ea of+ Right a0 ->+ mzipWith (\a1 (s2, eb) -> (s2, fmap (f a1) eb))+ (pure a0) (runParserT pb s1)+ Left msg -> pure (s1, Left msg))+ {-# INLINABLE mzipWith #-} +instance MonadTrans ParserT where+ lift = \ma -> ParserT (\s -> ma >>= \a -> pure (s, Right a))+ {-# INLINE lift #-}++instance MFunctor ParserT where+ hoist nat = \p -> ParserT (\s -> nat (runParserT p s))+ {-# INLINE hoist #-}++instance MonadIO m => MonadIO (ParserT m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++instance MonadReader r m => MonadReader r (ParserT m) where+ ask = lift ask+ {-# INLINE ask #-}+ local f = \p -> ParserT (\s -> local f (runParserT p s))+ {-# INLINE local #-}++instance MonadState s m => MonadState s (ParserT m) where+ state = lift . state+ {-# INLINE state #-}++instance MonadError e m => MonadError e (ParserT m) where+ throwError = lift . throwError+ {-# INLINABLE throwError #-}+ catchError ma h = ParserT (\s ->+ catchError (runParserT ma s)+ (\e -> runParserT (h e) s))+ {-# INLINABLE catchError #-}++instance Ex.MonadThrow m => Ex.MonadThrow (ParserT m) where+ throwM = lift . Ex.throwM+ {-# INLINABLE throwM #-}++instance Ex.MonadCatch m => Ex.MonadCatch (ParserT m) where+ catch ma h = ParserT (\s ->+ Ex.catch (runParserT ma s)+ (\e -> runParserT (h e) s))+ {-# INLINABLE catch #-}++instance Ex.MonadMask m => Ex.MonadMask (ParserT m) where+ mask f = ParserT (\s ->+ Ex.mask (\u ->+ runParserT (f (\p -> ParserT (u . runParserT p))) s))+ {-# INLINABLE mask #-}+ uninterruptibleMask f = ParserT (\s ->+ Ex.uninterruptibleMask (\u ->+ runParserT (f (\p -> ParserT (u . runParserT p))) s))+ {-# INLINABLE uninterruptibleMask #-}+ generalBracket acq rel use = ParserT (\s0 -> do+ ((_sb,eb), (sc,ec)) <- Ex.generalBracket+ (runParserT acq s0)+ (\(s1, ea) ec -> case ea of+ Right a -> case ec of+ Ex.ExitCaseSuccess (s2, Right b) ->+ runParserT (rel a (Ex.ExitCaseSuccess b)) s2+ Ex.ExitCaseSuccess (s2, Left msg) ->+ -- Result of using mzero or similar on release+ pure (s2, Left msg)+ Ex.ExitCaseException e ->+ runParserT (rel a (Ex.ExitCaseException e)) s1+ Ex.ExitCaseAbort ->+ runParserT (rel a Ex.ExitCaseAbort) s1+ Left msg ->+ -- acq failed, nothing to release+ pure (s1, Left msg))+ (\(s1, ea) -> case ea of+ Right a -> runParserT (use a) s1+ Left msg ->+ -- acq failed, nothing to use+ pure (s1, Left msg))+ -- We run ec first because its error message, if any, has priority+ pure (sc, flip (,) <$> ec <*> eb))++{- TODO: Should we export this?+-- | This version uses the current state on entering the continuation. See+-- 'liftCallCC''. It does not satisfy the uniformity property (see+-- 'Control.Monad.Signatures.CallCC').+instance MonadCont m => MonadCont (ParserT m) where+ callCC f = ParserT (\s0 ->+ callCC (\c -> runParserT (f (\a -> ParserT (\s1 -> c (s1, Right a)))) s0))+-}+ -------------------------------------------------------------------------------- -- Some parsers --- | @'pElement' "foo" p@ runs a 'Parser @p@ inside a 'Element' node named+-- | @'pElement' "foo" p@ runs a 'ParserT' @p@ inside a 'Element' node named -- @"foo"@. This parser __fails__ if such element does not exist at the current -- position. --@@ -368,32 +605,33 @@ -- -- __Consumes the matched element__ from the parser state. pElement- :: T.Text -- ^ Element name as strict 'T.Text'.- -> Parser a -- ^ 'Parser' to run /inside/ the matched 'Element'.- -> Parser a-pElement t0 p0 = Parser $ \case- SReg t1 as0 (Element' t as cs : cs0) | t == t0 ->- case unParser p0 (SReg t as cs) of- Right (_, a) -> Right (SReg t1 as0 cs0, a)- Left msg -> Left msg- STop (Element' t as cs : cs0) | t == t0 ->- case unParser p0 (SReg t as cs) of- Right (_, a) -> Right (STop cs0, a)- Left msg -> Left msg+ :: Monad m+ => T.Text -- ^ Element name as strict 'T.Text'.+ -> ParserT m a -- ^ 'ParserT' to run /inside/ the matched 'Element'.+ -> ParserT m a+pElement t0 p0 = ParserT $ \case+ SReg t1 as0 (Node_Element t as cs : cs0) | t == t0 ->+ runParserT p0 (SReg t as cs) >>= \case+ (_, Right a) -> pure (SReg t1 as0 cs0, Right a)+ (s1, Left msg) -> pure (s1, Left msg)+ STop (Node_Element t as cs : cs0) | t == t0 ->+ runParserT p0 (SReg t as cs) >>= \case+ (_, Right a) -> pure (STop cs0, Right a)+ (s1, Left msg) -> pure (s1, Left msg) -- skip leading whitespace- SReg t as (Text' x : cs) | TL.all Char.isSpace x ->- unParser (pElement t0 p0) (SReg t as cs)- STop (Text' x : cs) | TL.all Char.isSpace x ->- unParser (pElement t0 p0) (STop cs)- _ -> Left ("Missing element " <> show t0)+ SReg t as (Node_Text x : cs) | TL.all Char.isSpace x ->+ runParserT (pElement t0 p0) (SReg t as cs)+ STop (Node_Text x : cs) | TL.all Char.isSpace x ->+ runParserT (pElement t0 p0) (STop cs)+ s0 -> pure (s0, Left ("Missing element " <> show t0)) {-# INLINABLE pElement #-} --- | @'pAnyElement' p@ runs a 'Parser' @p@ inside the 'Element' node at the+-- | @'pAnyElement' p@ runs a 'ParserT' @p@ inside the 'Element' node at the -- current position, if any. Otherwise, if no such element exists, this parser -- __fails__. -- -- You can recover the name of the matched element using 'pName' inside the--- given 'Parser'. However, if you already know beforehand the name of the+-- given 'ParserT'. However, if you already know beforehand the name of the -- element that you want to match, it's better to use 'pElement' rather than -- 'pAnyElement'. --@@ -402,23 +640,24 @@ -- -- __Consumes the matched element__ from the parser state. pAnyElement- :: Parser a -- ^ 'Parser' to run /inside/ any matched 'Element'.- -> Parser a-pAnyElement p0 = Parser $ \case- SReg t0 as0 (Element' t as cs : cs0) ->- case unParser p0 (SReg t as cs) of- Right (_, a) -> Right (SReg t0 as0 cs0, a)- Left msg -> Left msg- STop (Element' t as cs : cs0) ->- case unParser p0 (SReg t as cs) of- Right (_, a) -> Right (STop cs0, a)- Left msg -> Left msg+ :: Monad m+ => ParserT m a -- ^ 'ParserT' to run /inside/ any matched 'Element'.+ -> ParserT m a+pAnyElement p0 = ParserT $ \case+ SReg t0 as0 (Node_Element t as cs : cs0) ->+ runParserT p0 (SReg t as cs) >>= \case+ (_, Right a) -> pure (SReg t0 as0 cs0, Right a)+ (s1, Left msg) -> pure (s1, Left msg)+ STop (Node_Element t as cs : cs0) ->+ runParserT p0 (SReg t as cs) >>= \case+ (_, Right a) -> pure (STop cs0, Right a)+ (s1, Left msg) -> pure (s1, Left msg) -- skip leading whitespace- SReg t as (Text' x : cs) | TL.all Char.isSpace x ->- unParser (pAnyElement p0) (SReg t as cs)- STop (Text' x : cs) | TL.all Char.isSpace x ->- unParser (pAnyElement p0) (STop cs)- _ -> Left "Missing element"+ SReg t as (Node_Text x : cs) | TL.all Char.isSpace x ->+ runParserT (pAnyElement p0) (SReg t as cs)+ STop (Node_Text x : cs) | TL.all Char.isSpace x ->+ runParserT (pAnyElement p0) (STop cs)+ s0 -> pure (s0, Left "Missing element") {-# INLINABLE pAnyElement #-} -- | Returns the name of the currently selected 'Element'.@@ -427,48 +666,52 @@ -- 'pElement', 'pAnyElement'). -- -- Doesn't modify the parser state.-pName :: Parser T.Text -- ^ Element name as strict 'T.Text'.-pName = Parser (\case- s@(SReg t _ _) -> Right (s, t)- _ -> Left "Before selecting an name, you must select an element")+pName+ :: Applicative m+ => ParserT m T.Text -- ^ Element name as strict 'T.Text'.+pName = ParserT (\s -> case s of+ SReg t _ _ -> pure (s, Right t)+ _ -> pure (s, Left "Before selecting an name, you must select an element")) {-# INLINABLE pName #-} --- | Return the value of the requested attribute, if defined. Returns an--- 'T.empty' 'T.Text' in case the attribute is defined but no value was given to--- it.+-- | Return the value of the requested attribute, if defined, as strict+-- 'T.Text'. Returns an 'T.empty' strict 'T.Text' in case the attribute is+-- defined but no value was given to it. -- -- This parser __fails__ if there's no currently selected 'Element' (see -- 'pElement', 'pAnyElement'). -- -- __Consumes the matched attribute__ from the parser state. pAttr- :: T.Text+ :: Applicative m+ => T.Text -- ^ Attribute name as strict 'T.Text'.- -> Parser T.Text+ -> ParserT m T.Text -- ^ Attribute value as strict 'T.Text', possibly 'T.empty'.-pAttr n = Parser (\case+pAttr n = ParserT (\s -> case s of SReg t as cs -> case HM.lookup n as of- Just x -> Right (SReg t (HM.delete n as) cs, x)- Nothing -> Left ("Missing attribute " <> show n)- _ -> Left "Before selecting an attribute, you must select an element")+ Just x -> pure (SReg t (HM.delete n as) cs, Right x)+ Nothing -> pure (s, Left ("Missing attribute " <> show n))+ _ -> pure (s, Left "Before selecting an attribute, you must select an element")) {-# INLINABLE pAttr #-} -- | Returns all of the available element attributes. ----- Returns 'T.empty' 'T.Text' as values in case an attribute is defined but no--- value was given to it.+-- Returns 'T.empty' strict 'T.Text' as values in case an attribute is defined+-- but no value was given to it. -- -- This parser __fails__ if there's no currently selected 'Element' (see -- 'pElement', 'pAnyElement'). -- -- __Consumes all the attributes__ for this element from the parser state. pAttrs- :: Parser (HM.HashMap T.Text T.Text)+ :: Applicative m+ => ParserT m (HM.HashMap T.Text T.Text) -- ^ Pairs of attribute names and possibly 'T.empty' values, as strict -- 'T.Text'.-pAttrs = Parser (\case- SReg t as cs -> Right (SReg t mempty cs, as)- _ -> Left "Before selecting an attribute, you must select an element")+pAttrs = ParserT (\s -> case s of+ SReg t as cs -> pure (SReg t mempty cs, Right as)+ _ -> pure (s, Left "Before selecting an attribute, you must select an element")) {-# INLINABLE pAttrs #-} -- | Returns all of the immediate children of the current element.@@ -479,56 +722,64 @@ -- -- __Consumes all the returned nodes__ from the parser state. pChildren- :: Parser [Node]- -- ^ 'Node's in their original order.-pChildren = Parser (\case- STop cs -> Right (STop mempty, cs)- SReg t as cs -> Right (SReg t as mempty, cs))+ :: Applicative m+ => ParserT m [Node] -- ^ 'Node's in their original order.+pChildren = ParserT (\case+ STop cs -> pure (STop mempty, Right cs)+ SReg t as cs -> pure (SReg t as mempty, Right cs)) {-# INLINABLE pChildren #-} --- | Returns the contents of a 'Text' node.+-- | Returns the contents of a text node as a strict 'TL.Text'. -- -- Surrounidng whitespace is not removed, as it is considered to be part of the -- text node. ----- If there is no text node at the current position, then this parser __fails__.--- This implies that 'pText' /never/ returns an empty 'TL.Text', since there is--- no such thing as a text node without text.+-- If there is no text node at the current position, then this parser+-- __fails__. This implies that 'pText' /never/ returns an empty strict+-- 'T.Text', since there is no such thing as a text node without text. -- -- Please note that consecutive text nodes are always concatenated and returned -- together. -- -- @--- 'runParser' 'pText' ('text' \"Ha\" <> 'text' \"sk\" <> 'text' \"ell\")--- == 'Right' ('text' \"Haskell\")+-- 'parse' 'pText' ('text' \"Ha\" <> 'text' \"sk\" <> 'text' \"ell\")+-- == 'Right' ('text' "Haskell") -- @ -- -- __Consumes the text__ from the parser state. This implies that if you -- perform two consecutive 'pText' calls, the second will always fail. -- -- @--- 'runParser' ('pText' >> 'pText') ('text' \"Ha\" <> 'text' \"sk\" <> 'text' \"ell\")--- == 'Left' \"Missing text node\"+-- 'parse' ('pText' >> 'pText') ('text' \"Ha\" <> 'text' \"sk\" <> 'text' \"ell\")+-- == 'Left' "Missing text node" -- @ pText- :: Parser TL.Text+ :: Applicative m+ => ParserT m T.Text+ -- ^ Content of the text node as a strict 'T.Text'.+pText = fmap TL.toStrict pTextLazy++-- | Like 'pText', but returns a lazy 'TL.Text'.+pTextLazy+ :: Applicative m+ => ParserT m TL.Text -- ^ Content of the text node as a lazy 'TL.Text'.-pText = Parser (\case+pTextLazy = ParserT (\case -- Note: this works only because we asume 'normalize' has been used.- STop (Text x : ns) -> Right (STop ns, x)- SReg t as (Text x : cs) -> Right (SReg t as cs, x)- _ -> Left "Missing text node")+ STop (Node_Text x : ns) -> pure (STop ns, Right x)+ SReg t as (Node_Text x : cs) -> pure (SReg t as cs, Right x)+ s0 -> pure (s0, Left "Missing text node")) {-# INLINABLE pText #-} -- | Succeeds if all of the elements, attributes and text nodes have -- been consumed.-pEndOfInput :: Parser ()-pEndOfInput = Parser (\s -> case isEof s of- True -> Right (s, ())- False -> Left "Not end of input yet")+pEndOfInput :: Applicative m => ParserT m ()+pEndOfInput = ParserT (\s -> case isEof s of+ True -> pure (s, Right ())+ False -> pure (s, Left "Not end of input yet")) {-# INLINABLE pEndOfInput #-} -isEof :: S -> Bool+isEof :: ParserState -> Bool isEof = \case SReg _ as cs -> HM.null as && null cs STop ns -> null ns@@ -543,7 +794,7 @@ -- If a 'FromXml' instance for @a@ exists, then: -- -- @- -- 'runParser' 'fromXml' ('toXml' a) == 'Right' a+ -- 'parse' 'fromXml' ('toXml' a) == 'Right' a -- @ toXml :: a -> [Node] @@ -562,20 +813,19 @@ where encodeNode :: Node -> BB.Builder encodeNode = \case- Text x -> encodeXmlUtf8Lazy x- Element t as cs ->+ Node_Text x -> encodeXmlUtf8Lazy x+ Node_Element t as cs -> -- This ugly code is so that we make sure we always bind concatenation -- to the right with as little effort as possible, using (<>). "<" <> encodeUtf8 t- <> encodeAttrs (">" <> encode cs <> "</" <> encodeUtf8 t <> ">")- (mapFromHashMap as)+ <> encodeAttrs (">" <> encode cs <> "</" <> encodeUtf8 t <> ">") as {-# INLINE encodeNode #-}- encodeAttrs :: BB.Builder -> Map.Map T.Text T.Text -> BB.Builder- encodeAttrs = Map.foldrWithKey+ encodeAttrs :: BB.Builder -> HM.HashMap T.Text T.Text -> BB.Builder+ encodeAttrs b as = Map.foldrWithKey' (\k v o -> " " <> encodeUtf8 k <> "=\"" <> encodeXmlUtf8 v <> "\"" <> o)+ b (mapFromHashMap as) {-# INLINE encodeAttrs #-} - -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- Node fixpoint@@ -649,7 +899,7 @@ -- | Zipper into a 'Node' tree. data Cursor = Cursor { _cursorCurrent :: !Node- -- ^ Retrieves the current node of a 'Cursor'.+ -- ^ Retrieves the current node of a @Cursor@. , _cursorLefts :: !(Seq Node) -- ^ Nodes to the left (ordered right to left). , _cursorRights :: !(Seq Node)@@ -664,10 +914,10 @@ traverseChildren :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor {-# INLINABLE traverseChildren #-} traverseChildren f c0 = case _cursorCurrent c0 of- Text _ -> pure c0- Element t as cs -> do+ Node_Text _ -> pure c0+ Node_Element t as cs -> do n1s <- fmap (normalize . join) (traverse f cs)- pure (c0 {_cursorCurrent = Element' t as n1s})+ pure (c0 {_cursorCurrent = Node_Element t as n1s}) -- | The cursor if left in the rightmost sibling. traverseRightSiblings :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor@@ -678,7 +928,7 @@ n2s <- fmap normalize (f n1) traverseRightSiblings f (cursorInsertManyRight n2s c1) --- | Builds a 'Cursor' for navigating a tree. That is, a forest with a single+-- | Builds a @Cursor@ for navigating a tree. That is, a forest with a single -- root 'Node'. cursorFromNode :: Node -> Cursor {-# INLINE cursorFromNode #-}@@ -747,4 +997,3 @@ mapFromHashMap = HM.foldrWithKey' Map.insert Map.empty {-# INLINE mapFromHashMap #-} ---}
test/Test.hs view
@@ -3,15 +3,17 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module Main where import Control.Applicative (liftA2, (<|>)) import Control.Monad (mplus)+import Control.Monad.Trans.Class import qualified Control.Monad.Trans.State as S import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL-import Data.Either (isLeft) import qualified Data.Text as T import qualified Test.Tasty as Tasty import qualified Test.Tasty.Runners as Tasty@@ -58,22 +60,28 @@ tt_element :: Tasty.TestTree tt_element = Tasty.testGroup "element" [ HU.testCase "empty name" $ do- HU.assert (isLeft (X.element' "" [] []))+ X.element' "" [] []+ @?= Left "Element name is blank" , HU.testCase "name with leading whitespace" $ do- HU.assert (isLeft (X.element' " x" [] []))+ X.element' " x" [] []+ @?= Left "Element name has surrounding whitespace: \" x\"" , HU.testCase "name with trailing whitespace" $ do- HU.assert (isLeft (X.element' "x " [] []))+ X.element' "x " [] []+ @?= Left "Element name has surrounding whitespace: \"x \"" , HU.testCase "empty attribute" $ do- HU.assert (isLeft (X.element' "x" [("","a")] []))+ X.element' "x" [("","a")] []+ @?= Left "Attribute name is blank" , HU.testCase "attribute with leading whitespace" $ do- HU.assert (isLeft (X.element' "x" [(" x","a")] []))+ X.element' "x" [(" x","a")] []+ @?= Left "Attribute name has surrounding whitespace: \" x\"" , HU.testCase "attribute with trailing whitespace" $ do- HU.assert (isLeft (X.element' "x" [("x ","a")] []))+ X.element' "x" [("x ","a")] []+ @?= Left "Attribute name has surrounding whitespace: \"x \"" ] tt_encoding :: Tasty.TestTree@@ -120,83 +128,83 @@ tt_parsing :: Tasty.TestTree tt_parsing = Tasty.testGroup "Parsing" [ HU.testCase "endOfInput" $ do- Right () @=? X.runParser X.pEndOfInput []+ Right () @=? X.parse X.pEndOfInput [] , HU.testCase "endOfInput: Not end of input yet" $ do- Left "Not end of input yet" @=? X.runParser X.pEndOfInput (X.text "&")+ Left "Not end of input yet" @=? X.parse X.pEndOfInput (X.text "&") , HU.testCase "text': empty" $ do- Left "Missing text node" @=? X.runParser X.pText []+ Left "Missing text node" @=? X.parse X.pText [] , HU.testCase "text': blank" $ do- Left "Missing text node" @=? X.runParser X.pText (X.text "")+ Left "Missing text node" @=? X.parse X.pText (X.text "") , HU.testCase "text': space" $ do Right " \t\n" @=?- X.runParser X.pText (X.text " " <> X.text "\t" <> X.text "\n")+ X.parse X.pText (X.text " " <> X.text "\t" <> X.text "\n") , HU.testCase "text': missing" $ do- Left "Missing text node" @=? X.runParser X.pText (X.element "a" [] [])+ Left "Missing text node" @=? X.parse X.pText (X.element "a" [] []) , HU.testCase "text'" $ do- Right "&" @=? X.runParser X.pText (X.text "&")+ Right "&" @=? X.parse X.pText (X.text "&") , HU.testCase "text': concat" $ do- Right "&<" @=? X.runParser X.pText+ Right "&<" @=? X.parse X.pText (X.text "&" <> X.text "" <> X.text "<") , HU.testCase "text': twice" $ do- Left "Missing text node" @=? X.runParser (X.pText >> X.pText)+ Left "Missing text node" @=? X.parse (X.pText >> X.pText) (X.text "&" <> X.text "" <> X.text "<") , HU.testCase "any element: empty" $ do- Left "Missing element" @=? X.runParser (X.pAnyElement (pure ())) []+ Left "Missing element" @=? X.parse (X.pAnyElement (pure ())) [] , HU.testCase "any element: text" $ do Left "Missing element"- @=? X.runParser (X.pAnyElement (pure ())) (X.text "a")+ @=? X.parse (X.pAnyElement (pure ())) (X.text "a") , HU.testCase "any element: pure" $ do- Right () @=? X.runParser (X.pAnyElement (pure ())) (X.element "x" [] [])+ Right () @=? X.parse (X.pAnyElement (pure ())) (X.element "x" [] []) , HU.testCase "any element: name" $ do Right "x"- @=? X.runParser (X.pAnyElement X.pName) (X.element "x" [] [])+ @=? X.parse (X.pAnyElement X.pName) (X.element "x" [] []) , HU.testCase "element: empty" $ do- Left "Missing element \"x\"" @=? X.runParser (X.pElement "x" (pure ())) []+ Left "Missing element \"x\"" @=? X.parse (X.pElement "x" (pure ())) [] , HU.testCase "element: Missing element" $ do Left "Missing element \"x\""- @=? X.runParser (X.pElement "x" (pure ())) (X.element "y" [] [])+ @=? X.parse (X.pElement "x" (pure ())) (X.element "y" [] []) , HU.testCase "element: pure" $ do Right ()- @=? X.runParser (X.pElement "x" (pure ())) (X.element "x" [] [])+ @=? X.parse (X.pElement "x" (pure ())) (X.element "x" [] []) , HU.testCase "element: name" $ do Right "x"- @=? X.runParser (X.pElement "x" X.pName) (X.element "x" [] [])+ @=? X.parse (X.pElement "x" X.pName) (X.element "x" [] []) , HU.testCase "element: leading whitespace" $ do Right ()- @=? X.runParser (X.pElement "x" (pure ()))+ @=? X.parse (X.pElement "x" (pure ())) (X.text " \n \t" <> X.element "x" [] []) , HU.testCase "element: text'" $ do Right "ab"- @=? X.runParser (X.pElement "x" X.pText)+ @=? X.parse (X.pElement "x" X.pText) (X.element "x" [] (X.text "a" <> X.text "b")) , HU.testCase "element: nested" $ do Right ([("a","b")], "z")- @=? X.runParser+ @=? X.parse (X.pElement "x" (X.pElement "y" (liftA2 (,) X.pAttrs X.pText))) (X.element "x" [] (X.element "y" [("a","b")] (X.text "z"))) , HU.testCase "element: nested with leading whitespace" $ do Right ([("a","b")], "z")- @=? X.runParser+ @=? X.parse (X.pElement "x" (X.pElement "y" (liftA2 (,) X.pAttrs X.pText))) (X.text " " <> X.element "x" [] (X.text " " <>@@ -204,104 +212,130 @@ , HU.testCase "element: twice" $ do Left "Missing element \"x\""- @=? X.runParser (X.pElement "x" (pure ()) >> X.pElement "x" (pure ()))+ @=? X.parse (X.pElement "x" (pure ()) >> X.pElement "x" (pure ())) (X.element "x" [] []) , HU.testCase "attr" $ do Right "a"- @=? X.runParser (X.pElement "x" (X.pAttr "y"))+ @=? X.parse (X.pElement "x" (X.pAttr "y")) (X.element "x" [("y","a"), ("z","b")] []) , HU.testCase "attr: Missing" $ do Left "Missing attribute \"y\""- @=? X.runParser (X.pElement "x" (X.pAttr "y")) (X.element "x" [] [])+ @=? X.parse (X.pElement "x" (X.pAttr "y")) (X.element "x" [] []) , HU.testCase "attrs: empty" $ do Right []- @=? X.runParser (X.pElement "x" X.pAttrs) (X.element "x" [] [])+ @=? X.parse (X.pElement "x" X.pAttrs) (X.element "x" [] []) , HU.testCase "attrs" $ do Right [("y","a"), ("z","b")]- @=? X.runParser (X.pElement "x" X.pAttrs)+ @=? X.parse (X.pElement "x" X.pAttrs) (X.element "x" [("z","b"), ("y","a")] []) , HU.testCase "attrs: twice" $ do Right []- @=? X.runParser (X.pElement "x" (X.pAttrs >> X.pAttrs))+ @=? X.parse (X.pElement "x" (X.pAttrs >> X.pAttrs)) (X.element "x" [("z","b"), ("y","a")] []) , HU.testCase "fail: empty" $ do (Left "x" :: Either String ())- @=? X.runParser (fail "x") []+ @=? X.parse (fail "x") [] , HU.testCase "fail" $ do (Left "x" :: Either String ())- @=? X.runParser (fail "x") (X.text "y")+ @=? X.parse (fail "x") (X.text "y") , HU.testCase "children: empty" $ do Right []- @=? X.runParser (X.pElement "x" X.pChildren) (X.element "x" [] [])+ @=? X.parse (X.pElement "x" X.pChildren) (X.element "x" [] []) , HU.testCase "children: top empty" $ do- Right [] @=? X.runParser X.pChildren []+ Right [] @=? X.parse X.pChildren [] , HU.testCase "children: top 1 node" $ do Right (X.element "x" [] [])- @=? X.runParser X.pChildren (X.element "x" [] [])+ @=? X.parse X.pChildren (X.element "x" [] []) , HU.testCase "children: top 1 node twice" $ do Right []- @=? X.runParser (X.pChildren >> X.pChildren) (X.element "x" [] [])+ @=? X.parse (X.pChildren >> X.pChildren) (X.element "x" [] []) , HU.testCase "children: top 2 nodes" $ do Right (X.element "x" [] [] <> X.text "ab" <> X.element "y" [] [])- @=? X.runParser X.pChildren+ @=? X.parse X.pChildren (X.element "x" [] [] <> X.text "a" <> X.text "b" <> X.element "y" [] []) , HU.testCase "children: 1 node" $ do Right (X.text "foo")- @=? X.runParser (X.pElement "x" X.pChildren)+ @=? X.parse (X.pElement "x" X.pChildren) (X.element "x" [] (X.text "foo")) , HU.testCase "children: 1 node twice" $ do Right []- @=? X.runParser (X.pElement "x" (X.pChildren >> X.pChildren))+ @=? X.parse (X.pElement "x" (X.pChildren >> X.pChildren)) (X.element "x" [] (X.text "foo")) , HU.testCase "children: 2 successive text' nodes" $ do Right (X.text "foobar")- @=? X.runParser (X.pElement "x" X.pChildren)+ @=? X.parse (X.pElement "x" X.pChildren) (X.element "x" [] (X.text "foo" <> X.text "bar")) , HU.testCase "children: 2 text' nodes twice" $ do Right []- @=? X.runParser (X.pElement "x" (X.pChildren >> X.pChildren))+ @=? X.parse (X.pElement "x" (X.pChildren >> X.pChildren)) (X.element "x" [] (X.text "foo" <> X.text "bar")) , HU.testCase "children: 3 nodes" $ do let ns0 = X.text "foo" <> X.element "a" [] [] <> X.text "bar" Right ns0- @=? X.runParser (X.pElement "x" X.pChildren)- (X.element "x" [] ns0)+ @=? X.parse (X.pElement "x" X.pChildren)+ (X.element "x" [] ns0) , HU.testCase "children: 3 nodes twice" $ do Right []- @=? X.runParser (X.pElement "x" (X.pChildren >> X.pChildren))+ @=? X.parse (X.pElement "x" (X.pChildren >> X.pChildren)) (X.element "x" [] (X.text "foo" <> X.element "a" [] [] <> X.text "bar")) + , QC.testProperty "parserT (runParserT pAnyElement) == pAnyElement" $ do+ QC.forAllShrink QC.arbitrary QC.shrink $ \t ->+ let p0 = X.pAnyElement ((,,) <$> X.pName <*> X.pAttrs <*> X.pChildren)+ p1 = X.parserT (X.runParserT p0)+ ns = X.element t [] []+ in X.parse p0 ns === X.parse p1 ns++ , QC.testProperty "parserT (runParserT pText) == pText" $ do+ QC.forAllShrink QC.arbitrary QC.shrink $ \t ->+ let p0 = X.pText+ p1 = X.parserT (X.runParserT p0)+ ns = X.text t+ in X.parse p0 ns === X.parse p1 ns++ , HU.testCase "ParserT StateT" $ do+ (Right "Haskell", "b")+ @=? S.runState (X.parseM (do s0 <- lift S.get+ a <- X.pElement s0 X.pText+ lift $ S.put (T.map succ s0)+ s1 <- lift S.get+ b <- X.pElement s1 X.pText+ pure (a <> b))+ (X.element "a" [] (X.text "Has") <>+ X.element "b" [] (X.text "kell")))+ "a" ] + tt_backtracking :: Tasty.TestTree tt_backtracking = Tasty.testGroup "Backtracking" [ HU.testCase "Alternative" $- Right "y" @=? X.runParser+ Right "y" @=? X.parse -- The second pText fails because the state is empty after the first ((X.pText >> X.pText >> pure "a") <|> X.pText) (X.text "y") , HU.testCase "MonadPlus" $- Right "y" @=? X.runParser+ Right "y" @=? X.parse -- The second pText fails because the state is empty after the first (mplus (X.pText >> X.pText >> pure "a") X.pText) (X.text "y")@@ -323,7 +357,8 @@ fixvisit :: (X.Node -> S.State T.Text [X.Node]) -> (X.Node -> S.State T.Text [X.Node])-fixvisit _ n@(X.Element t _ _) = do+fixvisit _ n = do+ let X.Element t _ _ = n S.modify (\ts -> mappend ts t) pure [n]
xmlbf.cabal view
@@ -1,5 +1,5 @@ name: xmlbf-version: 0.6.2+version: 0.7 synopsis: XML back and forth! Parser, renderer, ToXml, FromXml, fixpoints. description: XML back and forth! Parser, renderer, ToXml, FromXml, fixpoints. homepage: https://gitlab.com/k0001/xmlbf@@ -29,6 +29,9 @@ bytestring, containers, deepseq,+ exceptions,+ mmorph,+ mtl, selective, text, transformers,