{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE RecursiveDo                #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE Trustworthy                #-}

-- |
-- Copyright: © Herbert Valerio Riedel 2015-2018
-- SPDX-License-Identifier: GPL-2.0-or-later
--
module Data.YAML.Loader
    ( decodeLoader
    , Loader(..)
    , LoaderT
    , NodeId
    ) where

import           Control.Monad.State  (MonadState(..), gets, modify,
                                       StateT, evalStateT, state)
import           Control.Monad.Trans  (MonadTrans(..))
import qualified Data.ByteString.Lazy as BS.L
import qualified Data.Map             as Map
import qualified Data.Set             as Set

import           Data.YAML.Event      (Tag)
import qualified Data.YAML.Event      as YE
import           Util

-- | Unique identifier for identifying nodes
--
-- This is allows to observe the alias/anchor-reference structure
type NodeId = Word

-- | Structure defining how to construct a document tree/graph
--
-- @since 0.2.0
--
data Loader m n = Loader
  { forall (m :: * -> *) n.
Loader m n -> Tag -> ScalarStyle -> Text -> LoaderT m n
yScalar   :: Tag -> YE.ScalarStyle -> Text -> LoaderT m n
  , forall (m :: * -> *) n. Loader m n -> Tag -> [n] -> LoaderT m n
ySequence :: Tag -> [n]                    -> LoaderT m n
  , forall (m :: * -> *) n.
Loader m n -> Tag -> [(n, n)] -> LoaderT m n
yMapping  :: Tag -> [(n,n)]                -> LoaderT m n
  , forall (m :: * -> *) n.
Loader m n -> NodeId -> Bool -> n -> LoaderT m n
yAlias    :: NodeId -> Bool -> n           -> LoaderT m n
  , forall (m :: * -> *) n. Loader m n -> NodeId -> n -> LoaderT m n
yAnchor   :: NodeId -> n                   -> LoaderT m n
  }

-- | Helper type for 'Loader'
--
-- @since 0.2.0
type LoaderT m n = YE.Pos -> m (Either (YE.Pos,String) n)

-- TODO: newtype LoaderT m n = LoaderT { runLoaderT :: YE.Pos -> m (Either String n) }

-- | Generalised document tree/graph construction
--
-- This doesn't yet perform any tag resolution (thus all scalars are
-- represented as 'Text' values). See also 'Data.YAML.decodeNode' for a more
-- convenient interface.
--
-- @since 0.2.0
{-# INLINEABLE decodeLoader #-}
decodeLoader :: forall n m . MonadFix m => Loader m n -> BS.L.ByteString -> m (Either (YE.Pos, String) [n])
decodeLoader :: forall n (m :: * -> *).
MonadFix m =>
Loader m n -> ByteString -> m (Either (Pos, String) [n])
decodeLoader Loader{NodeId -> n -> LoaderT m n
NodeId -> Bool -> n -> LoaderT m n
Tag -> [n] -> LoaderT m n
Tag -> [(n, n)] -> LoaderT m n
Tag -> ScalarStyle -> Text -> LoaderT m n
yScalar :: forall (m :: * -> *) n.
Loader m n -> Tag -> ScalarStyle -> Text -> LoaderT m n
ySequence :: forall (m :: * -> *) n. Loader m n -> Tag -> [n] -> LoaderT m n
yMapping :: forall (m :: * -> *) n.
Loader m n -> Tag -> [(n, n)] -> LoaderT m n
yAlias :: forall (m :: * -> *) n.
Loader m n -> NodeId -> Bool -> n -> LoaderT m n
yAnchor :: forall (m :: * -> *) n. Loader m n -> NodeId -> n -> LoaderT m n
yScalar :: Tag -> ScalarStyle -> Text -> LoaderT m n
ySequence :: Tag -> [n] -> LoaderT m n
yMapping :: Tag -> [(n, n)] -> LoaderT m n
yAlias :: NodeId -> Bool -> n -> LoaderT m n
yAnchor :: NodeId -> n -> LoaderT m n
..} ByteString
bs0 = do
    case [Either (Pos, String) EvPos] -> Either (Pos, String) [EvPos]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Either (Pos, String) EvPos] -> Either (Pos, String) [EvPos])
-> [Either (Pos, String) EvPos] -> Either (Pos, String) [EvPos]
forall a b. (a -> b) -> a -> b
$ (Either (Pos, String) EvPos -> Bool)
-> [Either (Pos, String) EvPos] -> [Either (Pos, String) EvPos]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool)
-> (Either (Pos, String) EvPos -> Bool)
-> Either (Pos, String) EvPos
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Pos, String) EvPos -> Bool
forall {a}. Either a EvPos -> Bool
isComment) (ByteString -> [Either (Pos, String) EvPos]
YE.parseEvents ByteString
bs0) of
      Left (Pos
pos,String
err) -> Either (Pos, String) [n] -> m (Either (Pos, String) [n])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Pos, String) [n] -> m (Either (Pos, String) [n]))
-> Either (Pos, String) [n] -> m (Either (Pos, String) [n])
forall a b. (a -> b) -> a -> b
$ (Pos, String) -> Either (Pos, String) [n]
forall a b. a -> Either a b
Left (Pos
pos,String
err)
      Right [EvPos]
evs      -> PT n m [n] -> [EvPos] -> m (Either (Pos, String) [n])
forall (m :: * -> *) n a.
Monad m =>
PT n m a -> [EvPos] -> m (Either (Pos, String) a)
runParserT PT n m [n]
goStream [EvPos]
evs
  where
    isComment :: Either a EvPos -> Bool
isComment Either a EvPos
evPos = case Either a EvPos
evPos of
      Right (YE.EvPos {eEvent :: EvPos -> Event
eEvent = (YE.Comment Text
_), ePos :: EvPos -> Pos
ePos = Pos
_}) -> Bool
True
      Either a EvPos
_                                                    -> Bool
False

    goStream :: PT n m [n]
    goStream :: PT n m [n]
goStream = do
      _ <- (Event -> Bool) -> PT n m EvPos
forall (m :: * -> *) n. Monad m => (Event -> Bool) -> PT n m EvPos
satisfy (Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event
YE.StreamStart)
      ds <- manyUnless (== YE.StreamEnd) goDoc
      eof
      return ds

    goDoc :: PT n m n
    goDoc :: PT n m n
goDoc = do
      _ <- (Event -> Bool) -> PT n m EvPos
forall (m :: * -> *) n. Monad m => (Event -> Bool) -> PT n m EvPos
satisfy Event -> Bool
isDocStart
      modify $ \S n
s0 -> S n
s0 { sDict = mempty, sCycle = mempty }
      n <- goNode
      _ <- satisfy isDocEnd
      return n

    getNewNid :: PT n m Word
    getNewNid :: PT n m NodeId
getNewNid = (S n -> (NodeId, S n)) -> PT n m NodeId
forall a. (S n -> (a, S n)) -> PT n m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((S n -> (NodeId, S n)) -> PT n m NodeId)
-> (S n -> (NodeId, S n)) -> PT n m NodeId
forall a b. (a -> b) -> a -> b
$ \S n
s0 -> let i0 :: NodeId
i0 = S n -> NodeId
forall n. S n -> NodeId
sIdCnt S n
s0
                               in (NodeId
i0, S n
s0 { sIdCnt = i0+1 })

    returnNode :: YE.Pos -> Maybe YE.Anchor -> Either (YE.Pos, String) n -> PT n m n
    returnNode :: Pos -> Maybe Text -> Either (Pos, String) n -> PT n m n
returnNode Pos
_ Maybe Text
_ (Left (Pos, String)
err) = (Pos, String) -> PT n m n
forall a. (Pos, String) -> PT n m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos, String)
err
    returnNode Pos
_ Maybe Text
Nothing (Right n
node) = n -> PT n m n
forall a. a -> PT n m a
forall (m :: * -> *) a. Monad m => a -> m a
return n
node
    returnNode Pos
pos (Just Text
a) (Right n
node) = do
      nid <- PT n m NodeId
getNewNid
      node' <- liftEither' =<< lift (yAnchor nid node pos)
      modify $ \S n
s0 -> S n
s0 { sDict = Map.insert a (nid,node') (sDict s0) }
      return node'

    registerAnchor :: YE.Pos -> Maybe YE.Anchor -> PT n m n -> PT n m n
    registerAnchor :: Pos -> Maybe Text -> PT n m n -> PT n m n
registerAnchor Pos
_ Maybe Text
Nothing  PT n m n
pn = PT n m n
pn
    registerAnchor Pos
pos (Just Text
a) PT n m n
pn = do
      (S n -> S n) -> PT n m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((S n -> S n) -> PT n m ()) -> (S n -> S n) -> PT n m ()
forall a b. (a -> b) -> a -> b
$ \S n
s0 -> S n
s0 { sCycle = Set.insert a (sCycle s0) }
      nid <- PT n m NodeId
getNewNid

      mdo
        modify $ \S n
s0 -> S n
s0 { sDict = Map.insert a (nid,n) (sDict s0) }
        n0 <- pn
        n  <- liftEither' =<< lift (yAnchor nid n0 pos)
        return n

    exitAnchor :: Maybe YE.Anchor -> PT n m ()
    exitAnchor :: Maybe Text -> PT n m ()
exitAnchor Maybe Text
Nothing  = () -> PT n m ()
forall a. a -> PT n m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    exitAnchor (Just Text
a) = (S n -> S n) -> PT n m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((S n -> S n) -> PT n m ()) -> (S n -> S n) -> PT n m ()
forall a b. (a -> b) -> a -> b
$ \S n
s0 -> S n
s0 { sCycle = Set.delete a (sCycle s0) }

    goNode :: PT n m n
    goNode :: PT n m n
goNode = do
      n <- PT n m EvPos
forall (m :: * -> *) n. Monad m => PT n m EvPos
anyEv
      let pos = EvPos -> Pos
YE.ePos EvPos
n
      case YE.eEvent n of
        YE.Scalar Maybe Text
manc Tag
tag ScalarStyle
sty Text
val -> do
          Maybe Text -> PT n m ()
exitAnchor Maybe Text
manc
          n' <- m (Either (Pos, String) n) -> PT n m (Either (Pos, String) n)
forall (m :: * -> *) a. Monad m => m a -> PT n m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Tag -> ScalarStyle -> Text -> LoaderT m n
yScalar Tag
tag ScalarStyle
sty Text
val Pos
pos)
          returnNode pos manc $! n'

        YE.SequenceStart Maybe Text
manc Tag
tag NodeStyle
_ -> Pos -> Maybe Text -> PT n m n -> PT n m n
registerAnchor Pos
pos Maybe Text
manc (PT n m n -> PT n m n) -> PT n m n -> PT n m n
forall a b. (a -> b) -> a -> b
$ do
          ns <- (Event -> Bool) -> PT n m n -> PT n m [n]
forall (m :: * -> *) n a.
Monad m =>
(Event -> Bool) -> PT n m a -> PT n m [a]
manyUnless (Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event
YE.SequenceEnd) PT n m n
goNode
          exitAnchor manc
          liftEither' =<< lift (ySequence tag ns pos)

        YE.MappingStart Maybe Text
manc Tag
tag NodeStyle
_ -> Pos -> Maybe Text -> PT n m n -> PT n m n
registerAnchor Pos
pos Maybe Text
manc (PT n m n -> PT n m n) -> PT n m n -> PT n m n
forall a b. (a -> b) -> a -> b
$ do
          kvs <- (Event -> Bool) -> PT n m (n, n) -> PT n m [(n, n)]
forall (m :: * -> *) n a.
Monad m =>
(Event -> Bool) -> PT n m a -> PT n m [a]
manyUnless (Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event
YE.MappingEnd) ((n -> n -> (n, n)) -> PT n m n -> PT n m n -> PT n m (n, n)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) PT n m n
goNode PT n m n
goNode)
          exitAnchor manc
          liftEither' =<< lift (yMapping tag kvs pos)

        YE.Alias Text
a -> do
          d <- (S n -> Map Text (NodeId, n)) -> PT n m (Map Text (NodeId, n))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets S n -> Map Text (NodeId, n)
forall n. S n -> Map Text (NodeId, n)
sDict
          cy <- gets sCycle
          case Map.lookup a d of
            Maybe (NodeId, n)
Nothing       -> (Pos, String) -> PT n m n
forall a. (Pos, String) -> PT n m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos
pos, (String
"anchor not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
a))
            Just (NodeId
nid,n
n') -> Either (Pos, String) n -> PT n m n
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither' (Either (Pos, String) n -> PT n m n)
-> PT n m (Either (Pos, String) n) -> PT n m n
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Either (Pos, String) n) -> PT n m (Either (Pos, String) n)
forall (m :: * -> *) a. Monad m => m a -> PT n m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (NodeId -> Bool -> n -> LoaderT m n
yAlias NodeId
nid (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
a Set Text
cy) n
n' Pos
pos)

        Event
_ -> (Pos, String) -> PT n m n
forall a. (Pos, String) -> PT n m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos
pos, String
"goNode: unexpected event")

----------------------------------------------------------------------------
-- small parser framework


data S n = S { forall n. S n -> [EvPos]
sEvs   :: [YE.EvPos]
             , forall n. S n -> Map Text (NodeId, n)
sDict  :: Map YE.Anchor (Word,n)
             , forall n. S n -> Set Text
sCycle :: Set YE.Anchor
             , forall n. S n -> NodeId
sIdCnt :: !Word
             }

newtype PT n m a = PT (StateT (S n) (ExceptT (YE.Pos, String) m) a)
                 deriving ( (forall a b. (a -> b) -> PT n m a -> PT n m b)
-> (forall a b. a -> PT n m b -> PT n m a) -> Functor (PT n m)
forall a b. a -> PT n m b -> PT n m a
forall a b. (a -> b) -> PT n m a -> PT n m b
forall n (m :: * -> *) a b. Functor m => a -> PT n m b -> PT n m a
forall n (m :: * -> *) a b.
Functor m =>
(a -> b) -> PT n m a -> PT n m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall n (m :: * -> *) a b.
Functor m =>
(a -> b) -> PT n m a -> PT n m b
fmap :: forall a b. (a -> b) -> PT n m a -> PT n m b
$c<$ :: forall n (m :: * -> *) a b. Functor m => a -> PT n m b -> PT n m a
<$ :: forall a b. a -> PT n m b -> PT n m a
Functor
                          , Functor (PT n m)
Functor (PT n m) =>
(forall a. a -> PT n m a)
-> (forall a b. PT n m (a -> b) -> PT n m a -> PT n m b)
-> (forall a b c.
    (a -> b -> c) -> PT n m a -> PT n m b -> PT n m c)
-> (forall a b. PT n m a -> PT n m b -> PT n m b)
-> (forall a b. PT n m a -> PT n m b -> PT n m a)
-> Applicative (PT n m)
forall a. a -> PT n m a
forall a b. PT n m a -> PT n m b -> PT n m a
forall a b. PT n m a -> PT n m b -> PT n m b
forall a b. PT n m (a -> b) -> PT n m a -> PT n m b
forall a b c. (a -> b -> c) -> PT n m a -> PT n m b -> PT n m c
forall n (m :: * -> *). Monad m => Functor (PT n m)
forall n (m :: * -> *) a. Monad m => a -> PT n m a
forall n (m :: * -> *) a b.
Monad m =>
PT n m a -> PT n m b -> PT n m a
forall n (m :: * -> *) a b.
Monad m =>
PT n m a -> PT n m b -> PT n m b
forall n (m :: * -> *) a b.
Monad m =>
PT n m (a -> b) -> PT n m a -> PT n m b
forall n (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> PT n m a -> PT n m b -> PT n m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall n (m :: * -> *) a. Monad m => a -> PT n m a
pure :: forall a. a -> PT n m a
$c<*> :: forall n (m :: * -> *) a b.
Monad m =>
PT n m (a -> b) -> PT n m a -> PT n m b
<*> :: forall a b. PT n m (a -> b) -> PT n m a -> PT n m b
$cliftA2 :: forall n (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> PT n m a -> PT n m b -> PT n m c
liftA2 :: forall a b c. (a -> b -> c) -> PT n m a -> PT n m b -> PT n m c
$c*> :: forall n (m :: * -> *) a b.
Monad m =>
PT n m a -> PT n m b -> PT n m b
*> :: forall a b. PT n m a -> PT n m b -> PT n m b
$c<* :: forall n (m :: * -> *) a b.
Monad m =>
PT n m a -> PT n m b -> PT n m a
<* :: forall a b. PT n m a -> PT n m b -> PT n m a
Applicative
                          , Applicative (PT n m)
Applicative (PT n m) =>
(forall a b. PT n m a -> (a -> PT n m b) -> PT n m b)
-> (forall a b. PT n m a -> PT n m b -> PT n m b)
-> (forall a. a -> PT n m a)
-> Monad (PT n m)
forall a. a -> PT n m a
forall a b. PT n m a -> PT n m b -> PT n m b
forall a b. PT n m a -> (a -> PT n m b) -> PT n m b
forall n (m :: * -> *). Monad m => Applicative (PT n m)
forall n (m :: * -> *) a. Monad m => a -> PT n m a
forall n (m :: * -> *) a b.
Monad m =>
PT n m a -> PT n m b -> PT n m b
forall n (m :: * -> *) a b.
Monad m =>
PT n m a -> (a -> PT n m b) -> PT n m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall n (m :: * -> *) a b.
Monad m =>
PT n m a -> (a -> PT n m b) -> PT n m b
>>= :: forall a b. PT n m a -> (a -> PT n m b) -> PT n m b
$c>> :: forall n (m :: * -> *) a b.
Monad m =>
PT n m a -> PT n m b -> PT n m b
>> :: forall a b. PT n m a -> PT n m b -> PT n m b
$creturn :: forall n (m :: * -> *) a. Monad m => a -> PT n m a
return :: forall a. a -> PT n m a
Monad
                          , MonadState (S n)
                          , MonadError (YE.Pos, String)
                          , Monad (PT n m)
Monad (PT n m) =>
(forall a. (a -> PT n m a) -> PT n m a) -> MonadFix (PT n m)
forall a. (a -> PT n m a) -> PT n m a
forall n (m :: * -> *). MonadFix m => Monad (PT n m)
forall n (m :: * -> *) a. MonadFix m => (a -> PT n m a) -> PT n m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall n (m :: * -> *) a. MonadFix m => (a -> PT n m a) -> PT n m a
mfix :: forall a. (a -> PT n m a) -> PT n m a
MonadFix
                          )

instance MonadTrans (PT n) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> PT n m a
lift = StateT (S n) (ExceptT (Pos, String) m) a -> PT n m a
forall n (m :: * -> *) a.
StateT (S n) (ExceptT (Pos, String) m) a -> PT n m a
PT (StateT (S n) (ExceptT (Pos, String) m) a -> PT n m a)
-> (m a -> StateT (S n) (ExceptT (Pos, String) m) a)
-> m a
-> PT n m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (Pos, String) m a
-> StateT (S n) (ExceptT (Pos, String) m) a
forall (m :: * -> *) a. Monad m => m a -> StateT (S n) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Pos, String) m a
 -> StateT (S n) (ExceptT (Pos, String) m) a)
-> (m a -> ExceptT (Pos, String) m a)
-> m a
-> StateT (S n) (ExceptT (Pos, String) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ExceptT (Pos, String) m a
forall (m :: * -> *) a. Monad m => m a -> ExceptT (Pos, String) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

runParserT :: Monad m => PT n m a -> [YE.EvPos] -> m (Either (YE.Pos, String) a)
runParserT :: forall (m :: * -> *) n a.
Monad m =>
PT n m a -> [EvPos] -> m (Either (Pos, String) a)
runParserT (PT StateT (S n) (ExceptT (Pos, String) m) a
act) [EvPos]
s0 = ExceptT (Pos, String) m a -> m (Either (Pos, String) a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (Pos, String) m a -> m (Either (Pos, String) a))
-> ExceptT (Pos, String) m a -> m (Either (Pos, String) a)
forall a b. (a -> b) -> a -> b
$ StateT (S n) (ExceptT (Pos, String) m) a
-> S n -> ExceptT (Pos, String) m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (S n) (ExceptT (Pos, String) m) a
act ([EvPos] -> Map Text (NodeId, n) -> Set Text -> NodeId -> S n
forall n.
[EvPos] -> Map Text (NodeId, n) -> Set Text -> NodeId -> S n
S [EvPos]
s0 Map Text (NodeId, n)
forall a. Monoid a => a
mempty Set Text
forall a. Monoid a => a
mempty NodeId
0)

satisfy :: Monad m => (YE.Event -> Bool) -> PT n m YE.EvPos
satisfy :: forall (m :: * -> *) n. Monad m => (Event -> Bool) -> PT n m EvPos
satisfy Event -> Bool
p = do
  s0 <- PT n m (S n)
forall s (m :: * -> *). MonadState s m => m s
get
  case sEvs s0 of
    [] -> (Pos, String) -> PT n m EvPos
forall a. (Pos, String) -> PT n m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos
fakePos, String
"satisfy: premature eof")
    (EvPos
ev:[EvPos]
rest)
       | Event -> Bool
p (EvPos -> Event
YE.eEvent EvPos
ev) -> do S n -> PT n m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (S n
s0 { sEvs = rest})
                                EvPos -> PT n m EvPos
forall a. a -> PT n m a
forall (m :: * -> *) a. Monad m => a -> m a
return EvPos
ev
       | Bool
otherwise        -> (Pos, String) -> PT n m EvPos
forall a. (Pos, String) -> PT n m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EvPos -> Pos
YE.ePos EvPos
ev, (String
"satisfy: predicate failed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EvPos -> String
forall a. Show a => a -> String
show EvPos
ev))

peek :: Monad m => PT n m (Maybe YE.EvPos)
peek :: forall (m :: * -> *) n. Monad m => PT n m (Maybe EvPos)
peek = do
  s0 <- PT n m (S n)
forall s (m :: * -> *). MonadState s m => m s
get
  case sEvs s0 of
    []     -> Maybe EvPos -> PT n m (Maybe EvPos)
forall a. a -> PT n m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe EvPos
forall a. Maybe a
Nothing
    (EvPos
ev:[EvPos]
_) -> Maybe EvPos -> PT n m (Maybe EvPos)
forall a. a -> PT n m a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvPos -> Maybe EvPos
forall a. a -> Maybe a
Just EvPos
ev)

peek1 :: Monad m => PT n m YE.EvPos
peek1 :: forall (m :: * -> *) n. Monad m => PT n m EvPos
peek1 = PT n m EvPos
-> (EvPos -> PT n m EvPos) -> Maybe EvPos -> PT n m EvPos
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Pos, String) -> PT n m EvPos
forall a. (Pos, String) -> PT n m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos
fakePos,String
"peek1: premature eof")) EvPos -> PT n m EvPos
forall a. a -> PT n m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe EvPos -> PT n m EvPos)
-> PT n m (Maybe EvPos) -> PT n m EvPos
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PT n m (Maybe EvPos)
forall (m :: * -> *) n. Monad m => PT n m (Maybe EvPos)
peek

anyEv :: Monad m => PT n m YE.EvPos
anyEv :: forall (m :: * -> *) n. Monad m => PT n m EvPos
anyEv = (Event -> Bool) -> PT n m EvPos
forall (m :: * -> *) n. Monad m => (Event -> Bool) -> PT n m EvPos
satisfy (Bool -> Event -> Bool
forall a b. a -> b -> a
const Bool
True)

eof :: Monad m => PT n m ()
eof :: forall (m :: * -> *) n. Monad m => PT n m ()
eof = do
  s0 <- PT n m (S n)
forall s (m :: * -> *). MonadState s m => m s
get
  case sEvs s0 of
    []     -> () -> PT n m ()
forall a. a -> PT n m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (EvPos
ev:[EvPos]
_) -> (Pos, String) -> PT n m ()
forall a. (Pos, String) -> PT n m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EvPos -> Pos
YE.ePos EvPos
ev, String
"eof expected")

-- NB: consumes the end-event
manyUnless :: Monad m => (YE.Event -> Bool) -> PT n m a -> PT n m [a]
manyUnless :: forall (m :: * -> *) n a.
Monad m =>
(Event -> Bool) -> PT n m a -> PT n m [a]
manyUnless Event -> Bool
p PT n m a
act = do
  t0 <- PT n m EvPos
forall (m :: * -> *) n. Monad m => PT n m EvPos
peek1
  if p (YE.eEvent t0)
    then anyEv >> return []
    else liftM2 (:) act (manyUnless p act)

{-
tryError :: MonadError e m => m a -> m (Either e a)
tryError act = catchError (Right <$> act) (pure . Left)
-}

isDocStart :: YE.Event -> Bool
isDocStart :: Event -> Bool
isDocStart (YE.DocumentStart Directives
_) = Bool
True
isDocStart Event
_                    = Bool
False

isDocEnd :: YE.Event -> Bool
isDocEnd :: Event -> Bool
isDocEnd (YE.DocumentEnd Bool
_) = Bool
True
isDocEnd Event
_                  = Bool
False

fakePos :: YE.Pos
fakePos :: Pos
fakePos = YE.Pos { posByteOffset :: Int
posByteOffset = -Int
1 , posCharOffset :: Int
posCharOffset = -Int
1  , posLine :: Int
posLine = Int
1 , posColumn :: Int
posColumn = Int
0 }