xmlbf 0.3 → 0.4
raw patch · 4 files changed
+51/−16 lines, 4 files
Files
- ChangeLog.md +7/−0
- lib/Xmlbf.hs +25/−14
- test/Test.hs +18/−1
- xmlbf.cabal +1/−1
ChangeLog.md view
@@ -1,3 +1,10 @@+# 0.4++* BREAKING CHANGE. `pElement` now skips leading whitespace before an element.++* Fixed nested element parsing (#6)++ # 0.3 * BREAKING CHANGE. Renamed `df` and `dfM` to `dfpos` and `dfposM` respectively.
lib/Xmlbf.hs view
@@ -53,6 +53,7 @@ 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.Functor.Identity (Identity(Identity), runIdentity) import qualified Data.HashMap.Strict as HM@@ -192,8 +193,9 @@ data S = STop ![Node] -- ^ Parsing the top-level nodes.- | SReg !T.Text !(HM.HashMap T.Text T.Text) ![Node]+ | SReg !(HM.HashMap T.Text T.Text) ![Node] -- ^ Parsing a particular root element.+ deriving (Show) instance Applicative Parser where {-# INLINE pure #-}@@ -236,16 +238,24 @@ -- | @'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. --+-- Leading whitespace is ignored. If you need to preserve that whitespace for+-- some reason, capture it using 'pText' before using 'pElement'.+-- -- Consumes the element from the parser state. pElement :: T.Text -> Parser a -> Parser a {-# INLINABLE pElement #-} pElement t0 p0 = Parser $ \case- SReg t as (Element t' as' cs' : cs) | t == t0 -> do- (a,_) <- unParser p0 (SReg t' as' cs')- Right (a, SReg t as cs)- STop (Element t as cs : ns) | t == t0 -> do- (a,_) <- unParser p0 (SReg t as cs)- Right (a, STop ns)+ SReg as0 (Element' t as cs : cs0) | t == t0 -> do+ (a,_) <- unParser p0 (SReg as cs)+ Right (a, SReg as0 cs0)+ STop (Element' t as cs : cs0) | t == t0 -> do+ (a,_) <- unParser p0 (SReg 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 ->+ unParser (pElement t0 p0) (STop cs) _ -> Left ("Missing element " ++ show t0) -- | Return the value of the requested attribute, if defined. May return an@@ -256,9 +266,9 @@ {-# INLINABLE pAttr #-} pAttr n = Parser $ \case STop _ -> Left "Before selecting an attribute, you must select an element"- 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 ++ " in element " ++ show t)+ SReg as cs -> case HM.lookup n as of+ Just x -> Right (x, SReg (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.@@ -269,11 +279,12 @@ {-# INLINABLE pAttrs #-} pAttrs = Parser $ \case STop _ -> Left "Before selecting an attribute, you must select an element"- SReg t as cs -> Right (as, SReg t mempty cs)+ SReg as cs -> Right (as, SReg mempty cs) -- | Return a text node value (including CDATA). ----- Consumes the text node from the parser state.+-- Consumes the text node from the parser state. Surrounding whitespace is not+-- removed. -- -- 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.@@ -282,7 +293,7 @@ pText = Parser $ \case -- Note: this works only because we asume 'normalize' has been used. STop (Text x : ns) -> Right (x, STop ns)- SReg t as (Text x : cs) -> Right (x, SReg t as cs)+ SReg as (Text x : cs) -> Right (x, SReg as cs) _ -> Left "Missing text node" -- | Parses a value that can be 'read'.@@ -307,7 +318,7 @@ 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 --------------------------------------------------------------------------------
test/Test.hs view
@@ -150,18 +150,35 @@ Right () @=? X.runParser (X.pElement "x" (pure ())) [X.element' "x" [] []] + , HU.testCase "element: leading whitespace" $ do+ Right ()+ @=? X.runParser (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.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"]]]++ , 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"]]]+ , HU.testCase "attr" $ do Right "a" @=? X.runParser (X.pElement "x" (X.pAttr "y")) [X.element' "x" [("y","a"), ("z","b")] []] , HU.testCase "attr: Missing" $ do- Left "Missing attribute \"y\" in element \"x\""+ Left "Missing attribute \"y\"" @=? X.runParser (X.pElement "x" (X.pAttr "y")) [X.element' "x" [] []] , HU.testCase "attrs: empty" $ do
xmlbf.cabal view
@@ -1,5 +1,5 @@ name: xmlbf-version: 0.3+version: 0.4 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