diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +# 0.2 + +* 'Text' constructor hidden in favor of a 'text' function plus a 'Text' pattern + synonym, just like with 'element' and 'Element'. + +* Documentation: Render 'Element' pattern synonym. + + # 0.1 * First version. diff --git a/lib/Xmlbf.hs b/lib/Xmlbf.hs --- a/lib/Xmlbf.hs +++ b/lib/Xmlbf.hs @@ -16,8 +16,7 @@ -- 'Parser' type and the related tools. -- -- @xmlbf@ provides a 'ToXml' class intended to be used as the familiar --- 'Data.Aeson.toJSON' from the @aeson@ package. This relies on the --- 'Node' and 'Element'' types. +-- 'Data.Aeson.toJSON' from the @aeson@ package. -- -- @xmlb@ provides tools like 'df' and 'dfM' for finding a fixpoint -- of a XML structure. @@ -37,9 +36,14 @@ , ToXml(toXml) , encode - , Node(Text, Element) + , Node + + , pattern Element , element + , pattern Text + , text + -- * Fixpoints , df , dfM @@ -65,29 +69,41 @@ -------------------------------------------------------------------------------- --- | Either a text or an element node in an XML fragment. Construct with either --- 'Text' or 'element', respectively. +-- | Either a text or an element node in an XML fragment. +-- +-- 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' !T.Text deriving (Eq, Show) +-- | 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 +-- | Destruct a text 'Node'. +pattern Text :: T.Text -> Node +pattern Text t <- Text' t + -- | Constructs a 'Text'. instance IsString Node where - fromString = Text . T.pack + fromString = text . T.pack {-# INLINABLE fromString #-} -- | Concats 'Text's together. normalize :: [Node] -> [Node] {-# INLINE normalize #-} normalize = \case - Text a : Text b : ns -> normalize (Text (a <> b) : ns) + Text a : Text b : ns -> normalize (text (a <> b) : ns) (n : ns) -> n : normalize ns [] -> [] +-- | Construct a text 'Node'. +text :: T.Text -> Node +text = Text' +{-# INLINE text #-} + +-- | Construct an element 'Node'. element :: T.Text -- ^ Element' name. @@ -102,8 +118,8 @@ -- 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) + "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 @@ -191,10 +207,10 @@ -- Consumes the element from the parser state. pElement :: T.Text -> Parser a -> Parser a pElement t0 p0 = Parser $ \case - SReg t as (Element' t' as' cs' : cs) | t == t0 -> do + 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 + STop (Element t as cs : ns) | t == t0 -> do (a,_) <- unParser p0 (SReg t as cs) Right (a, STop ns) _ -> Left ("Missing element " ++ show t0) @@ -277,7 +293,7 @@ encode :: [Node] -> BB.Builder encode xs = mconcat $ xs >>= \case Text x -> [encodeXmlUtf8 x] - Element' t as cs -> + Element t as cs -> [ "<" , encodeUtf8 t , mconcat $ do @@ -315,9 +331,9 @@ -- @ -- foo :: 'Node' -> ['Node'] -- foo = 'df' $ \\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 -> let 'Right' e = 'element' "x" as cs in k e +-- 'Element' "x" as cs -> let 'Right' e = 'element' "y" as cs in [e] +-- 'Element' "y" as cs -> let 'Right' e = 'element' "z" as cs in k e -- @ -- -- /WARNING/ If you call @k@ in every branch, then 'df' will never terminate. @@ -361,7 +377,7 @@ {-# INLINE traverschildren #-} traverschildren f c0 = case _cursorCurrent c0 of Text _ -> pure c0 - Element' t as cs -> do + Element t as cs -> do n1s <- fmap (normalize . join) (traverse f cs) pure (c0 {_cursorCurrent = Element' t as n1s}) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -81,15 +81,15 @@ bsEncode [n0] @?= "" , HU.testCase "" $ do - let n0 = unsafeElement "x" [("a","y"), ("b","z")] [X.Text ""] + let n0 = unsafeElement "x" [("a","y"), ("b","z")] [X.text ""] bsEncode [n0] @?= "" , HU.testCase "foo" $ do - let n0 = unsafeElement "x" [] [X.Text "foo"] + let n0 = unsafeElement "x" [] [X.text "foo"] bsEncode [n0] @?= "foo" , HU.testCase "foobar" $ do - let n0 = unsafeElement "x" [] [X.Text "foo", X.Text "bar"] + let n0 = unsafeElement "x" [] [X.text "foo", X.text "bar"] bsEncode [n0] @?= "foobar" , HU.testCase "" $ do @@ -98,7 +98,7 @@ , HU.testCase "" $ do let n0 = unsafeElement "x" [] - [X.Text "", unsafeElement "y" [] [], X.Text ""] + [X.text "", unsafeElement "y" [] [], X.text ""] bsEncode [n0] @?= "" , HU.testCase "" $ do @@ -120,7 +120,7 @@ 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 Left "Missing text node" @=? X.runParser X.pText [] @@ -129,15 +129,15 @@ Left "Missing text node" @=? X.runParser X.pText [unsafeElement "a" [] []] , HU.testCase "text" $ do - Right "&" @=? X.runParser X.pText [X.Text "&"] + 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 Left "Missing text node" @=? X.runParser (X.pText >> X.pText) - [X.Text "&", X.Text "", X.Text "<"] + [X.text "&", X.text "", X.text "<"] , HU.testCase "element: empty" $ do Left "Missing element \"x\"" @=? X.runParser (X.pElement "x" (pure ())) [] @@ -153,7 +153,7 @@ , HU.testCase "element: text" $ do Right "ab" @=? X.runParser (X.pElement "x" X.pText) - [unsafeElement "x" [] [X.Text "a", X.Text "b"]] + [unsafeElement "x" [] [X.text "a", X.text "b"]] , HU.testCase "attr" $ do Right "a" @@ -174,7 +174,7 @@ [unsafeElement "x" [("z","b"), ("y","a")] []] , HU.testCase "read" $ do - Right False @=? X.runParser (X.pRead =<< X.pText) [X.Text "False"] + Right False @=? X.runParser (X.pRead =<< X.pText) [X.text "False"] ] tt_fixpoints :: Tasty.TestTree @@ -192,23 +192,23 @@ [n0] @=? S.evalState (X.dfM f n0) [] , HU.testCase "df: output single node" $ do - let n0 = unsafeElement "x" [] [X.Text "a", X.Text "b"] + let n0 = unsafeElement "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" -> k (X.text "foo") + X.Text "foo" -> k (X.text "FOO") n -> [n] - n1 = unsafeElement "x" [] [X.Text "FOO"] + n1 = unsafeElement "x" [] [X.text "FOO"] [n1] @=? X.df f n0 , HU.testCase "df: output multiple nodes" $ do - let n0 = unsafeElement "x" [] [X.Text "a"] + let n0 = unsafeElement "x" [] [X.text "a"] f = \k -> \case X.Text "a" -> let ny = unsafeElement "y" [] [] in [ny, ny] >>= k - X.Element "y" _ _ -> k (X.Text "b") + X.Element "y" _ _ -> k (X.text "b") X.Element "x" as cs -> - let nz = unsafeElement "z" as cs in [nz, X.Text "a"] >>= k + let nz = unsafeElement "z" as cs in [nz, X.text "a"] >>= k n -> [n] - ns1 = [unsafeElement "z" [] [X.Text "bb"], X.Text "bb"] + ns1 = [unsafeElement "z" [] [X.text "bb"], X.text "bb"] ns1 @=? X.df f n0 ] @@ -222,20 +222,3 @@ bsEncode :: [X.Node] -> B.ByteString bsEncode = BL.toStrict . BB.toLazyByteString . X.encode -{-- - -instance QC.Arbitrary X.Node where - arbitrary = QC.frequency - [ (1, X.Element <$> QC.arbitrary) - , (50, X.Text <$> QC.arbitrary) ] - shrink (X.Text t0) = X.Text <$> QC.shrink t0 - shrink (X.Element e0) = X.Element <$> QC.shrink e0 - -instance QC.Arbitrary X.Element where - arbitrary = X.Element - <$> QC.arbitrary - <*> QC.arbitrary - <*> QC.arbitrary - shrink (X.Element n as cs) = - X.Element <$> QC.shrink n <*> QC.shrink as <*> QC.shrink cs --} diff --git a/xmlbf.cabal b/xmlbf.cabal --- a/xmlbf.cabal +++ b/xmlbf.cabal @@ -1,5 +1,5 @@ name: xmlbf -version: 0.1 +version: 0.2 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