{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UndecidableInstances #-}

-- | 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
-- use
-- [xmlbf](https://hackage.haskell.org/package/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.
module Xmlbf {--}
 ( -- * Parsing
   parse
 , parseM
   -- ** Low-level
 , Parser
 , ParserT
 , parserT
 , runParserT
 , ParserState
 , initialParserState

   -- * Parsers
 , pElement
 , pAnyElement
 , pName
 , pAttr
 , pAttrs
 , pChildren
 , pText
 , pTextLazy
 , pEndOfInput

    -- * Rendering
 , encode

   -- * Nodes
 , Node
 , node

   -- ** Element
 , pattern Element
 , element
 , element'

   -- ** Text (strict)
 , pattern Text
 , text
 , text'

   -- ** Text (lazy)
 , pattern TextLazy
 , textLazy
 , textLazy'

   -- * Fixpoints
 , dfpos
 , dfposM
 , dfpre
 , dfpreM

   -- * 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, ap)
import qualified Control.Monad.Catch as Ex
import Control.Monad.Error.Class (MonadError(catchError, throwError))
import qualified Control.Monad.Fail
import Control.Monad.Fix (MonadFix(mfix))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Morph (MFunctor(hoist))
import Control.Monad.Reader.Class (MonadReader(local, ask))
import Control.Monad.State.Class (MonadState(state))
import Control.Monad.Trans (MonadTrans(lift))
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.Functor.Identity (Identity(Identity), runIdentity)
import qualified Data.Map.Strict as Map
import qualified Data.HashMap.Strict as HM
import Data.Kind (Type)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Data.Traversable (for)
import Data.Word (Word8)

--------------------------------------------------------------------------------

-- | Either a text or an element node in an XML fragment body.
--
-- Construct with 'text', 'textLazy' or 'element'.
--
-- Destruct with 'Text', 'TextLazy' or 'Element'.
data Node
  = Node_Element !T.Text !(HM.HashMap T.Text T.Text) ![Node]
  | Node_Text !TL.Text
  deriving (Node -> Node -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c== :: Node -> Node -> Bool
Eq)

instance NFData Node where
  rnf :: Node -> ()
rnf = \case
    Node_Element Text
n HashMap Text Text
as [Node]
cs -> forall a. NFData a => a -> ()
rnf Text
n seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf HashMap Text Text
as seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf [Node]
cs seq :: forall a b. a -> b -> b
`seq` ()
    Node_Text Text
t -> forall a. NFData a => a -> ()
rnf Text
t seq :: forall a b. a -> b -> b
`seq` ()
  {-# INLINABLE rnf #-}

instance Show Node where
  showsPrec :: Int -> Node -> ShowS
showsPrec Int
n = \Node
x -> Bool -> ShowS -> ShowS
showParen (Int
n forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ case Node
x of
    Node_Text Text
t -> String -> ShowS
showString String
"Text " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 Text
t
    Node_Element Text
t HashMap Text Text
as [Node]
cs ->
      String -> ShowS
showString String
"Element " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 Text
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 (forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Text Text
as) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 [Node]
cs

-- | Destruct an element 'Node'.
--
-- @
-- case n :: Node of
--   'Element' t as cs -> ...
--   _ -> ...
-- @
pattern Element
  :: T.Text  -- ^ Element name as strict 'T.Text'.
  -> HM.HashMap T.Text T.Text
  -- ^ Pairs of attribute names and possibly 'T.empty' values, as strict
  -- 'T.Text'.
  -> [Node]  -- ^ Element children.
  -> Node
pattern $mElement :: forall {r}.
Node
-> (Text -> HashMap Text Text -> [Node] -> r) -> ((# #) -> r) -> r
Element t as cs <- Node_Element t as cs

-- | Destruct a text 'Node' into a lazy 'TL.Text'.
--
-- @
-- case n :: Node of
--   'TextLazy' tl -> ...
--   _ -> ...
-- @
pattern TextLazy
  :: TL.Text  -- ^ Lazy 'TL.Text'.
  -> Node
pattern $mTextLazy :: forall {r}. Node -> (Text -> r) -> ((# #) -> r) -> r
TextLazy tl <- Node_Text tl

-- | Destruct a text 'Node' into a strict 'T.Text'.
--
-- @
-- case n :: Node of
--   'Text' t -> ...
--   _ -> ...
-- @
pattern Text
  :: T.Text  -- ^ Strict 'T.Text'.
  -> Node
pattern $mText :: forall {r}. Node -> (Text -> r) -> ((# #) -> r) -> r
Text t <- Node_Text (TL.toStrict -> t)

{-# COMPLETE Text, Element :: Node #-}
{-# COMPLETE TextLazy, Element :: Node #-}
{-# COMPLETE Node_Text, Element :: Node #-}
{-# COMPLETE Text, Node_Element :: Node #-}
{-# COMPLETE TextLazy, Node_Element :: Node #-}

-- | Case analysis for a 'Node'.
node
  :: (T.Text -> HM.HashMap T.Text T.Text -> [Node] -> a)
  -- ^ Transform an 'Element' node.
  -> (TL.Text -> a)
  -- ^ Transform a 'TextLazy' node.
  -> Node
  -> a
{-# INLINE node #-}
node :: forall a.
(Text -> HashMap Text Text -> [Node] -> a)
-> (Text -> a) -> Node -> a
node Text -> HashMap Text Text -> [Node] -> a
fe Text -> a
ft = \case
  Node_Text Text
t -> Text -> a
ft Text
t
  Node_Element Text
t HashMap Text Text
as [Node]
cs -> Text -> HashMap Text Text -> [Node] -> a
fe Text
t HashMap Text Text
as [Node]
cs

-- | Normalizes 'Node's by concatenating consecutive 'Text' nodes.
normalize :: [Node] -> [Node]
{-# INLINE normalize #-}
normalize :: [Node] -> [Node]
normalize = \case
   -- Note that @'Text' ""@ is forbidden by construction, actually. But we do
   -- take care of it in case the 'Node' was constructed unsafely somehow.
   Node_Text Text
"" : [Node]
ns -> [Node] -> [Node]
normalize [Node]
ns
   Node_Text Text
a : Node_Text Text
b : [Node]
ns -> [Node] -> [Node]
normalize (Text -> [Node]
textLazy (Text
a forall a. Semigroup a => a -> a -> a
<> Text
b) forall a. Semigroup a => a -> a -> a
<> [Node]
ns)
   Node_Text Text
a : [Node]
ns -> Text -> Node
Node_Text Text
a forall a. a -> [a] -> [a]
: [Node] -> [Node]
normalize [Node]
ns
   Node_Element Text
t HashMap Text Text
as [Node]
cs : [Node]
ns -> Text -> HashMap Text Text -> [Node] -> Node
Node_Element Text
t HashMap Text Text
as ([Node] -> [Node]
normalize [Node]
cs) forall a. a -> [a] -> [a]
: [Node] -> [Node]
normalize [Node]
ns
   [] -> []

-- | Construct a XML fragment body containing a single text 'Node', if given
-- 'T.Text' not empty.
--
-- This function will return empty list if it is not possible to construct the
-- 'Text' with the given input. To learn more about /why/ it was not possible to
-- construct it, use 'text'' instead.
--
-- 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. For example, when you know statically the input
-- is valid.
text
  :: T.Text  -- ^ Strict 'T.Text'.
  -> [Node]
{-# INLINE text #-}
text :: Text -> [Node]
text = Text -> [Node]
textLazy forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict

-- | Construct a text 'Node', if given 'T.Text' not empty.
--
-- Returns 'Left' if the 'Text' 'Node' can't be created, with an explanation
-- of why.
text'
  :: T.Text  -- ^ Strict 'T.Text'.
  -> Either String Node
{-# INLINE text' #-}
text' :: Text -> Either String Node
text' = Text -> Either String Node
textLazy' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict

-- | A version of 'text' working with lazy 'TL.Text'.
textLazy
  :: TL.Text  -- ^ Lazy 'TL.Text'.
  -> [Node]
{-# INLINE textLazy #-}
textLazy :: Text -> [Node]
textLazy = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
_ -> []) (\Node
x -> [Node
x]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Node
textLazy'

-- | A version of 'text'' working with lazy 'TL.Text'.
textLazy'
  :: TL.Text  -- ^ Lazy 'TL.Text'.
  -> Either String Node
{-# INLINE textLazy' #-}
textLazy' :: Text -> Either String Node
textLazy' = \case
  Text
"" -> forall a b. a -> Either a b
Left String
"Empty text"
  Text
t  -> forall a b. b -> Either a b
Right (Text -> Node
Node_Text Text
t)


-- | Construct a XML fragment body containing a single 'Element' 'Node', if
-- possible.
--
-- This function will return empty list if it is not possible to construct the
-- 'Element' with the given input. To learn more about /why/ it was not possible
-- to construct it, use 'element' instead.
--
-- Using 'element'' rather than 'element' is recommended, so that you are forced
-- 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 as a strict 'T.Text'.
  -> HM.HashMap T.Text T.Text
  -- ^ Pairs of attribute names and possibly 'T.empty' values, as strict
  -- 'T.Text'.
  -> [Node]                   -- ^ Children.
  -> [Node]
{-# INLINE element #-}
element :: Text -> HashMap Text Text -> [Node] -> [Node]
element Text
t HashMap Text Text
hm [Node]
ns = case Text -> HashMap Text Text -> [Node] -> Either String Node
element' Text
t HashMap Text Text
hm [Node]
ns of
  Right Node
x -> [Node
x]
  Left  String
_ -> []

-- | Construct an 'Element' 'Node'.
--
-- Returns 'Left' if the 'Element' 'Node' can't be created, with an explanation
-- of why.
element'
  :: T.Text                   -- ^ Element name as a strict 'T.Text'.
  -> HM.HashMap T.Text T.Text
  -- ^ Pairs of attribute names and possibly 'T.empty' values, as strict
  -- 'T.Text'.
  -> [Node]                   -- ^ Children.
  -> Either String Node
element' :: Text -> HashMap Text Text -> [Node] -> Either String Node
element' Text
t0 HashMap Text Text
hm0 [Node]
ns0 = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
t0 forall a. Eq a => a -> a -> Bool
/= Text -> Text
T.strip Text
t0)
     (forall a b. a -> Either a b
Left (String
"Element name has surrounding whitespace: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
t0))
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null Text
t0) (forall a b. a -> Either a b
Left String
"Element name is blank")
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k v. HashMap k v -> [k]
HM.keys HashMap Text Text
hm0) forall a b. (a -> b) -> a -> b
$ \Text
k -> do
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
k forall a. Eq a => a -> a -> Bool
/= Text -> Text
T.strip Text
k)
        (forall a b. a -> Either a b
Left (String
"Attribute name has surrounding whitespace: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
k))
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null Text
k) (forall a b. a -> Either a b
Left String
"Attribute name is blank")
  forall a b. b -> Either a b
Right (Text -> HashMap Text Text -> [Node] -> Node
Node_Element Text
t0 HashMap Text Text
hm0 ([Node] -> [Node]
normalize [Node]
ns0))

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- Parsing

class FromXml a where
  -- | Parses an XML fragment body into a value of type @a@.
  --
  -- If a 'ToXml' instance for @a@ exists, then:
  --
  -- @
  -- 'parse' 'fromXml' ('toXml' a)  ==  'Right' a
  -- @
  fromXml :: Monad m => ParserT m a

-- | Internal parser state.
data ParserState
  = STop ![Node]
    -- ^ Parsing the top-level nodes.
  | SReg !T.Text !(HM.HashMap T.Text T.Text) ![Node]
    -- ^ Parsing a particular root element.
  deriving (ParserState -> ParserState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParserState -> ParserState -> Bool
$c/= :: ParserState -> ParserState -> Bool
== :: ParserState -> ParserState -> Bool
$c== :: ParserState -> ParserState -> Bool
Eq)

-- | Construct an initial 'ParserState' to use with 'runParserT' from zero or
-- more top-level 'Node's.
initialParserState :: [Node] -> ParserState
initialParserState :: [Node] -> ParserState
initialParserState = [Node] -> ParserState
STop forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Node]
normalize
{-# INLINE initialParserState #-}

-- | XML parser for a value of type @a@.
--
-- This parser runs on top of some 'Monad' @m@,
-- making 'ParserT' a suitable monad transformer.
--
-- You can build a 'ParserT' using 'pElement', 'pAnyElement', 'pName',
-- 'pAttr', 'pAttrs', 'pChildren', 'pText', 'pEndOfInput', any of the
-- 'Applicative', 'Alternative' or 'Monad' combinators, or you can
-- use 'parserT' directly.
--
-- Run a 'ParserT' using 'parse', 'parseM' or 'runParserT'
newtype ParserT (m :: Type -> Type) (a :: Type)
  = ParserT (ParserState -> m (ParserState, Either String a))

-- | @'Parser' a@ is a type synonym for @'Parser' 'Identity' a@.
type Parser = ParserT Identity :: Type -> Type

-- | 'parserT' is the most general way or building a 'ParserT'.
--
-- Notice that 'ParserState''s internals are not exported, so you won't be
-- able to do much with it other than pass it around.
--
-- @
-- 'runParserT' . 'parserT'  ==  'id'
-- @
parserT
  :: (ParserState -> m (ParserState, Either String a))
  -- ^ Given a parser's internal state, obtain an @a@ if possible, otherwise
  -- return a 'String' describing the parsing failure. A new state with
  -- leftovers is returned.
  -> ParserT m a
parserT :: forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
parserT = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT
{-# INLINE parserT #-}

-- | 'runParserT' is the most general way or running a 'ParserT'.
--
-- As a simpler alternative to 'runParserT', consider using 'parseM', or even 'parse'
-- if you don't need transformer functionality.
--
-- Notice that 'ParserState''s internals are not exported, so you won't be
-- able to do much with it other than pass it around.
--
-- @
-- 'runParserT' . 'parserT'  ==  'id'
-- @
runParserT
  :: ParserT m a
  -- ^ Parser to run.
  -> ParserState
  -- ^ Initial parser state. You can obtain this from
  -- 'initialParserState' or from a previous execution of 'runParserT'.
  -> m (ParserState, Either String a)
  -- ^ Returns the leftover parser state, as well as an @a@ in case parsing was
  -- successful, or a 'String' with an error message otherwise.
runParserT :: forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (ParserT ParserState -> m (ParserState, Either String a)
f) = ParserState -> m (ParserState, Either String a)
f
{-# INLINE runParserT #-}

-- | Run a 'ParserT' 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 'ParserT'.
parseM
  :: Applicative m
  => ParserT m a
  -- ^ Parser to run.
  -> [Node]
  -- ^ XML fragment body to parse. That is, top-level XML 'Node's.
  -> m (Either String a)
  -- ^ If parsing fails, a 'String' with an error message is returned.
  -- Otherwise, the parser output @a@ is returned.
parseM :: forall (m :: * -> *) a.
Applicative m =>
ParserT m a -> [Node] -> m (Either String a)
parseM ParserT m a
p = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> ParserState
initialParserState
{-# INLINE parseM #-}

-- | Pure version of 'parseM'.
parse
  :: 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, the parser output @a@ is returned.
parse :: forall a. Parser a -> [Node] -> Either String a
parse Parser a
p = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
Applicative m =>
ParserT m a -> [Node] -> m (Either String a)
parseM Parser a
p
{-# INLINE parse #-}

#if MIN_VERSION_base(4,9,0)
instance (Monad m, Semigroup a) => Semigroup (ParserT m a) where
  <> :: ParserT m a -> ParserT m a -> ParserT m a
(<>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE (<>) #-}
#endif

instance (Monad m, Monoid a) => Monoid (ParserT m a) where
  mempty :: ParserT m a
mempty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  {-# INLINE mempty #-}
#if MIN_VERSION_base(4,9,0)
  mappend :: ParserT m a -> ParserT m a -> ParserT m a
mappend = forall a. Semigroup a => a -> a -> a
(<>)
#else
  mappend = liftA2 mappend
#endif
  {-# INLINE mappend #-}

instance Functor m => Functor (ParserT m) where
  fmap :: forall a b. (a -> b) -> ParserT m a -> ParserT m b
fmap a -> b
f = \ParserT m a
pa -> forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)) (forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
pa ParserState
s))
  {-# INLINE fmap #-}

-- | The 'Monad' superclass is necessary because 'ParserT' shortcircuits like
-- 'Control.Monad.Trans.Except.ExceptT'.
instance Monad m => Applicative (ParserT m) where
  pure :: forall a. a -> ParserT m a
pure = \a
a -> forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s, forall a b. b -> Either a b
Right a
a))
  {-# INLINE pure #-}
  <*> :: forall a b. ParserT m (a -> b) -> ParserT m a -> ParserT m b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  {-# INLINE (<*>) #-}

-- | @ma '<|>' mb@ backtracks the internal parser state before running @mb@.
instance Monad m => Alternative (ParserT m) where
  empty :: forall a. ParserT m a
empty = forall (m :: * -> *) a. Applicative m => String -> ParserT m a
pFail String
"empty"
  {-# INLINE empty #-}
  ParserT m a
pa <|> :: forall a. ParserT m a -> ParserT m a -> ParserT m a
<|> ParserT m a
pb = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s0 -> do
    (ParserState
s1, Either String a
ea) <- forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
pa ParserState
s0
    case Either String a
ea of
      Right a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s1, forall a b. b -> Either a b
Right a
a)
      Left String
_ -> forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
pb ParserState
s0)
  {-# INLINABLE (<|>) #-}

instance Monad m => Selective (ParserT m) where
  select :: forall a b.
ParserT m (Either a b) -> ParserT m (a -> b) -> ParserT m b
select ParserT m (Either a b)
pe ParserT m (a -> b)
pf = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s0 -> do
    (ParserState
s1, Either String (Either a b)
eeab) <- forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m (Either a b)
pe ParserState
s0
    case Either String (Either a b)
eeab of
      Right (Right b
b) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s1, forall a b. b -> Either a b
Right b
b)
      Right (Left a
a) -> forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (ParserT m (a -> b)
pf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) ParserState
s1
      Left String
msg -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s1, forall a b. a -> Either a b
Left String
msg))
  {-# INLINABLE select #-}

instance Monad m => Monad (ParserT m) where
  return :: forall a. a -> ParserT m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}
  ParserT m a
pa >>= :: forall a b. ParserT m a -> (a -> ParserT m b) -> ParserT m b
>>= a -> ParserT m b
kpb = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s0 -> do
    (ParserState
s1, Either String a
ea) <- forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
pa ParserState
s0
    case Either String a
ea of
      Right a
a -> forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (a -> ParserT m b
kpb a
a) ParserState
s1
      Left String
msg -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s1, forall a b. a -> Either a b
Left String
msg))
  {-# INLINABLE (>>=) #-}
#if !MIN_VERSION_base(4,9,0)
  fail = pFail
  {-# INLINE fail #-}
#endif

#if MIN_VERSION_base(4,9,0)
instance Monad m => Control.Monad.Fail.MonadFail (ParserT m) where
  fail :: forall a. String -> ParserT m a
fail = forall (m :: * -> *) a. Applicative m => String -> ParserT m a
pFail
  {-# INLINE fail #-}
#endif

-- | A 'ParserT' that always fails with the given error message.
pFail :: Applicative m => String -> ParserT m a
pFail :: forall (m :: * -> *) a. Applicative m => String -> ParserT m a
pFail = \String
msg -> forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s, forall a b. a -> Either a b
Left String
msg))
{-# INLINE pFail #-}

-- | @'mplus' ma mb@ backtracks the internal parser state before running @mb@.
instance Monad m => MonadPlus (ParserT m) where
  mzero :: forall a. ParserT m a
mzero = forall (f :: * -> *) a. Alternative f => f a
empty
  {-# INLINE mzero #-}
  mplus :: forall a. ParserT m a -> ParserT m a -> ParserT m a
mplus = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
  {-# INLINE mplus #-}

instance MonadFix m => MonadFix (ParserT m) where
  mfix :: forall a. (a -> ParserT m a) -> ParserT m a
mfix a -> ParserT m a
f =
    let die :: String -> a
die = \String
msg -> forall a. HasCallStack => String -> a
error (String
"mfix (ParserT): " forall a. Semigroup a => a -> a -> a
<> String
msg)
    in forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s0 ->
         forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (\ ~(ParserState
_s1, Either String a
ea) -> forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (a -> ParserT m a
f (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a}. String -> a
die forall a. a -> a
id Either String a
ea)) ParserState
s0))

instance MonadZip m => MonadZip (ParserT m) where
  mzipWith :: forall a b c.
(a -> b -> c) -> ParserT m a -> ParserT m b -> ParserT m c
mzipWith a -> b -> c
f ParserT m a
pa ParserT m b
pb = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s0 -> do
    (ParserState
s1, Either String a
ea) <- forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
pa ParserState
s0
    case Either String a
ea of
      Right a
a0 ->
        forall (m :: * -> *) a b c.
MonadZip m =>
(a -> b -> c) -> m a -> m b -> m c
mzipWith (\a
a1 (ParserState
s2, Either String b
eb) -> (ParserState
s2, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b -> c
f a
a1) Either String b
eb))
                 (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a0) (forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m b
pb ParserState
s1)
      Left String
msg -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s1, forall a b. a -> Either a b
Left String
msg))
  {-# INLINABLE mzipWith #-}

instance MonadTrans ParserT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ParserT m a
lift = \m a
ma -> forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s -> m a
ma forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s, forall a b. b -> Either a b
Right a
a))
  {-# INLINE lift #-}

instance MFunctor ParserT where
  hoist :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> ParserT m b -> ParserT n b
hoist forall a. m a -> n a
nat = \ParserT m b
p -> forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s -> forall a. m a -> n a
nat (forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m b
p ParserState
s))
  {-# INLINE hoist #-}

instance MonadIO m => MonadIO (ParserT m) where
  liftIO :: forall a. IO a -> ParserT m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
  {-# INLINE liftIO #-}

instance MonadReader r m => MonadReader r (ParserT m) where
  ask :: ParserT m r
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
  {-# INLINE ask #-}
  local :: forall a. (r -> r) -> ParserT m a -> ParserT m a
local r -> r
f = \ParserT m a
p -> forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f (forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
p ParserState
s))
  {-# INLINE local #-}

instance MonadState s m => MonadState s (ParserT m) where
  state :: forall a. (s -> (a, s)) -> ParserT m a
state = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state
  {-# INLINE state #-}

instance MonadError e m => MonadError e (ParserT m) where
  throwError :: forall a. e -> ParserT m a
throwError = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  {-# INLINABLE throwError #-}
  catchError :: forall a. ParserT m a -> (e -> ParserT m a) -> ParserT m a
catchError ParserT m a
ma e -> ParserT m a
h = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s ->
    forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
ma ParserState
s)
               (\e
e -> forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (e -> ParserT m a
h e
e) ParserState
s))
  {-# INLINABLE catchError #-}

instance Ex.MonadThrow m => Ex.MonadThrow (ParserT m) where
  throwM :: forall e a. Exception e => e -> ParserT m a
throwM = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Ex.throwM
  {-# INLINABLE throwM #-}

instance Ex.MonadCatch m => Ex.MonadCatch (ParserT m) where
  catch :: forall e a.
Exception e =>
ParserT m a -> (e -> ParserT m a) -> ParserT m a
catch ParserT m a
ma e -> ParserT m a
h = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s ->
    forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Ex.catch (forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
ma ParserState
s)
             (\e
e -> forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (e -> ParserT m a
h e
e) ParserState
s))
  {-# INLINABLE catch #-}

instance Ex.MonadMask m => Ex.MonadMask (ParserT m) where
  mask :: forall b.
((forall a. ParserT m a -> ParserT m a) -> ParserT m b)
-> ParserT m b
mask (forall a. ParserT m a -> ParserT m a) -> ParserT m b
f = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s ->
    forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Ex.mask (\forall a. m a -> m a
u ->
      forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ((forall a. ParserT m a -> ParserT m a) -> ParserT m b
f (\ParserT m a
p -> forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (forall a. m a -> m a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
p))) ParserState
s))
  {-# INLINABLE mask #-}
  uninterruptibleMask :: forall b.
((forall a. ParserT m a -> ParserT m a) -> ParserT m b)
-> ParserT m b
uninterruptibleMask (forall a. ParserT m a -> ParserT m a) -> ParserT m b
f = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s ->
    forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Ex.uninterruptibleMask (\forall a. m a -> m a
u ->
      forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ((forall a. ParserT m a -> ParserT m a) -> ParserT m b
f (\ParserT m a
p -> forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (forall a. m a -> m a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
p))) ParserState
s))
  {-# INLINABLE uninterruptibleMask #-}
  generalBracket :: forall a b c.
ParserT m a
-> (a -> ExitCase b -> ParserT m c)
-> (a -> ParserT m b)
-> ParserT m (b, c)
generalBracket ParserT m a
acq a -> ExitCase b -> ParserT m c
rel a -> ParserT m b
use = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s0 -> do
    ((ParserState
_sb,Either String b
eb), (ParserState
sc,Either String c
ec)) <- forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
Ex.generalBracket
      (forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
acq ParserState
s0)
      (\(ParserState
s1, Either String a
ea) ExitCase (ParserState, Either String b)
ec -> case Either String a
ea of
          Right a
a -> case ExitCase (ParserState, Either String b)
ec of
            Ex.ExitCaseSuccess (ParserState
s2, Right b
b) ->
              forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (a -> ExitCase b -> ParserT m c
rel a
a (forall a. a -> ExitCase a
Ex.ExitCaseSuccess b
b)) ParserState
s2
            Ex.ExitCaseSuccess (ParserState
s2, Left String
msg) ->
              -- Result of using mzero or similar on release
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s2, forall a b. a -> Either a b
Left String
msg)
            Ex.ExitCaseException SomeException
e ->
              forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (a -> ExitCase b -> ParserT m c
rel a
a (forall a. SomeException -> ExitCase a
Ex.ExitCaseException SomeException
e)) ParserState
s1
            ExitCase (ParserState, Either String b)
Ex.ExitCaseAbort ->
              forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (a -> ExitCase b -> ParserT m c
rel a
a forall a. ExitCase a
Ex.ExitCaseAbort) ParserState
s1
          Left String
msg ->
            -- acq failed, nothing to release
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s1, forall a b. a -> Either a b
Left String
msg))
      (\(ParserState
s1, Either String a
ea) -> case Either String a
ea of
          Right a
a -> forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (a -> ParserT m b
use a
a) ParserState
s1
          Left String
msg ->
            -- acq failed, nothing to use
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s1, forall a b. a -> Either a b
Left String
msg))
    -- We run ec first because its error message, if any, has priority
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
sc, forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String c
ec forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either String b
eb))

{- TODO: Should we export this?
-- | This version uses the current state on entering the continuation. See
-- 'liftCallCC''.  It does not satisfy the uniformity property (see
-- 'Control.Monad.Signatures.CallCC').
instance MonadCont m => MonadCont (ParserT m) where
  callCC f = ParserT (\s0 ->
    callCC (\c -> runParserT (f (\a -> ParserT (\s1 -> c (s1, Right a)))) s0))
-}

--------------------------------------------------------------------------------
-- Some parsers

-- | @'pElement' "foo" p@ runs a 'ParserT' @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 matched element__ from the parser state.
pElement
  :: Monad m
  => T.Text       -- ^ Element name as strict 'T.Text'.
  -> ParserT m a  -- ^ 'ParserT' to run /inside/ the matched 'Element'.
  -> ParserT m a
pElement :: forall (m :: * -> *) a.
Monad m =>
Text -> ParserT m a -> ParserT m a
pElement Text
t0 ParserT m a
p0 = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT forall a b. (a -> b) -> a -> b
$ \case
  SReg Text
t1 HashMap Text Text
as0 (Node_Element Text
t HashMap Text Text
as [Node]
cs : [Node]
cs0) | Text
t forall a. Eq a => a -> a -> Bool
== Text
t0 ->
    forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
p0 (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t HashMap Text Text
as [Node]
cs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (ParserState
_, Right a
a) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t1 HashMap Text Text
as0 [Node]
cs0, forall a b. b -> Either a b
Right a
a)
      (ParserState
s1, Left String
msg) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s1, forall a b. a -> Either a b
Left String
msg)
  STop (Node_Element Text
t HashMap Text Text
as [Node]
cs : [Node]
cs0) | Text
t forall a. Eq a => a -> a -> Bool
== Text
t0 ->
    forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
p0 (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t HashMap Text Text
as [Node]
cs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (ParserState
_, Right a
a) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node] -> ParserState
STop [Node]
cs0, forall a b. b -> Either a b
Right a
a)
      (ParserState
s1, Left String
msg) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s1, forall a b. a -> Either a b
Left String
msg)
  -- skip leading whitespace
  SReg Text
t HashMap Text Text
as (Node_Text Text
x : [Node]
cs) | (Char -> Bool) -> Text -> Bool
TL.all Char -> Bool
Char.isSpace Text
x ->
    forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (forall (m :: * -> *) a.
Monad m =>
Text -> ParserT m a -> ParserT m a
pElement Text
t0 ParserT m a
p0) (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t HashMap Text Text
as [Node]
cs)
  STop (Node_Text Text
x : [Node]
cs) | (Char -> Bool) -> Text -> Bool
TL.all Char -> Bool
Char.isSpace Text
x ->
    forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (forall (m :: * -> *) a.
Monad m =>
Text -> ParserT m a -> ParserT m a
pElement Text
t0 ParserT m a
p0) ([Node] -> ParserState
STop [Node]
cs)
  ParserState
s0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s0, forall a b. a -> Either a b
Left (String
"Missing element " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
t0))
{-# INLINABLE pElement #-}

-- | @'pAnyElement' p@ runs a 'ParserT' @p@ inside the 'Element' node at the
-- current position, if any. Otherwise, if no such element exists, this parser
-- __fails__.
--
-- You can recover the name of the matched element using 'pName' inside the
-- given 'ParserT'. However, if you already know beforehand the name of the
-- element that you want to match, it's better to use 'pElement' rather than
-- 'pAnyElement'.
--
-- Leading whitespace is ignored. If you need to preserve that whitespace for
-- some reason, capture it using 'pText' before using 'pAnyElement'.
--
-- __Consumes the matched element__ from the parser state.
pAnyElement
  :: Monad m
  => ParserT m a  -- ^ 'ParserT' to run /inside/ any matched 'Element'.
  -> ParserT m a
pAnyElement :: forall (m :: * -> *) a. Monad m => ParserT m a -> ParserT m a
pAnyElement ParserT m a
p0 = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT forall a b. (a -> b) -> a -> b
$ \case
  SReg Text
t0 HashMap Text Text
as0 (Node_Element Text
t HashMap Text Text
as [Node]
cs : [Node]
cs0) ->
    forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
p0 (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t HashMap Text Text
as [Node]
cs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (ParserState
_, Right a
a) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t0 HashMap Text Text
as0 [Node]
cs0, forall a b. b -> Either a b
Right a
a)
      (ParserState
s1, Left String
msg) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s1, forall a b. a -> Either a b
Left String
msg)
  STop (Node_Element Text
t HashMap Text Text
as [Node]
cs : [Node]
cs0) ->
    forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT ParserT m a
p0 (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t HashMap Text Text
as [Node]
cs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (ParserState
_, Right a
a) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node] -> ParserState
STop [Node]
cs0, forall a b. b -> Either a b
Right a
a)
      (ParserState
s1, Left String
msg) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s1, forall a b. a -> Either a b
Left String
msg)
  -- skip leading whitespace
  SReg Text
t HashMap Text Text
as (Node_Text Text
x : [Node]
cs) | (Char -> Bool) -> Text -> Bool
TL.all Char -> Bool
Char.isSpace Text
x ->
    forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (forall (m :: * -> *) a. Monad m => ParserT m a -> ParserT m a
pAnyElement ParserT m a
p0) (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t HashMap Text Text
as [Node]
cs)
  STop (Node_Text Text
x : [Node]
cs) | (Char -> Bool) -> Text -> Bool
TL.all Char -> Bool
Char.isSpace Text
x ->
    forall (m :: * -> *) a.
ParserT m a -> ParserState -> m (ParserState, Either String a)
runParserT (forall (m :: * -> *) a. Monad m => ParserT m a -> ParserT m a
pAnyElement ParserT m a
p0) ([Node] -> ParserState
STop [Node]
cs)
  ParserState
s0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s0, forall a b. a -> Either a b
Left String
"Missing element")
{-# INLINABLE pAnyElement #-}

-- | Returns the name of the currently selected 'Element'.
--
-- This parser __fails__ if there's no currently selected 'Element' (see
-- 'pElement', 'pAnyElement').
--
-- Doesn't modify the parser state.
pName
  :: Applicative m
  => ParserT m T.Text -- ^ Element name as strict 'T.Text'.
pName :: forall (m :: * -> *). Applicative m => ParserT m Text
pName = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s -> case ParserState
s of
  SReg Text
t HashMap Text Text
_ [Node]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s, forall a b. b -> Either a b
Right Text
t)
  ParserState
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s, forall a b. a -> Either a b
Left String
"Before selecting an name, you must select an element"))
{-# INLINABLE pName #-}

-- | Return the value of the requested attribute, if defined, as strict
-- 'T.Text'. Returns an 'T.empty' strict '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' (see
-- 'pElement', 'pAnyElement').
--
-- __Consumes the matched attribute__ from the parser state.
pAttr
  :: Applicative m
  => T.Text
  -- ^ Attribute name as strict 'T.Text'.
  -> ParserT m T.Text
  -- ^ Attribute value as strict 'T.Text', possibly 'T.empty'.
pAttr :: forall (m :: * -> *). Applicative m => Text -> ParserT m Text
pAttr Text
n = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s -> case ParserState
s of
  SReg Text
t HashMap Text Text
as [Node]
cs -> case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
n HashMap Text Text
as of
    Just Text
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Text
n HashMap Text Text
as) [Node]
cs, forall a b. b -> Either a b
Right Text
x)
    Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s, forall a b. a -> Either a b
Left (String
"Missing attribute " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
n))
  ParserState
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s, forall a b. a -> Either a b
Left String
"Before selecting an attribute, you must select an element"))
{-# INLINABLE pAttr #-}

-- | Returns all of the available element attributes.
--
-- Returns 'T.empty' strict 'T.Text' as values in case an attribute is defined
-- but no value was given to it.
--
-- 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
  :: Applicative m
  => ParserT m (HM.HashMap T.Text T.Text)
  -- ^ Pairs of attribute names and possibly 'T.empty' values, as strict
  -- 'T.Text'.
pAttrs :: forall (m :: * -> *).
Applicative m =>
ParserT m (HashMap Text Text)
pAttrs = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s -> case ParserState
s of
  SReg Text
t HashMap Text Text
as [Node]
cs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t forall a. Monoid a => a
mempty [Node]
cs, forall a b. b -> Either a b
Right HashMap Text Text
as)
  ParserState
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s, forall a b. a -> Either a b
Left String
"Before selecting an attribute, you must select an element"))
{-# INLINABLE pAttrs #-}

-- | Returns all of the immediate children of the current element.
--
-- If parsing top-level nodes rather than a particular element (that is, if
-- 'pChildren' is /not/ being run inside 'pElement'), then all of the top level
-- 'Node's will be returned.
--
-- __Consumes all the returned nodes__ from the parser state.
pChildren
  :: Applicative m
  => ParserT m [Node] -- ^ 'Node's in their original order.
pChildren :: forall (m :: * -> *). Applicative m => ParserT m [Node]
pChildren = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\case
  STop [Node]
cs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node] -> ParserState
STop forall a. Monoid a => a
mempty, forall a b. b -> Either a b
Right [Node]
cs)
  SReg Text
t HashMap Text Text
as [Node]
cs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t HashMap Text Text
as forall a. Monoid a => a
mempty, forall a b. b -> Either a b
Right [Node]
cs))
{-# INLINABLE pChildren #-}

-- | Returns the contents of a text node as a strict 'TL.Text'.
--
-- 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 strict
-- 'T.Text', since there is no such thing as a text node without text.
--
-- Please note that consecutive text nodes are always concatenated and returned
-- together.
--
-- @
-- 'parse' 'pText' ('text' \"Ha\" <> 'text' \"sk\" <> 'text' \"ell\")
--     == 'Right' ('text' "Haskell")
-- @
--
-- __Consumes the text__ from the parser state. This implies that if you
-- perform two consecutive 'pText' calls, the second will always fail.
--
-- @
-- 'parse' ('pText' >> 'pText') ('text' \"Ha\" <> 'text' \"sk\" <> 'text' \"ell\")
--     == 'Left' "Missing text node"
-- @
pText
  :: Applicative m
  => ParserT m T.Text
  -- ^ Content of the text node as a strict 'T.Text'.
pText :: forall (m :: * -> *). Applicative m => ParserT m Text
pText = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
TL.toStrict forall (m :: * -> *). Applicative m => ParserT m Text
pTextLazy

-- | Like 'pText', but returns a lazy 'TL.Text'.
pTextLazy
  :: Applicative m
  => ParserT m TL.Text
  -- ^ Content of the text node as a lazy 'TL.Text'.
pTextLazy :: forall (m :: * -> *). Applicative m => ParserT m Text
pTextLazy = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\case
  -- Note: this works only because we asume 'normalize' has been used.
  STop (Node_Text Text
x : [Node]
ns) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node] -> ParserState
STop [Node]
ns, forall a b. b -> Either a b
Right Text
x)
  SReg Text
t HashMap Text Text
as (Node_Text Text
x : [Node]
cs) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> HashMap Text Text -> [Node] -> ParserState
SReg Text
t HashMap Text Text
as [Node]
cs, forall a b. b -> Either a b
Right Text
x)
  ParserState
s0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s0, forall a b. a -> Either a b
Left String
"Missing text node"))
{-# INLINABLE pText #-}

-- | Succeeds if all of the elements, attributes and text nodes have
-- been consumed.
pEndOfInput :: Applicative m => ParserT m ()
pEndOfInput :: forall (m :: * -> *). Applicative m => ParserT m ()
pEndOfInput = forall (m :: * -> *) a.
(ParserState -> m (ParserState, Either String a)) -> ParserT m a
ParserT (\ParserState
s -> case ParserState -> Bool
isEof ParserState
s of
  Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s, forall a b. b -> Either a b
Right ())
  Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserState
s, forall a b. a -> Either a b
Left String
"Not end of input yet"))
{-# INLINABLE pEndOfInput #-}

isEof :: ParserState -> Bool
isEof :: ParserState -> Bool
isEof = \case
  SReg Text
_ HashMap Text Text
as [Node]
cs -> forall k v. HashMap k v -> Bool
HM.null HashMap Text Text
as Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node]
cs
  STop [Node]
ns -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node]
ns
{-# INLINE isEof #-}

--------------------------------------------------------------------------------
-- Rendering

class ToXml a where
  -- | Renders a value of type @a@ into an XML fragment body.
  --
  -- If a 'FromXml' instance for @a@ exists, then:
  --
  -- @
  -- 'parse' 'fromXml' ('toXml' a)  ==  'Right' a
  -- @
  toXml :: a -> [Node]

-- | Encodes a list of XML 'Node's, representing an XML fragment body, to an
-- UTF8-encoded and XML-escaped bytestring.
--
-- This function doesn't render self-closing elements. Instead, all
-- elements have a corresponding closing tag.
--
-- Also, it doesn't render CDATA sections. Instead, all text is escaped as
-- necessary.
--
-- Element attributes are rendered in alphabetical order.
encode :: [Node] -> BB.Builder
encode :: [Node] -> Builder
encode [Node]
xs = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map Node -> Builder
encodeNode [Node]
xs)
  where
    encodeNode :: Node -> BB.Builder
    encodeNode :: Node -> Builder
encodeNode = \case
      Node_Text Text
x -> Text -> Builder
encodeXmlUtf8Lazy Text
x
      Node_Element Text
t HashMap Text Text
as [Node]
cs ->
         -- This ugly code is so that we make sure we always bind concatenation
         -- to the right with as little effort as possible, using (<>).
         Builder
"<" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeUtf8 Text
t
             forall a. Semigroup a => a -> a -> a
<> Builder -> HashMap Text Text -> Builder
encodeAttrs (Builder
">" forall a. Semigroup a => a -> a -> a
<> [Node] -> Builder
encode [Node]
cs forall a. Semigroup a => a -> a -> a
<> Builder
"</" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeUtf8 Text
t forall a. Semigroup a => a -> a -> a
<> Builder
">") HashMap Text Text
as
    {-# INLINE encodeNode #-}
    encodeAttrs :: BB.Builder -> HM.HashMap T.Text T.Text -> BB.Builder
    encodeAttrs :: Builder -> HashMap Text Text -> Builder
encodeAttrs Builder
b HashMap Text Text
as = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey'
      (\Text
k Text
v Builder
o -> Builder
" " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeUtf8 Text
k forall a. Semigroup a => a -> a -> a
<> Builder
"=\"" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeXmlUtf8 Text
v forall a. Semigroup a => a -> a -> a
<> Builder
"\"" forall a. Semigroup a => a -> a -> a
<> Builder
o)
      Builder
b (forall k v. Ord k => HashMap k v -> Map k v
mapFromHashMap HashMap Text Text
as)
    {-# INLINE encodeAttrs #-}

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- Node fixpoint

-- | Post-order depth-first replacement of 'Node' and all of its children.
--
-- This function works like 'Data.Function.fix', but the given function is
-- trying to find a fixpoint for the individual children nodes, not for the root
-- node.
--
-- For example, the following function renames every node named @"w"@ to @"y"@,
-- and every node named @"y"@ to @"z"@. It accomplishes this by first renaming
-- @"w"@ nodes to @"x"@, and then, by using @k@ recursively to further rename
-- all @"x"@ nodes (including the ones that were just created) to @"y"@ in a
-- post-order depth-first manner. After renaming an @"x"@ node to @"y"@, the
-- recursion stops (i.e., @k@ is not used), so our new @"y"@ nodes won't be
-- further renamed to @"z"@. However, nodes that were named @"y"@ initially will
-- be renamed to @"z"@.
--
-- In our example we only replace one node with another, but a node can be
-- replaced with zero or more nodes, depending on the length of the resulting
-- list.
--
-- @
-- 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
-- @
--
-- 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@.
dfpos :: ((Node -> [Node]) -> Node -> [Node]) -> Node -> [Node]
dfpos :: ((Node -> [Node]) -> Node -> [Node]) -> Node -> [Node]
dfpos (Node -> [Node]) -> Node -> [Node]
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Monad m =>
((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfposM (\Node -> Identity [Node]
k -> forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> [Node]) -> Node -> [Node]
f (forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Identity [Node]
k))

-- | Monadic version of 'dfpos'.
dfposM :: Monad m => ((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfposM :: forall (m :: * -> *).
Monad m =>
((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfposM (Node -> m [Node]) -> Node -> m [Node]
f = \Node
n0 -> do
  Cursor
c1 <- forall (m :: * -> *).
Monad m =>
(Node -> m [Node]) -> Cursor -> m Cursor
traverseChildren (forall (m :: * -> *).
Monad m =>
((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfposM (Node -> m [Node]) -> Node -> m [Node]
f) (Node -> Cursor
cursorFromNode Node
n0)
  Cursor
c2 <- forall (m :: * -> *).
Monad m =>
(Node -> m [Node]) -> Cursor -> m Cursor
traverseRightSiblings (forall (m :: * -> *).
Monad m =>
((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfposM (Node -> m [Node]) -> Node -> m [Node]
f) Cursor
c1
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Node] -> [Node]
normalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join)
       (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Node -> m [Node]) -> Node -> m [Node]
f (forall (m :: * -> *).
Monad m =>
((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfposM (Node -> m [Node]) -> Node -> m [Node]
f)) (Cursor -> [Node]
cursorSiblings Cursor
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 :: ((Node -> [Node]) -> Node -> [Node]) -> Node -> [Node]
dfpre (Node -> [Node]) -> Node -> [Node]
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Monad m =>
((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfpreM (\Node -> Identity [Node]
k -> forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> [Node]) -> Node -> [Node]
f (forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Identity [Node]
k))

-- | Monadic version of 'dfpre'.
dfpreM :: Monad m => ((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfpreM :: forall (m :: * -> *).
Monad m =>
((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfpreM (Node -> m [Node]) -> Node -> m [Node]
f = \Node
n0 -> do
  [Node]
ns <- (Node -> m [Node]) -> Node -> m [Node]
f (forall (m :: * -> *).
Monad m =>
((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfpreM (Node -> m [Node]) -> Node -> m [Node]
f) Node
n0
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Node] -> [Node]
normalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Node]
ns forall a b. (a -> b) -> a -> b
$ \Node
n -> do
     Cursor
c1 <- forall (m :: * -> *).
Monad m =>
(Node -> m [Node]) -> Cursor -> m Cursor
traverseChildren (forall (m :: * -> *).
Monad m =>
((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfpreM (Node -> m [Node]) -> Node -> m [Node]
f) (Node -> Cursor
cursorFromNode Node
n)
     Cursor -> [Node]
cursorSiblings forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Monad m =>
(Node -> m [Node]) -> Cursor -> m Cursor
traverseRightSiblings (forall (m :: * -> *).
Monad m =>
((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]
dfpreM (Node -> m [Node]) -> Node -> m [Node]
f) Cursor
c1


--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- INTERNAL: Cursor
--
-- Most of this comes from Chris Smith's xmlhtml, BSD3 licensed
-- https://hackage.haskell.org/package/xmlhtml

-- | Zipper into a 'Node' tree.
data Cursor = Cursor
  { Cursor -> Node
_cursorCurrent :: !Node
    -- ^ Retrieves the current node of a @Cursor@.
  , Cursor -> Seq Node
_cursorLefts :: !(Seq Node)
    -- ^ Nodes to the left (ordered right to left).
  , Cursor -> Seq Node
_cursorRights :: !(Seq Node)
    -- ^ Nodes to the right (ordered left to right).
  , Cursor -> Seq (Seq Node, Text, HashMap Text Text, Seq Node)
_cursorParents :: !(Seq (Seq Node, T.Text, HM.HashMap T.Text T.Text, Seq Node))
    -- ^ Parents' name, attributes, and siblings.
  }

------------------------------------------------------------------------------

-- | The cursor if left where it starts.
traverseChildren :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor
{-# INLINABLE traverseChildren #-}
traverseChildren :: forall (m :: * -> *).
Monad m =>
(Node -> m [Node]) -> Cursor -> m Cursor
traverseChildren Node -> m [Node]
f Cursor
c0 = case Cursor -> Node
_cursorCurrent Cursor
c0 of
  Node_Text Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Cursor
c0
  Node_Element Text
t HashMap Text Text
as [Node]
cs -> do
     [Node]
n1s <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Node] -> [Node]
normalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join) (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Node -> m [Node]
f [Node]
cs)
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cursor
c0 {_cursorCurrent :: Node
_cursorCurrent = Text -> HashMap Text Text -> [Node] -> Node
Node_Element Text
t HashMap Text Text
as [Node]
n1s})

-- | The cursor if left in the rightmost sibling.
traverseRightSiblings :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor
{-# INLINABLE traverseRightSiblings #-}
traverseRightSiblings :: forall (m :: * -> *).
Monad m =>
(Node -> m [Node]) -> Cursor -> m Cursor
traverseRightSiblings Node -> m [Node]
f Cursor
c0 = case Cursor -> Maybe (Node, Cursor)
cursorRemoveRight Cursor
c0 of
   Maybe (Node, Cursor)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Cursor
c0
   Just (Node
n1, Cursor
c1) -> do
      [Node]
n2s <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Node] -> [Node]
normalize (Node -> m [Node]
f Node
n1)
      forall (m :: * -> *).
Monad m =>
(Node -> m [Node]) -> Cursor -> m Cursor
traverseRightSiblings Node -> m [Node]
f ([Node] -> Cursor -> Cursor
cursorInsertManyRight [Node]
n2s Cursor
c1)

-- | Builds a @Cursor@ for navigating a tree. That is, a forest with a single
-- root 'Node'.
cursorFromNode :: Node -> Cursor
{-# INLINE cursorFromNode #-}
cursorFromNode :: Node -> Cursor
cursorFromNode Node
n = Node
-> Seq Node
-> Seq Node
-> Seq (Seq Node, Text, HashMap Text Text, Seq Node)
-> Cursor
Cursor Node
n forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

-- | Retrieves a list of the 'Node's at the same level as the current position
-- of a cursor, including the current node.
cursorSiblings :: Cursor -> [Node]
{-# INLINE cursorSiblings #-}
cursorSiblings :: Cursor -> [Node]
cursorSiblings (Cursor Node
cur Seq Node
ls Seq Node
rs Seq (Seq Node, Text, HashMap Text Text, Seq Node)
_) =
  forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall a. Seq a -> Seq a
Seq.reverse Seq Node
ls forall a. Semigroup a => a -> a -> a
<> (Node
cur forall a. a -> Seq a -> Seq a
Seq.<| Seq Node
rs))

-- | Removes the node to the right and return it.
cursorRemoveRight :: Cursor -> Maybe (Node, Cursor)
{-# INLINABLE cursorRemoveRight #-}
cursorRemoveRight :: Cursor -> Maybe (Node, Cursor)
cursorRemoveRight = \case
  Cursor Node
n Seq Node
ls Seq Node
rs0 Seq (Seq Node, Text, HashMap Text Text, Seq Node)
ps | Bool -> Bool
not (forall a. Seq a -> Bool
Seq.null Seq Node
rs0) ->
     case forall a. Seq a -> ViewL a
Seq.viewl Seq Node
rs0 of
        Node
r Seq.:< Seq Node
rs -> forall a. a -> Maybe a
Just (Node
r, Node
-> Seq Node
-> Seq Node
-> Seq (Seq Node, Text, HashMap Text Text, Seq Node)
-> Cursor
Cursor Node
n Seq Node
ls Seq Node
rs Seq (Seq Node, Text, HashMap Text Text, Seq Node)
ps)
        ViewL Node
_ -> forall a. HasCallStack => a
undefined -- unreachable, rs0 is not empty
  Cursor
_ -> forall a. Maybe a
Nothing

-- | Inserts a list of new 'Node's to the right of the current position.
cursorInsertManyRight :: [Node] -> Cursor -> Cursor
{-# INLINE cursorInsertManyRight #-}
cursorInsertManyRight :: [Node] -> Cursor -> Cursor
cursorInsertManyRight [Node]
ns (Cursor Node
nn Seq Node
ls Seq Node
rs Seq (Seq Node, Text, HashMap Text Text, Seq Node)
ps) =
  Node
-> Seq Node
-> Seq Node
-> Seq (Seq Node, Text, HashMap Text Text, Seq Node)
-> Cursor
Cursor Node
nn Seq Node
ls (forall a. [a] -> Seq a
Seq.fromList [Node]
ns forall a. Semigroup a => a -> a -> a
<> Seq Node
rs) Seq (Seq Node, Text, HashMap Text Text, Seq Node)
ps

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- Miscellaneous

encodeUtf8 :: T.Text -> BB.Builder
{-# INLINE encodeUtf8 #-}
encodeUtf8 :: Text -> Builder
encodeUtf8 = Text -> Builder
T.encodeUtf8Builder

encodeXmlUtf8 :: T.Text -> BB.Builder
{-# INLINE encodeXmlUtf8 #-}
encodeXmlUtf8 :: Text -> Builder
encodeXmlUtf8 = BoundedPrim Word8 -> Text -> Builder
T.encodeUtf8BuilderEscaped BoundedPrim Word8
xmlEscaped

encodeXmlUtf8Lazy :: TL.Text -> BB.Builder
{-# INLINE encodeXmlUtf8Lazy #-}
encodeXmlUtf8Lazy :: Text -> Builder
encodeXmlUtf8Lazy = BoundedPrim Word8 -> Text -> Builder
TL.encodeUtf8BuilderEscaped BoundedPrim Word8
xmlEscaped

xmlEscaped :: BBP.BoundedPrim Word8
{-# INLINE xmlEscaped #-}
xmlEscaped :: BoundedPrim Word8
xmlEscaped =
   forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
BBP.condB (forall a. Eq a => a -> a -> Bool
== Word8
38) ((Word8, (Word8, (Word8, (Word8, Word8)))) -> BoundedPrim Word8
fixed5 (Word8
38,(Word8
97,(Word8
109,(Word8
112,Word8
59))))) forall a b. (a -> b) -> a -> b
$  -- '&'  ->  "&amp;"
   forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
BBP.condB (forall a. Eq a => a -> a -> Bool
== Word8
60) ((Word8, (Word8, (Word8, Word8))) -> BoundedPrim Word8
fixed4 (Word8
38,(Word8
108,(Word8
116,Word8
59)))) forall a b. (a -> b) -> a -> b
$       -- '<'  ->  "&lt;"
   forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
BBP.condB (forall a. Eq a => a -> a -> Bool
== Word8
62) ((Word8, (Word8, (Word8, Word8))) -> BoundedPrim Word8
fixed4 (Word8
38,(Word8
103,(Word8
116,Word8
59)))) forall a b. (a -> b) -> a -> b
$       -- '>'  ->  "&gt;"
   forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
BBP.condB (forall a. Eq a => a -> a -> Bool
== Word8
34) ((Word8, (Word8, (Word8, (Word8, Word8)))) -> BoundedPrim Word8
fixed5 (Word8
38,(Word8
35,(Word8
51,(Word8
52,Word8
59))))) forall a b. (a -> b) -> a -> b
$    -- '"'  ->  "&#34;"
   forall a. FixedPrim a -> BoundedPrim a
BBP.liftFixedToBounded FixedPrim Word8
BBP.word8
 where
   {-# INLINE fixed4 #-}
   fixed4 :: (Word8, (Word8, (Word8, Word8))) -> BBP.BoundedPrim Word8
   fixed4 :: (Word8, (Word8, (Word8, Word8))) -> BoundedPrim Word8
fixed4 (Word8, (Word8, (Word8, Word8)))
x = forall a. FixedPrim a -> BoundedPrim a
BBP.liftFixedToBounded
     (forall a b. a -> b -> a
const (Word8, (Word8, (Word8, Word8)))
x forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
BBP.>$< FixedPrim Word8
BBP.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
BBP.>*< FixedPrim Word8
BBP.word8
              forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
BBP.>*< FixedPrim Word8
BBP.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
BBP.>*< FixedPrim Word8
BBP.word8)
   {-# INLINE fixed5 #-}
   fixed5 :: (Word8, (Word8, (Word8, (Word8, Word8)))) -> BBP.BoundedPrim Word8
   fixed5 :: (Word8, (Word8, (Word8, (Word8, Word8)))) -> BoundedPrim Word8
fixed5 (Word8, (Word8, (Word8, (Word8, Word8))))
x = forall a. FixedPrim a -> BoundedPrim a
BBP.liftFixedToBounded
     (forall a b. a -> b -> a
const (Word8, (Word8, (Word8, (Word8, Word8))))
x forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
BBP.>$< FixedPrim Word8
BBP.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
BBP.>*< FixedPrim Word8
BBP.word8
              forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
BBP.>*< FixedPrim Word8
BBP.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
BBP.>*< FixedPrim Word8
BBP.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
BBP.>*< FixedPrim Word8
BBP.word8)

mapFromHashMap :: Ord k => HM.HashMap k v -> Map.Map k v
mapFromHashMap :: forall k v. Ord k => HashMap k v -> Map k v
mapFromHashMap = forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HM.foldrWithKey' forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert forall k a. Map k a
Map.empty
{-# INLINE mapFromHashMap #-}