xmlbf 0.4.1 → 0.5
raw patch · 4 files changed
+477/−214 lines, 4 filesdep +deepseq
Dependencies added: deepseq
Files
- ChangeLog.md +43/−0
- lib/Xmlbf.hs +232/−115
- test/Test.hs +199/−98
- xmlbf.cabal +3/−1
ChangeLog.md view
@@ -1,3 +1,46 @@+# 0.5++* COMPILER ASSISTED BREAKING CHANGE. `element` now returns `[Node]`.+ This makes the library safer. It's not possible to construct a+ malformed `Element` anymore using the names exported by the library.+ It is also ergonomic, since most functions with which you would want+ to use a manually constructed `Element` expect a `[Node]` anyway.++* COMPILER ASSISTED BREAKING CHANGE. `element'` now returns+ `Either String Node`.++* COMPILER ASSISTED BREAKING CHANGE. `text` now returns `[Node]`.++* COMPILER ASSISTED BREAKING CHANGE. Removed `IsString Node` instance.++* COMPILER ASSISTED BREAKING CHANGE. Use lazy `Text` inside `Text`+ nodes. This improves `Text` concatenation performance, performed+ internally by `Xmlbf`, and makes more intelligent use of memory when+ dealing with long texts.++* COMPILER ASSISTED BREAKING CHANGE. Removed `pRead`. You are encouraged+ to use `pFail` or `mzero` if you want to write a failing parser.++* BREAKING CHANGE. `pText` now skips empty text nodes.++* Added `node`.++* Added `pFail`.++* Added `text'`.++* Added `pChildren`.++* Added `pAnyElement`.++* Added `pName`.++* Added `NFData` instance for `Node`.++* `encode` doesn't render self-closing tags anymore. Instead, each element has+ its corresponding closing tag.++ # 0.4.1 * Generalized type of `pRead`.
lib/Xmlbf.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -27,11 +28,14 @@ FromXml(fromXml) , Parser , runParser+ , pFail , pElement+ , pAnyElement+ , pName , pAttr , pAttrs+ , pChildren , pText- , pRead , pEndOfInput -- * Rendering@@ -39,6 +43,7 @@ , encode , Node+ , node , pattern Element , element@@ -46,6 +51,7 @@ , pattern Text , text+ , text' -- * Fixpoints , dfpos@@ -54,6 +60,7 @@ , dfpreM ) where +import Control.DeepSeq (NFData(rnf)) import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Builder.Prim as BBP import qualified Data.Char as Char@@ -63,27 +70,31 @@ import Data.Monoid ((<>)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq-import Data.String (IsString(fromString)) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import Data.Typeable (Typeable, typeRep, tyConName, typeRepTyCon)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL import Data.Traversable (for) import Data.Word (Word8) import Control.Applicative (Alternative(empty, (<|>)))-import Control.Monad (MonadPlus(mplus, mzero), join, guard)+import Control.Monad (MonadPlus(mplus, mzero), join, when) import Control.Monad.Fail (MonadFail(fail))-import qualified Text.Read -------------------------------------------------------------------------------- --- | Either a text or an element node in an XML fragment.+-- | Either a text or an element node in an XML fragment body. -- -- Construct with 'text' or 'element'. Destruct with 'Text' or 'Element'. data Node = Element' !T.Text !(HM.HashMap T.Text T.Text) ![Node]- | Text' !T.Text+ | 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` ()+ instance Show Node where showsPrec n = \x -> showParen (n > 10) $ case x of Text' t -> showString "Text " . showsPrec 0 t@@ -96,80 +107,111 @@ -- | 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 #-}+{-# COMPLETE Element #-} -- TODO this leads to silly pattern matching warnings -- | Destruct a text 'Node'.-pattern Text :: T.Text -> Node+pattern Text :: TL.Text -> Node pattern Text t <- Text' t-{-# COMPLETE Text #-}+{-# COMPLETE Text #-} -- TODO this leads to silly pattern matching warnings --- | Constructs a 'Text'.-instance IsString Node where- fromString = text . T.pack- {-# INLINABLE fromString #-}+-- | 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.+ -> Node+ -> a+{-# INLINE node #-}+node fe ft = \case+ Text' t -> ft t+ Element' t as cs -> fe t as cs --- | Concats 'Text's together.+-- | Normalizes 'Node's by concatenating consecutive 'Text' nodes. normalize :: [Node] -> [Node] {-# INLINE normalize #-} normalize = \case- Text a : Text b : ns -> normalize (text (a <> b) : ns)- (n : ns) -> n : normalize ns+ -- 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 [] -> [] --- | Construct a text 'Node'.-text :: T.Text -> Node-text = Text'+-- | Construct a XML fragment body containing a single 'Text' 'Node', if+-- possible.+--+-- 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+-- construct it, use 'text'' instead.+--+-- Using 'text'' rather than 'text' is recommended, so that you are forced to+-- acknowledge a failing situation in case it happens. However, 'text' is at+-- times more convenient to use, whenever you know the input is valid.+text :: TL.Text -> [Node] {-# INLINE text #-}+text t = case text' t of+ Right x -> [x]+ Left _ -> [] --- | Construct an element 'Node'.+-- | Construct a 'Text' 'Node', if possible.+--+-- Returns 'Left' if the 'Text' 'Node' can't be created, with an explanation+-- of why.+text' :: TL.Text -> Either String Node+{-# INLINE text' #-}+text' = \case+ "" -> Left "Empty text"+ t -> Right (Text' t)++-- | Construct a XML fragment body containing a single 'Element' 'Node', if+-- possible.+--+-- This function will return empty list if it is not possible to construct the+-- 'Element' with the given input. To learn more about /why/ it was not possible+-- to construct it, use 'element' instead.+--+-- Using 'element'' rather than 'element' is recommended, so that you are forced+-- 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.- -> HM.HashMap T.Text T.Text- -- ^ Attributes.+ :: T.Text -- ^ Element' name.+ -> HM.HashMap T.Text T.Text -- ^ Attributes.+ -> [Node] -- ^ Children. -> [Node]- -- ^ Children.- -> Either String Node- -- ^ Returns 'Left' if the element name, or atribute names, or attribute- -- values are invalid.- --- -- TODO: We just check for emptyness currently.-element t0 hm0 ns0 = do- guarde (t0 == T.strip t0) $- "Element name has surrounding whitespace: " ++ show t0- guarde (not (T.null t0)) ("Element name is blank: " ++ show t0)- for_ (HM.keys hm0) $ \k -> do- guarde (k == T.strip k) $- "Attribute name has surrounding whitespace: " ++ show k- guarde (not (T.null k)) ("Attribute name is blank: " ++ show k)- Right (Element' t0 hm0 (normalize ns0))+{-# INLINE element #-}+element t hm ns = case element' t hm ns of+ Right x -> [x]+ Left _ -> [] --- | Unsafe version of 'element', causing a runtime 'error' in situations--- where 'element' would return 'Left'. So, don't use this unless you know--- what you are doing.+-- | Construct an 'Element' 'Node'.+--+-- Returns 'Left' if the 'Element' 'Node' can't be created, with an explanation+-- of why. element' :: T.Text -- ^ Element' name. -> HM.HashMap T.Text T.Text -- ^ Attributes. -> [Node] -- ^ Children.- -> Node-{-# INLINE element' #-}-element' t hm ns =- case element t hm ns of- Right x -> x- Left e -> error ("element': " ++ e)---guarde :: Bool -> String -> Either String ()-{-# INLINE guarde #-}-guarde True _ = Right ()-guarde False s = Left s+ -> 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))+ 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)) -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- Parsing class FromXml a where- -- | Parses an XML fragment into a value of type @a@.+ -- | Parses an XML fragment body into a value of type @a@. -- -- If a 'ToXml' instance for @a@ exists, then: --@@ -181,22 +223,23 @@ -- | XML parser monad. To be run with 'runParser'. -- -- You can build a 'Parser' using 'pElement', 'pAttr', 'pAttrs', 'pText',--- 'pRead', or any of the 'Applicative', 'Alternative' or 'Monad' combinators.+-- 'pFail', or any of the 'Applicative', 'Alternative' or 'Monad' combinators. newtype Parser a = Parser { unParser :: S -> Either String (a, S) } deriving (Functor) --- | Run a parser on an XML fragment. If the parser fails, then a 'String' with--- an error message is returned.+-- | Run a parser on an XML fragment body. If the parser fails, then a 'String'+-- with an error message is returned. -- -- 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 :: Parser a -> [Node] -> Either String a runParser p0 = fmap fst . unParser p0 . STop . normalize +-- | Internal parser state. data S = STop ![Node] -- ^ Parsing the top-level nodes.- | SReg !(HM.HashMap T.Text T.Text) ![Node]+ | SReg !T.Text !(HM.HashMap T.Text T.Text) ![Node] -- ^ Parsing a particular root element. deriving (Show) @@ -210,16 +253,14 @@ pure (f a, s2) instance Monad Parser where- {-# INLINE return #-}- return = pure {-# INLINE (>>=) #-} Parser ga >>= k = Parser $ \s0 -> do (a, s1) <- ga s0 unParser (k a) s1- fail e = Parser (\_ -> Left e)+ fail = pFail instance MonadFail Parser where- fail e = Parser (\_ -> Left e)+ fail = pFail -- | Backtracks. instance Alternative Parser where@@ -238,6 +279,10 @@ -------------------------------------------------------------------------------- -- Some parsers +-- | A 'Parser' that always fails with the given error message.+pFail :: String -> Parser a+pFail e = Parser (\_ -> Left e)+ -- | @'pElement' "foo" p@ runs a 'Parser' @p@ inside a element node named -- @"foo"@. This fails if such element does not exist at the current position. --@@ -248,70 +293,131 @@ pElement :: T.Text -> Parser a -> Parser a {-# INLINABLE pElement #-} pElement t0 p0 = Parser $ \case- SReg as0 (Element' t as cs : cs0) | t == t0 -> do- (a,_) <- unParser p0 (SReg as cs)- Right (a, SReg as0 cs0)+ SReg t1 as0 (Element' t as cs : cs0) | t == t0 -> do+ (a,_) <- unParser p0 (SReg t as cs)+ Right (a, SReg t1 as0 cs0) STop (Element' t as cs : cs0) | t == t0 -> do- (a,_) <- unParser p0 (SReg as cs)+ (a,_) <- unParser p0 (SReg t as cs) Right (a, STop cs0) -- skip leading whitespace- SReg as (Text' x : cs) | T.all Char.isSpace x ->- unParser (pElement t0 p0) (SReg as cs)- STop (Text' x : cs) | T.all Char.isSpace x ->+ 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) +-- | @'pAnyElement' p@ runs a 'Parser' @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+-- element that you want to match, it's better to use 'pElement' rather than+-- 'pAnyElement'.+--+-- Leading whitespace is ignored. If you need to preserve that whitespace for+-- some reason, capture it using 'pText' before using 'pAnyElement'.+--+-- Consumes the element from the parser state.+pAnyElement :: Parser a -> Parser a+{-# INLINABLE pAnyElement #-}+pAnyElement p0 = Parser $ \case+ SReg t0 as0 (Element' t as cs : cs0) -> do+ (a,_) <- unParser p0 (SReg t as cs)+ Right (a, SReg t0 as0 cs0)+ STop (Element' t as cs : cs0) -> do+ (a,_) <- unParser p0 (SReg t as cs)+ Right (a, STop cs0)+ -- 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"++-- | Returns the name of the currently selected element.+--+-- This parser fails if there's no currently selected element.+--+-- Doesn't modify the parser state.+pName :: Parser T.Text+{-# INLINABLE pName #-}+pName = Parser $ \case+ SReg t as cs -> Right (t, SReg t as cs)+ STop _ -> Left "Before selecting an name, you must select an element"+ -- | Return the value of the requested attribute, if defined. May return an -- empty string in case the attribute is defined but no value was given to it. --+-- This parser fails if there's no currently selected element.+-- -- Consumes the attribute from the parser state. pAttr :: T.Text -> Parser T.Text {-# INLINABLE pAttr #-} pAttr n = Parser $ \case STop _ -> Left "Before selecting an attribute, you must select an element"- SReg as cs -> case HM.lookup n as of- Just x -> Right (x, SReg (HM.delete n as) cs)+ SReg t as cs -> case HM.lookup n as of+ Just x -> Right (x, SReg t (HM.delete n as) cs) Nothing -> Left ("Missing attribute " ++ show n) -- | Returns all of the available element attributes. May return empty strings -- 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.+-- -- Consumes all of the remaining attributes for this element from the parser -- state. pAttrs :: Parser (HM.HashMap T.Text T.Text) {-# INLINABLE pAttrs #-} pAttrs = Parser $ \case STop _ -> Left "Before selecting an attribute, you must select an element"- SReg as cs -> Right (as, SReg mempty cs)+ SReg t as cs -> Right (as, SReg t mempty cs) --- | Return a text node value (including CDATA).+-- | Returns all of the immediate children of the current element. ----- Consumes the text node from the parser state. Surrounding whitespace is not--- removed.+-- If parsing top-level nodes rather than a particular element (that is, if+-- 'pChildren' is /not/ being run inside 'pElement'), then all of the top level+-- 'Node's will be returned. ----- Law: When two consecutive calls to 'pText' are made, the first call returns--- all of the available consecutive text, and the second call always fails.-pText :: Parser T.Text+-- Consumes all of the returned nodes from the parser state.+pChildren :: Parser [Node]+{-# INLINABLE pChildren #-}+pChildren = Parser $ \case+ STop cs -> Right (cs, STop mempty)+ SReg t as cs -> Right (cs, SReg t as mempty)++-- | Return a text node value.+--+-- 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 '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")+-- @+--+-- The returned text is consumed 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"+-- @+pText :: Parser TL.Text {-# INLINABLE pText #-} pText = Parser $ \case -- Note: this works only because we asume 'normalize' has been used. STop (Text x : ns) -> Right (x, STop ns)- SReg as (Text x : cs) -> Right (x, SReg as cs)+ SReg t as (Text x : cs) -> Right (x, SReg t as cs) _ -> Left "Missing text node" --- | A version of 'read' (from "Prelude") that can fail in the 'Parser'--- monad (or any other 'MonadFail').------ Note: In case it isn't obvious from the type signature, this function doesn't--- touch the underlying 'Parser' state at all.-pRead :: (Typeable a, Read a, MonadFail m) => T.Text -> m a-{-# INLINABLE pRead #-}-pRead = \t -> case Text.Read.readMaybe (T.unpack t) of- Just a -> pure a- ya@Nothing -> do- let ty = tyConName (typeRepTyCon (typeRep ya))- Control.Monad.Fail.fail ("Can't read as " ++ ty ++ ": " ++ show t)- -- | Succeeds if all of the elements, attributes and text nodes have -- been consumed. pEndOfInput :: Parser ()@@ -323,14 +429,14 @@ isEof :: S -> Bool {-# INLINE isEof #-} isEof = \case- SReg as cs -> HM.null as && null cs+ SReg _ as cs -> HM.null as && null cs STop ns -> null ns -------------------------------------------------------------------------------- -- Rendering class ToXml a where- -- | Renders a value of type @a@ into an XML fragment.+ -- | Renders a value of type @a@ into an XML fragment body. -- -- If a 'FromXml' instance for @a@ exists, then: --@@ -339,23 +445,30 @@ -- @ toXml :: a -> [Node] --- | Encodes a list of XML 'Node's to an UTF8-encoded and XML-escaped--- bytestring.+-- | Encodes a list of XML 'Node's, representing an XML fragment body, to an+-- UTF8-encoded and XML-escaped bytestring.+--+-- This function doesn't render self-closing elements. Instead, all+-- elements have a corresponding closing tag.+--+-- Also, it doesn't render CDATA sections. Instead, all text is escaped as+-- necessary. encode :: [Node] -> BB.Builder-encode xs = mconcat $ xs >>= \case- Text x -> [encodeXmlUtf8 x]- Element t as cs ->- [ "<"- , encodeUtf8 t- , mconcat $ do- (k,v) <- HM.toList as- guard (not (T.null k))- [ " ", encodeUtf8 k, "=\"", encodeXmlUtf8 v, "\"" ]- , if null cs then "/" else ""- , ">"- , encode cs- , if null cs then "" else "</" <> encodeUtf8 t <> ">"- ]+encode xs = mconcat (map encodeNode xs)+ where+ encodeNode :: Node -> BB.Builder+ encodeNode = \case+ Text x -> encodeXmlUtf8Lazy x+ 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 <> ">") as+ encodeAttrs :: BB.Builder -> HM.HashMap T.Text T.Text -> BB.Builder+ encodeAttrs = HM.foldlWithKey'+ (\o k v -> " " <> encodeUtf8 k <> "=\"" <> encodeXmlUtf8 v <> "\"" <> o)+ {-# INLINE encodeNode #-}+ {-# INLINE encodeAttrs #-} -------------------------------------------------------------------------------- --------------------------------------------------------------------------------@@ -383,9 +496,9 @@ -- @ -- foo :: 'Node' -> ['Node'] -- foo = 'dfpos' $ \\k -> \\case--- 'Element' "w" as cs -> k ('element'' "x" as cs)--- 'Element' "x" as cs -> ['element'' "y" as cs]--- 'Element' "y" as cs -> k ('element'' "z" as cs)+-- 'Element' "w" as cs -> 'element'' "x" as cs >>= k+-- 'Element' "x" as cs -> 'element'' "y" as cs+-- 'Element' "y" as cs -> 'element'' "z" as cs >>= k -- @ -- -- See 'dfpre' for pre-orderd depth-first replacement.@@ -499,6 +612,10 @@ encodeXmlUtf8 :: T.Text -> BB.Builder {-# INLINE encodeXmlUtf8 #-} encodeXmlUtf8 = T.encodeUtf8BuilderEscaped xmlEscaped++encodeXmlUtf8Lazy :: TL.Text -> BB.Builder+{-# INLINE encodeXmlUtf8Lazy #-}+encodeXmlUtf8Lazy = TL.encodeUtf8BuilderEscaped xmlEscaped xmlEscaped :: BBP.BoundedPrim Word8 {-# INLINE xmlEscaped #-}
test/Test.hs view
@@ -8,6 +8,7 @@ import Debug.Trace import Control.Applicative (many, liftA2)+import Control.DeepSeq (rnf) import qualified Control.Monad.Trans.State as S import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB@@ -36,80 +37,84 @@ -------------------------------------------------------------------------------- tt_main :: Tasty.TestTree tt_main = Tasty.testGroup "main"- [ tt_element+ [ tt_text+ , tt_element , tt_encoding , tt_parsing , tt_fixpoints ] +tt_text :: Tasty.TestTree+tt_text = Tasty.testGroup "text'"+ [ QC.testProperty "text: empty or one" $+ QC.forAllShrink QC.arbitrary QC.shrink $ \t ->+ length (X.text t) <= 1++ , QC.testProperty "text: like text'" $+ QC.forAllShrink QC.arbitrary QC.shrink $ \t ->+ case X.text' t of+ Left _ -> X.text t === []+ Right n -> X.text t === [n]+ ]+ tt_element :: Tasty.TestTree tt_element = Tasty.testGroup "element" [ HU.testCase "empty name" $ do- HU.assert (isLeft (X.element "" [] []))+ HU.assert (isLeft (X.element' "" [] [])) , HU.testCase "name with leading whitespace" $ do- HU.assert (isLeft (X.element " x" [] []))+ HU.assert (isLeft (X.element' " x" [] [])) , HU.testCase "name with trailing whitespace" $ do- HU.assert (isLeft (X.element "x " [] []))+ HU.assert (isLeft (X.element' "x " [] [])) , HU.testCase "empty attribute" $ do- HU.assert (isLeft (X.element "x" [("","a")] []))+ HU.assert (isLeft (X.element' "x" [("","a")] [])) , HU.testCase "attribute with leading whitespace" $ do- HU.assert (isLeft (X.element "x" [(" x","a")] []))+ HU.assert (isLeft (X.element' "x" [(" x","a")] [])) , HU.testCase "attribute with trailing whitespace" $ do- HU.assert (isLeft (X.element "x" [("x ","a")] []))+ HU.assert (isLeft (X.element' "x" [("x ","a")] [])) ] tt_encoding :: Tasty.TestTree tt_encoding = Tasty.testGroup "Encoding"- [ HU.testCase "" $ do+ [ HU.testCase "empty" $ do bsEncode [] @?= "" - , HU.testCase "<x a=\"y\"/>" $ do- let n0 = X.element' "x" [("a","y")] []- bsEncode [n0] @?= "<x a=\"y\"/>"-- , HU.testCase "<x a=\"y\" b=\"\"/>" $ do- let n0 = X.element' "x" [("a","y"), ("b","")] []- bsEncode [n0] @?= "<x a=\"y\" b=\"\"/>"-- , HU.testCase "<x a=\"y\" b=\"z\"/>" $ do- let n0 = X.element' "x" [("a","y"), ("b","z")] []- bsEncode [n0] @?= "<x a=\"y\" b=\"z\"/>"+ , HU.testCase "xml: <x a=\"y\"></x>" $ do+ bsEncode (X.element "x" [("a","y")] [])+ @?= "<x a=\"y\"></x>" - , HU.testCase "<x a=\"y\" b=\"z\"></x>" $ do- let n0 = X.element' "x" [("a","y"), ("b","z")] [X.text ""]- bsEncode [n0] @?= "<x a=\"y\" b=\"z\"></x>"+ , HU.testCase "xml: <x b=\"\" a=\"y\"></x>" $ do+ bsEncode (X.element "x" [("a","y"), ("b","")] [])+ @?= "<x b=\"\" a=\"y\"></x>" - , HU.testCase "<x>foo</x>" $ do- let n0 = X.element' "x" [] [X.text "foo"]- bsEncode [n0] @?= "<x>foo</x>"+ , HU.testCase "xml: <x b=\"z\" a=\"y\"></x>" $ do+ bsEncode (X.element "x" [("a","y"), ("b","z")] [])+ @?= "<x b=\"z\" a=\"y\"></x>" - , HU.testCase "<x>foobar</x>" $ do- let n0 = X.element' "x" [] [X.text "foo", X.text "bar"]- bsEncode [n0] @?= "<x>foobar</x>"+ , HU.testCase "xml: <x>foo</x>" $ do+ bsEncode (X.element "x" [] (X.text "foo"))+ @?= "<x>foo</x>" - , HU.testCase "<x><y/></x>" $ do- let n0 = X.element' "x" [] [X.element' "y" [] []]- bsEncode [n0] @?= "<x><y/></x>"+ , HU.testCase "xml: <x>foobar</x>" $ do+ bsEncode (X.element "x" [] (X.text "foo" <> X.text "bar"))+ @?= "<x>foobar</x>" - , HU.testCase "<x><y/></x>" $ do- let n0 = X.element' "x" []- [X.text "", X.element' "y" [] [], X.text ""]- bsEncode [n0] @?= "<x><y/></x>"+ , HU.testCase "xml: <x><y></y></x>" $ do+ bsEncode (X.element "x" [] (X.element "y" [] []))+ @?= "<x><y></y></x>" - , HU.testCase "<x><y/><z/></x>" $ do- let n0 = X.element' "x" []- [X.element' "y" [] [], X.element' "z" [] []]- bsEncode [n0] @?= "<x><y/><z/></x>"+ , HU.testCase "xml: <x><y></y><z></z></x>" $ do+ bsEncode (X.element "x" []+ (X.element "y" [] [] <> X.element "z" [] []))+ @?= "<x><y></y><z></z></x>" - , HU.testCase "<x><y>" $ do- let n0 = X.element' "x" [] []- n1 = X.element' "y" [] []- bsEncode [n0,n1] @?= "<x/><y/>"+ , HU.testCase "xml: <x></x><y></y>" $ do+ bsEncode (X.element "x" [] [] <> X.element "y" [] [])+ @?= "<x></x><y></y>" ] --------------------------------------------------------------------------------@@ -120,94 +125,190 @@ Right () @=? X.runParser 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.runParser X.pEndOfInput (X.text "&") - , HU.testCase "text: empty" $ do+ , HU.testCase "text': empty" $ do Left "Missing text node" @=? X.runParser X.pText [] - , HU.testCase "text: Missing text node" $ do- Left "Missing text node" @=? X.runParser X.pText [X.element' "a" [] []]+ , HU.testCase "text': blank" $ do+ Left "Missing text node" @=? X.runParser X.pText (X.text "") - , HU.testCase "text" $ do- Right "&" @=? X.runParser X.pText [X.text "&"]+ , HU.testCase "text': space" $ do+ Right " \t\n" @=?+ X.runParser X.pText (X.text " " <> X.text "\t" <> X.text "\n") - , HU.testCase "text: concat" $ do+ , HU.testCase "text': missing" $ do+ Left "Missing text node" @=? X.runParser X.pText (X.element "a" [] [])++ , HU.testCase "text'" $ do+ Right "&" @=? X.runParser X.pText (X.text "&")++ , HU.testCase "text': concat" $ do Right "&<" @=? X.runParser X.pText- [X.text "&", X.text "", X.text "<"]+ (X.text "&" <> X.text "" <> X.text "<") - , HU.testCase "text: twice" $ do+ , HU.testCase "text': twice" $ do Left "Missing text node" @=? X.runParser (X.pText >> X.pText)- [X.text "&", X.text "", X.text "<"]+ (X.text "&" <> X.text "" <> X.text "<") + , HU.testCase "any element: empty" $ do+ Left "Missing element" @=? X.runParser (X.pAnyElement (pure ())) []++ , HU.testCase "any element: text" $ do+ Left "Missing element"+ @=? X.runParser (X.pAnyElement (pure ())) (X.text "a")++ , HU.testCase "any element: pure" $ do+ Right () @=? X.runParser (X.pAnyElement (pure ())) (X.element "x" [] [])++ , HU.testCase "any element: name" $ do+ Right "x"+ @=? X.runParser (X.pAnyElement X.pName) (X.element "x" [] [])+ , HU.testCase "element: empty" $ do Left "Missing element \"x\"" @=? X.runParser (X.pElement "x" (pure ())) [] , HU.testCase "element: Missing element" $ do Left "Missing element \"x\""- @=? X.runParser (X.pElement "x" (pure ())) [X.element' "y" [] []]+ @=? X.runParser (X.pElement "x" (pure ())) (X.element "y" [] []) , HU.testCase "element: pure" $ do Right ()- @=? X.runParser (X.pElement "x" (pure ())) [X.element' "x" [] []]+ @=? X.runParser (X.pElement "x" (pure ())) (X.element "x" [] []) + , HU.testCase "element: name" $ do+ Right "x"+ @=? X.runParser (X.pElement "x" X.pName) (X.element "x" [] [])+ , HU.testCase "element: leading whitespace" $ do Right () @=? X.runParser (X.pElement "x" (pure ()))- [X.text " \n \t", X.element' "x" [] []]+ (X.text " \n \t" <> X.element "x" [] []) - , HU.testCase "element: text" $ do+ , HU.testCase "element: text'" $ do Right "ab" @=? X.runParser (X.pElement "x" X.pText)- [X.element' "x" [] [X.text "a", X.text "b"]]+ (X.element "x" [] (X.text "a" <> X.text "b")) , HU.testCase "element: nested" $ do Right ([("a","b")], "z") @=? X.runParser (X.pElement "x" (X.pElement "y" (liftA2 (,) X.pAttrs X.pText)))- [X.element' "x" [] [X.element' "y" [("a","b")] [X.text "z"]]]+ (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.pElement "x" (X.pElement "y" (liftA2 (,) X.pAttrs X.pText)))- [X.text " ", X.element' "x" [] [X.text " ", X.element' "y" [("a","b")] [X.text "z"]]]+ (X.text " " <>+ X.element "x" [] (X.text " " <>+ X.element "y" [("a","b")] (X.text "z"))) + , HU.testCase "element: twice" $ do+ Left "Missing element \"x\""+ @=? X.runParser (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.element' "x" [("y","a"), ("z","b")] []]+ (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.runParser (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.runParser (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.element' "x" [("z","b"), ("y","a")] []]+ (X.element "x" [("z","b"), ("y","a")] []) - , HU.testCase "read" $ do- Right False @=? X.runParser (X.pRead =<< X.pText) [X.text "False"]- (Left "Can't read as Bool: \"XXXXX\"" :: Either String Bool)- @=? X.runParser (X.pRead =<< X.pText) [X.text "XXXXX"]+ , HU.testCase "attrs: twice" $ do+ Right []+ @=? X.runParser (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 (X.pFail "x") []++ , HU.testCase "fail" $ do+ (Left "x" :: Either String ())+ @=? X.runParser (X.pFail "x") (X.text "y")++ , HU.testCase "children: empty" $ do+ Right []+ @=? X.runParser (X.pElement "x" X.pChildren) (X.element "x" [] [])++ , HU.testCase "children: top empty" $ do+ Right [] @=? X.runParser X.pChildren []++ , HU.testCase "children: top 1 node" $ do+ Right (X.element "x" [] [])+ @=? X.runParser X.pChildren (X.element "x" [] [])++ , HU.testCase "children: top 1 node twice" $ do+ Right []+ @=? X.runParser (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.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.element "x" [] (X.text "foo"))++ , HU.testCase "children: 1 node twice" $ do+ Right []+ @=? X.runParser (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.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.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)++ , HU.testCase "children: 3 nodes twice" $ do+ Right []+ @=? X.runParser (X.pElement "x" (X.pChildren >> X.pChildren))+ (X.element "x" []+ (X.text "foo" <> X.element "a" [] [] <> X.text "bar"))+ ] node0 :: X.Node-node0 =- X.element' "a" []- [ X.element' "b" []- [ X.element' "c" [] []- , X.element' "d" [] [] ]- , X.element' "e" []- [ X.element' "f" [] []- , X.element' "g" [] [] ] ]+Right node0 =+ X.element' "a" [] $ mconcat+ [ X.element "b" []+ (X.element "c" [] [] <>+ X.element "d" [] [])+ , X.element "e" []+ (X.element "f" [] [] <>+ X.element "g" [] [])+ ] + fixvisit :: (X.Node -> S.State T.Text [X.Node]) -> (X.Node -> S.State T.Text [X.Node]) fixvisit k n@(X.Element t _ _) = do@@ -222,24 +323,24 @@ ts @?= "cdbfgea" , HU.testCase "dfpos: output single node" $ do- let n0 = X.element' "x" [] [X.text "a", X.text "b"]+ let Right n0 = X.element' "x" [] (X.text "a" <> X.text "b") f = \k -> \case- X.Text "ab" -> k (X.text "foo")- X.Text "foo" -> k (X.text "FOO")+ X.Text "ab" -> X.text "foo" >>= k+ X.Text "foo" -> X.text "FOO" >>= k n -> [n]- n1 = X.element' "x" [] [X.text "FOO"]- [n1] @?= X.dfpos f n0+ X.element "x" [] (X.text "FOO")+ @?= X.dfpos f n0 , HU.testCase "dfpos: output multiple nodes" $ do- let n0 = X.element' "x" [] [X.text "a"]+ let Right n0 = X.element' "x" [] (X.text "a") f = \k -> \case- X.Text "a" -> let ny = X.element' "y" [] [] in [ny, ny] >>= k- X.Element "y" _ _ -> k (X.text "b")+ X.Text "a" -> let ny = X.element "y" [] [] in (ny <> ny) >>= k+ X.Element "y" _ _ -> X.text "b" >>= k X.Element "x" as cs ->- let nz = X.element' "z" as cs in [nz, X.text "a"] >>= k+ (X.element "z" as cs <> X.text "a") >>= k n -> [n]- ns1 = [X.element' "z" [] [X.text "bb"], X.text "bb"]- ns1 @?= X.dfpos f n0+ (X.element "z" [] (X.text "bb") <> X.text "bb")+ @?= X.dfpos f n0 , HU.testCase "dfpre: depth-first pre-order?" $ do let (ns, ts) = S.runState (X.dfpreM fixvisit node0) []@@ -247,24 +348,24 @@ ts @?= "abcdefg" , HU.testCase "dfpre: output single node" $ do- let n0 = X.element' "x" [] [X.text "a", X.text "b"]+ let Right n0 = X.element' "x" [] (X.text "a" <> X.text "b") f = \k -> \case- X.Text "ab" -> k (X.text "foo")- X.Text "foo" -> k (X.text "FOO")+ X.Text "ab" -> X.text "foo" >>= k+ X.Text "foo" -> X.text "FOO" >>= k n -> [n]- n1 = X.element' "x" [] [X.text "FOO"]- [n1] @?= X.dfpre f n0+ X.element "x" [] (X.text "FOO")+ @?= X.dfpre f n0 , HU.testCase "dfpre: output multiple nodes" $ do- let n0 = X.element' "x" [] [X.text "a"]+ let Right n0 = X.element' "x" [] (X.text "a") f = \k -> \case- X.Text "a" -> let ny = X.element' "y" [] [] in [ny, ny] >>= k- X.Element "y" _ _ -> k (X.text "b")+ X.Text "a" -> let ny = X.element "y" [] [] in (ny <> ny) >>= k+ X.Element "y" _ _ -> X.text "b" >>= k X.Element "x" as cs ->- let nz = X.element' "z" as cs in [nz, X.text "a"] >>= k+ (X.element "z" as cs <> X.text "a") >>= k n -> [n]- ns1 = [X.element' "z" [] [X.text "bb"], X.text "bb"]- ns1 @?= X.dfpre f n0+ X.element "z" [] (X.text "bb") <> X.text "bb"+ @?= X.dfpre f n0 ] --------------------------------------------------------------------------------
xmlbf.cabal view
@@ -1,5 +1,5 @@ name: xmlbf-version: 0.4.1+version: 0.5 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@@ -23,6 +23,7 @@ base <5, bytestring, containers,+ deepseq, text, transformers, unordered-containers@@ -35,6 +36,7 @@ build-depends: base, bytestring,+ deepseq, xmlbf, QuickCheck, quickcheck-instances,