diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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`. diff --git a/lib/Xmlbf.hs b/lib/Xmlbf.hs --- a/lib/Xmlbf.hs +++ b/lib/Xmlbf.hs @@ -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 #-} diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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 "" $ do - let n0 = X.element' "x" [("a","y")] [] - bsEncode [n0] @?= "" - - , HU.testCase "" $ do - let n0 = X.element' "x" [("a","y"), ("b","")] [] - bsEncode [n0] @?= "" - - , HU.testCase "" $ do - let n0 = X.element' "x" [("a","y"), ("b","z")] [] - bsEncode [n0] @?= "" + , HU.testCase "xml: " $ do + bsEncode (X.element "x" [("a","y")] []) + @?= "" - , HU.testCase "" $ do - let n0 = X.element' "x" [("a","y"), ("b","z")] [X.text ""] - bsEncode [n0] @?= "" + , HU.testCase "xml: " $ do + bsEncode (X.element "x" [("a","y"), ("b","")] []) + @?= "" - , HU.testCase "foo" $ do - let n0 = X.element' "x" [] [X.text "foo"] - bsEncode [n0] @?= "foo" + , HU.testCase "xml: " $ do + bsEncode (X.element "x" [("a","y"), ("b","z")] []) + @?= "" - , HU.testCase "foobar" $ do - let n0 = X.element' "x" [] [X.text "foo", X.text "bar"] - bsEncode [n0] @?= "foobar" + , HU.testCase "xml: foo" $ do + bsEncode (X.element "x" [] (X.text "foo")) + @?= "foo" - , HU.testCase "" $ do - let n0 = X.element' "x" [] [X.element' "y" [] []] - bsEncode [n0] @?= "" + , HU.testCase "xml: foobar" $ do + bsEncode (X.element "x" [] (X.text "foo" <> X.text "bar")) + @?= "foobar" - , HU.testCase "" $ do - let n0 = X.element' "x" [] - [X.text "", X.element' "y" [] [], X.text ""] - bsEncode [n0] @?= "" + , HU.testCase "xml: " $ do + bsEncode (X.element "x" [] (X.element "y" [] [])) + @?= "" - , HU.testCase "" $ do - let n0 = X.element' "x" [] - [X.element' "y" [] [], X.element' "z" [] []] - bsEncode [n0] @?= "" + , HU.testCase "xml: " $ do + bsEncode (X.element "x" [] + (X.element "y" [] [] <> X.element "z" [] [])) + @?= "" - , HU.testCase "" $ do - let n0 = X.element' "x" [] [] - n1 = X.element' "y" [] [] - bsEncode [n0,n1] @?= "" + , HU.testCase "xml: " $ do + bsEncode (X.element "x" [] [] <> X.element "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 ] -------------------------------------------------------------------------------- diff --git a/xmlbf.cabal b/xmlbf.cabal --- a/xmlbf.cabal +++ b/xmlbf.cabal @@ -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,