{-# LANGUAGE FlexibleInstances #-}

{- |
Module      : Language.Egison.EvalState
Licence     : MIT

This module defines the state during the evaluation.
-}

module Language.Egison.EvalState
  ( EvalState(..)
  , initialEvalState
  , MonadEval(..)
  , mLabelFuncName
  ) where

import           Control.Monad.Except
import           Control.Monad.Trans.State.Strict

import           Language.Egison.IExpr


newtype EvalState = EvalState
  -- Names of called functions for improved error message
  { EvalState -> [Var]
funcNameStack :: [Var]
  }

initialEvalState :: EvalState
initialEvalState :: EvalState
initialEvalState = EvalState :: [Var] -> EvalState
EvalState { funcNameStack :: [Var]
funcNameStack = [] }

class (Applicative m, Monad m) => MonadEval m where
  pushFuncName :: Var -> m ()
  topFuncName :: m Var
  popFuncName :: m ()
  getFuncNameStack :: m [Var]

instance Monad m => MonadEval (StateT EvalState m) where
  pushFuncName :: Var -> StateT EvalState m ()
pushFuncName Var
name = do
    EvalState
st <- StateT EvalState m EvalState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    EvalState -> StateT EvalState m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (EvalState -> StateT EvalState m ())
-> EvalState -> StateT EvalState m ()
forall a b. (a -> b) -> a -> b
$ EvalState
st { funcNameStack :: [Var]
funcNameStack = Var
name Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: EvalState -> [Var]
funcNameStack EvalState
st }
    () -> StateT EvalState m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  topFuncName :: StateT EvalState m Var
topFuncName = [Var] -> Var
forall a. [a] -> a
head ([Var] -> Var) -> (EvalState -> [Var]) -> EvalState -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalState -> [Var]
funcNameStack (EvalState -> Var)
-> StateT EvalState m EvalState -> StateT EvalState m Var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT EvalState m EvalState
forall (m :: * -> *) s. Monad m => StateT s m s
get
  popFuncName :: StateT EvalState m ()
popFuncName = do
    EvalState
st <- StateT EvalState m EvalState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    EvalState -> StateT EvalState m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (EvalState -> StateT EvalState m ())
-> EvalState -> StateT EvalState m ()
forall a b. (a -> b) -> a -> b
$ EvalState
st { funcNameStack :: [Var]
funcNameStack = [Var] -> [Var]
forall a. [a] -> [a]
tail ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ EvalState -> [Var]
funcNameStack EvalState
st }
    () -> StateT EvalState m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  getFuncNameStack :: StateT EvalState m [Var]
getFuncNameStack = EvalState -> [Var]
funcNameStack (EvalState -> [Var])
-> StateT EvalState m EvalState -> StateT EvalState m [Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT EvalState m EvalState
forall (m :: * -> *) s. Monad m => StateT s m s
get

instance (MonadEval m) => MonadEval (ExceptT e m) where
  pushFuncName :: Var -> ExceptT e m ()
pushFuncName Var
name = m () -> ExceptT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT e m ()) -> m () -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ Var -> m ()
forall (m :: * -> *). MonadEval m => Var -> m ()
pushFuncName Var
name
  topFuncName :: ExceptT e m Var
topFuncName = m Var -> ExceptT e m Var
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Var
forall (m :: * -> *). MonadEval m => m Var
topFuncName
  popFuncName :: ExceptT e m ()
popFuncName = m () -> ExceptT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
forall (m :: * -> *). MonadEval m => m ()
popFuncName
  getFuncNameStack :: ExceptT e m [Var]
getFuncNameStack = m [Var] -> ExceptT e m [Var]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m [Var]
forall (m :: * -> *). MonadEval m => m [Var]
getFuncNameStack

mLabelFuncName :: MonadEval m => Maybe Var -> m a -> m a
mLabelFuncName :: Maybe Var -> m a -> m a
mLabelFuncName Maybe Var
Nothing m a
m = m a
m
mLabelFuncName (Just Var
name) m a
m = do
  Var -> m ()
forall (m :: * -> *). MonadEval m => Var -> m ()
pushFuncName Var
name
  a
v <- m a
m
  m ()
forall (m :: * -> *). MonadEval m => m ()
popFuncName
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v