xmlbf 0.5 → 0.6
raw patch · 6 files changed
+305/−179 lines, 6 filesdep +selectivedep ~basesetup-changed
Dependencies added: selective
Dependency ranges changed: base
Files
- ChangeLog.md +14/−0
- LICENSE +1/−1
- Setup.hs +0/−4
- lib/Xmlbf.hs +256/−157
- test/Test.hs +20/−8
- xmlbf.cabal +14/−9
ChangeLog.md view
@@ -1,3 +1,17 @@+# 0.6++* COMPILER ASSISTED BREAKING CHANGE. `pFail` was removed in favour of+ `fail` from `Monad` of `MonadFail`.++* Added instances for `Parser`: `Semigroup`, `Monoid`, `Selective`, `MonadFix`,+ `MonadZip`.++* Documentation improvements.++* Added dependency on `selective`.++* Removed unnecessary test dependencies.+ # 0.5 * COMPILER ASSISTED BREAKING CHANGE. `element` now returns `[Node]`.
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2017-2018, Renzo Carbonara <renλren.zone>.+Copyright 2017-2019, 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
− Setup.hs
@@ -1,4 +0,0 @@-#! /usr/bin/env nix-shell-#! nix-shell ./shell.nix -i runghc-import Distribution.Simple-main = defaultMain
lib/Xmlbf.hs view
@@ -1,34 +1,29 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-} -- | XML back and forth! --+-- @xmlbf@ provides high-level tools for encoding and decoding XML.+--+-- @xmlbf@ provides tools like 'dfpos' and 'dfposM' for finding a fixpoint+-- of an XML fragment.+--+-- @xmlbf@ provides 'FromXml' and 'ToXml' typeclasses intended to be used as the+-- familiar 'Data.Aeson.FromJSON' and 'Data.Aeson.ToXml' from the @aeson@+-- package.+-- -- @xmlbf@ doesn't do any parsing of raw XML on its own. Instead, one should--- rely on libraries like+-- use @xmlbf@ together with libraries like -- [xmlbf-xeno](https://hackage.haskell.org/package/xmlbf-xeno) or -- [xmlbf-xmlhtml](https://hackage.haskell.org/package/xmlbf-xmlhtml) for -- this.------ @xmlbf@ provides a 'FromXml' class intended to be used as the familiar--- 'Data.Aeson.FromJSON' from the @aeson@ package. This relies on the--- '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.------ @xmlb@ provides tools like 'dfpos' and 'dfposM' for finding a fixpoint--- of a XML structure.-module Xmlbf+module Xmlbf {--} ( -- * Parsing- FromXml(fromXml)+ runParser , Parser- , runParser- , pFail+ -- * Parsers , pElement , pAnyElement , pName@@ -38,10 +33,10 @@ , pText , pEndOfInput - -- * Rendering- , ToXml(toXml)+ -- * Rendering , encode + -- * Nodes , Node , node @@ -58,16 +53,27 @@ , dfposM , dfpre , dfpreM- ) where + -- * Typeclasses+ , FromXml(fromXml)+ , ToXml(toXml)+ ) --}+ where++import Control.Applicative (Alternative(empty, (<|>)), liftA2) import Control.DeepSeq (NFData(rnf))+import Control.Monad (MonadPlus(mplus, mzero), join, when)+import qualified Control.Monad.Fail+import Control.Monad.Fix (MonadFix(mfix))+import Control.Monad.Zip (MonadZip(mzipWith))+import Control.Selective (Selective(select)) 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.Function (fix) import Data.Functor.Identity (Identity(Identity), runIdentity) import qualified Data.HashMap.Strict as HM-import Data.Monoid ((<>)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq import qualified Data.Text as T@@ -76,9 +82,6 @@ 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, when)-import Control.Monad.Fail (MonadFail(fail)) -------------------------------------------------------------------------------- @@ -94,6 +97,7 @@ rnf = \case Element' n as cs -> rnf n `seq` rnf as `seq` rnf cs `seq` () Text' t -> rnf t `seq` ()+ {-# INLINABLE rnf #-} instance Show Node where showsPrec n = \x -> showParen (n > 10) $ case x of@@ -105,7 +109,7 @@ showsPrec 0 cs -- | Destruct an element 'Node'.-pattern Element :: T.Text -> (HM.HashMap T.Text T.Text) -> [Node] -> Node+pattern Element :: T.Text -> HM.HashMap T.Text T.Text -> [Node] -> Node pattern Element t as cs <- Element' t as cs {-# COMPLETE Element #-} -- TODO this leads to silly pattern matching warnings @@ -148,22 +152,27 @@ -- -- 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]+-- times more convenient to use. For example, when you know statically the input+-- is valid.+text+ :: TL.Text -- ^ Lazy 'TL.Text'.+ -> [Node] {-# INLINE text #-} text t = case text' t of Right x -> [x]- Left _ -> []+ Left _ -> [] -- | 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+text'+ :: TL.Text -- ^ Lazy 'TL.Text'.+ -> Either String Node {-# INLINE text' #-} text' = \case "" -> Left "Empty text"- t -> Right (Text' t)+ t -> Right (Text' t) -- | Construct a XML fragment body containing a single 'Element' 'Node', if -- possible.@@ -176,23 +185,23 @@ -- 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.- -> [Node] -- ^ Children.+ :: T.Text -- ^ Element' name as a strict 'T.Text'.+ -> HM.HashMap T.Text T.Text -- ^ Attributes as strict 'T.Text' pairs.+ -> [Node] -- ^ Children. -> [Node] {-# INLINE element #-} element t hm ns = case element' t hm ns of Right x -> [x]- Left _ -> []+ Left _ -> [] -- | 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.+ :: T.Text -- ^ Element' name as a strict 'T.Text'.+ -> HM.HashMap T.Text T.Text -- ^ Attributes as strict 'T.Text' pairs.+ -> [Node] -- ^ Children. -> Either String Node element' t0 hm0 ns0 = do when (t0 /= T.strip t0)@@ -216,99 +225,169 @@ -- If a 'ToXml' instance for @a@ exists, then: -- -- @- -- 'runParser' 'fromXml' ('toXml' a) == 'Right' a+ -- 'runParser' 'fromXml' ('toXml' a) == pure ('Right' a) -- @ fromXml :: Parser a --- | XML parser monad. To be run with 'runParser'.------ You can build a 'Parser' using 'pElement', 'pAttr', 'pAttrs', 'pText',--- '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 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 !T.Text !(HM.HashMap T.Text T.Text) ![Node] -- ^ Parsing a particular root element.- deriving (Show) +-- | Construct an initial parser state to use with 'unParser' from zero or+-- more top-level 'Node's.+initialS :: [Node] -> S+initialS = STop . normalize+{-# INLINE initialS #-}++-- | XML parser for a value of type @a@.+--+-- You can build a 'Parser' using 'pElement', 'pAnyElement', 'pName',+-- 'pAttr', 'pAttrs', 'pChildren', 'pText', 'pEndOfInput', any of the+-- 'Applicative', 'Alternative', 'Monad' or related combinators.+--+-- Run a 'Parser' using 'runParser'.+newtype Parser a = Parser { unParser :: S -> Either String (S, a) }++-- | Run a 'Parser' on an XML fragment body.+--+-- 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+ -- ^ Parser to run.+ -> [Node]+ -- ^ XML fragment body to parse. That is, top-level XML 'Node's.+ -> Either String a+ -- ^ If parsing fails, a 'String' with an error message is returned.+ -- Otherwise, we the parser output @a@ is returned.+runParser p = fmap snd . unParser p . initialS+{-# INLINE runParser #-}++#if MIN_VERSION_base(4,9,0)+instance Semigroup a => Semigroup (Parser a) where+ (<>) = liftA2 (<>)+ {-# INLINE (<>) #-}+#endif++instance Monoid a => Monoid (Parser a) where+ mempty = pure mempty+ {-# INLINE mempty #-}+#if MIN_VERSION_base(4,9,0)+ mappend = (<>)+#else+ mappend = liftA2 mappend+#endif+ {-# INLINE mappend #-}++instance Functor Parser where+ fmap f = \pa -> Parser (\s -> fmap (fmap f) (unParser pa s))+ {-# INLINE fmap #-}+ instance Applicative Parser where+ pure = \a -> Parser (\s -> Right (s, a)) {-# INLINE pure #-}- pure = \a -> Parser (\s -> Right (a, s))- {-# INLINE (<*>) #-}- Parser gf <*> Parser ga = Parser $ \s0 -> do- (f, s1) <- gf s0- (a, s2) <- ga s1- pure (f a, s2)+ pf <*> pa = Parser (\s0 -> do+ (s1, f) <- unParser pf s0+ (s2, a) <- unParser pa s1+ Right (s2, f a))+ {-# INLINABLE (<*>) #-} +-- | @ma '<|>' mb@ backtracks the internal parser state before running @mb@.+instance Alternative Parser where+ empty = pFail "empty"+ {-# INLINE empty #-}+ pa <|> pb = Parser (\s0 ->+ case unParser pa s0 of+ Right (s1, a) -> Right (s1, a)+ Left _ -> unParser pb s0)+ {-# INLINABLE (<|>) #-}++instance Selective Parser where+ select pe pf = Parser (\s0 -> do+ (s1, ea) <- unParser pe s0+ case ea of+ Right b -> Right (s1, b)+ Left a -> do+ (s2, f) <- unParser pf s1+ Right (s2, f a))+ {-# INLINABLE select #-}+ instance Monad Parser where- {-# INLINE (>>=) #-}- Parser ga >>= k = Parser $ \s0 -> do- (a, s1) <- ga s0- unParser (k a) s1+ return = pure+ {-# INLINE return #-}+ pa >>= kpb = Parser (\s0 -> do+ (s1, a) <- unParser pa s0+ unParser (kpb a) s1)+ {-# INLINABLE (>>=) #-} fail = pFail+ {-# INLINE fail #-} -instance MonadFail Parser where+#if MIN_VERSION_base(4,9,0)+instance Control.Monad.Fail.MonadFail Parser where fail = pFail+ {-# INLINE fail #-}+#endif --- | Backtracks.-instance Alternative Parser where- {-# INLINE empty #-}- empty = Parser (\_ -> Left "empty")- {-# INLINE (<|>) #-}- Parser a <|> Parser b = Parser (\s -> either (\_ -> b s) Right (a s))+-- | A 'Parser' that always fails with the given error message.+pFail :: String -> Parser a+pFail = \msg -> Parser (\_ -> Left msg)+{-# INLINE pFail #-} --- | Backtracks.+-- | @'mzero' ma mb@ backtracks the internal parser state before running @mb@. instance MonadPlus Parser where- {-# INLINE mzero #-} mzero = empty- {-# INLINE mplus #-}+ {-# INLINE mzero #-} mplus = (<|>)+ {-# INLINE mplus #-} +instance MonadFix Parser where+ mfix f =+ let die = \msg -> error ("mfix (Parser): " <> msg)+ in Parser (\s0 -> fix (flip unParser s0 . f . either die snd))+ {-# INLINABLE mfix #-}++instance MonadZip Parser where+ mzipWith = liftA2+ {-# INLINE mzipWith #-}+ -------------------------------------------------------------------------------- -- 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.+-- | @'pElement' "foo" p@ runs a 'Parser @p@ inside a 'Element' node named+-- @"foo"@. This parser __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 #-}+-- __Consumes the matched element__ from the parser state.+pElement+ :: T.Text -- ^ Element name as strict 'T.Text'.+ -> Parser a -- ^ 'Parser' to run /inside/ the matched 'Element'.+ -> Parser a pElement t0 p0 = Parser $ \case- 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 t as cs)- Right (a, STop cs0)+ SReg t1 as0 (Element' t as cs : cs0) | t == t0 ->+ case unParser p0 (SReg t as cs) of+ Right (_, a) -> Right (SReg t1 as0 cs0, a)+ Left msg -> Left msg+ STop (Element' t as cs : cs0) | t == t0 ->+ case unParser p0 (SReg t as cs) of+ Right (_, a) -> Right (STop cs0, a)+ Left msg -> Left msg -- skip leading whitespace 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)+ _ -> Left ("Missing element " <> show t0)+{-# INLINABLE pElement #-} --- | @'pAnyElement' p@ runs a 'Parser' @p@ inside the element node at the+-- | @'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.+-- __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@@ -318,60 +397,76 @@ -- 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 #-}+-- __Consumes the matched element__ from the parser state.+pAnyElement+ :: Parser a -- ^ 'Parser' to run /inside/ any matched 'Element'.+ -> Parser a 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)+ SReg t0 as0 (Element' t as cs : cs0) ->+ case unParser p0 (SReg t as cs) of+ Right (_, a) -> Right (SReg t0 as0 cs0, a)+ Left msg -> Left msg+ STop (Element' t as cs : cs0) ->+ case unParser p0 (SReg t as cs) of+ Right (_, a) -> Right (STop cs0, a)+ Left msg -> Left msg -- 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"+{-# INLINABLE pAnyElement #-} --- | Returns the name of the currently selected element.+-- | Returns the name of the currently selected 'Element'. ----- This parser fails if there's no currently selected element.+-- This parser __fails__ if there's no currently selected 'Element' (see+-- 'pElement', 'pAnyElement'). -- -- Doesn't modify the parser state.-pName :: Parser T.Text+pName :: Parser T.Text -- ^ Element name as strict 'T.Text'.+pName = Parser (\case+ s@(SReg t _ _) -> Right (s, t)+ _ -> Left "Before selecting an name, you must select an element") {-# 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.+-- | Return the value of the requested attribute, if defined. Returns an+-- 'T.empty' 'T.Text' in case the attribute is defined but no value was given to+-- it. ----- This parser fails if there's no currently selected element.+-- This parser __fails__ if there's no currently selected 'Element' (see+-- 'pElement', 'pAnyElement'). ----- 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"+-- __Consumes the matched attribute__ from the parser state.+pAttr+ :: T.Text+ -- ^ Attribute name as strict 'T.Text'.+ -> Parser T.Text+ -- ^ Attribute value as strict 'T.Text', possibly 'T.empty'.+pAttr n = Parser (\case 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)+ Just x -> Right (SReg t (HM.delete n as) cs, x)+ Nothing -> Left ("Missing attribute " <> show n)+ _ -> Left "Before selecting an attribute, you must select an element")+{-# INLINABLE pAttr #-} --- | 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.+-- | Returns all of the available element attributes. ----- This parser fails if there's no currently selected element.+-- Returns 'T.empty' 'T.Text' as values in case an attribute is defined but no+-- value was given to it. ----- Consumes all of the remaining attributes for this element from the parser--- state.-pAttrs :: Parser (HM.HashMap T.Text T.Text)+-- This parser __fails__ if there's no currently selected 'Element' (see+-- 'pElement', 'pAnyElement').+--+-- __Consumes all the attributes__ for this element from the parser state.+pAttrs+ :: Parser (HM.HashMap T.Text T.Text)+ -- ^ Pairs of attribute names and possibly 'T.empty' values, as strict+ -- 'T.Text'.+pAttrs = Parser (\case+ SReg t as cs -> Right (SReg t mempty cs, as)+ _ -> Left "Before selecting an attribute, you must select an element") {-# 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) -- | Returns all of the immediate children of the current element. --@@ -379,20 +474,22 @@ -- 'pChildren' is /not/ being run inside 'pElement'), then all of the top level -- 'Node's will be returned. ----- Consumes all of the returned nodes from the parser state.-pChildren :: Parser [Node]+-- __Consumes all the returned nodes__ from the parser state.+pChildren+ :: Parser [Node]+ -- ^ 'Node's in their original order.+pChildren = Parser (\case+ STop cs -> Right (STop mempty, cs)+ SReg t as cs -> Right (SReg t as mempty, cs)) {-# 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.+-- | Returns the contents of a 'Text' node. -- -- 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+-- If there is no text node at the current position, then this parser __fails__.+-- This implies that 'pText' /never/ returns an empty 'TL.Text', since there is -- no such thing as a text node without text. -- -- Please note that consecutive text nodes are always concatenated and returned@@ -400,37 +497,39 @@ -- -- @ -- 'runParser' 'pText' ('text' \"Ha\" <> 'text' \"sk\" <> 'text' \"ell\")--- == 'Right' ('text' "Haskell")+-- == 'Right' ('text' \"Haskell\") -- @ ----- The returned text is consumed from the parser state. This implies that if you+-- __Consumes the text__ 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"+-- == 'Left' \"Missing text node\" -- @-pText :: Parser TL.Text+pText+ :: Parser TL.Text+ -- ^ Content of the text node as a lazy 'TL.Text'.+pText = Parser (\case+ -- Note: this works only because we asume 'normalize' has been used.+ STop (Text x : ns) -> Right (STop ns, x)+ SReg t as (Text x : cs) -> Right (SReg t as cs, x)+ _ -> Left "Missing text node") {-# 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 t as (Text x : cs) -> Right (x, SReg t as cs)- _ -> Left "Missing text node" -- | Succeeds if all of the elements, attributes and text nodes have -- been consumed. pEndOfInput :: Parser ()+pEndOfInput = Parser (\s -> case isEof s of+ True -> Right (s, ())+ False -> Left "Not end of input yet") {-# INLINABLE pEndOfInput #-}-pEndOfInput = Parser (\s ->- if isEof s then Right ((), s)- else Left "Not end of input yet") isEof :: S -> Bool-{-# INLINE isEof #-} isEof = \case SReg _ as cs -> HM.null as && null cs STop ns -> null ns+{-# INLINE isEof #-} -------------------------------------------------------------------------------- -- Rendering@@ -464,10 +563,10 @@ -- to the right with as little effort as possible, using (<>). "<" <> encodeUtf8 t <> encodeAttrs (">" <> encode cs <> "</" <> encodeUtf8 t <> ">") as+ {-# INLINE encodeNode #-} 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 #-} --------------------------------------------------------------------------------@@ -496,9 +595,9 @@ -- @ -- foo :: 'Node' -> ['Node'] -- foo = 'dfpos' $ \\k -> \\case--- '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+-- '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.@@ -556,7 +655,7 @@ -- | The cursor if left where it starts. traverseChildren :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor-{-# INLINE traverseChildren #-}+{-# INLINABLE traverseChildren #-} traverseChildren f c0 = case _cursorCurrent c0 of Text _ -> pure c0 Element t as cs -> do@@ -565,7 +664,7 @@ -- | The cursor if left in the rightmost sibling. traverseRightSiblings :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor-{-# INLINE traverseRightSiblings #-}+{-# INLINABLE traverseRightSiblings #-} traverseRightSiblings f c0 = case cursorRemoveRight c0 of Nothing -> pure c0 Just (n1, c1) -> do@@ -587,7 +686,7 @@ -- | Removes the node to the right and return it. cursorRemoveRight :: Cursor -> Maybe (Node, Cursor)-{-# INLINE cursorRemoveRight #-}+{-# INLINABLE cursorRemoveRight #-} cursorRemoveRight = \case Cursor n ls rs0 ps | not (Seq.null rs0) -> case Seq.viewl rs0 of@@ -636,4 +735,4 @@ fixed5 x = BBP.liftFixedToBounded (const x BBP.>$< BBP.word8 BBP.>*< BBP.word8 BBP.>*< BBP.word8 BBP.>*< BBP.word8 BBP.>*< BBP.word8)-+--}
test/Test.hs view
@@ -5,15 +5,12 @@ module Main where -import Debug.Trace--import Control.Applicative (many, liftA2)-import Control.DeepSeq (rnf)+import Control.Applicative (liftA2, (<|>))+import Control.Monad (mplus) import qualified Control.Monad.Trans.State as S import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL-import qualified Data.HashMap.Strict as HM import Data.Either (isLeft) import qualified Data.Text as T import qualified Test.Tasty as Tasty@@ -41,6 +38,7 @@ , tt_element , tt_encoding , tt_parsing+ , tt_backtracking , tt_fixpoints ] @@ -234,11 +232,11 @@ , HU.testCase "fail: empty" $ do (Left "x" :: Either String ())- @=? X.runParser (X.pFail "x") []+ @=? X.runParser (fail "x") [] , HU.testCase "fail" $ do (Left "x" :: Either String ())- @=? X.runParser (X.pFail "x") (X.text "y")+ @=? X.runParser (fail "x") (X.text "y") , HU.testCase "children: empty" $ do Right []@@ -295,7 +293,21 @@ ] +tt_backtracking :: Tasty.TestTree+tt_backtracking = Tasty.testGroup "Backtracking"+ [ HU.testCase "Alternative" $+ Right "y" @=? X.runParser+ -- The second pText fails because the state is empty after the first+ ((X.pText >> X.pText >> pure "a") <|> X.pText)+ (X.text "y")+ , HU.testCase "MonadPlus" $+ Right "y" @=? X.runParser+ -- The second pText fails because the state is empty after the first+ (mplus (X.pText >> X.pText >> pure "a") X.pText)+ (X.text "y")+ ] + node0 :: X.Node Right node0 = X.element' "a" [] $ mconcat@@ -311,7 +323,7 @@ fixvisit :: (X.Node -> S.State T.Text [X.Node]) -> (X.Node -> S.State T.Text [X.Node])-fixvisit k n@(X.Element t _ _) = do+fixvisit _ n@(X.Element t _ _) = do S.modify (\ts -> mappend ts t) pure [n]
xmlbf.cabal view
@@ -1,29 +1,35 @@ name: xmlbf-version: 0.5+version: 0.6 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+bug-reports: https://gitlab.com/k0001/xmlbf/issues license: Apache-2.0 license-file: LICENSE author: Renzo Carbonara maintainer: ren§ren*zone-copyright: Copyright 2017-2018 Renzo Carbonara-category: Text+copyright: Copyright 2017-2019 Renzo Carbonara+category: Text, XML build-type: Simple extra-source-files: ChangeLog.md README.md cabal-version: >=1.10 +source-repository head+ type: git+ location: https://gitlab.com/k0001/xmlbf+ library hs-source-dirs: lib exposed-modules: Xmlbf default-language: Haskell2010- ghc-options: -O2 -Wall- ghcjs-options: -O3 -Wall+ ghc-options: -O2 -Wall -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ ghcjs-options: -O3 -Wall -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints build-depends: base <5, bytestring, containers, deepseq,+ selective, text, transformers, unordered-containers@@ -33,11 +39,11 @@ type: exitcode-stdio-1.0 main-is: Test.hs hs-source-dirs: test+ ghc-options: -O2 -Wall -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints+ ghcjs-options: -O3 -Wall -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints build-depends: base, bytestring,- deepseq,- xmlbf, QuickCheck, quickcheck-instances, tasty,@@ -45,5 +51,4 @@ tasty-quickcheck, text, transformers,- unordered-containers-+ xmlbf