{-# 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
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{..} bs0 :: 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
pos,err :: 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 evs :: [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 evPos :: Either a EvPos
evPos = case Either a EvPos
evPos of
      Right (YE.EvPos {eEvent :: EvPos -> Event
eEvent = (YE.Comment _), ePos :: EvPos -> Pos
ePos = Pos
_}) -> Bool
True
      _                                                    -> 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
$ \s0 :: 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
$ \s0 :: 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
+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 _ _ (Left err :: (Pos, String)
err) = (Pos, String) -> PT n m n
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos, String)
err
    returnNode _ Nothing (Right node :: n
node) = n -> PT n m n
forall (m :: * -> *) a. Monad m => a -> m a
return n
node
    returnNode pos :: Pos
pos (Just a :: Text
a) (Right node :: 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
$ \s0 :: 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 _ Nothing  pn :: PT n m n
pn = PT n m n
pn
    registerAnchor pos :: Pos
pos (Just a :: Text
a) pn :: 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
$ \s0 :: 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
$ \s0 :: 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 Nothing  = () -> PT n m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    exitAnchor (Just a :: 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
$ \s0 :: 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 manc :: Maybe Text
manc tag :: Tag
tag sty :: ScalarStyle
sty val :: 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 manc :: Maybe Text
manc tag :: Tag
tag _ -> 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 manc :: Maybe Text
manc tag :: Tag
tag _ -> 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 a :: 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
            Nothing       -> (Pos, String) -> PT n m n
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos
pos, ("anchor not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
a))
            Just (nid :: NodeId
nid,n' :: 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)

        _ -> (Pos, String) -> PT n m n
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pos
pos, "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 act :: StateT (S n) (ExceptT (Pos, String) m) a
act) s0 :: [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 0)

satisfy :: Monad m => (YE.Event -> Bool) -> PT n m YE.EvPos
satisfy :: (Event -> Bool) -> PT n m EvPos
satisfy p :: 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, "satisfy: premature eof")
    (ev :: EvPos
ev:rest :: [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, ("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
    (ev :: EvPos
ev:_) -> 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,"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 ()
    (ev :: EvPos
ev:_) -> (Pos, String) -> PT n m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EvPos -> Pos
YE.ePos EvPos
ev, "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 p :: Event -> Bool
p act :: 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 _) = Bool
True
isDocStart _                    = Bool
False

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

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