packages feed

xmlbf 0.2 → 0.3

raw patch · 6 files changed

+183/−72 lines, 6 filessetup-changed

Files

ChangeLog.md view
@@ -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
LICENSE view
@@ -1,3 +1,20 @@+Copyright 2017-2018, Renzo Carbonara <renλren.zone>.++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
Setup.hs view
@@ -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
lib/Xmlbf.hs view
@@ -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)
test/Test.hs view
@@ -69,46 +69,46 @@       bsEncode [] @?= ""    , HU.testCase "<x a=\"y\"/>" $ do-      let n0 = unsafeElement "x" [("a","y")] []+      let n0 = X.element' "x" [("a","y")] []       bsEncode [n0] @?= "<x a=\"y\"/>"    , HU.testCase "<x a=\"y\" b=\"\"/>" $ do-      let n0 = unsafeElement "x" [("a","y"), ("b","")] []+      let n0 = X.element' "x" [("a","y"), ("b","")] []       bsEncode [n0] @?= "<x a=\"y\" b=\"\"/>"    , HU.testCase "<x a=\"y\" b=\"z\"/>" $ do-      let n0 = unsafeElement "x" [("a","y"), ("b","z")] []+      let n0 = X.element' "x" [("a","y"), ("b","z")] []       bsEncode [n0] @?= "<x a=\"y\" b=\"z\"/>"    , HU.testCase "<x a=\"y\" b=\"z\"></x>" $ do-      let n0 = unsafeElement "x" [("a","y"), ("b","z")] [X.text ""]+      let n0 = X.element' "x" [("a","y"), ("b","z")] [X.text ""]       bsEncode [n0] @?= "<x a=\"y\" b=\"z\"></x>"    , HU.testCase "<x>foo</x>" $ do-      let n0 = unsafeElement "x" [] [X.text "foo"]+      let n0 = X.element' "x" [] [X.text "foo"]       bsEncode [n0] @?= "<x>foo</x>"    , HU.testCase "<x>foobar</x>" $ do-      let n0 = unsafeElement "x" [] [X.text "foo", X.text "bar"]+      let n0 = X.element' "x" [] [X.text "foo", X.text "bar"]       bsEncode [n0] @?= "<x>foobar</x>"    , HU.testCase "<x><y/></x>" $ do-      let n0 = unsafeElement "x" [] [unsafeElement "y" [] []]+      let n0 = X.element' "x" [] [X.element' "y" [] []]       bsEncode [n0] @?= "<x><y/></x>"    , HU.testCase "<x><y/></x>" $ 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] @?= "<x><y/></x>"    , HU.testCase "<x><y/><z/></x>" $ do-      let n0 = unsafeElement "x" []-                  [unsafeElement "y" [] [], unsafeElement "z" [] []]+      let n0 = X.element' "x" []+                  [X.element' "y" [] [], X.element' "z" [] []]       bsEncode [n0] @?= "<x><y/><z/></x>"    , HU.testCase "<x><y>" $ do-      let n0 = unsafeElement "x" [] []-          n1 = unsafeElement "y" [] []+      let n0 = X.element' "x" [] []+          n1 = X.element' "y" [] []       bsEncode [n0,n1] @?= "<x/><y/>"   ] @@ -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
xmlbf.cabal view
@@ -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