----------------------------------------------------------------------------
-- |
-- Module      :  CSPM.Interpreter.Eval
-- Copyright   :  (c) Fontaine 2009
-- License     :  BSD
-- 
-- Maintainer  :  Fontaine@cs.uni-duesseldorf.de
-- Stability   :  experimental
-- Portability :  GHC-only
--
-- The main eval function of the Interpreter.
--
----------------------------------------------------------------------------
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE BangPatterns #-}
module CSPM.Interpreter.Eval
(
  eval
 ,getAllEvents
 ,processDeclList
 ,runEM
 ,evalOutField
 ,evalFieldSet
 ,evalProcess
)
where

import qualified CSPM.CoreLanguage as Core

import Language.CSPM.AST as AST hiding (Bindings)
import qualified Language.CSPM.Frontend as Frontend

import CSPM.Interpreter.Types as Types
import CSPM.Interpreter.Bindings as Bindings
import CSPM.Interpreter.PatternMatcher
import CSPM.Interpreter.Hash as Hash
import CSPM.Interpreter.SSet as SSet
import CSPM.Interpreter.ClosureSet as ClosureSet
import CSPM.Interpreter.Renaming as Renaming

import Data.Digest.Pure.HashMD5 as HashClass

import Control.Arrow
import qualified Control.Monad.Reader as Reader
import Control.Monad.RWS.Lazy as RWS hiding (guard)
import Control.Monad hiding (guard)
import Data.Ord
import Data.List as List
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.List as List
import Debug.Trace

-- | Evaluate an expression in an envirionment.
runEval :: Env -> AST.LExp -> Value
runEval env expr = runEM (eval expr) env

-- | Run the 'EM' monad with a given envirionment.
runEM  :: EM x -> Env -> x
runEM action env = Reader.runReader (unEM action) env

runEnv :: Env -> EM x -> x
runEnv env action = Reader.runReader (unEM action) env

{- todo : check whether the order of the cases influences efficency. -}

-- | Evaluate an expression in the 'EM' monad.
eval :: LExp -> EM Value
eval expr = case unLabel expr of
  Var v -> lookupIdent v
  IntExp i -> return $ VInt i
  SetEnum s -> do
    l <- mapM eval s
    return $ VSet $ Set.fromList l
  ListEnum l -> mapM eval l >>= return . VList
  SetOpen _  -> throwFeatureNotImplemented "open sets" $ Just $ srcLoc expr
  ListOpen s -> do
  -- todo : this can easily give non-termination
  -- maybe use an enumerator here ?
    x <- evalInt s
    return $ VList $ map VInt [x..]
  SetClose (a,b) -> do
    s <- evalInt a
    e <- evalInt b
    return $ VSet $ Set.fromList $ map VInt [s..e]
  ListClose (a,b) -> do
    s <- evalInt a
    e <- evalInt b
    return $ VList $ map VInt [s..e]
  SetComprehension (el,comps) -> do
    l <- evalSetComp ret comps 
    return $ VSet l
    where ret = mapM eval el >>= return . Set.fromList
  ListComprehension (el, comps) -> do
    l <- evalListComp (mapM eval el) comps
    return $ VList l
  ClosureComprehension (el, comps) -> do
    l <- evalListComp (mapM eval el) comps
    ClosureSet.mkEventClosure l >>= return . VClosure
  LetI decls freenames e -> do
    env <- getEnv
    let digest = closureDigest expr env freenames
    return $ runEval (processDeclList digest env decls) e
  Ifte cond t e -> do
    c <- evalBool cond
    if c then eval t else eval e
  CallFunction fkt args -> do
    f <- eval fkt
    parameter <- mapM eval $ concat args
    functionCall f parameter
  CallBuiltIn bi [[e]] -> builtIn1 bi e
  CallBuiltIn bi [[a,b]] -> builtIn2 bi a b
  CallBuiltIn _ _
    -> throwScriptError "calling builtIn with worng number of args"
         (Just $ srcLoc expr) Nothing
  Lambda {} -> throwInternalError "not expection Constructor Lambda"
                 (Just $ srcLoc expr) $ Nothing
  LambdaI freeNames patL body -> do
    env <- getEnv
    return $ VFun $ FunClosure {
       getFunCases = [FunCaseI patL body]
      ,getFunEnv = env
      ,getFunArgNum = length patL
      ,getFunId = closureDigest expr env freeNames
      }
  Stop -> return  $ VProcess $ Core.stop
  Skip -> return  $ VProcess $ Core.skip
  CTrue  -> return $ VBool True
  Events -> liftM VClosure evalAllEvents
  CFalse -> return $ VBool False
  BoolSet -> return $ VSet $ Set.fromList [VBool True,VBool False]
{-
  many prob test contain unboundet INT
  IntSet -> return $ VAllInts
-}
  IntSet -> return $ VSet $ Set.fromList $ map VInt [0..100]
  TupleExp l -> mapM eval l >>= return . VTuple
  Parens e -> eval e
  AndExp a b -> do
    av <- evalBool a
    if av then eval b else return $ VBool False
  OrExp a b -> do
    av <- evalBool a
    if av then return $ VBool True else eval b
  NotExp e -> evalBool e >>= return . VBool . not
  Fun1 bi e -> builtIn1 bi e
  Fun2 bi a b -> builtIn2 bi a b
  DotTuple l -> mapM eval l >>= return . VDotTuple . concatMap flatTuple
    where
      flatTuple (VDotTuple l ) = l
      flatTuple x = [x]
  Closure l -> mapM eval l >>= ClosureSet.mkEventClosure >>= return . VClosure
  ProcSharing s a b
   -> liftM3 Core.sharing
       (switchedOffProc a)
       (evalClosureExp s)
       (switchedOffProc b)
      >>= return . VProcess
  ProcAParallel aLeft aRight pLeft pRight
    -> liftM4 Core.aparallel
        (evalClosureExp aLeft)
        (evalClosureExp aRight)
        (switchedOffProc pLeft)
        (switchedOffProc pRight)
      >>= return . VProcess
  ProcLinkParallel l p q
    -> liftM3 Core.linkParallel
        (evalLinkList l)
        (switchedOffProc p)
        (switchedOffProc q)
       >>= return . VProcess
  ProcRenaming rlist gen proc -> do
    pairs <- case gen of
      Nothing -> mapM evalRenaming rlist
      Just gen -> evalListComp (mapM evalRenaming rlist ) $ unLabel gen
    p <- switchedOffProc proc
    return $ VProcess $ Core.renaming (toRenaming pairs) p
    where
      evalRenaming :: LRename -> EM (Value,Value)
      evalRenaming (unLabel -> Rename a b) = liftM2 (,) (eval a) (eval b)
  ProcRepSequence comp p
    -> evalProcCompL p comp >>= return . VProcess . Core.repSeq
  ProcRepInternalChoice comp p
    -> evalProcCompS p comp >>= return . VProcess . Core.repInternalChoice
  ProcRepExternalChoice comp p
    -> evalProcCompS p comp >>= return . VProcess . Core.repExternalChoice
  ProcRepInterleave comp p
    -> evalProcCompS p comp >>= return . VProcess . Core.repInterleave
  ProcRepAParallel comp c p
    -> evalListComp ret (unLabel comp) 
         >>= return . VProcess . Core.repAParallel
    where ret = do { x <- evalClosureExp c; y <- switchedOffProc p; return [(x,y)]}
  ProcRepLinkParallel comp link p
    -> liftM2 Core.repLinkParallel
        (evalLinkList link)
        (evalProcCompL p comp)
       >>= return . VProcess
  ProcRepSharing comp closure p -> do
    l <- evalProcCompS p comp
    c <- evalClosureExp closure
    return $ VProcess $ Core.repSharing c l
  PrefixI free chan fields body -> do
    env <- getEnv 
    return $ VProcess $ Core.prefix $ PrefixState {
        prefixEnv = env
       ,prefixFields = chanOut:fields
       ,prefixBody = body
       ,prefixRHS = throwInternalError "prefixRHS undefiend" (Just $ srcLoc expr) Nothing
       ,prefixDigest = closureDigest body env free
       ,prefixPatternFailed = False
     }
      where chanOut = setNode chan $ OutComm chan
  ExprWithFreeNames body en
    -> throwInternalError "didn't expect ExprWithFreeNames" (Just $ srcLoc expr) Nothing
  _ -> throwFeatureNotImplemented "hit catch-all case of eval function"
         $ Just $ srcLoc expr 

evalBool :: LExp -> EM Bool
evalBool e = do
  v <- eval e
  case v of
    VBool b -> return b
    _  -> throwTypingError "expecting type Bool" (Just $ srcLoc e) $ Just v


evalInt :: LExp -> EM Integer
evalInt e = do
  v <- eval e
  case v of
    VInt b -> return b
    _ -> throwTypingError "expecting type Integer" (Just $ srcLoc e) $ Just v

evalList :: LExp -> EM [Value]
evalList e = do
  v <- eval e
  case v of
    VList l -> return l

--  used in mydemos/SimpleRepAlphParallel.csp SYSTEM
    VDataType l -> return $ map VConstructor l

--  because of a hack in RepAParalle
    VSet l -> return $ Set.toList l
--  because of a hack in evalProcCompS
    VClosure c -> return $ Set.toList $ closureToSet c

    _ -> throwTypingError "expecting type List" (Just $ srcLoc e) $ Just v

setFromValue :: Value -> EM (Set Value)
setFromValue v = case setFromValueM v of
  Just l -> return l
  Nothing -> throwTypingError "expecting type Set" Nothing $ Just v

evalSet :: LExp -> EM (Set Value)
evalSet e = do
  v <- eval e
  case setFromValueM v of
    Just l -> return l
    Nothing -> throwTypingError "expecting type Set" (Just $ srcLoc e) $ Just v

setFromValueM :: Value -> Maybe (Set Value)
setFromValueM v = case v of
  VSet l -> Just l
  VClosure c -> Just $ closureToSet c
  VDataType l -> Just $ Set.fromList  --used in basin_olderog_bank.csp
                     $ map VConstructor l
  _ -> Nothing

evalProcess :: LExp -> EM Process
evalProcess e = do
  v <- eval e
  case v of
    VProcess p -> return p
    _  -> throwTypingError "expecting type Process" (Just $ srcLoc e) $ Just v

evalClosureExp :: LExp -> EM ClosureSet
evalClosureExp e = do
  v <- eval e
  case v of
    VClosure x -> return x
--    VAllEvents -> evalAllEvents
    VSet s -> return $ setToClosure s
    _ -> throwTypingError "expecting type Event-Closure" (Just $ srcLoc e) $ Just v

listFromValue :: Value -> EM [Value]
listFromValue (VList l) = return l
listFromValue v = throwTypingError "expecting type List" Nothing $ Just v

processFromValue :: Value -> EM Process
processFromValue (VProcess p) = return p
processFromValue v = throwTypingError "expecting type Process" Nothing $ Just v

builtIn1 :: LBuiltIn -> LExp -> EM Value
builtIn1 op expr 
  = case lBuiltInToConst op of
    F_Seq -> evalSet expr >>= return . VAllSequents
    F_card -> do
      s <- evalSet expr
      return $ VInt $ fromIntegral $ Set.size s
    F_empty  -> evalSet expr >>= return . VBool . Set.null
    F_head   -> do
      l <- evalList expr
      case l of
        [] -> throwScriptError "head of empty list" (Just $ srcLoc expr) Nothing
        h:_tail -> return h
    F_tail   -> do
      l <- evalList expr
      case l of
        [] -> throwScriptError "tail of empty list" (Just $ srcLoc expr) Nothing
        _head:rest -> return $ VList rest
    F_length -> evalList expr >>= return . VInt . fromIntegral . List.length
    F_Len2   -> evalList expr >>= return . VInt . fromIntegral . List.length
    F_Union -> do
      s <- evalSet expr 
      setList <- mapM setFromValue $ Set.elems s
      return $ VSet $ Set.unions setList
    F_Inter  -> do
      s <- evalSet expr 
      setList <- mapM setFromValue $ Set.elems s
      case setList of
        [] ->  throwScriptError "intersection of empty set of sets" 
                  (Just $ srcLoc expr) Nothing
        l  -> return $ VSet $ List.foldl1' Set.intersection l
    F_set    -> evalList expr >>= return . VSet . Set.fromList
    F_Set    -> do
      s <- evalSet expr
      return $ VSet $ Set.fromList $ map (VSet . Set.fromList ) 
        $ List.subsequences $ Set.toList s
    F_concat -> do
      l <- evalList expr >>= mapM listFromValue
      return $ VList $ List.concat l
    F_null -> do
      l <- evalList expr
      return $ VBool (List.null l)
    F_CHAOS -> liftM (VProcess . Core.chaos) $ evalClosureExp expr
    c -> throwInternalError "malformed AST1" (Just $ srcLoc expr) Nothing

builtIn2 :: LBuiltIn -> LExp -> LExp -> EM Value
builtIn2 op a b =
  case lBuiltInToConst op of
    F_union  -> setOp Set.union
    F_inter  -> setOp Set.intersection
    F_diff   -> setOp Set.difference
    F_member -> do
      av <- eval a
      s <- evalSet b
      return $ VBool $ Set.member av s
    F_Seq    -> throwFeatureNotImplemented "builtIn2 FSeq" Nothing
    F_elem   -> do
      av <- eval a
      l  <- evalList b
      return $ VBool $ List.elem av l
    F_Concat -> do
      x <- evalList a
      y <- evalList b
      return $ VList $ x ++y
    F_Mult   -> intOp (*)
    F_Div    -> intOp div
    F_Mod    -> intOp mod
    F_Add    -> intOp (+)
    F_Sub    -> intOp (-)
    F_Eq     -> do
      x <- eval a
      y <- eval b
      return $ VBool (x == y)
    F_NEq    -> do
      x <- eval a
      y <- eval b
      return $ VBool (x /= y)
    F_GE     -> intCmp (>=)
    F_LE     -> intCmp (<=)
    F_LT     -> intCmp (<)
    F_GT     -> intCmp (>)
    F_Sequential -> procOp Core.seq
    F_Interrupt  -> procOp Core.interrupt
    F_ExtChoice  -> do
      x <- switchedOffProc a
      y <- switchedOffProc b
      return $ VProcess $ Core.externalChoice x y
    F_Timeout    -> procOp Core.timeout
    F_IntChoice  -> do
      x <- switchedOffProc a
      y <- switchedOffProc b
      return $ VProcess $ Core.internalChoice x y
    F_Interleave -> do
      x <- switchedOffProc a
      y <- switchedOffProc b
      return $ VProcess $ Core.interleave x y
    F_Hiding -> do
      proc <- switchedOffProc a
      hidden <- evalClosureExp b
      return $ VProcess $ Core.hide hidden proc
    F_Guard -> do
      cond <- evalBool a
      if cond then liftM VProcess $ switchedOffProc b
              else return $ VProcess Core.stop
    c -> throwInternalError "malformed AST2" Nothing Nothing
  where
    intOp :: (Integer -> Integer -> Integer) -> EM Value
    intOp o = do
      x <- evalInt a
      y <- evalInt b
      return $ VInt $ o x y
    intCmp :: (Integer -> Integer -> Bool) -> EM Value
    intCmp rel = do
      x <- evalInt a
      y <- evalInt b
      return $ VBool $ rel x y
    setOp :: (Set Value -> Set Value -> Set Value) -> EM Value
    setOp o = do
      x <- evalSet a
      y <- evalSet b
      return $ VSet $ o x y
    procOp :: (Process -> Process -> Process) -> EM Value
    procOp o = do
      x <- switchedOffProc a
      y <- switchedOffProc b
      return $ VProcess $ o x y

type DeclM x = RWS (Digest,Env) () (Bindings, IntMap.IntMap Digest) x
 
processDeclList :: Digest -> Env -> [LDecl] -> Env
processDeclList digest oldEnv decls =
-- todo :: really do a lot of testing that we do not end in a loop here
  let
    ((),(newBinds,newDigests),()) = runRWS action (digest,newEnv) 
       (getLetBindings oldEnv, letDigests oldEnv)
    action = mapM_ processDecl decls
    newEnv = oldEnv { letBindings = newBinds, letDigests = newDigests}
  in newEnv

bindIdentM :: LIdent -> Value -> DeclM ()
bindIdentM i v = do
  d <- asks fst
  modify $ \(values,digests) ->
    (bindIdent i v values
    ,IntMap.insert (identId i) (HashClass.mixInt d $ identId i) digests)

processDecl :: LDecl -> DeclM ()
processDecl decl = do 
  case unLabel decl of
    PatBind pat expr -> do
      finalEnv <- asks snd
      let rhs = runEval finalEnv expr  -- evaluate the righthand side
      modify $ first $ \oldBinds -> tryMatchLazy oldBinds pat rhs
      digest <- asks fst
      forM_ (boundNames pat) $ \i -> modify $ second
        $ IntMap.insert (identId i) (HashClass.mixInt digest $ identId i)
    FunBind i cases -> do
        finalEnv <- asks snd
        digest <- asks fst
        bindIdentM i $ VFun $ FunClosure {
          getFunCases = cases 
         ,getFunEnv = finalEnv
         ,getFunArgNum = length $ (\(FunCaseI pl _) -> pl) $ head cases
         ,getFunId  = mixInt digest $ AST.unNodeId $ AST.nodeId decl
         }
  -- Just Ignore
    AssertRef _ _ _  -> return ()
    AssertBool _ -> return ()
    Transparent names ->  forM_ names $ \n -> bindIdentM n cspIdentityFunction
    SubType _ _ -> throwFeatureNotImplemented "subtype declarations" $ Just $ srcLoc decl
    DataType tname constrList -> do
       constrs <- mapM constrDecl constrList
       bindIdentM tname (VDataType constrs )
    NameType tname t -> do
      finalEnv <- asks snd
      bindIdentM tname (VNameType $ runEnv finalEnv $ evalTypeDef t)
    Print _expr -> return ()
    AST.Channel idList t -> do
      finalEnv <- asks snd
      forM_ idList $ \i -> bindIdentM i $ VChannel $ Types.Channel {
              chanId = AST.uniqueIdentId $ AST.unUIdent $ unLabel i
             ,chanName = AST.realName $ AST.unUIdent $ AST.unLabel i
             ,chanLen = case t of
                Nothing -> 1
                Just t -> case unLabel t of
                  TypeTuple l -> 2
                  TypeDot l  -> length l +1
             ,chanFields = case t of
                Nothing -> []
                Just l -> runEnv finalEnv $ evalTypeDef l
             }

constrDecl :: LConstructor -> DeclM Types.Constructor
constrDecl (unLabel -> AST.Constructor ident td) = do
  finalEnv <- asks snd
  let
    cl = case td of
      Nothing -> []
      Just l -> runEnv finalEnv $ evalTypeDef l

    constr = Types.Constructor
               (AST.uniqueIdentId $ AST.unUIdent $ unLabel ident)
               (AST.realName $ AST.unUIdent $ unLabel ident)
               cl 
  bindIdentM ident $ VConstructor constr
  return constr

evalTypeDef :: LTypeDef -> EM [FieldSet]
evalTypeDef t = case unLabel t of
  TypeDot l  -> mapM evalFieldSet l
  TypeTuple l -> do
    el <- mapM evalFieldSet l
    -- cross-product
    return [SSet.fromList $ map VTuple $ sequence $ map SSet.toList el]

evalFieldSet :: LExp -> EM FieldSet
evalFieldSet expr = do
  v <- eval expr
  case v of
    VInt {} -> return $ SSet.singleton v
    VChannel {} -> return $ SSet.singleton v
    VSet s -> return $ SSet.Proper s
-- todo : fixthis when we have ClosureExpressions
-- todo: this does not work for constructors that have fields
    VDataType constrList -> return $ SSet.fromList $ map VConstructor constrList
    VAllInts -> return $ SSet.fromList $ map VInt [0..10] --todo
    _ -> throwTypingError "valueToEventSet " (Just $ srcLoc expr) $ Just v

switchedOffProc :: LExp -> EM Process
switchedOffProc (unLabel -> ExprWithFreeNames free expr) = do
  env <- getEnv
  return $ Core.switchedOff $ SwitchedOffProc {
    switchedOffDigest = (closureDigest expr env free)
   ,switchedOffExpr = expr
   ,switchedOffProcess = runEM (evalProcess expr) env
   }
switchedOffProc exp
 = throwInternalError "cannot determine free variables" (Just $ srcLoc exp) Nothing

evalOutField :: LExp -> EM Field
evalOutField expr = do
  v <- eval expr
  case v of
    VInt {} -> return v
    VChannel {} -> return v
    VConstructor {} -> return v
    VTuple {} -> return v 
    VDotTuple {} -> return v -- todo : fix for genric buffers
    VBool {} -> return v
{-
todo: support lists and sets as channel fields
write test for VSet and VList
-}
    VSet {} -> return v
    VList {} -> return v        

    _ -> throwTypingError "Eval.hs : evalOutField" (Just $ srcLoc expr) $ Just v


{- redo this: most procComprehensions work on sets ! -}
evalProcCompL :: LExp -> LCompGenList -> EM [Process]
evalProcCompL p comp = evalListComp ret $ unLabel comp
  where
    ret = do
      r <- switchedOffProc p
      return [r]

{-
fdr does not remove duplicates from replicatesProc compostions 
see examples/CSP/FDRFeatureTests/ReplicatedInterleaveSetDef.csp
-}
evalProcCompS :: LExp -> LCompGenList -> EM [Process]
evalProcCompS = evalProcCompL
{-
evalProcCompS p comp
  =     (evalSetComp ret $ unLabel comp)
    >>= (mapM processFromValue) . Set.toList
  where
{- we intermediatley wrap processes with VProcess 
if we make evalSetComp polymorphic we get the following error
src/Language/CSPM/Interpreter/Eval.hs:536:0:
    Contexts differ in length
      (Use -XRelaxedPolyRec to allow this)
-}
    ret = switchedOffProc p >>= return . Set.singleton . VProcess 
-}

evalListComp :: EM [x] -> [LCompGen] -> EM [x]
evalListComp ret [] = ret
evalListComp ret (h:t) = case unLabel h of
  Guard g -> do
    b <- evalBool g
    if b then evalListComp ret t
         else return []
  Generator pat gen -> do
    list <- evalList gen
    rets <- mapM (evalCompPat pat) list
    return $ concat rets
  where
    evalCompPat pat val = do
      e <- getEnv
      case tryMatchStrict (getArgBindings e) pat val of
        Nothing -> return []
        Just newBinds 
          -> return $ runEM
               (evalListComp ret t) 
               (setArgBindings e newBinds)

evalSetComp :: EM (Set Value) -> [LCompGen] -> EM (Set Value)
evalSetComp ret [] = ret
evalSetComp ret (h:t) = case unLabel h of
    Guard g -> do
      b <- evalBool g
      if b then evalSetComp ret t
           else return Set.empty
    Generator pat gen -> do
      set <- evalSet gen
      rets <- mapM (evalCompPat pat) $ Set.elems set
      return $ Set.unions rets
    where
      evalCompPat pat val = do
        e <- getEnv
        case tryMatchStrict (getArgBindings e) pat val of
          Nothing -> return Set.empty
          Just newBinds 
            -> return $ runEM
                 (evalSetComp ret t) 
                 (setArgBindings e newBinds)

evalAllEvents :: EM ClosureSet
evalAllEvents = do
  channels <- lookupAllChannels
  ClosureSet.mkEventClosure $ map VChannel channels

getAllEvents :: Env -> ClosureSet
getAllEvents = runEM evalAllEvents

cspIdentityFunction :: Value
cspIdentityFunction = VFun $ FunClosure {
   getFunCases = [funCase]
  ,getFunEnv = emptyEnvirionment
  ,getFunArgNum = 1
  ,getFunId = Hash.hash "cspIdentityFunction"
  }
  where
    funCase = FunCaseI [ labeled $ VarPat someId] (labeled $ Var someId)
    someId = labeled $ UIdent $ UniqueIdent {
      uniqueIdentId = -1
     ,bindingSide = e
     ,bindingLoc = e
     ,idType = e
     ,realName = e
     ,newName = e
     ,prologMode = e
     ,bindType = NotLetBound }
    e = throwInternalError "use identityFunction magic constants" Nothing Nothing

evalLinkList :: LLinkList -> EM RenamingRelation
evalLinkList l = case unLabel l of
  LinkList x -> liftM toRenaming $ mapM evalLink x
  LinkListComprehension gen links
    -> liftM toRenaming $ evalListComp (mapM evalLink links ) gen
  where
    evalLink :: LLink -> EM (Value,Value)
    evalLink (unLabel -> Link a b) = liftM2 (,) (eval a) (eval b)

functionCall :: Value -> [Value] -> EM (Value)
functionCall v arguments = case v of
  VFun fkt -> callFkt fkt arguments
  VPartialApplied fkt oldArgs -> callFkt fkt (oldArgs ++ arguments)
  f -> throwTypingError "calling non-function" Nothing $ Just f
  where
    tryFunCases :: [FunCase] -> [Value] -> Env -> Value
    tryFunCases [] _ _ = throwPatternMatchError "no matching function case" Nothing
    tryFunCases ((FunCaseI parameter fktBody) : moreCases) args env =
      case matchList parameter args (getArgBindings env) of
        Just newBinds -> runEval (setArgBindings env newBinds) fktBody
        Nothing -> tryFunCases moreCases args env
    tryFunCases (FunCase {} : _) _ _
      = throwInternalError "not expecting FunCase-Constructor" Nothing Nothing

    matchList :: [LPattern] -> [Value] -> Bindings -> Maybe Bindings
    matchList patList valList env
      = foldM (\e (pat,val) -> tryMatchStrict e pat val) 
         env (zip patList valList)

{-
  going from
  callFkt fkt args = return $ tryFunCases (getFunCases fkt) args (getFunEnv fkt)
  to the version which supports partial application
  costs ca 17 % in the fibonacci -example
-}
    callFkt :: FunClosure -> [Value] -> EM Value
    callFkt fkt args
       = case compare haveArgs needArgs of
           EQ -> return $ tryFunCases (getFunCases fkt) args (getFunEnv fkt)
           GT -> do
             f2 <- callFkt fkt $ take needArgs args
             functionCall f2 $ drop needArgs args
           LT -> return $ VPartialApplied fkt args
       where
         haveArgs = length args
         needArgs = getFunArgNum fkt