{-# 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
  { Loader m n -> Tag -> ScalarStyle -> Text -> LoaderT m n
yScalar   :: Tag -> YE.ScalarStyle -> Text -> LoaderT m n
  , Loader m n -> Tag -> [n] -> LoaderT m n
ySequence :: Tag -> [n]                    -> LoaderT m n
  , Loader m n -> Tag -> [(n, n)] -> LoaderT m n
yMapping  :: Tag -> [(n,n)]                -> LoaderT m n
  , Loader m n -> NodeId -> Bool -> n -> LoaderT m n
yAlias    :: NodeId -> Bool -> n           -> LoaderT 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 :: 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 [Either (Pos, String) EvPos] -> Either (Pos, String) [EvPos]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t 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 (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
      EvPos
_ <- (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)
      [n]
ds <- (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.StreamEnd) PT n m n
goDoc
      PT n m ()
forall (m :: * -> *) n. Monad m => PT n m ()
eof
      [n] -> PT n m [n]
forall (m :: * -> *) a. Monad m => a -> m a
return [n]
ds

    goDoc :: PT n m n
    goDoc :: PT n m n
goDoc = do
      EvPos
_ <- (Event -> Bool) -> PT n m EvPos
forall (m :: * -> *) n. Monad m => (Event -> Bool) -> PT n m EvPos
satisfy Event -> Bool
isDocStart
      (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 { sDict :: Map Text (NodeId, n)
sDict = Map Text (NodeId, n)
forall a. Monoid a => a
mempty, sCycle :: Set Text
sCycle = Set Text
forall a. Monoid a => a
mempty }
      n
n <- PT n m n
goNode
      EvPos
_ <- (Event -> Bool) -> PT n m EvPos
forall (m :: * -> *) n. Monad m => (Event -> Bool) -> PT n m EvPos
satisfy Event -> Bool
isDocEnd
      n -> PT n m n
forall (m :: * -> *) a. Monad m => a -> m a
return n
n

    getNewNid :: PT n m Word
    getNewNid :: PT n m NodeId
getNewNid = (S n -> (NodeId, S n)) -> PT n m NodeId
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 :: NodeId
sIdCnt = NodeId
i0NodeId -> NodeId -> NodeId
forall 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) = (Pos, String) -> PT n m n
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 (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' <- 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 (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)
      (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 { sDict :: Map Text (NodeId, n)
sDict = Text -> (NodeId, n) -> Map Text (NodeId, n) -> Map Text (NodeId, n)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
a (NodeId
nid,n
node') (S n -> Map Text (NodeId, n)
forall n. S n -> Map Text (NodeId, n)
sDict S n
s0) }
      n -> PT n m n
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
      (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 Text
sCycle = Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
a (S n -> Set Text
forall n. S n -> Set Text
sCycle S n
s0) }
      NodeId
nid <- PT n m NodeId
getNewNid

      mdo
        (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 { sDict :: Map Text (NodeId, n)
sDict = Text -> (NodeId, n) -> Map Text (NodeId, n) -> Map Text (NodeId, n)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
a (NodeId
nid,n
n) (S n -> Map Text (NodeId, n)
forall n. S n -> Map Text (NodeId, n)
sDict S n
s0) }
        n
n0 <- PT n m n
pn
        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 (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)
        n -> PT n m n
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  = () -> PT n m ()
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 Text
sCycle = Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.delete Text
a (S n -> Set Text
forall n. S n -> Set Text
sCycle S n
s0) }

    goNode :: PT n m n
    goNode :: PT n m n
goNode = do
      EvPos
n <- PT n m EvPos
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' <- m (Either (Pos, String) n) -> PT n m (Either (Pos, String) 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 (Either (Pos, String) n -> PT n m n)
-> Either (Pos, String) n -> PT n m n
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 (PT n m n -> PT n m n) -> PT n m n -> PT n m n
forall a b. (a -> b) -> a -> b
$ do
          [n]
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
          Maybe Text -> PT n m ()
exitAnchor Maybe Text
manc
          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 (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 (PT n m n -> PT n m n) -> PT n m n -> PT n m n
forall a b. (a -> b) -> a -> b
$ do
          [(n, n)]
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)
          Maybe Text -> PT n m ()
exitAnchor Maybe Text
manc
          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 (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 <- (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
          Set Text
cy <- (S n -> Set Text) -> PT n m (Set Text)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets S n -> Set Text
forall n. S n -> Set Text
sCycle
          case Text -> Map Text (NodeId, n) -> Maybe (NodeId, n)
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       -> (Pos, String) -> PT n m n
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 (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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos
pos, String
"goNode: unexpected event")

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


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

newtype PT n m a = PT (StateT (S n) (ExceptT (YE.Pos, String) m) a)
                 deriving ( a -> PT n m b -> PT n m a
(a -> b) -> PT n m a -> PT n m b
(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
<$ :: 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 :: (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
                          , Functor (PT n m)
a -> PT n m a
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)
PT n m a -> PT n m b -> PT n m b
PT n m a -> PT n m b -> PT n m a
PT n m (a -> b) -> PT n m a -> PT n m b
(a -> b -> c) -> PT n m a -> PT n m b -> PT n m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> PT n m a
$cpure :: forall n (m :: * -> *) a. Monad m => a -> PT n m a
$cp1Applicative :: forall n (m :: * -> *). Monad m => Functor (PT n m)
Applicative
                          , Applicative (PT n m)
a -> PT n m a
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)
PT n m a -> (a -> PT n m b) -> PT n m b
PT n m a -> PT n m b -> PT n m b
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 :: a -> PT n m a
$creturn :: forall n (m :: * -> *) a. Monad m => a -> PT n m a
>> :: 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
>>= :: 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
$cp1Monad :: forall n (m :: * -> *). Monad m => Applicative (PT n m)
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)
(a -> PT n m a) -> PT n m a
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 :: (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
$cp1MonadFix :: forall n (m :: * -> *). MonadFix m => Monad (PT n m)
MonadFix
                          )

instance MonadTrans (PT n) where
  lift :: 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 (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 (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 :: 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 :: (Event -> Bool) -> PT n m EvPos
satisfy Event -> Bool
p = do
  S n
s0 <- PT n m (S n)
forall s (m :: * -> *). MonadState s m => m s
get
  case S n -> [EvPos]
forall n. S n -> [EvPos]
sEvs S n
s0 of
    [] -> (Pos, String) -> PT n m EvPos
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 :: [EvPos]
sEvs = [EvPos]
rest})
                                EvPos -> PT n m EvPos
forall (m :: * -> *) a. Monad m => a -> m a
return EvPos
ev
       | Bool
otherwise        -> (Pos, String) -> PT n m EvPos
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 :: PT n m (Maybe EvPos)
peek = do
  S n
s0 <- PT n m (S n)
forall s (m :: * -> *). MonadState s m => m s
get
  case S n -> [EvPos]
forall n. S n -> [EvPos]
sEvs S n
s0 of
    []     -> Maybe EvPos -> PT n m (Maybe EvPos)
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 (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 :: 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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos
fakePos,String
"peek1: premature eof")) EvPos -> PT n m EvPos
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 :: 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 :: PT n m ()
eof = do
  S n
s0 <- PT n m (S n)
forall s (m :: * -> *). MonadState s m => m s
get
  case S n -> [EvPos]
forall n. S n -> [EvPos]
sEvs S n
s0 of
    []     -> () -> PT n m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (EvPos
ev:[EvPos]
_) -> (Pos, String) -> PT n m ()
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 :: (Event -> Bool) -> PT n m a -> PT n m [a]
manyUnless Event -> Bool
p PT n m a
act = do
  EvPos
t0 <- PT n m EvPos
forall (m :: * -> *) n. Monad m => PT n m EvPos
peek1
  if Event -> Bool
p (EvPos -> Event
YE.eEvent EvPos
t0)
    then PT n m EvPos
forall (m :: * -> *) n. Monad m => PT n m EvPos
anyEv PT n m EvPos -> PT n m [a] -> PT n m [a]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> PT n m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else (a -> [a] -> [a]) -> PT n m a -> PT n m [a] -> PT n m [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) PT n m a
act ((Event -> Bool) -> PT n m a -> PT n m [a]
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 = Pos :: Int -> Int -> Int -> Int -> Pos
YE.Pos { posByteOffset :: Int
posByteOffset = -Int
1 , posCharOffset :: Int
posCharOffset = -Int
1  , posLine :: Int
posLine = Int
1 , posColumn :: Int
posColumn = Int
0 }