{-# LANGUAGE TemplateHaskell #-}

module Interpreter.Result where

import Analyzer.AnalyzedAst (Function (..), FunctionValue (Function, Nil), Identifier)
import Control.Lens (At (at), LensLike', ix, makeLenses, (^.))
import Control.Monad.Except (ExceptT)
import Control.Monad.ST (ST)
import Control.Monad.State (MonadTrans (lift), StateT)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.STRef (STRef, readSTRef)
import Data.Text (Text, unpack)

-- * Interpretation result

-- | Represents the result of interpretation.
type Result s a = ExceptT Err (StateT (Env s) (ST s)) a

lift2 :: ST s a -> Result s a
lift2 :: forall s a. ST s a -> Result s a
lift2 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- ** Result value

type ResultValue = Either Err

-- | Represents unsuccessful interpretation.
data Err
  = -- | Division by zero error.
    DivisionByZero
  | -- | Index out of bounds error, contains info about index and array length.
    IndexOutOfRange Int Int
  | -- | No return error.
    NoReturn
  | -- | Null dereference error (happens when trying to call the `nil` as a regular function).
    Npe
  | -- | Panic error (happens when calling `panic` stdlib function).
    Panic Text
  | -- | Unexpected error, this type of errors must never happen.
    UnexpectedError

instance Show Err where
  show :: Err -> String
show Err
DivisionByZero = String
"panic: runtime error: integer divide by zero"
  show (IndexOutOfRange Int
i Int
len) = String
"panic: runtime error: index out of range [" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
i forall a. Semigroup a => a -> a -> a
<> String
"] with length " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
len
  show Err
NoReturn = String
"panic: runtime error: no return"
  show Err
Npe = String
"panic: runtime error: nil pointer dereference"
  show (Panic Text
msg) = String
"panic: " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
msg
  show Err
UnexpectedError = String
"panic: unexpected error"

-- ** State

-- *** Environment

data Env s = Env
  { forall s. Env s -> Map Text (STRef s Function, Scope s)
_funcs :: Map Identifier (STRef s Function, Scope s),
    forall s. Env s -> [FuncScope s]
_funcScopes :: [FuncScope s],
    forall s. Env s -> AccOut
_accumulatedOutput :: AccOut
  }

-- | Accumulated output (every element is a text printed to the stdout).
type AccOut = [Text]

emptyEnv :: Env s
emptyEnv :: forall s. Env s
emptyEnv = forall s.
Map Text (STRef s Function, Scope s)
-> [FuncScope s] -> AccOut -> Env s
Env forall k a. Map k a
Map.empty [] []

-- *** Function scope

newtype FuncScope s = FuncScope {forall s. FuncScope s -> [Scope s]
_scopes :: [Scope s]}

-- *** Scope

-- | Scope contains identifiers mapped to their types.
newtype Scope s = Scope {forall s. Scope s -> Map Text (STRef s (RuntimeValue s))
_vars :: Map Identifier (STRef s (RuntimeValue s))}

-- | Create empty 'Scope'.
emptyScope :: Scope s
emptyScope :: forall s. Scope s
emptyScope = forall s. Map Text (STRef s (RuntimeValue s)) -> Scope s
Scope forall k a. Map k a
Map.empty

-- *** Runtime value

-- | Represents runtime value of the calculated expression.
data RuntimeValue s
  = -- | Int value.
    ValInt Int
  | -- | Boolean value.
    ValBool Bool
  | -- | String value.
    ValString Text
  | -- | Array value.
    ValArray [RuntimeValue s]
  | -- | Function value.
    ValFunction FunctionValue (Scope s)

instance Eq (RuntimeValue s) where
  ValInt Int
lhs == :: RuntimeValue s -> RuntimeValue s -> Bool
== ValInt Int
rhs = Int
lhs forall a. Eq a => a -> a -> Bool
== Int
rhs
  ValBool Bool
lhs == ValBool Bool
rhs = Bool
lhs forall a. Eq a => a -> a -> Bool
== Bool
rhs
  ValString Text
lhs == ValString Text
rhs = Text
lhs forall a. Eq a => a -> a -> Bool
== Text
rhs
  ValArray [RuntimeValue s]
lhs == ValArray [RuntimeValue s]
rhs = [RuntimeValue s]
lhs forall a. Eq a => a -> a -> Bool
== [RuntimeValue s]
rhs
  ValFunction FunctionValue
_ Scope s
_ == ValFunction FunctionValue
_ Scope s
_ = Bool
False
  RuntimeValue s
_ == RuntimeValue s
_ = Bool
False

-- *** Optics

makeLenses ''Env
makeLenses ''FuncScope
makeLenses ''Scope

var :: Applicative f => Int -> Int -> Identifier -> LensLike' f (Env s) (Maybe (STRef s (RuntimeValue s)))
var :: forall (f :: * -> *) s.
Applicative f =>
Int
-> Int
-> Text
-> LensLike' f (Env s) (Maybe (STRef s (RuntimeValue s)))
var Int
i Int
j Text
name = forall s. Lens' (Env s) [FuncScope s]
funcScopes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s s. Iso (FuncScope s) (FuncScope s) [Scope s] [Scope s]
scopes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
j forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s s.
Iso
  (Scope s)
  (Scope s)
  (Map Text (STRef s (RuntimeValue s)))
  (Map Text (STRef s (RuntimeValue s)))
vars forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
name

-- ** Evaluated state

-- *** Environment

data Env' = Env'
  { Env' -> Map Text Function
_funcs' :: Map Identifier Function,
    Env' -> [FuncScope']
_funcScopes' :: [FuncScope'],
    Env' -> AccOut
_accumulatedOutput' :: AccOut
  }
  deriving (Int -> Env' -> ShowS
[Env'] -> ShowS
Env' -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Env'] -> ShowS
$cshowList :: [Env'] -> ShowS
show :: Env' -> String
$cshow :: Env' -> String
showsPrec :: Int -> Env' -> ShowS
$cshowsPrec :: Int -> Env' -> ShowS
Show)

evalEnv :: Env s -> ST s Env'
evalEnv :: forall s. Env s -> ST s Env'
evalEnv (Env Map Text (STRef s Function, Scope s)
fs [FuncScope s]
fScs AccOut
accOut) = do
  Map Text Function
fs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall s a. STRef s a -> ST s a
readSTRef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Map Text (STRef s Function, Scope s)
fs
  [FuncScope']
fScs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s. FuncScope s -> ST s FuncScope'
evalFuncScope [FuncScope s]
fScs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Map Text Function -> [FuncScope'] -> AccOut -> Env'
Env' Map Text Function
fs' [FuncScope']
fScs' AccOut
accOut

-- *** Function scope

newtype FuncScope' = FuncScope' {FuncScope' -> [Scope']
_scopes' :: [Scope']}
  deriving (Int -> FuncScope' -> ShowS
[FuncScope'] -> ShowS
FuncScope' -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FuncScope'] -> ShowS
$cshowList :: [FuncScope'] -> ShowS
show :: FuncScope' -> String
$cshow :: FuncScope' -> String
showsPrec :: Int -> FuncScope' -> ShowS
$cshowsPrec :: Int -> FuncScope' -> ShowS
Show)

evalFuncScope :: FuncScope s -> ST s FuncScope'
evalFuncScope :: forall s. FuncScope s -> ST s FuncScope'
evalFuncScope (FuncScope [Scope s]
scs) = [Scope'] -> FuncScope'
FuncScope' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s. Scope s -> ST s Scope'
evalScope [Scope s]
scs

-- *** Scope

newtype Scope' = Scope' {Scope' -> Map Text RuntimeValue'
_vars' :: Map Identifier RuntimeValue'}
  deriving (Int -> Scope' -> ShowS
[Scope'] -> ShowS
Scope' -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scope'] -> ShowS
$cshowList :: [Scope'] -> ShowS
show :: Scope' -> String
$cshow :: Scope' -> String
showsPrec :: Int -> Scope' -> ShowS
$cshowsPrec :: Int -> Scope' -> ShowS
Show)

evalScope :: Scope s -> ST s Scope'
evalScope :: forall s. Scope s -> ST s Scope'
evalScope Scope s
sc = Map Text RuntimeValue' -> Scope'
Scope' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s. RuntimeValue s -> RuntimeValue'
evalRuntimeValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. STRef s a -> ST s a
readSTRef) (Scope s
sc forall s a. s -> Getting a s a -> a
^. forall s s.
Iso
  (Scope s)
  (Scope s)
  (Map Text (STRef s (RuntimeValue s)))
  (Map Text (STRef s (RuntimeValue s)))
vars)

-- *** Runtime value

-- | Represents runtime value of the calculated expression.
data RuntimeValue'
  = -- | Int value.
    ValInt' Int
  | -- | Boolean value.
    ValBool' Bool
  | -- | String value.
    ValString' Text
  | -- | Array value.
    ValArray' [RuntimeValue']
  | -- | Function value.
    ValFunction' FunctionValue

instance Show RuntimeValue' where
  show :: RuntimeValue' -> String
show (ValInt' Int
int) = forall a. Show a => a -> String
show Int
int
  show (ValBool' Bool
bool) = if Bool
bool then String
"true" else String
"false"
  show (ValString' Text
string) = Text -> String
unpack Text
string
  show (ValArray' [RuntimeValue']
vs) = String
"[" forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords (forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RuntimeValue']
vs) forall a. Semigroup a => a -> a -> a
<> String
"]"
  show (ValFunction' (Function (FuncOrdinary OrdinaryFunction
_))) = String
"function"
  show (ValFunction' (Function (FuncStdLib Text
name))) = Text -> String
unpack Text
name
  show (ValFunction' FunctionValue
Nil) = String
"nil"

evalRuntimeValue :: RuntimeValue s -> RuntimeValue'
evalRuntimeValue :: forall s. RuntimeValue s -> RuntimeValue'
evalRuntimeValue RuntimeValue s
rv = case RuntimeValue s
rv of
  ValInt Int
v -> Int -> RuntimeValue'
ValInt' Int
v
  ValBool Bool
v -> Bool -> RuntimeValue'
ValBool' Bool
v
  ValString Text
v -> Text -> RuntimeValue'
ValString' Text
v
  ValArray [RuntimeValue s]
v -> [RuntimeValue'] -> RuntimeValue'
ValArray' forall a b. (a -> b) -> a -> b
$ forall s. RuntimeValue s -> RuntimeValue'
evalRuntimeValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RuntimeValue s]
v
  ValFunction FunctionValue
v Scope s
_ -> FunctionValue -> RuntimeValue'
ValFunction' FunctionValue
v

unevalRuntimeValue :: RuntimeValue' -> RuntimeValue s
unevalRuntimeValue :: forall s. RuntimeValue' -> RuntimeValue s
unevalRuntimeValue RuntimeValue'
rv = case RuntimeValue'
rv of
  ValInt' Int
v -> forall s. Int -> RuntimeValue s
ValInt Int
v
  ValBool' Bool
v -> forall s. Bool -> RuntimeValue s
ValBool Bool
v
  ValString' Text
v -> forall s. Text -> RuntimeValue s
ValString Text
v
  ValArray' [RuntimeValue']
v -> forall s. [RuntimeValue s] -> RuntimeValue s
ValArray forall a b. (a -> b) -> a -> b
$ forall s. RuntimeValue' -> RuntimeValue s
unevalRuntimeValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RuntimeValue']
v
  ValFunction' FunctionValue
v -> forall s. FunctionValue -> Scope s -> RuntimeValue s
ValFunction FunctionValue
v forall s. Scope s
emptyScope

-- *** Optics

makeLenses ''Env'
makeLenses ''FuncScope'
makeLenses ''Scope'