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