{- CSci 450: Organization of Programming Languages
   Imperative Core Language, Evaluator
   Fall 2017 H. Conrad Cunningham

1234567890123456789012345678901234567890123456789012345678901234567890

2017-09-14: Based partly on Expression Language evaluator code

The intention of this module is to encapsulate the knowledge of how
ImpCore definitions and expressions are evaluated but to delegate the
details of how environments and values are implemented to the
Environment and ValImpCore modules, respectively.

The structure of the abstract syntax is defined in module
AbSynImpCore, but its semantics is known by the current module and
others that manipulate the abstract syntax trees.

WARNINGS:

1. The implementation of the "print" primitive uses impure output via
   "unsafePerformIO".

2. The current implementation of this module assumes that ValType
   entities are in class Num.

TODO:
- Consider what specifically needs to be imported and exported
- Generalize evalBinArith and evalBinRel
- Better encapsulate the value-level operations in ValueImpCore

-}

module EvalImpCore
    ( ValType, Name, AnEnv, DEnv, Env, Def(..), Expr(..),
      EvalErr, ActionD(..), Result(..),
      newDEnv, showDEnv, evalScript, evalDef
    )
where

-- Haskell libraries
import Data.Either      ( rights )
import Data.List        ( intercalate )
import System.IO.Unsafe ( unsafePerformIO )

-- Expression Language modules
import Values       ( ValType, Name, defaultVal, boolToVal, valToBool )
import AbSynImpCore ( Def(..), Expr(..) )
import Environments ( AnEnv, newEnv, toList, getBinding, newBinding,
                      setBinding, bindList )

{-  ENVIRONMENT

    A definition-level environment consists of two component
    environments:

    1.  GEnv -- global variables and their values
    2.  FEnv -- functions and their definitions

    An expression-level adds another component environment:

    3.  PEnv -- parmeters of the active function call

    This provides separate name spaces for global variables, function
    names, and parameter names. A variable reference first checks
    the parameter environment and then the global environment, so
    a name in the parameter environment hides the same name in the
    global environment.
-}

type GEnv    = AnEnv ValType       -- global variable environment
type FEnv    = AnEnv ([Name],Expr) -- function environment
type PEnv    = AnEnv ValType       -- parameter environment

type DEnv    = (GEnv,FEnv)         -- definition-level environment
type Env     = (GEnv,FEnv,PEnv)    -- expression-level environment


{-  Function "showDEnv" takes a definition environment and returns
    a string of its contents suitable for display.
-}

showDEnv :: DEnv -> String
showDEnv (genv,fenv) =
    "\nGlobal Variables\n" ++ showGEnv (toList genv) ++
    "\nFunctions       \n" ++ showFEnv (toList fenv) ++ "\n"

showGEnv :: GEnv -> String
showGEnv genv =
    concatMap
        (\(n,v) -> n ++ "\t" ++ show v ++ "\n")
        (toList genv)

showFEnv :: FEnv -> String
showFEnv fenv =
    concatMap
        (\(n,(ps,be)) -> n ++ "\t" ++ "(" ++
            intercalate "," ps ++ ")\t" ++ show be ++"\n")
        (toList fenv)


{-  The top-level definition evaluation functions return values of
    type Either EvalErr Result.  Elements of type Result consist of
    three values the actual ValType result of evaluation, if any,
    an ActionD flag that recordes the type of change made to the
    Definition Environment (DEnv), and the name of the newly defined
    variable or function, if any.
-}

type EvalErr = String

data ActionD = ValD   -- val (global variable) declaration
             | FunD   -- function declaration
--           | UseD   -- file use  -- moved to REPL command
             | ExprD  -- top-level expression 
             | NoActD -- no result
               deriving (Eq, Show)

data Result = Result ValType ActionD Name
              deriving (Eq, Show)


{-  Function "newDEnv" creates a new definition-level environment
    DEnv. It sets the global variable Name denoted by "lastVal" to
    the ValType denoted by "defaultVal", but otherwise the
    environment is empty.
-}

lastVal :: Name
lastVal = "it"

newDEnv :: DEnv
newDEnv = (newBinding lastVal defaultVal newEnv, newEnv)

{-  Function "evalScript" takes a list of definitions and a
    definition-level environment and then evaluates the definitions
    sequentialy from left to right (i.e., from the head of the
    list toward the tail) beginning in the input environment.
    It returns a Result and a copy of the defintion-level environment
    updated appropriately for the list of definitions.
-}

evalScript :: [Def] -> DEnv -> (Either EvalErr Result, DEnv)
evalScript ds denv =
    let seqeval (Right _, env1) def = evalDef def env1
        seqeval errRes          _   = errRes
    in  foldl seqeval (Right (Result defaultVal NoActD ""), denv) ds

 
{-  Function "evalDef" takes a definition and a definition-level
    environment, evaluates the definition in the input environment,
    and returns a Result and a copy of the defintion-level environment
    updated appropriately.
-}

evalDef :: Def -> DEnv -> (Either EvalErr Result, DEnv)

-- Define a new global variable
evalDef (Val n e) denv@(genv,fenv) =
    case getBinding n genv of
        Just _  ->  -- n already defined
            ( Left ("Attempt to redefine global variable: " ++ n),
              denv )
        Nothing ->  -- define variable n with initial value e
            let (rres,(rgenv,_,_)) = evalExpr e (genv,fenv,newEnv)
            in  case rres of
                Right rval -> ( Right (Result rval ValD n),
                                (newBinding n rval rgenv, fenv) )
                Left err   -> ( Left err, denv )
                               
-- Define a new function
evalDef (Define fn fs e) denv@(genv,fenv) =
    case getBinding fn fenv of
        Just _  ->  -- n already defined
           ( Left ("Attempt to redefine function: " ++ fn),
             denv )
        Nothing ->  -- define function n
            ( Right (Result defaultVal FunD fn),
              (genv, newBinding fn (fs,e) fenv) )

-- Moved to REPL command
-- -- Use a file
-- evalDef (Use n) denv = ( Right (Result defaultVal UseD n), denv )
                      
-- Evaluate a top-level expression. Bind its value to "lastVal".
evalDef (Top e) denv@(genv,fenv) =
    let (res, (genv',_,_)) = evalExpr e (genv,fenv,newEnv)
    in  case res of
        Right v ->
            case getBinding lastVal genv' of
                Just _  -> ( Right (Result v ExprD ""),
                             (setBinding lastVal v genv', fenv) )
                Nothing -> ( Right (Result v ExprD ""),
                             (newBinding lastVal v genv', fenv) )
        Left err -> (Left err, denv)


{-  Function "evalExpr" takes an expression and an expression-level
    environment, evaluates the expression in the input
    environment, and returns a pair containing the Result
    and an appropriately updated expression-level environment.

    Most expressions consist of subexpressions. A subexpression can
    be a Set expression or some other expression that modifies the
    environment. Thus, it is important to evalExpruate the
    subexpressions in the correct order and in the appropriately
    updated environments.
-}

evalExpr :: Expr -> Env -> (Either EvalErr ValType,Env)

-- For a Lit, unwrap the literal value and return it and the
-- unmodified environment.

evalExpr (Lit v) env = ( Right v, env )

-- For a Var, retrieve the variable value from the parameter
-- environment, if defined there, or from the global environment
-- otherwise. Return the value and the unmodified environment.

evalExpr (Var n) env@(genv,_,penv) =
    case getBinding n penv of
      Just v  -> ( Right v, env )  -- formal parameter
      Nothing ->
          case getBinding n genv of
              Just v  -> ( Right v, env ) -- global
              Nothing ->
                ( Left ("Attempt to reference an undefined variable: "                         ++ n), env )


-- For a numeric primitive binary operator, evaluate the operands
-- and return the result of applying the operator to the
-- operand values and the updated environment.

evalExpr (Add l r) env = evalBinArith (+)   l r env
evalExpr (Sub l r) env = evalBinArith (-)   l r env
evalExpr (Mul l r) env = evalBinArith (*)   l r env
evalExpr (Div l r) env = evalBinArith (div) l r env

-- For a primitive relational operator, evaluate the operands
-- and return the result of applying the operator to the
-- operand values and the updated environment.

evalExpr (Eq  l r) env = evalBinRel (==) l r env
evalExpr (Lt  l r) env = evalBinRel (<)  l r env
evalExpr (Gt  l r) env = evalBinRel (>)  l r env

-- For the primitive print operator, evaluate the operand and print
-- its value. Return the operand value and the updated environment.
-- Note: Uses an impure output operation via "unsafePerformIO".

evalExpr (Print e) env =
    let (pres,penv) = evalExpr e env
    in  case pres of
        Right pval -> (unsafePerformIO (putStrLn (show pval)))
                      `seq` (Right pval,penv)
        l@(Left _) -> ( l, env )

-- For If, evaluate the condition expression and then evaluate either
-- the "then" expression or the "else" expression depending upon
-- result. Return the result and the updated environment.

evalExpr (If ce te ee) env =
    let (cres,cenv) = evalExpr ce env
    in case cres of
        Right cval | valToBool cval -> evalExpr te cenv
        Right _                     -> evalExpr ee cenv
        l@(Left _)                  -> ( l, env )

-- For While, evaluate the termination condition. If false, return 0
-- and the updated environment; otherwise, evaluate the body
-- expression and then repeat the While.

evalExpr wh@(While ce be) env =
    let (cres,cenv) = evalExpr ce env
    in  case cres of
        Right cval | valToBool cval ->
            let (bres,benv) = evalExpr be cenv
            in  case bres of
                Right _    -> evalExpr wh benv
                l@(Left _) -> ( l, cenv )
        Right cval -> ( Right defaultVal, cenv )
        l@(Left _) -> ( l, env )

-- For Begin, evaluate the expressions in the list from left to right
-- for their side effects and return the value of last experession and
-- the updated environment. For an empty list, return the "defaultVal"
-- and the unmodified environment.

evalExpr (Begin es) env =
    let seqeval (Right _,env1) e = evalExpr e env1
        seqeval errRes         _ = errRes
    in  foldl seqeval (Right defaultVal,env) es


-- For epplications of user-defined functions, evaluate the arguments
-- from left to right and bind these into a new parameter environment,
-- evaluate the body expression in the possibly modified global
-- environment and new parameter environment. (Any previous parameters
-- are not accessible.) Return the value of the body expression and
-- the updated environment.

evalExpr (Apply fn args) env@(genv,fenv,penv) =
    case getBinding fn fenv of
        Just (parms,be) | length args == length parms ->
            let (parmres,(genv',_,penv')) = evalExprList args env
            in  case parmres of
                Right ps ->
                    let localpenv = bindList (zip parms ps) newEnv
                        (bres, (genv'',_,_)) =
                            evalExpr be (genv',fenv,localpenv)
                    in  case bres of
                        Right bval ->
                            ( Right bval, (genv'',fenv,penv') )
                        l@(Left _) -> ( l, env )
                Left err -> ( Left err, env )
        Just _  ->
            ( Left ("Function called with wrong number of args: "
                    ++ fn), env )
        Nothing ->
            ( Left ("Attempt to call undefined function: " ++ fn),
              env )

-- For Set, first check whether the target value is defined in either
-- the parameter environment or the global environment (or both).
--
-- If not defined, this expression fails.
--
-- If defined, then evaluate the right-hand-side expression in the
-- input environment and bind its value to the parameter, if defined,
-- or to the global variable otherwise in the modified
-- environment. Note that the right-hand-side expression may contain
-- nested Set expressions or other expressions with side effects.
--
-- Return the value of the right-hand-side and the updated
-- environment.

evalExpr (Set n e) env@(genv,fenv,penv) =
   case getBinding n penv of
       Just _  ->  -- n in penv
           let (rres, (rgenv,_,rpenv)) = evalExpr e env
           in  case rres of
               Right rval -> ( Right rval,
                               (rgenv,fenv,setBinding n rval rpenv) )
               l@(Left _) -> ( l, env )
       Nothing ->
           case getBinding n genv of
               Just _  ->  -- n in genv
                   let (rres, (rgenv,_,rpenv)) = evalExpr e env
                   in  case rres of
                       Right rval ->
                           ( Right rval,
                             (setBinding n rval rgenv,fenv,rpenv) )
                       l@(Left _) -> ( l, env )
               Nothing -> 
                 ( Left ("Attempt to assign undefined variable: "
                         ++ n), env )


{-  Function "evalBinArith" takes a binary arithmetic function,
    its two operand expressions, and an environment, evaluates
    the operands from left to right, and applies the function
    to the operand values. It then returns the resulting value
    and the modified environment.
-}

evalBinArith :: (ValType -> ValType -> ValType) -> Expr -> Expr -> Env
               -> (Either EvalErr ValType, Env)
evalBinArith aop l r env =
    let (lres,lenv) = evalExpr l env
    in  case lres of
        Right lval ->
            let (rres,renv) = evalExpr r lenv
            in  case rres of
                Right rval -> ( Right (aop lval rval), renv )
                l@(Left _) -> ( l, env )
        l@(Left _) -> ( l, env )


{-  Function "evalBinRel" takes a binary Boolean function,
    its two operand expressions, and an environment, evaluates
    the operands from left to right, and applies the function
    to the operand values. It then returns the resulting Boolean
    value (encoded as a ValType) and the updated environment.
-}

evalBinRel :: (ValType -> ValType -> Bool) -> Expr -> Expr -> Env
               -> (Either EvalErr ValType,Env)
evalBinRel bop l r env =
    let (lres,lenv) = evalExpr l env
    in  case lres of
        Right lval ->
            let (rres,renv) = evalExpr r lenv
            in  case rres of
                Right rval -> ( Right (boolToVal (bop lval rval)),
                                renv )
                l@(Left _) ->  ( l, env )
        l@(Left _) -> ( l, env )


{-  Function "evalExprList" takes a list of expressions and an
    environment and evaluates the expressions from left to right.
    It returns the list of results and the updated environment.

    Note: Uses scanl and rigts, perhaps for the first times.
-}

evalExprList :: [Expr] -> Env -> (Either EvalErr [ValType],Env)
evalExprList es env =
    let seqeval (Right _,env1)  e = evalExpr e env1
        seqeval (Left err,env1) _ = ( Left err, env1 )
        esres   = scanl seqeval (Right defaultVal,env) es
        lastres = last esres
        lastenv = snd  lastres
    in  case lastres of
        (Right _, _)  ->
            ( Right (rights (map fst (tail esres))), lastenv )
        (Left err, _) ->
            ( Left err, env )