module InterpreterMonadisch
where

import Parser

import Control.Monad
import Control.Monad.State
import Control.Applicative ((<*>),(<$>))
import Text.ParserCombinators.Parsec (runParser)

import Data.List as List
import Data.Map as Map

main :: IO ()
main = do
  env <- runInterpreter program1
  putStrLn "environment after program execution:"
  print env
  
data Value
  = VInt Integer
  | VBool Bool
  deriving Show

type Env = Map String Value
type EvalM a = StateT Env IO a

initialEnv :: Env
initialEnv = Map.empty

eval :: Exp -> EvalM Value
eval expr = case expr of
  Sum a b -> do -- erste Schreibweise
    va <- evalInt a
    vb <- evalInt b
    return $ VInt $ va + vb
  Diff a b -> do
    va <- evalInt a
    vb <- evalInt b
    return $ VInt $ va - vb
  Prod a b -> fmap VInt $ liftM2 (*) (evalInt a) (evalInt b) --zweite Schreibweise
  Quot a b -> fmap VInt $ div <$> evalInt a <*> evalInt b --dritte Schreibweise 
  Neg a    -> do
    va <- evalInt a
    return $ VInt $ negate va
  Equal a b -> compareInts (==) a b -- vierte Schreibweise (mit Hilfsfunktion)
  NEqual a b -> compareInts (/=) a b
  Ident i -> do
    env <- get
    case Map.lookup i env of
      Just v -> return v
      Nothing -> error $ "undefined identifier" ++ show i
  Const a -> return $ VInt a
  where
    compareInts :: (Integer -> Integer -> Bool) -> Exp -> Exp -> EvalM Value
    compareInts fkt a b = do
      av <- evalInt a
      bv <- evalInt b
      return $ VBool $ fkt av bv

evalInt :: Exp -> EvalM Integer
evalInt e = do
  v <- eval e
  case v of
    VInt x -> return x
    _ -> throwTypeError

evalBool :: Exp -> EvalM Bool
evalBool e = do
  v <- eval e
  case v of
    VBool x -> return x
    _ -> throwTypeError

throwTypeError :: a
throwTypeError = error "typeError"

test1 :: String -> IO Value
test1 src = case runParser parseExp () "testInput" src of
  Right expr -> evalStateT (eval expr) initialEnv
  Left err -> error $ show err


{-
Ausfuehren von Statements
-}

execBlock :: SBlock -> EvalM ()
execBlock = mapM_ execStmt

execStmt :: Stmt -> EvalM ()
execStmt stmt = case stmt of
  Assign ident expr -> do
     val <- eval expr
     oldEnv <- get
     let newEnv = Map.insert ident val oldEnv
     put newEnv
--Assign geht noch compakter mit modify
  Print expr -> do
    val <- eval expr
    liftIO $ print val
--  Print expr -> eval expr >>= (liftIO . print) -- alternative Schreibweise
  While expr block -> execStmt $ If expr (block ++ [stmt]) Nothing
  If expr thenBlock elseBlock -> do
    cond <- evalBool expr
    if cond then execBlock thenBlock
            else case elseBlock of
              Nothing -> return ()
              Just sb -> execBlock sb

runInterpreter :: String -> IO Env
runInterpreter src = case runParser parsePrg () "testInput" src of
  Right prg -> execStateT (execBlock prg) initialEnv
  Left err -> error $ show err


program1 :: String
program1 = concat $ List.intersperse "\n" [
     "begin"
    ,"  let x=10;"
    ,"  let z=1;"
    ,"  while (x!=0) begin"
    ,"    print x;"
    ,"    let x=x-1;"
    ,"    let y=-(x+y)*z+4;"
    ,"    print y"
    ,"  end"
    ,"end."
    ]