{-# 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
yAnchor :: NodeId -> n -> LoaderT m n
yAlias :: NodeId -> Bool -> n -> LoaderT m n
yMapping :: Tag -> [(n, n)] -> LoaderT m n
ySequence :: Tag -> [n] -> LoaderT m n
yScalar :: Tag -> ScalarStyle -> Text -> LoaderT m n
yAnchor :: forall (m :: * -> *) n. Loader m n -> NodeId -> n -> LoaderT m n
yAlias :: forall (m :: * -> *) n.
Loader m n -> NodeId -> Bool -> n -> LoaderT m n
yMapping :: forall (m :: * -> *) n.
Loader m n -> Tag -> [(n, n)] -> LoaderT m n
ySequence :: forall (m :: * -> *) n. Loader m n -> Tag -> [n] -> LoaderT m n
yScalar :: forall (m :: * -> *) n.
Loader m n -> Tag -> ScalarStyle -> Text -> LoaderT m n
..} ByteString
bs0 = do
    case forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Either a EvPos -> Bool
isComment) (ByteString -> EvStream
YE.parseEvents ByteString
bs0) of
      Left (Pos
pos,String
err) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (Pos
pos,String
err)
      Right [EvPos]
evs      -> 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
      EvPos
_ <- forall (m :: * -> *) n. Monad m => (Event -> Bool) -> PT n m EvPos
satisfy (forall a. Eq a => a -> a -> Bool
== Event
YE.StreamStart)
      [n]
ds <- forall (m :: * -> *) n a.
Monad m =>
(Event -> Bool) -> PT n m a -> PT n m [a]
manyUnless (forall a. Eq a => a -> a -> Bool
== Event
YE.StreamEnd) PT n m n
goDoc
      forall (m :: * -> *) n. Monad m => PT n m ()
eof
      forall (m :: * -> *) a. Monad m => a -> m a
return [n]
ds

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

    getNewNid :: PT n m Word
    getNewNid :: PT n m NodeId
getNewNid = forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state forall a b. (a -> b) -> a -> b
$ \S n
s0 -> let i0 :: NodeId
i0 = forall n. S n -> NodeId
sIdCnt S n
s0
                               in (NodeId
i0, S n
s0 { sIdCnt :: NodeId
sIdCnt = NodeId
i0forall a. Num a => a -> a -> a
+NodeId
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) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos, String)
err
    returnNode Pos
_ Maybe Text
Nothing (Right n
node) = forall (m :: * -> *) a. Monad m => a -> m a
return n
node
    returnNode Pos
pos (Just Text
a) (Right n
node) = do
      NodeId
nid <- PT n m NodeId
getNewNid
      n
node' <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (NodeId -> n -> LoaderT m n
yAnchor NodeId
nid n
node Pos
pos)
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \S n
s0 -> S n
s0 { sDict :: Map Text (NodeId, n)
sDict = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
a (NodeId
nid,n
node') (forall n. S n -> Map Text (NodeId, n)
sDict S n
s0) }
      forall (m :: * -> *) a. Monad m => a -> m a
return n
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
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \S n
s0 -> S n
s0 { sCycle :: Set Text
sCycle = forall a. Ord a => a -> Set a -> Set a
Set.insert Text
a (forall n. S n -> Set Text
sCycle S n
s0) }
      NodeId
nid <- PT n m NodeId
getNewNid

      mdo
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \S n
s0 -> S n
s0 { sDict :: Map Text (NodeId, n)
sDict = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
a (NodeId
nid,n
n) (forall n. S n -> Map Text (NodeId, n)
sDict S n
s0) }
        n
n0 <- PT n m n
pn
        n
n  <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (NodeId -> n -> LoaderT m n
yAnchor NodeId
nid n
n0 Pos
pos)
        forall (m :: * -> *) a. Monad m => a -> m a
return n
n

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

    goNode :: PT n m n
    goNode :: PT n m n
goNode = do
      EvPos
n <- forall (m :: * -> *) n. Monad m => PT n m EvPos
anyEv
      let pos :: Pos
pos = EvPos -> Pos
YE.ePos EvPos
n
      case EvPos -> Event
YE.eEvent EvPos
n of
        YE.Scalar Maybe Text
manc Tag
tag ScalarStyle
sty Text
val -> do
          Maybe Text -> PT n m ()
exitAnchor Maybe Text
manc
          Either (Pos, String) n
n' <- 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)
          Pos -> Maybe Text -> Either (Pos, String) n -> PT n m n
returnNode Pos
pos Maybe Text
manc forall a b. (a -> b) -> a -> b
$! Either (Pos, String) n
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 forall a b. (a -> b) -> a -> b
$ do
          [n]
ns <- forall (m :: * -> *) n a.
Monad m =>
(Event -> Bool) -> PT n m a -> PT n m [a]
manyUnless (forall a. Eq a => a -> a -> Bool
== Event
YE.SequenceEnd) PT n m n
goNode
          Maybe Text -> PT n m ()
exitAnchor Maybe Text
manc
          forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Tag -> [n] -> LoaderT m n
ySequence Tag
tag [n]
ns Pos
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 forall a b. (a -> b) -> a -> b
$ do
          [(n, n)]
kvs <- forall (m :: * -> *) n a.
Monad m =>
(Event -> Bool) -> PT n m a -> PT n m [a]
manyUnless (forall a. Eq a => a -> a -> Bool
== Event
YE.MappingEnd) (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)
          Maybe Text -> PT n m ()
exitAnchor Maybe Text
manc
          forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Tag -> [(n, n)] -> LoaderT m n
yMapping Tag
tag [(n, n)]
kvs Pos
pos)

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

        Event
_ -> 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 -> 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
<$ :: forall a b. a -> PT n m b -> PT n m a
$c<$ :: forall n (m :: * -> *) a b. Functor m => a -> PT n m b -> PT n m a
fmap :: forall a b. (a -> b) -> PT n m a -> PT n m b
$cfmap :: forall n (m :: * -> *) a b.
Functor m =>
(a -> b) -> PT n m a -> PT n m b
Functor
                          , 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
<* :: forall a b. PT n m a -> PT n m b -> PT n m a
$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 b
$c*> :: forall n (m :: * -> *) a b.
Monad m =>
PT n m a -> PT n m b -> PT n m b
liftA2 :: forall a b c. (a -> b -> c) -> PT n m a -> PT n m b -> PT n m c
$cliftA2 :: forall n (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> PT n m a -> PT n m b -> PT n m c
<*> :: forall a b. PT n m (a -> b) -> PT n m a -> PT n m b
$c<*> :: forall n (m :: * -> *) a b.
Monad m =>
PT n m (a -> b) -> PT n m a -> PT n m b
pure :: forall a. a -> PT n m a
$cpure :: forall n (m :: * -> *) a. Monad m => a -> PT n m a
Applicative
                          , 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
return :: forall a. a -> PT n m a
$creturn :: forall n (m :: * -> *) a. Monad m => a -> PT n m a
>> :: 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 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 -> (a -> PT n m b) -> PT n m b
Monad
                          , MonadState (S n)
                          , MonadError (YE.Pos, String)
                          , 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
mfix :: forall a. (a -> PT n m a) -> PT n m a
$cmfix :: forall n (m :: * -> *) a. MonadFix m => (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 = forall n (m :: * -> *) a.
StateT (S n) (ExceptT (Pos, String) m) a -> PT n m a
PT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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 = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (S n) (ExceptT (Pos, String) m) a
act (forall n.
[EvPos] -> Map Text (NodeId, n) -> Set Text -> NodeId -> S n
S [EvPos]
s0 forall a. Monoid a => a
mempty 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
  S n
s0 <- forall s (m :: * -> *). MonadState s m => m s
get
  case forall n. S n -> [EvPos]
sEvs S n
s0 of
    [] -> 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 forall s (m :: * -> *). MonadState s m => s -> m ()
put (S n
s0 { sEvs :: [EvPos]
sEvs = [EvPos]
rest})
                                forall (m :: * -> *) a. Monad m => a -> m a
return EvPos
ev
       | Bool
otherwise        -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EvPos -> Pos
YE.ePos EvPos
ev, (String
"satisfy: predicate failed " forall a. [a] -> [a] -> [a]
++ 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
  S n
s0 <- forall s (m :: * -> *). MonadState s m => m s
get
  case forall n. S n -> [EvPos]
sEvs S n
s0 of
    []     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    (EvPos
ev:[EvPos]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos
fakePos,String
"peek1: premature eof")) forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = forall (m :: * -> *) n. Monad m => (Event -> Bool) -> PT n m EvPos
satisfy (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
  S n
s0 <- forall s (m :: * -> *). MonadState s m => m s
get
  case forall n. S n -> [EvPos]
sEvs S n
s0 of
    []     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (EvPos
ev:[EvPos]
_) -> 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
  EvPos
t0 <- forall (m :: * -> *) n. Monad m => PT n m EvPos
peek1
  if Event -> Bool
p (EvPos -> Event
YE.eEvent EvPos
t0)
    then forall (m :: * -> *) n. Monad m => PT n m EvPos
anyEv forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
    else forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) PT n m a
act (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)

{-
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 }