{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.Jsonnet.Eval.Monad where
import Control.Lens (locally, makeLenses, view)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Except
( ExceptT (..),
MonadError (throwError),
MonadFix,
MonadIO,
runExceptT,
)
import Control.Monad.Reader (MonadReader, ReaderT (..))
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M (union)
import Language.Jsonnet.Common (Backtrace (..), StackFrame (..))
import Language.Jsonnet.Core (Core)
import Language.Jsonnet.Error (Error (EvalError), EvalError)
import Language.Jsonnet.Parser.SrcSpan (SrcSpan)
import Unbound.Generics.LocallyNameless
( Fresh,
FreshMT,
Name,
runFreshMT,
s2n,
)
type Ctx a = Map (Name Core) a
data CallStack = CallStack
{
CallStack -> [Maybe SrcSpan]
_spans :: [Maybe SrcSpan],
CallStack -> [Name Core]
_scopes :: [Name Core]
}
makeLenses ''CallStack
emptyStack :: CallStack
emptyStack :: CallStack
emptyStack = [Maybe SrcSpan] -> [Name Core] -> CallStack
CallStack [] [String -> Name Core
forall a. String -> Name a
s2n String
"top-level"]
data EvalState a = EvalState
{
forall a. EvalState a -> Ctx a
_ctx :: Ctx a,
forall a. EvalState a -> CallStack
_callStack :: CallStack,
forall a. EvalState a -> Maybe SrcSpan
_currentPos :: Maybe SrcSpan
}
makeLenses ''EvalState
newtype EvalM a b = EvalM
{ forall a b.
EvalM a b -> ExceptT Error (ReaderT (EvalState a) (FreshMT IO)) b
unEval :: ExceptT Error (ReaderT (EvalState a) (FreshMT IO)) b
}
deriving
( (forall a b. (a -> b) -> EvalM a a -> EvalM a b)
-> (forall a b. a -> EvalM a b -> EvalM a a) -> Functor (EvalM a)
forall a b. a -> EvalM a b -> EvalM a a
forall a b. (a -> b) -> EvalM a a -> EvalM a b
forall a a b. a -> EvalM a b -> EvalM a a
forall a a b. (a -> b) -> EvalM a a -> EvalM a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> EvalM a b -> EvalM a a
$c<$ :: forall a a b. a -> EvalM a b -> EvalM a a
fmap :: forall a b. (a -> b) -> EvalM a a -> EvalM a b
$cfmap :: forall a a b. (a -> b) -> EvalM a a -> EvalM a b
Functor,
Functor (EvalM a)
Functor (EvalM a)
-> (forall a. a -> EvalM a a)
-> (forall a b. EvalM a (a -> b) -> EvalM a a -> EvalM a b)
-> (forall a b c.
(a -> b -> c) -> EvalM a a -> EvalM a b -> EvalM a c)
-> (forall a b. EvalM a a -> EvalM a b -> EvalM a b)
-> (forall a b. EvalM a a -> EvalM a b -> EvalM a a)
-> Applicative (EvalM a)
forall a. Functor (EvalM a)
forall a. a -> EvalM a a
forall a a. a -> EvalM a a
forall a b. EvalM a a -> EvalM a b -> EvalM a a
forall a b. EvalM a a -> EvalM a b -> EvalM a b
forall a b. EvalM a (a -> b) -> EvalM a a -> EvalM a b
forall a a b. EvalM a a -> EvalM a b -> EvalM a a
forall a a b. EvalM a a -> EvalM a b -> EvalM a b
forall a a b. EvalM a (a -> b) -> EvalM a a -> EvalM a b
forall a b c. (a -> b -> c) -> EvalM a a -> EvalM a b -> EvalM a c
forall a a b c.
(a -> b -> c) -> EvalM a a -> EvalM a b -> EvalM a c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. EvalM a a -> EvalM a b -> EvalM a a
$c<* :: forall a a b. EvalM a a -> EvalM a b -> EvalM a a
*> :: forall a b. EvalM a a -> EvalM a b -> EvalM a b
$c*> :: forall a a b. EvalM a a -> EvalM a b -> EvalM a b
liftA2 :: forall a b c. (a -> b -> c) -> EvalM a a -> EvalM a b -> EvalM a c
$cliftA2 :: forall a a b c.
(a -> b -> c) -> EvalM a a -> EvalM a b -> EvalM a c
<*> :: forall a b. EvalM a (a -> b) -> EvalM a a -> EvalM a b
$c<*> :: forall a a b. EvalM a (a -> b) -> EvalM a a -> EvalM a b
pure :: forall a. a -> EvalM a a
$cpure :: forall a a. a -> EvalM a a
Applicative,
Applicative (EvalM a)
Applicative (EvalM a)
-> (forall a b. EvalM a a -> (a -> EvalM a b) -> EvalM a b)
-> (forall a b. EvalM a a -> EvalM a b -> EvalM a b)
-> (forall a. a -> EvalM a a)
-> Monad (EvalM a)
forall a. Applicative (EvalM a)
forall a. a -> EvalM a a
forall a a. a -> EvalM a a
forall a b. EvalM a a -> EvalM a b -> EvalM a b
forall a b. EvalM a a -> (a -> EvalM a b) -> EvalM a b
forall a a b. EvalM a a -> EvalM a b -> EvalM a b
forall a a b. EvalM a a -> (a -> EvalM a b) -> EvalM a b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> EvalM a a
$creturn :: forall a a. a -> EvalM a a
>> :: forall a b. EvalM a a -> EvalM a b -> EvalM a b
$c>> :: forall a a b. EvalM a a -> EvalM a b -> EvalM a b
>>= :: forall a b. EvalM a a -> (a -> EvalM a b) -> EvalM a b
$c>>= :: forall a a b. EvalM a a -> (a -> EvalM a b) -> EvalM a b
Monad,
Monad (EvalM a)
Monad (EvalM a)
-> (forall a. IO a -> EvalM a a) -> MonadIO (EvalM a)
forall a. Monad (EvalM a)
forall a. IO a -> EvalM a a
forall a a. IO a -> EvalM a a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> EvalM a a
$cliftIO :: forall a a. IO a -> EvalM a a
MonadIO,
MonadReader (EvalState a),
MonadError Error,
Monad (EvalM a)
Monad (EvalM a)
-> (forall e a. Exception e => e -> EvalM a a)
-> MonadThrow (EvalM a)
forall a. Monad (EvalM a)
forall e a. Exception e => e -> EvalM a a
forall a e a. Exception e => e -> EvalM a a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> EvalM a a
$cthrowM :: forall a e a. Exception e => e -> EvalM a a
MonadThrow,
MonadThrow (EvalM a)
MonadThrow (EvalM a)
-> (forall e a.
Exception e =>
EvalM a a -> (e -> EvalM a a) -> EvalM a a)
-> MonadCatch (EvalM a)
forall a. MonadThrow (EvalM a)
forall e a.
Exception e =>
EvalM a a -> (e -> EvalM a a) -> EvalM a a
forall a e a.
Exception e =>
EvalM a a -> (e -> EvalM a a) -> EvalM a a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: forall e a.
Exception e =>
EvalM a a -> (e -> EvalM a a) -> EvalM a a
$ccatch :: forall a e a.
Exception e =>
EvalM a a -> (e -> EvalM a a) -> EvalM a a
MonadCatch,
MonadCatch (EvalM a)
MonadCatch (EvalM a)
-> (forall b.
((forall a. EvalM a a -> EvalM a a) -> EvalM a b) -> EvalM a b)
-> (forall b.
((forall a. EvalM a a -> EvalM a a) -> EvalM a b) -> EvalM a b)
-> (forall a b c.
EvalM a a
-> (a -> ExitCase b -> EvalM a c)
-> (a -> EvalM a b)
-> EvalM a (b, c))
-> MonadMask (EvalM a)
forall a. MonadCatch (EvalM a)
forall b.
((forall a. EvalM a a -> EvalM a a) -> EvalM a b) -> EvalM a b
forall a b.
((forall a. EvalM a a -> EvalM a a) -> EvalM a b) -> EvalM a b
forall a b c.
EvalM a a
-> (a -> ExitCase b -> EvalM a c)
-> (a -> EvalM a b)
-> EvalM a (b, c)
forall a a b c.
EvalM a a
-> (a -> ExitCase b -> EvalM a c)
-> (a -> EvalM a b)
-> EvalM a (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
EvalM a a
-> (a -> ExitCase b -> EvalM a c)
-> (a -> EvalM a b)
-> EvalM a (b, c)
$cgeneralBracket :: forall a a b c.
EvalM a a
-> (a -> ExitCase b -> EvalM a c)
-> (a -> EvalM a b)
-> EvalM a (b, c)
uninterruptibleMask :: forall b.
((forall a. EvalM a a -> EvalM a a) -> EvalM a b) -> EvalM a b
$cuninterruptibleMask :: forall a b.
((forall a. EvalM a a -> EvalM a a) -> EvalM a b) -> EvalM a b
mask :: forall b.
((forall a. EvalM a a -> EvalM a a) -> EvalM a b) -> EvalM a b
$cmask :: forall a b.
((forall a. EvalM a a -> EvalM a a) -> EvalM a b) -> EvalM a b
MonadMask,
Monad (EvalM a)
Monad (EvalM a)
-> (forall a. String -> EvalM a a) -> MonadFail (EvalM a)
forall a. Monad (EvalM a)
forall a. String -> EvalM a a
forall a a. String -> EvalM a a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> EvalM a a
$cfail :: forall a a. String -> EvalM a a
MonadFail,
Monad (EvalM a)
Monad (EvalM a)
-> (forall a. (a -> EvalM a a) -> EvalM a a) -> MonadFix (EvalM a)
forall a. Monad (EvalM a)
forall a. (a -> EvalM a a) -> EvalM a a
forall a a. (a -> EvalM a a) -> EvalM a a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: forall a. (a -> EvalM a a) -> EvalM a a
$cmfix :: forall a a. (a -> EvalM a a) -> EvalM a a
MonadFix,
Monad (EvalM a)
Monad (EvalM a)
-> (forall a. Name a -> EvalM a (Name a)) -> Fresh (EvalM a)
forall a. Monad (EvalM a)
forall a. Name a -> EvalM a (Name a)
forall a a. Name a -> EvalM a (Name a)
forall (m :: * -> *).
Monad m -> (forall a. Name a -> m (Name a)) -> Fresh m
fresh :: forall a. Name a -> EvalM a (Name a)
$cfresh :: forall a a. Name a -> EvalM a (Name a)
Fresh
)
runEvalM :: Ctx a -> EvalM a b -> IO (Either Error b)
runEvalM :: forall a b. Ctx a -> EvalM a b -> IO (Either Error b)
runEvalM Ctx a
ctx EvalM a b
e = FreshMT IO (Either Error b) -> IO (Either Error b)
forall (m :: * -> *) a. Monad m => FreshMT m a -> m a
runFreshMT (ReaderT (EvalState a) (FreshMT IO) (Either Error b)
-> EvalState a -> FreshMT IO (Either Error b)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ExceptT Error (ReaderT (EvalState a) (FreshMT IO)) b
-> ReaderT (EvalState a) (FreshMT IO) (Either Error b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (EvalM a b -> ExceptT Error (ReaderT (EvalState a) (FreshMT IO)) b
forall a b.
EvalM a b -> ExceptT Error (ReaderT (EvalState a) (FreshMT IO)) b
unEval EvalM a b
e)) EvalState a
st)
where
st :: EvalState a
st = Ctx a -> CallStack -> Maybe SrcSpan -> EvalState a
forall a. Ctx a -> CallStack -> Maybe SrcSpan -> EvalState a
EvalState Ctx a
ctx CallStack
emptyStack Maybe SrcSpan
forall a. Maybe a
Nothing
throwE :: EvalError -> EvalM a b
throwE :: forall a b. EvalError -> EvalM a b
throwE EvalError
e = Error -> EvalM a b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> EvalM a b)
-> (Backtrace Core -> Error) -> Backtrace Core -> EvalM a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalError -> Backtrace Core -> Error
EvalError EvalError
e (Backtrace Core -> EvalM a b)
-> EvalM a (Backtrace Core) -> EvalM a b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EvalM a (Backtrace Core)
forall a. EvalM a (Backtrace Core)
getBacktrace
extendEnv :: Ctx a -> EvalM a b -> EvalM a b
extendEnv :: forall a b. Ctx a -> EvalM a b -> EvalM a b
extendEnv = ASetter (EvalState a) (EvalState a) (Ctx a) (Ctx a)
-> (Ctx a -> Ctx a) -> EvalM a b -> EvalM a b
forall s (m :: * -> *) a b r.
MonadReader s m =>
ASetter s s a b -> (a -> b) -> m r -> m r
locally ASetter (EvalState a) (EvalState a) (Ctx a) (Ctx a)
forall a a. Lens (EvalState a) (EvalState a) (Ctx a) (Ctx a)
ctx ((Ctx a -> Ctx a) -> EvalM a b -> EvalM a b)
-> (Ctx a -> Ctx a -> Ctx a) -> Ctx a -> EvalM a b -> EvalM a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx a -> Ctx a -> Ctx a
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union
withEnv :: Ctx a -> EvalM a b -> EvalM a b
withEnv :: forall a b. Ctx a -> EvalM a b -> EvalM a b
withEnv = ASetter (EvalState a) (EvalState a) (Ctx a) (Ctx a)
-> (Ctx a -> Ctx a) -> EvalM a b -> EvalM a b
forall s (m :: * -> *) a b r.
MonadReader s m =>
ASetter s s a b -> (a -> b) -> m r -> m r
locally ASetter (EvalState a) (EvalState a) (Ctx a) (Ctx a)
forall a a. Lens (EvalState a) (EvalState a) (Ctx a) (Ctx a)
ctx ((Ctx a -> Ctx a) -> EvalM a b -> EvalM a b)
-> (Ctx a -> Ctx a -> Ctx a) -> Ctx a -> EvalM a b -> EvalM a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx a -> Ctx a -> Ctx a
forall a b. a -> b -> a
const
pushStackFrame :: (Name Core, Maybe SrcSpan) -> EvalM a b -> EvalM a b
pushStackFrame :: forall a b. (Name Core, Maybe SrcSpan) -> EvalM a b -> EvalM a b
pushStackFrame (Name Core
name, Maybe SrcSpan
span) =
ASetter (EvalState a) (EvalState a) [Name Core] [Name Core]
-> ([Name Core] -> [Name Core]) -> EvalM a b -> EvalM a b
forall s (m :: * -> *) a b r.
MonadReader s m =>
ASetter s s a b -> (a -> b) -> m r -> m r
locally ((CallStack -> Identity CallStack)
-> EvalState a -> Identity (EvalState a)
forall a. Lens' (EvalState a) CallStack
callStack ((CallStack -> Identity CallStack)
-> EvalState a -> Identity (EvalState a))
-> (([Name Core] -> Identity [Name Core])
-> CallStack -> Identity CallStack)
-> ASetter (EvalState a) (EvalState a) [Name Core] [Name Core]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name Core] -> Identity [Name Core])
-> CallStack -> Identity CallStack
Lens' CallStack [Name Core]
scopes) (Name Core
name Name Core -> [Name Core] -> [Name Core]
forall a. a -> [a] -> [a]
:)
(EvalM a b -> EvalM a b)
-> (EvalM a b -> EvalM a b) -> EvalM a b -> EvalM a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter (EvalState a) (EvalState a) [Maybe SrcSpan] [Maybe SrcSpan]
-> ([Maybe SrcSpan] -> [Maybe SrcSpan]) -> EvalM a b -> EvalM a b
forall s (m :: * -> *) a b r.
MonadReader s m =>
ASetter s s a b -> (a -> b) -> m r -> m r
locally ((CallStack -> Identity CallStack)
-> EvalState a -> Identity (EvalState a)
forall a. Lens' (EvalState a) CallStack
callStack ((CallStack -> Identity CallStack)
-> EvalState a -> Identity (EvalState a))
-> (([Maybe SrcSpan] -> Identity [Maybe SrcSpan])
-> CallStack -> Identity CallStack)
-> ASetter
(EvalState a) (EvalState a) [Maybe SrcSpan] [Maybe SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe SrcSpan] -> Identity [Maybe SrcSpan])
-> CallStack -> Identity CallStack
Lens' CallStack [Maybe SrcSpan]
spans) (Maybe SrcSpan
span Maybe SrcSpan -> [Maybe SrcSpan] -> [Maybe SrcSpan]
forall a. a -> [a] -> [a]
:)
getBacktrace :: EvalM a (Backtrace Core)
getBacktrace :: forall a. EvalM a (Backtrace Core)
getBacktrace = do
[Maybe SrcSpan]
sp <- (:) (Maybe SrcSpan -> [Maybe SrcSpan] -> [Maybe SrcSpan])
-> EvalM a (Maybe SrcSpan)
-> EvalM a ([Maybe SrcSpan] -> [Maybe SrcSpan])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe SrcSpan) (EvalState a) (Maybe SrcSpan)
-> EvalM a (Maybe SrcSpan)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe SrcSpan) (EvalState a) (Maybe SrcSpan)
forall a. Lens' (EvalState a) (Maybe SrcSpan)
currentPos EvalM a ([Maybe SrcSpan] -> [Maybe SrcSpan])
-> EvalM a [Maybe SrcSpan] -> EvalM a [Maybe SrcSpan]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Getting [Maybe SrcSpan] (EvalState a) [Maybe SrcSpan]
-> EvalM a [Maybe SrcSpan]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((CallStack -> Const [Maybe SrcSpan] CallStack)
-> EvalState a -> Const [Maybe SrcSpan] (EvalState a)
forall a. Lens' (EvalState a) CallStack
callStack ((CallStack -> Const [Maybe SrcSpan] CallStack)
-> EvalState a -> Const [Maybe SrcSpan] (EvalState a))
-> (([Maybe SrcSpan] -> Const [Maybe SrcSpan] [Maybe SrcSpan])
-> CallStack -> Const [Maybe SrcSpan] CallStack)
-> Getting [Maybe SrcSpan] (EvalState a) [Maybe SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe SrcSpan] -> Const [Maybe SrcSpan] [Maybe SrcSpan])
-> CallStack -> Const [Maybe SrcSpan] CallStack
Lens' CallStack [Maybe SrcSpan]
spans)
[Name Core]
sc <- Getting [Name Core] (EvalState a) [Name Core]
-> EvalM a [Name Core]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((CallStack -> Const [Name Core] CallStack)
-> EvalState a -> Const [Name Core] (EvalState a)
forall a. Lens' (EvalState a) CallStack
callStack ((CallStack -> Const [Name Core] CallStack)
-> EvalState a -> Const [Name Core] (EvalState a))
-> (([Name Core] -> Const [Name Core] [Name Core])
-> CallStack -> Const [Name Core] CallStack)
-> Getting [Name Core] (EvalState a) [Name Core]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name Core] -> Const [Name Core] [Name Core])
-> CallStack -> Const [Name Core] CallStack
Lens' CallStack [Name Core]
scopes)
Backtrace Core -> EvalM a (Backtrace Core)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Backtrace Core -> EvalM a (Backtrace Core))
-> Backtrace Core -> EvalM a (Backtrace Core)
forall a b. (a -> b) -> a -> b
$
[StackFrame Core] -> Backtrace Core
forall a. [StackFrame a] -> Backtrace a
Backtrace ([StackFrame Core] -> Backtrace Core)
-> [StackFrame Core] -> Backtrace Core
forall a b. (a -> b) -> a -> b
$
case [Maybe SrcSpan] -> Maybe [SrcSpan]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe SrcSpan]
sp of
Just [SrcSpan]
sp -> (Name Core -> SrcSpan -> StackFrame Core)
-> [Name Core] -> [SrcSpan] -> [StackFrame Core]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name Core -> SrcSpan -> StackFrame Core
forall a. Name a -> SrcSpan -> StackFrame a
StackFrame [Name Core]
sc [SrcSpan]
sp
Maybe [SrcSpan]
Nothing -> []