{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

module Language.Jsonnet.Eval.Monad where

import Control.Arrow
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Except
import Control.Monad.RWS.Strict
import Control.Monad.Reader
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Maybe (listToMaybe)
import Debug.Trace
import GHC.Generics
import Language.Jsonnet.Common
import Language.Jsonnet.Core
import Language.Jsonnet.Error
import Language.Jsonnet.Parser.SrcSpan
import {-# SOURCE #-} Language.Jsonnet.Value (Thunk)
import Unbound.Generics.LocallyNameless

instance (Monoid w, Fresh m) => Fresh (RWST r w s m) where
  fresh :: forall a. Name a -> RWST r w s m (Name a)
fresh = m (Name a) -> RWST r w s m (Name a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Name a) -> RWST r w s m (Name a))
-> (Name a -> m (Name a)) -> Name a -> RWST r w s m (Name a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name a -> m (Name a)
forall (m :: * -> *) a. Fresh m => Name a -> m (Name a)
fresh

newtype Eval a = Eval
  { forall a.
Eval a -> ExceptT Error (RWST Env () EvalState (FreshMT IO)) a
unEval :: ExceptT Error (RWST Env () EvalState (FreshMT IO)) a
  }
  deriving
    ( (forall a b. (a -> b) -> Eval a -> Eval b)
-> (forall a b. a -> Eval b -> Eval a) -> Functor Eval
forall a b. a -> Eval b -> Eval a
forall a b. (a -> b) -> Eval a -> Eval 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 -> Eval b -> Eval a
$c<$ :: forall a b. a -> Eval b -> Eval a
fmap :: forall a b. (a -> b) -> Eval a -> Eval b
$cfmap :: forall a b. (a -> b) -> Eval a -> Eval b
Functor,
      Functor Eval
Functor Eval
-> (forall a. a -> Eval a)
-> (forall a b. Eval (a -> b) -> Eval a -> Eval b)
-> (forall a b c. (a -> b -> c) -> Eval a -> Eval b -> Eval c)
-> (forall a b. Eval a -> Eval b -> Eval b)
-> (forall a b. Eval a -> Eval b -> Eval a)
-> Applicative Eval
forall a. a -> Eval a
forall a b. Eval a -> Eval b -> Eval a
forall a b. Eval a -> Eval b -> Eval b
forall a b. Eval (a -> b) -> Eval a -> Eval b
forall a b c. (a -> b -> c) -> Eval a -> Eval b -> Eval 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. Eval a -> Eval b -> Eval a
$c<* :: forall a b. Eval a -> Eval b -> Eval a
*> :: forall a b. Eval a -> Eval b -> Eval b
$c*> :: forall a b. Eval a -> Eval b -> Eval b
liftA2 :: forall a b c. (a -> b -> c) -> Eval a -> Eval b -> Eval c
$cliftA2 :: forall a b c. (a -> b -> c) -> Eval a -> Eval b -> Eval c
<*> :: forall a b. Eval (a -> b) -> Eval a -> Eval b
$c<*> :: forall a b. Eval (a -> b) -> Eval a -> Eval b
pure :: forall a. a -> Eval a
$cpure :: forall a. a -> Eval a
Applicative,
      Applicative Eval
Applicative Eval
-> (forall a b. Eval a -> (a -> Eval b) -> Eval b)
-> (forall a b. Eval a -> Eval b -> Eval b)
-> (forall a. a -> Eval a)
-> Monad Eval
forall a. a -> Eval a
forall a b. Eval a -> Eval b -> Eval b
forall a b. Eval a -> (a -> Eval b) -> Eval 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 -> Eval a
$creturn :: forall a. a -> Eval a
>> :: forall a b. Eval a -> Eval b -> Eval b
$c>> :: forall a b. Eval a -> Eval b -> Eval b
>>= :: forall a b. Eval a -> (a -> Eval b) -> Eval b
$c>>= :: forall a b. Eval a -> (a -> Eval b) -> Eval b
Monad,
      Monad Eval
Monad Eval -> (forall a. IO a -> Eval a) -> MonadIO Eval
forall a. IO a -> Eval a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> Eval a
$cliftIO :: forall a. IO a -> Eval a
MonadIO,
      Monad Eval
Monad Eval -> (forall a. (a -> Eval a) -> Eval a) -> MonadFix Eval
forall a. (a -> Eval a) -> Eval a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: forall a. (a -> Eval a) -> Eval a
$cmfix :: forall a. (a -> Eval a) -> Eval a
MonadFix,
      MonadWriter (),
      MonadReader Env,
      MonadError Error,
      MonadState EvalState,
      Monad Eval
Monad Eval
-> (forall e a. Exception e => e -> Eval a) -> MonadThrow Eval
forall e a. Exception e => e -> Eval a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> Eval a
$cthrowM :: forall e a. Exception e => e -> Eval a
MonadThrow,
      MonadThrow Eval
MonadThrow Eval
-> (forall e a. Exception e => Eval a -> (e -> Eval a) -> Eval a)
-> MonadCatch Eval
forall e a. Exception e => Eval a -> (e -> Eval a) -> Eval 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 => Eval a -> (e -> Eval a) -> Eval a
$ccatch :: forall e a. Exception e => Eval a -> (e -> Eval a) -> Eval a
MonadCatch,
      MonadCatch Eval
MonadCatch Eval
-> (forall b. ((forall a. Eval a -> Eval a) -> Eval b) -> Eval b)
-> (forall b. ((forall a. Eval a -> Eval a) -> Eval b) -> Eval b)
-> (forall a b c.
    Eval a
    -> (a -> ExitCase b -> Eval c) -> (a -> Eval b) -> Eval (b, c))
-> MonadMask Eval
forall b. ((forall a. Eval a -> Eval a) -> Eval b) -> Eval b
forall a b c.
Eval a
-> (a -> ExitCase b -> Eval c) -> (a -> Eval b) -> Eval (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.
Eval a
-> (a -> ExitCase b -> Eval c) -> (a -> Eval b) -> Eval (b, c)
$cgeneralBracket :: forall a b c.
Eval a
-> (a -> ExitCase b -> Eval c) -> (a -> Eval b) -> Eval (b, c)
uninterruptibleMask :: forall b. ((forall a. Eval a -> Eval a) -> Eval b) -> Eval b
$cuninterruptibleMask :: forall b. ((forall a. Eval a -> Eval a) -> Eval b) -> Eval b
mask :: forall b. ((forall a. Eval a -> Eval a) -> Eval b) -> Eval b
$cmask :: forall b. ((forall a. Eval a -> Eval a) -> Eval b) -> Eval b
MonadMask,
      Monad Eval
Monad Eval -> (forall a. String -> Eval a) -> MonadFail Eval
forall a. String -> Eval a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> Eval a
$cfail :: forall a. String -> Eval a
MonadFail,
      Monad Eval
Monad Eval -> (forall a. Name a -> Eval (Name a)) -> Fresh Eval
forall a. Name a -> Eval (Name a)
forall (m :: * -> *).
Monad m -> (forall a. Name a -> m (Name a)) -> Fresh m
fresh :: forall a. Name a -> Eval (Name a)
$cfresh :: forall a. Name a -> Eval (Name a)
Fresh,
      (forall x. Eval a -> Rep (Eval a) x)
-> (forall x. Rep (Eval a) x -> Eval a) -> Generic (Eval a)
forall x. Rep (Eval a) x -> Eval a
forall x. Eval a -> Rep (Eval a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Eval a) x -> Eval a
forall a x. Eval a -> Rep (Eval a) x
$cto :: forall a x. Rep (Eval a) x -> Eval a
$cfrom :: forall a x. Eval a -> Rep (Eval a) x
Generic
    )

type Ctx = Map (Name Core) Thunk

extendCtx :: Ctx -> Eval a -> Eval a
extendCtx :: forall a. Ctx -> Eval a -> Eval a
extendCtx Ctx
ctx' =
  (Env -> Env) -> Eval a -> Eval a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
    ( \env :: Env
env@Env {Ctx
ctx :: Env -> Ctx
ctx :: Ctx
ctx} ->
        Env
env {ctx :: Ctx
ctx = Ctx -> Ctx -> Ctx
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Ctx
ctx' Ctx
ctx}
    )

pushScope :: Name Core -> Eval a -> Eval a
pushScope :: forall a. Name Core -> Eval a -> Eval a
pushScope Name Core
name =
  (Env -> Env) -> Eval a -> Eval a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
    ( \env :: Env
env@Env {[Maybe (Name Core)]
scopes :: Env -> [Maybe (Name Core)]
scopes :: [Maybe (Name Core)]
scopes} ->
        Env
env {scopes :: [Maybe (Name Core)]
scopes = Name Core -> Maybe (Name Core)
forall a. a -> Maybe a
Just Name Core
name Maybe (Name Core) -> [Maybe (Name Core)] -> [Maybe (Name Core)]
forall a. a -> [a] -> [a]
: [Maybe (Name Core)]
scopes}
    )

pushSpan :: Maybe SrcSpan -> Eval a -> Eval a
pushSpan :: forall a. Maybe SrcSpan -> Eval a -> Eval a
pushSpan Maybe SrcSpan
span Eval a
c = do
  (Env -> Env) -> Eval a -> Eval a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
    ( \env :: Env
env@Env {[Maybe SrcSpan]
spans :: Env -> [Maybe SrcSpan]
spans :: [Maybe SrcSpan]
spans} ->
        Env
env {spans :: [Maybe SrcSpan]
spans = Maybe SrcSpan
span Maybe SrcSpan -> [Maybe SrcSpan] -> [Maybe SrcSpan]
forall a. a -> [a] -> [a]
: [Maybe SrcSpan]
spans}
    )
    Eval a
c

withCtx :: Ctx -> Eval a -> Eval a
withCtx :: forall a. Ctx -> Eval a -> Eval a
withCtx Ctx
ctx = (Env -> Env) -> Eval a -> Eval a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Env
env -> Env
env {ctx :: Ctx
ctx = Ctx
ctx})

data Env = Env
  { Env -> Ctx
ctx :: Ctx,
    Env -> [Maybe SrcSpan]
spans :: [Maybe SrcSpan],
    Env -> [Maybe (Name Core)]
scopes :: [Maybe (Name Core)]
  }

withEnv :: Env -> Eval a -> Eval a
withEnv :: forall a. Env -> Eval a -> Eval a
withEnv Env
rho = (Env -> Env) -> Eval a -> Eval a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Env -> Env -> Env
forall a b. a -> b -> a
const Env
rho)

emptyEnv :: Env
emptyEnv :: Env
emptyEnv = Ctx -> [Maybe SrcSpan] -> [Maybe (Name Core)] -> Env
Env Ctx
forall k a. Map k a
M.empty [] [Maybe (Name Core)
forall a. Maybe a
Nothing]

data EvalState = EvalState
  { EvalState -> Maybe SrcSpan
currentPos :: Maybe SrcSpan
  }

emptyState :: EvalState
emptyState :: EvalState
emptyState = Maybe SrcSpan -> EvalState
EvalState Maybe SrcSpan
forall a. Maybe a
Nothing

--  traceShowM $ "length of spans: "
--  traceShowM $ length sp
--  traceShowM $ "length of scopes: "
--  traceShowM $ length sc
getBacktrace :: Eval (Backtrace Core)
getBacktrace :: Eval (Backtrace Core)
getBacktrace = do
  [Maybe SrcSpan]
sp <- (:) (Maybe SrcSpan -> [Maybe SrcSpan] -> [Maybe SrcSpan])
-> Eval (Maybe SrcSpan)
-> Eval ([Maybe SrcSpan] -> [Maybe SrcSpan])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EvalState -> Maybe SrcSpan) -> Eval (Maybe SrcSpan)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EvalState -> Maybe SrcSpan
currentPos Eval ([Maybe SrcSpan] -> [Maybe SrcSpan])
-> Eval [Maybe SrcSpan] -> Eval [Maybe SrcSpan]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Env -> [Maybe SrcSpan]) -> Eval [Maybe SrcSpan]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> [Maybe SrcSpan]
spans
  [Maybe (Name Core)]
sc <- (Env -> [Maybe (Name Core)]) -> Eval [Maybe (Name Core)]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> [Maybe (Name Core)]
scopes
  Backtrace Core -> Eval (Backtrace Core)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Backtrace Core -> Eval (Backtrace Core))
-> Backtrace Core -> Eval (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 -> (Maybe (Name Core) -> SrcSpan -> StackFrame Core)
-> [Maybe (Name Core)] -> [SrcSpan] -> [StackFrame Core]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe (Name Core) -> SrcSpan -> StackFrame Core
forall a. Maybe (Name a) -> SrcSpan -> StackFrame a
StackFrame [Maybe (Name Core)]
sc [SrcSpan]
sp
        Maybe [SrcSpan]
Nothing -> []

throwE :: EvalError -> Eval a
throwE :: forall a. EvalError -> Eval a
throwE EvalError
e = Error -> Eval a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> Eval a)
-> (Backtrace Core -> Error) -> Backtrace Core -> Eval a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalError -> Backtrace Core -> Error
EvalError EvalError
e (Backtrace Core -> Eval a) -> Eval (Backtrace Core) -> Eval a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Eval (Backtrace Core)
getBacktrace

runEval :: Env -> Eval a -> ExceptT Error IO a
runEval :: forall a. Env -> Eval a -> ExceptT Error IO a
runEval Env
env = (RWST Env () EvalState (FreshMT IO) (Either Error a)
 -> IO (Either Error a))
-> ExceptT Error (RWST Env () EvalState (FreshMT IO)) a
-> ExceptT Error IO a
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT RWST Env () EvalState (FreshMT IO) (Either Error a)
-> IO (Either Error a)
forall {m :: * -> *} {w} {b}.
Monad m =>
RWST Env w EvalState (FreshMT m) b -> m b
f (ExceptT Error (RWST Env () EvalState (FreshMT IO)) a
 -> ExceptT Error IO a)
-> (Eval a -> ExceptT Error (RWST Env () EvalState (FreshMT IO)) a)
-> Eval a
-> ExceptT Error IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eval a -> ExceptT Error (RWST Env () EvalState (FreshMT IO)) a
forall a.
Eval a -> ExceptT Error (RWST Env () EvalState (FreshMT IO)) a
unEval
  where
    f :: RWST Env w EvalState (FreshMT m) b -> m b
f RWST Env w EvalState (FreshMT m) b
comp = do
      (b
a, EvalState
_, w
_) <- FreshMT m (b, EvalState, w) -> m (b, EvalState, w)
forall (m :: * -> *) a. Monad m => FreshMT m a -> m a
runFreshMT (FreshMT m (b, EvalState, w) -> m (b, EvalState, w))
-> FreshMT m (b, EvalState, w) -> m (b, EvalState, w)
forall a b. (a -> b) -> a -> b
$ RWST Env w EvalState (FreshMT m) b
-> Env -> EvalState -> FreshMT m (b, EvalState, w)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST RWST Env w EvalState (FreshMT m) b
comp Env
env EvalState
emptyState
      b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a