module Eval4 where

-- ---------------------------------------------------------------------------
--
-- 4. Ausbaustufe: Zustandsmonade, Ausgabe, Eingabe, Fehlerbehandlung
-- 
-- ---------------------------------------------------------------------------

import Data.Map(Map)
import qualified Data.Map as Map

import Control.Monad.Identity
import Control.Monad.State.Strict
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.Error

import Opn

-- ---------------------------------------------------------------------------
--
-- The Abstract Syntax
--
-- ---------------------------------------------------------------------------

-- Simple types
type VarId = String
type ParamId = String

-- Expressions
data Expr = Var VarId
          | Lit Val
          | Read ParamId
          | UnOp UnOp Expr
          | BinOp BinOp Expr Expr          
          deriving (Read, Show)

-- Statements
data Stmt = Assign VarId Expr
          | If Expr [Stmt]
          | While Expr [Stmt]
          | Print Expr
          | Raise String
          | Handle [Stmt] Stmt
          deriving (Read, Show)

-- A Program
type Prog = [Stmt]

-- ---------------------------------------------------------------------------
--
-- The Semantics
--
-- ---------------------------------------------------------------------------

-- Our State model:
type SimpleState a = Map VarId a

initialState :: SimpleState Val
initialState = Map.empty

-- Output:
type Output = [String]

-- Environment (bindings):
type Env    = [(ParamId, Val)]

-- Errors:
data Exn = DivZero | UndefVar VarId | UndefParam ParamId | UserErr String

instance Error Exn where
  strMsg msg = UserErr msg

instance Show Exn where
  show DivZero        = "division by zero"
  show (UndefVar v)   = "undefined variable: `"++ v++ "'"
  show (UndefParam p) = "undefined parameter: `"++ p++ "'"
  show (UserErr msg)  = "user error: "++ msg

-- The evaluation monad:
type Val    = Integer
type Eval a = 
  ReaderT Env (WriterT Output (ErrorT Exn (StateT (SimpleState Val) Identity))) a
  -- Note errors need to be nested *inside* writer!

-- Runnin a program needs an environment, and produces a list of output messages
run :: Env-> Prog-> IO ()
run e p = do putStrLn "Program output:"
             case run' e p of 
               Left e -> putStrLn $ "+++ Uncaught exception: "++ show e
               Right m -> mapM_ putStrLn m

run' :: Env-> Prog-> Either Exn Output
run' e p = 
  let (a, s) = runIdentity (runStateT (runErrorT (execWriterT (runReaderT  (eval p) e))) initialState)
  in  s `seq` a -- force evaluation of the state iState

eval :: Prog -> Eval ()
eval s = forM_ s evalStmt

evalStmt :: Stmt-> Eval ()
evalStmt s = case s of 
  Assign v e -> do ev <- evalExpr e
                   s  <- get
                   put (Map.insert v ev s)
  If e s  -> do ev <- evalExpr e
                when (v2b ev) $ eval s
  While c b  -> Opn.fix (evalExpr c) (eval b)
  Print e -> do ev <- evalExpr e
                tell [show ev]
  Handle s h -> eval s `catchError` (\_ -> evalStmt h)
  Raise m -> throwError (UserErr m)

evalExpr :: Expr -> Eval Val
evalExpr e = case e of 
  Var v ->  do s <- get 
               case Map.lookup v s of
                 Just vv -> return vv
                 Nothing -> throwError $ UndefVar v
  Lit i -> return i
  Read p -> do e <- ask 
               case lookup p e of
                 Just i  -> return i
                 Nothing -> throwError $ UndefParam p
  BinOp b e1 e2 -> do v1 <- evalExpr e1
                      v2 <- evalExpr e2
                      when (b == Div && v2 == 0) $ throwError $ DivZero
                      return $ binOp b v1 v2
  UnOp o e -> do v<- evalExpr e
                 return $ unOp o v