{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}

module Language.Ginger.Interpret.Type
where

import Language.Ginger.AST
import Language.Ginger.RuntimeError
import Language.Ginger.SourcePosition
import Language.Ginger.Value

import Control.Applicative ((<|>))
import Control.Monad (forM)
import Control.Monad.Except
  ( ExceptT (..)
  , MonadError (..)
  , runExceptT
  , throwError
  )
import Control.Monad.Reader
  ( ReaderT
  , MonadReader
  , runReaderT
  , asks
  )
import Control.Monad.State
  ( StateT (..)
  , MonadState (..)
  , MonadTrans (..)
  , evalStateT
  , get
  , gets
  , modify
  )
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import System.Random (SplitGen (..))

-- | The Ginger interpreter monad. Provides error reporting / handling via
-- 'MonadError', an execution context ('Context'), and an evaluation state
-- ('EvalState').
newtype GingerT m a =
  GingerT { forall (m :: * -> *) a.
GingerT m a
-> ReaderT
     (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a
unGingerT :: ReaderT (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a }
  deriving ((forall a b. (a -> b) -> GingerT m a -> GingerT m b)
-> (forall a b. a -> GingerT m b -> GingerT m a)
-> Functor (GingerT m)
forall a b. a -> GingerT m b -> GingerT m a
forall a b. (a -> b) -> GingerT m a -> GingerT m b
forall (m :: * -> *) a b.
Functor m =>
a -> GingerT m b -> GingerT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GingerT m a -> GingerT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GingerT m a -> GingerT m b
fmap :: forall a b. (a -> b) -> GingerT m a -> GingerT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> GingerT m b -> GingerT m a
<$ :: forall a b. a -> GingerT m b -> GingerT m a
Functor, Functor (GingerT m)
Functor (GingerT m) =>
(forall a. a -> GingerT m a)
-> (forall a b. GingerT m (a -> b) -> GingerT m a -> GingerT m b)
-> (forall a b c.
    (a -> b -> c) -> GingerT m a -> GingerT m b -> GingerT m c)
-> (forall a b. GingerT m a -> GingerT m b -> GingerT m b)
-> (forall a b. GingerT m a -> GingerT m b -> GingerT m a)
-> Applicative (GingerT m)
forall a. a -> GingerT m a
forall a b. GingerT m a -> GingerT m b -> GingerT m a
forall a b. GingerT m a -> GingerT m b -> GingerT m b
forall a b. GingerT m (a -> b) -> GingerT m a -> GingerT m b
forall a b c.
(a -> b -> c) -> GingerT m a -> GingerT m b -> GingerT m c
forall (m :: * -> *). Monad m => Functor (GingerT m)
forall (m :: * -> *) a. Monad m => a -> GingerT m a
forall (m :: * -> *) a b.
Monad m =>
GingerT m a -> GingerT m b -> GingerT m a
forall (m :: * -> *) a b.
Monad m =>
GingerT m a -> GingerT m b -> GingerT m b
forall (m :: * -> *) a b.
Monad m =>
GingerT m (a -> b) -> GingerT m a -> GingerT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> GingerT m a -> GingerT m b -> GingerT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> GingerT m a
pure :: forall a. a -> GingerT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
GingerT m (a -> b) -> GingerT m a -> GingerT m b
<*> :: forall a b. GingerT m (a -> b) -> GingerT m a -> GingerT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> GingerT m a -> GingerT m b -> GingerT m c
liftA2 :: forall a b c.
(a -> b -> c) -> GingerT m a -> GingerT m b -> GingerT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
GingerT m a -> GingerT m b -> GingerT m b
*> :: forall a b. GingerT m a -> GingerT m b -> GingerT m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
GingerT m a -> GingerT m b -> GingerT m a
<* :: forall a b. GingerT m a -> GingerT m b -> GingerT m a
Applicative, Applicative (GingerT m)
Applicative (GingerT m) =>
(forall a b. GingerT m a -> (a -> GingerT m b) -> GingerT m b)
-> (forall a b. GingerT m a -> GingerT m b -> GingerT m b)
-> (forall a. a -> GingerT m a)
-> Monad (GingerT m)
forall a. a -> GingerT m a
forall a b. GingerT m a -> GingerT m b -> GingerT m b
forall a b. GingerT m a -> (a -> GingerT m b) -> GingerT m b
forall (m :: * -> *). Monad m => Applicative (GingerT m)
forall (m :: * -> *) a. Monad m => a -> GingerT m a
forall (m :: * -> *) a b.
Monad m =>
GingerT m a -> GingerT m b -> GingerT m b
forall (m :: * -> *) a b.
Monad m =>
GingerT m a -> (a -> GingerT m b) -> GingerT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
GingerT m a -> (a -> GingerT m b) -> GingerT m b
>>= :: forall a b. GingerT m a -> (a -> GingerT m b) -> GingerT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
GingerT m a -> GingerT m b -> GingerT m b
>> :: forall a b. GingerT m a -> GingerT m b -> GingerT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> GingerT m a
return :: forall a. a -> GingerT m a
Monad)

-- | Evaluation state. This keeps track of variables in scope, as well as
-- loaded templates and blocks, and the current source position.
data EvalState m =
  EvalState
    { forall (m :: * -> *). EvalState m -> Env m
evalEnv :: !(Env m)
    , forall (m :: * -> *). EvalState m -> Map RefID (Value m)
evalMutables :: !(Map RefID (Value m))
    , forall (m :: * -> *). EvalState m -> RefID
evalNextRefID :: !RefID
    , forall (m :: * -> *). EvalState m -> Map Text CachedTemplate
evalLoadedTemplates :: !(Map Text CachedTemplate)
    , forall (m :: * -> *). EvalState m -> Map Identifier LoadedBlock
evalBlocks :: !(Map Identifier LoadedBlock)
    , forall (m :: * -> *). EvalState m -> Maybe SourcePosition
evalSourcePosition :: !(Maybe SourcePosition)
    , forall (m :: * -> *). EvalState m -> SomePRNG
evalPRNG :: !SomePRNG
    }

data LoadedBlock =
  LoadedBlock
    { LoadedBlock -> Block
loadedBlock :: !Block
    , LoadedBlock -> Maybe LoadedBlock
loadedBlockParent :: !(Maybe LoadedBlock)
    }
    deriving (Int -> LoadedBlock -> ShowS
[LoadedBlock] -> ShowS
LoadedBlock -> String
(Int -> LoadedBlock -> ShowS)
-> (LoadedBlock -> String)
-> ([LoadedBlock] -> ShowS)
-> Show LoadedBlock
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoadedBlock -> ShowS
showsPrec :: Int -> LoadedBlock -> ShowS
$cshow :: LoadedBlock -> String
show :: LoadedBlock -> String
$cshowList :: [LoadedBlock] -> ShowS
showList :: [LoadedBlock] -> ShowS
Show)

instance Semigroup (EvalState m) where
  EvalState m
a <> :: EvalState m -> EvalState m -> EvalState m
<> EvalState m
b =
    EvalState
      { evalEnv :: Env m
evalEnv = EvalState m -> Env m
forall (m :: * -> *). EvalState m -> Env m
evalEnv EvalState m
a Env m -> Env m -> Env m
forall a. Semigroup a => a -> a -> a
<> EvalState m -> Env m
forall (m :: * -> *). EvalState m -> Env m
evalEnv EvalState m
b
      , evalMutables :: Map RefID (Value m)
evalMutables = EvalState m -> Map RefID (Value m)
forall (m :: * -> *). EvalState m -> Map RefID (Value m)
evalMutables EvalState m
a Map RefID (Value m) -> Map RefID (Value m) -> Map RefID (Value m)
forall a. Semigroup a => a -> a -> a
<> EvalState m -> Map RefID (Value m)
forall (m :: * -> *). EvalState m -> Map RefID (Value m)
evalMutables EvalState m
b
      , evalNextRefID :: RefID
evalNextRefID = RefID -> RefID -> RefID
forall a. Ord a => a -> a -> a
max (EvalState m -> RefID
forall (m :: * -> *). EvalState m -> RefID
evalNextRefID EvalState m
a) (EvalState m -> RefID
forall (m :: * -> *). EvalState m -> RefID
evalNextRefID EvalState m
b)
      , evalLoadedTemplates :: Map Text CachedTemplate
evalLoadedTemplates = EvalState m -> Map Text CachedTemplate
forall (m :: * -> *). EvalState m -> Map Text CachedTemplate
evalLoadedTemplates EvalState m
a Map Text CachedTemplate
-> Map Text CachedTemplate -> Map Text CachedTemplate
forall a. Semigroup a => a -> a -> a
<> EvalState m -> Map Text CachedTemplate
forall (m :: * -> *). EvalState m -> Map Text CachedTemplate
evalLoadedTemplates EvalState m
b
      , evalBlocks :: Map Identifier LoadedBlock
evalBlocks = EvalState m -> Map Identifier LoadedBlock
forall (m :: * -> *). EvalState m -> Map Identifier LoadedBlock
evalBlocks EvalState m
a Map Identifier LoadedBlock
-> Map Identifier LoadedBlock -> Map Identifier LoadedBlock
forall a. Semigroup a => a -> a -> a
<> EvalState m -> Map Identifier LoadedBlock
forall (m :: * -> *). EvalState m -> Map Identifier LoadedBlock
evalBlocks EvalState m
b
      , evalSourcePosition :: Maybe SourcePosition
evalSourcePosition = EvalState m -> Maybe SourcePosition
forall (m :: * -> *). EvalState m -> Maybe SourcePosition
evalSourcePosition EvalState m
a Maybe SourcePosition
-> Maybe SourcePosition -> Maybe SourcePosition
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> EvalState m -> Maybe SourcePosition
forall (m :: * -> *). EvalState m -> Maybe SourcePosition
evalSourcePosition EvalState m
b
      , evalPRNG :: SomePRNG
evalPRNG = EvalState m -> SomePRNG
forall (m :: * -> *). EvalState m -> SomePRNG
evalPRNG EvalState m
a
      }

data CachedTemplate
  = CachedTemplate !LoadedTemplate
  | MissingTemplate

data LoadedTemplate =
  LoadedTemplate
    { LoadedTemplate -> Maybe LoadedTemplate
loadedTemplateParent :: !(Maybe LoadedTemplate)
    , LoadedTemplate -> Statement
loadedTemplateBody :: !Statement
    }

runGingerT :: (Monad m, SplitGen g)
           => GingerT m a
           -> Context m
           -> Env m
           -> g
           -> m (Either RuntimeError a)
runGingerT :: forall (m :: * -> *) g a.
(Monad m, SplitGen g) =>
GingerT m a -> Context m -> Env m -> g -> m (Either RuntimeError a)
runGingerT GingerT m a
g Context m
ctx Env m
env g
rng =
  ExceptT RuntimeError m a -> m (Either RuntimeError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
    (StateT (EvalState m) (ExceptT RuntimeError m) a
-> EvalState m -> ExceptT RuntimeError m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT
      (ReaderT
  (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a
-> Context m -> StateT (EvalState m) (ExceptT RuntimeError m) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (GingerT m a
-> ReaderT
     (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a
forall (m :: * -> *) a.
GingerT m a
-> ReaderT
     (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a
unGingerT GingerT m a
g) Context m
ctx)
      (EvalState
        { evalEnv :: Env m
evalEnv = Env m
env { envRootMay = Just env }
        , evalMutables :: Map RefID (Value m)
evalMutables = Map RefID (Value m)
forall a. Monoid a => a
mempty
        , evalNextRefID :: RefID
evalNextRefID = Int -> RefID
RefID Int
0
        , evalLoadedTemplates :: Map Text CachedTemplate
evalLoadedTemplates = Map Text CachedTemplate
forall a. Monoid a => a
mempty
        , evalBlocks :: Map Identifier LoadedBlock
evalBlocks = Map Identifier LoadedBlock
forall a. Monoid a => a
mempty
        , evalSourcePosition :: Maybe SourcePosition
evalSourcePosition = Maybe SourcePosition
forall a. Maybe a
Nothing
        , evalPRNG :: SomePRNG
evalPRNG = g -> SomePRNG
forall g. SplitGen g => g -> SomePRNG
SomePRNG g
rng
        }
      )
    )

decorateError :: Monad m
              => SourcePosition
              -> RuntimeError
              -> GingerT m a
decorateError :: forall (m :: * -> *) a.
Monad m =>
SourcePosition -> RuntimeError -> GingerT m a
decorateError SourcePosition
pos RuntimeError
err =
  RuntimeError -> GingerT m a
forall a. RuntimeError -> GingerT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SourcePosition -> RuntimeError -> RuntimeError
PositionedError SourcePosition
pos RuntimeError
err)

deriving instance Monad m => MonadState (EvalState m) (GingerT m)
deriving instance Monad m => MonadReader (Context m) (GingerT m)
deriving instance Monad m => MonadError RuntimeError (GingerT m)

instance MonadTrans GingerT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> GingerT m a
lift = ReaderT
  (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a
-> GingerT m a
forall (m :: * -> *) a.
ReaderT
  (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a
-> GingerT m a
GingerT (ReaderT
   (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a
 -> GingerT m a)
-> (m a
    -> ReaderT
         (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a)
-> m a
-> GingerT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (EvalState m) (ExceptT RuntimeError m) a
-> ReaderT
     (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT (Context m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (EvalState m) (ExceptT RuntimeError m) a
 -> ReaderT
      (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a)
-> (m a -> StateT (EvalState m) (ExceptT RuntimeError m) a)
-> m a
-> ReaderT
     (Context m) (StateT (EvalState m) (ExceptT RuntimeError m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT RuntimeError m a
-> StateT (EvalState m) (ExceptT RuntimeError m) a
forall (m :: * -> *) a. Monad m => m a -> StateT (EvalState m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RuntimeError m a
 -> StateT (EvalState m) (ExceptT RuntimeError m) a)
-> (m a -> ExceptT RuntimeError m a)
-> m a
-> StateT (EvalState m) (ExceptT RuntimeError m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ExceptT RuntimeError m a
forall (m :: * -> *) a. Monad m => m a -> ExceptT RuntimeError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

lookupVar :: Monad m
          => Identifier
          -> GingerT m (Value m)
lookupVar :: forall (m :: * -> *). Monad m => Identifier -> GingerT m (Value m)
lookupVar Identifier
name =
  Identifier -> GingerT m (Maybe (Value m))
forall (m :: * -> *).
Monad m =>
Identifier -> GingerT m (Maybe (Value m))
lookupVarMaybe Identifier
name GingerT m (Maybe (Value m))
-> (Maybe (Value m) -> GingerT m (Value m)) -> GingerT m (Value m)
forall a b. GingerT m a -> (a -> GingerT m b) -> GingerT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GingerT m (Value m)
-> (Value m -> GingerT m (Value m))
-> Maybe (Value m)
-> GingerT m (Value m)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RuntimeError -> GingerT m (Value m)
forall a. RuntimeError -> GingerT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuntimeError -> GingerT m (Value m))
-> RuntimeError -> GingerT m (Value m)
forall a b. (a -> b) -> a -> b
$ Text -> RuntimeError
NotInScopeError (Identifier -> Text
identifierName Identifier
name)) Value m -> GingerT m (Value m)
forall a. a -> GingerT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

lookupVarMaybe :: Monad m
               => Identifier
               -> GingerT m (Maybe (Value m))
lookupVarMaybe :: forall (m :: * -> *).
Monad m =>
Identifier -> GingerT m (Maybe (Value m))
lookupVarMaybe Identifier
name = do
  Maybe (Value m)
valEnv <- (EvalState m -> Maybe (Value m)) -> GingerT m (Maybe (Value m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Identifier -> Map Identifier (Value m) -> Maybe (Value m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Identifier
name (Map Identifier (Value m) -> Maybe (Value m))
-> (EvalState m -> Map Identifier (Value m))
-> EvalState m
-> Maybe (Value m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env m -> Map Identifier (Value m)
forall (m :: * -> *). Env m -> Map Identifier (Value m)
envVars (Env m -> Map Identifier (Value m))
-> (EvalState m -> Env m)
-> EvalState m
-> Map Identifier (Value m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalState m -> Env m
forall (m :: * -> *). EvalState m -> Env m
evalEnv)
  case Maybe (Value m)
valEnv of
    Maybe (Value m)
Nothing ->
      (Context m -> Maybe (Value m)) -> GingerT m (Maybe (Value m))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Identifier -> Map Identifier (Value m) -> Maybe (Value m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Identifier
name (Map Identifier (Value m) -> Maybe (Value m))
-> (Context m -> Map Identifier (Value m))
-> Context m
-> Maybe (Value m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context m -> Map Identifier (Value m)
forall (m :: * -> *). Context m -> Map Identifier (Value m)
contextVars)
    Just Value m
val ->
      Maybe (Value m) -> GingerT m (Maybe (Value m))
forall a. a -> GingerT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Value m) -> GingerT m (Maybe (Value m)))
-> Maybe (Value m) -> GingerT m (Maybe (Value m))
forall a b. (a -> b) -> a -> b
$ Value m -> Maybe (Value m)
forall a. a -> Maybe a
Just Value m
val

modifyEnv :: Monad m
          => (Env m -> Env m)
          -> GingerT m ()
modifyEnv :: forall (m :: * -> *). Monad m => (Env m -> Env m) -> GingerT m ()
modifyEnv Env m -> Env m
f =
  (EvalState m -> EvalState m) -> GingerT m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EvalState m
s -> EvalState m
s { evalEnv = f (evalEnv s) })

setVar :: Monad m
       => Identifier
       -> Value m
       -> GingerT m ()
setVar :: forall (m :: * -> *).
Monad m =>
Identifier -> Value m -> GingerT m ()
setVar Identifier
name Value m
val =
  (Env m -> Env m) -> GingerT m ()
forall (m :: * -> *). Monad m => (Env m -> Env m) -> GingerT m ()
modifyEnv (\Env m
e -> Env m
e { envVars = Map.insert name val $ envVars e })

setVars :: Monad m
        => Map Identifier (Value m)
        -> GingerT m ()
setVars :: forall (m :: * -> *).
Monad m =>
Map Identifier (Value m) -> GingerT m ()
setVars Map Identifier (Value m)
vars = (Env m -> Env m) -> GingerT m ()
forall (m :: * -> *). Monad m => (Env m -> Env m) -> GingerT m ()
modifyEnv (\Env m
e -> Env m
e { envVars = vars <> envVars e })

setMutable :: forall m. Monad m
           => Identifier
           -> Identifier
           -> Value m
           -> GingerT m ()
setMutable :: forall (m :: * -> *).
Monad m =>
Identifier -> Identifier -> Value m -> GingerT m ()
setMutable Identifier
name Identifier
attr Value m
val = do
  Value m
varVal <- Identifier -> GingerT m (Value m)
forall (m :: * -> *). Monad m => Identifier -> GingerT m (Value m)
lookupVar Identifier
name
  RefID
refID <- case Value m
varVal of
    MutableRefV RefID
i -> RefID -> GingerT m RefID
forall a. a -> GingerT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RefID
i
    Value m
x -> RuntimeError -> GingerT m RefID
forall a. RuntimeError -> GingerT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuntimeError -> GingerT m RefID)
-> RuntimeError -> GingerT m RefID
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> RuntimeError
TagError (Identifier -> Text
identifierName Identifier
name) Text
"mutable ref" (Value m -> Text
forall (m :: * -> *). Value m -> Text
tagNameOf Value m
x)
  RefID -> (Value m -> GingerT m (Value m)) -> GingerT m ()
forall (m :: * -> *).
Monad m =>
RefID -> (Value m -> GingerT m (Value m)) -> GingerT m ()
modifyMutable RefID
refID Value m -> GingerT m (Value m)
go
  where
    go :: Value m -> GingerT m (Value m)
    go :: Value m -> GingerT m (Value m)
go (DictV Map Scalar (Value m)
m) = Value m -> GingerT m (Value m)
forall a. a -> GingerT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Scalar (Value m) -> Value m
forall (m :: * -> *). Map Scalar (Value m) -> Value m
DictV (Map Scalar (Value m) -> Value m)
-> Map Scalar (Value m) -> Value m
forall a b. (a -> b) -> a -> b
$ Scalar -> Value m -> Map Scalar (Value m) -> Map Scalar (Value m)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Identifier -> Scalar
forall a. ToScalar a => a -> Scalar
toScalar Identifier
attr) Value m
val Map Scalar (Value m)
m)
    go Value m
x = RuntimeError -> GingerT m (Value m)
forall a. RuntimeError -> GingerT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuntimeError -> GingerT m (Value m))
-> RuntimeError -> GingerT m (Value m)
forall a b. (a -> b) -> a -> b
$
                Text -> Text -> Text -> RuntimeError
TagError
                (Identifier -> Text
identifierName Identifier
name)
                Text
"dict"
                (Value m -> Text
forall (m :: * -> *). Value m -> Text
tagNameOf Value m
x)

setBlock :: Monad m
         => Identifier
         -> Block
         -> GingerT m LoadedBlock
setBlock :: forall (m :: * -> *).
Monad m =>
Identifier -> Block -> GingerT m LoadedBlock
setBlock Identifier
name Block
block = do
  Maybe LoadedBlock
mparent <- (EvalState m -> Maybe LoadedBlock) -> GingerT m (Maybe LoadedBlock)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Identifier -> Map Identifier LoadedBlock -> Maybe LoadedBlock
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Identifier
name (Map Identifier LoadedBlock -> Maybe LoadedBlock)
-> (EvalState m -> Map Identifier LoadedBlock)
-> EvalState m
-> Maybe LoadedBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalState m -> Map Identifier LoadedBlock
forall (m :: * -> *). EvalState m -> Map Identifier LoadedBlock
evalBlocks)
  let lblock :: LoadedBlock
lblock = Block -> Maybe LoadedBlock -> LoadedBlock
LoadedBlock Block
block Maybe LoadedBlock
forall a. Maybe a
Nothing
      lblock' :: LoadedBlock
lblock' = LoadedBlock
-> (LoadedBlock -> LoadedBlock) -> Maybe LoadedBlock -> LoadedBlock
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LoadedBlock
lblock (LoadedBlock -> LoadedBlock -> LoadedBlock
appendLoadedBlock LoadedBlock
lblock) Maybe LoadedBlock
mparent
  (EvalState m -> EvalState m) -> GingerT m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EvalState m
s -> EvalState m
s { evalBlocks = Map.insert name lblock' (evalBlocks s) })
  LoadedBlock -> GingerT m LoadedBlock
forall a. a -> GingerT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadedBlock
lblock'

allocMutable :: (Monad m, MonadTrans t, MonadState (EvalState m) (t m))
             => Value m
             -> t m RefID
allocMutable :: forall (m :: * -> *) (t :: (* -> *) -> * -> *).
(Monad m, MonadTrans t, MonadState (EvalState m) (t m)) =>
Value m -> t m RefID
allocMutable Value m
val = do
  RefID
refID <- (EvalState m -> RefID) -> t m RefID
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EvalState m -> RefID
forall (m :: * -> *). EvalState m -> RefID
evalNextRefID
  (EvalState m -> EvalState m) -> t m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EvalState m
s ->
    EvalState m
s { evalNextRefID = succ (evalNextRefID s)
      , evalMutables = Map.insert refID val (evalMutables s)
      })
  RefID -> t m RefID
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RefID
refID

assignMutable :: Monad m
              => RefID
              -> Value m
              -> GingerT m ()
assignMutable :: forall (m :: * -> *). Monad m => RefID -> Value m -> GingerT m ()
assignMutable RefID
refID Value m
val =
  (EvalState m -> EvalState m) -> GingerT m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EvalState m
s -> EvalState m
s { evalMutables = Map.insert refID val (evalMutables s) })

modifyMutable :: Monad m
              => RefID
              -> (Value m -> GingerT m (Value m))
              -> GingerT m ()
modifyMutable :: forall (m :: * -> *).
Monad m =>
RefID -> (Value m -> GingerT m (Value m)) -> GingerT m ()
modifyMutable RefID
refID Value m -> GingerT m (Value m)
f = do
  Value m
mval <- RefID -> GingerT m (Value m)
forall (m :: * -> *). Monad m => RefID -> GingerT m (Value m)
derefMutable RefID
refID
  Value m
mval' <- Value m -> GingerT m (Value m)
f Value m
mval
  (EvalState m -> EvalState m) -> GingerT m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EvalState m
s -> EvalState m
s { evalMutables = Map.insert refID mval' (evalMutables s) })

derefMutableMaybe :: Monad m
                  => RefID
                  -> GingerT m (Maybe (Value m))
derefMutableMaybe :: forall (m :: * -> *).
Monad m =>
RefID -> GingerT m (Maybe (Value m))
derefMutableMaybe RefID
refID =
  (EvalState m -> Maybe (Value m)) -> GingerT m (Maybe (Value m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (RefID -> Map RefID (Value m) -> Maybe (Value m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RefID
refID (Map RefID (Value m) -> Maybe (Value m))
-> (EvalState m -> Map RefID (Value m))
-> EvalState m
-> Maybe (Value m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalState m -> Map RefID (Value m)
forall (m :: * -> *). EvalState m -> Map RefID (Value m)
evalMutables)

derefMutable :: Monad m
             => RefID
             -> GingerT m (Value m)
derefMutable :: forall (m :: * -> *). Monad m => RefID -> GingerT m (Value m)
derefMutable RefID
refID =
  RefID -> GingerT m (Maybe (Value m))
forall (m :: * -> *).
Monad m =>
RefID -> GingerT m (Maybe (Value m))
derefMutableMaybe RefID
refID GingerT m (Maybe (Value m))
-> (Maybe (Value m) -> GingerT m (Value m)) -> GingerT m (Value m)
forall a b. GingerT m a -> (a -> GingerT m b) -> GingerT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    GingerT m (Value m)
-> (Value m -> GingerT m (Value m))
-> Maybe (Value m)
-> GingerT m (Value m)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RuntimeError -> GingerT m (Value m)
forall a. RuntimeError -> GingerT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuntimeError -> GingerT m (Value m))
-> RuntimeError -> GingerT m (Value m)
forall a b. (a -> b) -> a -> b
$ Text -> RuntimeError
NotInScopeError (Text
"ref#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RefID -> Text
forall a. Show a => a -> Text
Text.show RefID
refID)) Value m -> GingerT m (Value m)
forall a. a -> GingerT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

setSourcePosition :: Monad m
                  => SourcePosition
                  -> GingerT m ()
setSourcePosition :: forall (m :: * -> *). Monad m => SourcePosition -> GingerT m ()
setSourcePosition SourcePosition
pos = do
  (EvalState m -> EvalState m) -> GingerT m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EvalState m
s -> EvalState m
s { evalSourcePosition = Just pos })

clearSourcePosition :: Monad m
                    => GingerT m ()
clearSourcePosition :: forall (m :: * -> *). Monad m => GingerT m ()
clearSourcePosition =
  (EvalState m -> EvalState m) -> GingerT m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EvalState m
s -> EvalState m
s { evalSourcePosition = Nothing })


appendLoadedBlock :: LoadedBlock -> LoadedBlock -> LoadedBlock
appendLoadedBlock :: LoadedBlock -> LoadedBlock -> LoadedBlock
appendLoadedBlock LoadedBlock
t LoadedBlock
h =
  case LoadedBlock -> Maybe LoadedBlock
loadedBlockParent LoadedBlock
h of
    Maybe LoadedBlock
Nothing -> LoadedBlock
h { loadedBlockParent = Just t }
    Just LoadedBlock
p -> LoadedBlock
h { loadedBlockParent = Just (appendLoadedBlock t p) }

getBlock :: Monad m
         => Identifier
         -> GingerT m (Maybe LoadedBlock)
getBlock :: forall (m :: * -> *).
Monad m =>
Identifier -> GingerT m (Maybe LoadedBlock)
getBlock Identifier
name = (EvalState m -> Maybe LoadedBlock) -> GingerT m (Maybe LoadedBlock)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Identifier -> Map Identifier LoadedBlock -> Maybe LoadedBlock
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Identifier
name (Map Identifier LoadedBlock -> Maybe LoadedBlock)
-> (EvalState m -> Map Identifier LoadedBlock)
-> EvalState m
-> Maybe LoadedBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalState m -> Map Identifier LoadedBlock
forall (m :: * -> *). EvalState m -> Map Identifier LoadedBlock
evalBlocks)

scoped :: Monad m
       => GingerT m a
       -> GingerT m a
scoped :: forall (m :: * -> *) a. Monad m => GingerT m a -> GingerT m a
scoped GingerT m a
action = do
  EvalState m
s <- GingerT m (EvalState m)
forall s (m :: * -> *). MonadState s m => m s
get
  a
retval <- GingerT m a
action
  (Env m -> Env m) -> GingerT m ()
forall (m :: * -> *). Monad m => (Env m -> Env m) -> GingerT m ()
modifyEnv ((Env m -> Env m) -> GingerT m ())
-> (Env m -> Env m) -> GingerT m ()
forall a b. (a -> b) -> a -> b
$ Env m -> Env m -> Env m
forall a b. a -> b -> a
const (EvalState m -> Env m
forall (m :: * -> *). EvalState m -> Env m
evalEnv EvalState m
s)
  a -> GingerT m a
forall a. a -> GingerT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
retval

-- | Run a 'GingerT' action in a fresh environment; however, any globals set
-- by the invoked action will be ported back to the calling environment.
withoutContext :: Monad m
               => GingerT m a
               -> GingerT m a
withoutContext :: forall (m :: * -> *) a. Monad m => GingerT m a -> GingerT m a
withoutContext GingerT m a
action = do
  Env m
e <- (EvalState m -> Env m) -> GingerT m (Env m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EvalState m -> Env m
forall (m :: * -> *). EvalState m -> Env m
evalEnv
  (Env m -> Env m) -> GingerT m ()
forall (m :: * -> *). Monad m => (Env m -> Env m) -> GingerT m ()
modifyEnv Env m -> Env m
forall (m :: * -> *). Env m -> Env m
envRoot
  a
retval <- GingerT m a
action
  Env m
e' <- (EvalState m -> Env m) -> GingerT m (Env m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EvalState m -> Env m
forall (m :: * -> *). EvalState m -> Env m
evalEnv
  (Env m -> Env m) -> GingerT m ()
forall (m :: * -> *). Monad m => (Env m -> Env m) -> GingerT m ()
modifyEnv ((Env m -> Env m) -> GingerT m ())
-> (Env m -> Env m) -> GingerT m ()
forall a b. (a -> b) -> a -> b
$ Env m -> Env m -> Env m
forall a b. a -> b -> a
const (Env m
e' Env m -> Env m -> Env m
forall a. Semigroup a => a -> a -> a
<> Env m
e)
  a -> GingerT m a
forall a. a -> GingerT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
retval

withEnv :: Monad m
        => Env m
        -> GingerT m a
        -> GingerT m a
withEnv :: forall (m :: * -> *) a.
Monad m =>
Env m -> GingerT m a -> GingerT m a
withEnv Env m
env GingerT m a
action = do
  EvalState m
s <- GingerT m (EvalState m)
forall s (m :: * -> *). MonadState s m => m s
get
  (Env m -> Env m) -> GingerT m ()
forall (m :: * -> *). Monad m => (Env m -> Env m) -> GingerT m ()
modifyEnv (Env m -> Env m -> Env m
forall a b. a -> b -> a
const Env m
env)
  a
retval <- GingerT m a
action
  (Env m -> Env m) -> GingerT m ()
forall (m :: * -> *). Monad m => (Env m -> Env m) -> GingerT m ()
modifyEnv (Env m -> Env m -> Env m
forall a b. a -> b -> a
const (Env m -> Env m -> Env m) -> Env m -> Env m -> Env m
forall a b. (a -> b) -> a -> b
$ EvalState m -> Env m
forall (m :: * -> *). EvalState m -> Env m
evalEnv EvalState m
s)
  a -> GingerT m a
forall a. a -> GingerT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
retval

bind :: Monad m => (Env m -> a) -> GingerT m a
bind :: forall (m :: * -> *) a. Monad m => (Env m -> a) -> GingerT m a
bind Env m -> a
f = Env m -> a
f (Env m -> a) -> GingerT m (Env m) -> GingerT m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EvalState m -> Env m) -> GingerT m (Env m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EvalState m -> Env m
forall (m :: * -> *). EvalState m -> Env m
evalEnv

-- | Lift a dictionary value into the current scope, such that dictionary keys
-- become variables bound to the respective values in the dictionary.
scopify :: forall m. Monad m
        => Value m
        -> GingerT m ()
scopify :: forall (m :: * -> *). Monad m => Value m -> GingerT m ()
scopify = \case
    DictV Map Scalar (Value m)
items -> do
      [(Identifier, Value m)]
items' <- [(Scalar, Value m)]
-> ((Scalar, Value m) -> GingerT m (Identifier, Value m))
-> GingerT m [(Identifier, Value m)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map Scalar (Value m) -> [(Scalar, Value m)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Scalar (Value m)
items) (((Scalar, Value m) -> GingerT m (Identifier, Value m))
 -> GingerT m [(Identifier, Value m)])
-> ((Scalar, Value m) -> GingerT m (Identifier, Value m))
-> GingerT m [(Identifier, Value m)]
forall a b. (a -> b) -> a -> b
$ \(Scalar
k, Value m
v) -> do
        Identifier
k' <- Scalar -> GingerT m Identifier
scalarToIdentifier Scalar
k
        (Identifier, Value m) -> GingerT m (Identifier, Value m)
forall a. a -> GingerT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Identifier
k', Value m
v)
      Map Identifier (Value m) -> GingerT m ()
forall (m :: * -> *).
Monad m =>
Map Identifier (Value m) -> GingerT m ()
setVars (Map Identifier (Value m) -> GingerT m ())
-> Map Identifier (Value m) -> GingerT m ()
forall a b. (a -> b) -> a -> b
$ [(Identifier, Value m)] -> Map Identifier (Value m)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Identifier, Value m)]
items'
    Value m
x -> RuntimeError -> GingerT m ()
forall a. RuntimeError -> GingerT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuntimeError -> GingerT m ()) -> RuntimeError -> GingerT m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> RuntimeError
TagError Text
"liftScope" Text
"dict" (Value m -> Text
forall (m :: * -> *). Value m -> Text
tagNameOf Value m
x)
  where
    scalarToIdentifier :: Scalar -> GingerT m Identifier
    scalarToIdentifier :: Scalar -> GingerT m Identifier
scalarToIdentifier (StringScalar Text
txt) = Identifier -> GingerT m Identifier
forall a. a -> GingerT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Identifier -> GingerT m Identifier)
-> Identifier -> GingerT m Identifier
forall a b. (a -> b) -> a -> b
$ Text -> Identifier
Identifier Text
txt
    scalarToIdentifier Scalar
x = RuntimeError -> GingerT m Identifier
forall a. RuntimeError -> GingerT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuntimeError -> GingerT m Identifier)
-> RuntimeError -> GingerT m Identifier
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> RuntimeError
TagError Text
"liftScope" Text
"string" (Value Any -> Text
forall (m :: * -> *). Value m -> Text
tagNameOf (Value Any -> Text) -> Value Any -> Text
forall a b. (a -> b) -> a -> b
$ Scalar -> Value Any
forall (m :: * -> *). Scalar -> Value m
ScalarV Scalar
x)

withJinjaFilters :: (Monad m)
                 => GingerT m a
                 -> GingerT m a
withJinjaFilters :: forall (m :: * -> *) a. Monad m => GingerT m a -> GingerT m a
withJinjaFilters = Identifier -> GingerT m a -> GingerT m a
forall (m :: * -> *) a.
Monad m =>
Identifier -> GingerT m a -> GingerT m a
withJinjaKey Identifier
"filters"

withJinjaTests :: (Monad m)
                 => GingerT m a
                 -> GingerT m a
withJinjaTests :: forall (m :: * -> *) a. Monad m => GingerT m a -> GingerT m a
withJinjaTests = Identifier -> GingerT m a -> GingerT m a
forall (m :: * -> *) a.
Monad m =>
Identifier -> GingerT m a -> GingerT m a
withJinjaKey Identifier
"tests"

withJinjaKey :: (Monad m)
             => Identifier
             -> GingerT m a
             -> GingerT m a
withJinjaKey :: forall (m :: * -> *) a.
Monad m =>
Identifier -> GingerT m a -> GingerT m a
withJinjaKey Identifier
key GingerT m a
inner =
  GingerT m a -> GingerT m a
forall (m :: * -> *) a. Monad m => GingerT m a -> GingerT m a
scoped (GingerT m a -> GingerT m a) -> GingerT m a -> GingerT m a
forall a b. (a -> b) -> a -> b
$ do
    Value m
jinjaFilters <-
      (Map Scalar (Value m) -> Value m)
-> GingerT m (Map Scalar (Value m)) -> GingerT m (Value m)
forall a b. (a -> b) -> GingerT m a -> GingerT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value m -> Maybe (Value m) -> Value m
forall a. a -> Maybe a -> a
fromMaybe Value m
forall (m :: * -> *). Value m
NoneV (Maybe (Value m) -> Value m)
-> (Map Scalar (Value m) -> Maybe (Value m))
-> Map Scalar (Value m)
-> Value m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scalar -> Map Scalar (Value m) -> Maybe (Value m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Identifier -> Scalar
forall a. ToScalar a => a -> Scalar
toScalar Identifier
key)) (GingerT m (Map Scalar (Value m)) -> GingerT m (Value m))
-> GingerT m (Map Scalar (Value m)) -> GingerT m (Value m)
forall a b. (a -> b) -> a -> b
$
      Identifier -> GingerT m (Value m)
forall (m :: * -> *). Monad m => Identifier -> GingerT m (Value m)
lookupVar Identifier
"__jinja__" GingerT m (Value m)
-> (Value m -> GingerT m (Map Scalar (Value m)))
-> GingerT m (Map Scalar (Value m))
forall a b. GingerT m a -> (a -> GingerT m b) -> GingerT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Either RuntimeError (Map Scalar (Value m)))
-> GingerT m (Map Scalar (Value m))
forall (m :: * -> *) e (t :: (* -> *) -> * -> *) a.
(Monad m, MonadError e (t m), MonadTrans t) =>
m (Either e a) -> t m a
eitherExceptM (m (Either RuntimeError (Map Scalar (Value m)))
 -> GingerT m (Map Scalar (Value m)))
-> (Value m -> m (Either RuntimeError (Map Scalar (Value m))))
-> Value m
-> GingerT m (Map Scalar (Value m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value m -> m (Either RuntimeError (Map Scalar (Value m)))
forall (m :: * -> *).
Monad m =>
Value m -> m (Either RuntimeError (Map Scalar (Value m)))
asDictVal
    Value m -> GingerT m ()
forall (m :: * -> *). Monad m => Value m -> GingerT m ()
scopify Value m
jinjaFilters
    GingerT m a
inner