diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,9 +1,20 @@ +# 0.3 + +* BREAKING CHANGE. Renamed `df` and `dfM` to `dfpos` and `dfposM` respectively. + +* Added `dfpre` and `dfpreM`. + +* Improved `Show` instance for `Node`. + +* Added `element'`. + + # 0.2 -* 'Text' constructor hidden in favor of a 'text' function plus a 'Text' pattern - synonym, just like with 'element' and 'Element'. +* `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. +* Documentation: Render `Element` pattern synonym. # 0.1 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,3 +1,20 @@ +Copyright 2017-2018, Renzo Carbonara . + +Except where otherwise explicitly mentioned, all of contents of the +"xmlbf" project are licensed under the Apache License, Version 2.0 (the +"License"); you may not use this file except in compliance with the +License. You may obtain a copy of the License at the end of this file or at +http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + + +------------------------------------------------------------------------------- + Apache License Version 2.0, January 2004 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,4 @@ #! /usr/bin/env nix-shell -#! nix-shell ./default.nix -i runghc +#! nix-shell ./shell.nix -i runghc import Distribution.Simple main = defaultMain diff --git a/lib/Xmlbf.hs b/lib/Xmlbf.hs --- a/lib/Xmlbf.hs +++ b/lib/Xmlbf.hs @@ -3,7 +3,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} - {-# LANGUAGE ScopedTypeVariables #-} -- | XML back and forth! @@ -18,7 +17,7 @@ -- @xmlbf@ provides a 'ToXml' class intended to be used as the familiar -- 'Data.Aeson.toJSON' from the @aeson@ package. -- --- @xmlb@ provides tools like 'df' and 'dfM' for finding a fixpoint +-- @xmlb@ provides tools like 'dfpos' and 'dfposM' for finding a fixpoint -- of a XML structure. module Xmlbf ( -- * Parsing @@ -40,13 +39,16 @@ , pattern Element , element + , element' , pattern Text , text -- * Fixpoints - , df - , dfM + , dfpos + , dfposM + , dfpre + , dfpreM ) where import qualified Data.ByteString.Builder as BB @@ -61,6 +63,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable (Typeable, typeRep, tyConName, typeRepTyCon) +import Data.Traversable (for) import Data.Word (Word8) import Control.Applicative (Alternative(empty, (<|>))) import Control.Monad (MonadPlus(mplus, mzero), join, guard) @@ -75,15 +78,26 @@ data Node = Element' !T.Text !(HM.HashMap T.Text T.Text) ![Node] | Text' !T.Text - deriving (Eq, Show) + deriving (Eq) +instance Show Node where + showsPrec n = \x -> showParen (n > 10) $ case x of + Text' t -> showString "Text " . showsPrec 0 t + 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 #-} -- | Destruct a text 'Node'. pattern Text :: T.Text -> Node pattern Text t <- Text' t +{-# COMPLETE Text #-} -- | Constructs a 'Text'. instance IsString Node where @@ -126,6 +140,21 @@ guarde (not (T.null k)) ("Attribute name is blank: " ++ show k) Right (Element' t0 hm0 (normalize ns0)) +-- | 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. +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 () @@ -154,6 +183,9 @@ -- | Run a parser on an XML fragment. 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 @@ -206,6 +238,7 @@ -- -- 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') @@ -256,6 +289,7 @@ -- -- Consumes the raw string from the parser state. pRead :: (Typeable a, Read a) => T.Text -> Parser a +{-# INLINABLE pRead #-} pRead = \t -> case Text.Read.readMaybe (T.unpack t) of Just a -> pure a ya@Nothing -> do @@ -265,6 +299,7 @@ -- | Succeeds if all of the elements, attributes and text nodes have -- been consumed. pEndOfInput :: Parser () +{-# INLINABLE pEndOfInput #-} pEndOfInput = Parser (\s -> if isEof s then Right ((), s) else Left "Not end of input yet") @@ -330,27 +365,44 @@ -- -- @ -- foo :: 'Node' -> ['Node'] --- foo = 'df' $ \\k -> \\case +-- foo = 'dfpos' $ \\k -> \\case -- '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. +-- See 'dfpre' for pre-orderd depth-first replacement. +-- +-- /WARNING/ If you call @k@ in every branch, then 'dfpos' will never terminate. -- Make sure the recursion stops at some point by simply returning a list of -- nodes instead of calling @k@. -df :: ((Node -> [Node]) -> Node -> [Node]) -> Node -> [Node] -df f = runIdentity . dfM (\k -> Identity . f (runIdentity . k)) +dfpos :: ((Node -> [Node]) -> Node -> [Node]) -> Node -> [Node] +dfpos f = runIdentity . dfposM (\k -> Identity . f (runIdentity . k)) --- | Monadic version of 'df'. -dfM :: Monad m => ((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node] -dfM f = \n0 -> do - let c0 = cursorFromNode n0 - c1 <- traverschildren (dfM f) c0 - c2 <- traverseRightSiblings (dfM f) c1 +-- | Monadic version of 'dfpos'. +dfposM :: Monad m => ((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node] +dfposM f = \n0 -> do + c1 <- traverseChildren (dfposM f) (cursorFromNode n0) + c2 <- traverseRightSiblings (dfposM f) c1 fmap (normalize . join) - (traverse (f (dfM f)) (cursorSiblings c2)) + (traverse (f (dfposM f)) (cursorSiblings c2)) + +-- | Pre-order depth-first replacement of 'Node' and all of its children. +-- +-- This is just like 'dfpos' but the search proceeds in a different order. +dfpre :: ((Node -> [Node]) -> Node -> [Node]) -> Node -> [Node] +dfpre f = runIdentity . dfpreM (\k -> Identity . f (runIdentity . k)) + +-- | Monadic version of 'dfpre'. +dfpreM :: Monad m => ((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node] +dfpreM f = \n0 -> do + ns <- f (dfpreM f) n0 + fmap (normalize . join) $ for ns $ \n -> do + c1 <- traverseChildren (dfpreM f) (cursorFromNode n) + cursorSiblings <$> traverseRightSiblings (dfpreM f) c1 + + -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- INTERNAL: Cursor @@ -373,9 +425,9 @@ ------------------------------------------------------------------------------ -- | The cursor if left where it starts. -traverschildren :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor -{-# INLINE traverschildren #-} -traverschildren f c0 = case _cursorCurrent c0 of +traverseChildren :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor +{-# INLINE traverseChildren #-} +traverseChildren f c0 = case _cursorCurrent c0 of Text _ -> pure c0 Element t as cs -> do n1s <- fmap (normalize . join) (traverse f cs) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -69,46 +69,46 @@ bsEncode [] @?= "" , HU.testCase "" $ do - let n0 = unsafeElement "x" [("a","y")] [] + let n0 = X.element' "x" [("a","y")] [] bsEncode [n0] @?= "" , HU.testCase "" $ do - let n0 = unsafeElement "x" [("a","y"), ("b","")] [] + let n0 = X.element' "x" [("a","y"), ("b","")] [] bsEncode [n0] @?= "" , HU.testCase "" $ do - let n0 = unsafeElement "x" [("a","y"), ("b","z")] [] + let n0 = X.element' "x" [("a","y"), ("b","z")] [] bsEncode [n0] @?= "" , HU.testCase "" $ do - let n0 = unsafeElement "x" [("a","y"), ("b","z")] [X.text ""] + let n0 = X.element' "x" [("a","y"), ("b","z")] [X.text ""] bsEncode [n0] @?= "" , HU.testCase "foo" $ do - let n0 = unsafeElement "x" [] [X.text "foo"] + let n0 = X.element' "x" [] [X.text "foo"] bsEncode [n0] @?= "foo" , HU.testCase "foobar" $ do - let n0 = unsafeElement "x" [] [X.text "foo", X.text "bar"] + let n0 = X.element' "x" [] [X.text "foo", X.text "bar"] bsEncode [n0] @?= "foobar" , HU.testCase "" $ do - let n0 = unsafeElement "x" [] [unsafeElement "y" [] []] + let n0 = X.element' "x" [] [X.element' "y" [] []] bsEncode [n0] @?= "" , HU.testCase "" $ do - let n0 = unsafeElement "x" [] - [X.text "", unsafeElement "y" [] [], X.text ""] + let n0 = X.element' "x" [] + [X.text "", X.element' "y" [] [], X.text ""] bsEncode [n0] @?= "" , HU.testCase "" $ do - let n0 = unsafeElement "x" [] - [unsafeElement "y" [] [], unsafeElement "z" [] []] + let n0 = X.element' "x" [] + [X.element' "y" [] [], X.element' "z" [] []] bsEncode [n0] @?= "" , HU.testCase "" $ do - let n0 = unsafeElement "x" [] [] - n1 = unsafeElement "y" [] [] + let n0 = X.element' "x" [] [] + n1 = X.element' "y" [] [] bsEncode [n0,n1] @?= "" ] @@ -126,7 +126,7 @@ Left "Missing text node" @=? X.runParser X.pText [] , HU.testCase "text: Missing text node" $ do - Left "Missing text node" @=? X.runParser X.pText [unsafeElement "a" [] []] + Left "Missing text node" @=? X.runParser X.pText [X.element' "a" [] []] , HU.testCase "text" $ do Right "&" @=? X.runParser X.pText [X.text "&"] @@ -144,80 +144,111 @@ , HU.testCase "element: Missing element" $ do Left "Missing element \"x\"" - @=? X.runParser (X.pElement "x" (pure ())) [unsafeElement "y" [] []] + @=? X.runParser (X.pElement "x" (pure ())) [X.element' "y" [] []] , HU.testCase "element: pure" $ do Right () - @=? X.runParser (X.pElement "x" (pure ())) [unsafeElement "x" [] []] + @=? X.runParser (X.pElement "x" (pure ())) [X.element' "x" [] []] , HU.testCase "element: text" $ do Right "ab" @=? X.runParser (X.pElement "x" X.pText) - [unsafeElement "x" [] [X.text "a", X.text "b"]] + [X.element' "x" [] [X.text "a", X.text "b"]] , HU.testCase "attr" $ do Right "a" @=? X.runParser (X.pElement "x" (X.pAttr "y")) - [unsafeElement "x" [("y","a"), ("z","b")] []] + [X.element' "x" [("y","a"), ("z","b")] []] , HU.testCase "attr: Missing" $ do Left "Missing attribute \"y\" in element \"x\"" - @=? X.runParser (X.pElement "x" (X.pAttr "y")) [unsafeElement "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) [unsafeElement "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) - [unsafeElement "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"] ] + +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" [] [] ] ] + + +fixvisit :: (X.Node -> S.State T.Text [X.Node]) + -> (X.Node -> S.State T.Text [X.Node]) +fixvisit k n@(X.Element t _ _) = do + S.modify (\ts -> mappend ts t) + pure [n] + tt_fixpoints :: Tasty.TestTree tt_fixpoints = Tasty.testGroup "fixpoints" - [ HU.testCase "df: depth-first post-order?" $ do - let n0 = unsafeElement "a" [] - [ unsafeElement "b" [] - [ unsafeElement "c" [] [] - , unsafeElement "d" [] [] ] - , unsafeElement "e" [] - [ unsafeElement "f" [] [] - , unsafeElement "g" [] [] ] ] - f = \k n@(X.Element t _ _) -> S.modify (t:) >> pure [n] - ["c","d","b","f","g","e","a"] @=? reverse (S.execState (X.dfM f n0) []) - [n0] @=? S.evalState (X.dfM f n0) [] + [ HU.testCase "dfpos: depth-first post-order?" $ do + let (ns, ts) = S.runState (X.dfposM fixvisit node0) [] + ns @?= [node0] + ts @?= "cdbfgea" - , HU.testCase "df: output single node" $ do - let n0 = unsafeElement "x" [] [X.text "a", X.text "b"] + , HU.testCase "dfpos: output single node" $ do + let 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") n -> [n] - n1 = unsafeElement "x" [] [X.text "FOO"] - [n1] @=? X.df f n0 + n1 = X.element' "x" [] [X.text "FOO"] + [n1] @?= X.dfpos f n0 - , HU.testCase "df: output multiple nodes" $ do - let n0 = unsafeElement "x" [] [X.text "a"] + , HU.testCase "dfpos: output multiple nodes" $ do + let n0 = X.element' "x" [] [X.text "a"] f = \k -> \case - X.Text "a" -> let ny = unsafeElement "y" [] [] in [ny, ny] >>= k + X.Text "a" -> let ny = X.element' "y" [] [] in [ny, ny] >>= k 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 = X.element' "z" as cs in [nz, X.text "a"] >>= k n -> [n] - ns1 = [unsafeElement "z" [] [X.text "bb"], X.text "bb"] - ns1 @=? X.df f n0 + ns1 = [X.element' "z" [] [X.text "bb"], X.text "bb"] + ns1 @?= X.dfpos f n0 + + , HU.testCase "dfpre: depth-first pre-order?" $ do + let (ns, ts) = S.runState (X.dfpreM fixvisit node0) [] + ns @?= [node0] + ts @?= "abcdefg" + + , HU.testCase "dfpre: output single node" $ do + let 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") + n -> [n] + n1 = X.element' "x" [] [X.text "FOO"] + [n1] @?= X.dfpre f n0 + + , HU.testCase "dfpre: output multiple nodes" $ do + let 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.Element "x" as cs -> + let nz = X.element' "z" as cs in [nz, X.text "a"] >>= k + n -> [n] + ns1 = [X.element' "z" [] [X.text "bb"], X.text "bb"] + ns1 @?= X.dfpre f n0 ] -------------------------------------------------------------------------------- - -unsafeElement :: T.Text -> HM.HashMap T.Text T.Text -> [X.Node] -> X.Node -unsafeElement n as cs = case X.element n as cs of - Right e -> e - Left e -> error ("unsafeElement: " ++ e) bsEncode :: [X.Node] -> B.ByteString bsEncode = BL.toStrict . BB.toLazyByteString . X.encode diff --git a/xmlbf.cabal b/xmlbf.cabal --- a/xmlbf.cabal +++ b/xmlbf.cabal @@ -1,5 +1,5 @@ name: xmlbf -version: 0.2 +version: 0.3 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 @@ -7,7 +7,7 @@ license-file: LICENSE author: Renzo Carbonara maintainer: ren§ren*zone -copyright: Copyright 2017 Renzo Carbonara +copyright: Copyright 2017-2018 Renzo Carbonara category: Text build-type: Simple extra-source-files: ChangeLog.md README.md