{- |
Module                  : Language.Jsonnet.Eval.Monad
Copyright               : (c) 2020-2021 Alexandre Moreno
SPDX-License-Identifier : BSD-3-Clause OR Apache-2.0
Maintainer              : Alexandre Moreno <alexmorenocano@gmail.com>
Stability               : experimental
Portability             : non-portable
-}
{-# 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

-- | Simulate a call-stack to report stack traces
data CallStack = CallStack
  { -- | source location of call-sites
    CallStack -> [Maybe SrcSpan]
_spans :: [Maybe SrcSpan],
    -- | names of called functions
    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
  { -- | binding local variables to their values
    forall a. EvalState a -> Ctx a
_ctx :: Ctx a,
    -- | call-stack simulation
    forall a. EvalState a -> CallStack
_callStack :: CallStack,
    -- | source span of expression being evaluated
    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 -> []