Add evaluation of whole programs, typechecking functions and mainmain

5 files changed, 86 insertions, 30 deletions

diff --git a/app/Main.hs b/app/Main.hs
index de1c1ab..efe495b 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,6 +1,18 @@
 module Main where
 
-import Lib
+import Syntax
+import Typecheck
+import Eval
+import Control.Monad.Except
 
 main :: IO ()
-main = someFunc
+main = do
+  input <-getContents
+  let program = (read input)::Program 
+  case runExcept $ wfProgram program of
+    Left s -> print s
+    Right () ->
+      let (ret,state) = runProgram program in
+        case ret of
+          Left err-> print$ "Program finished with error" ++show err ++ "in state " ++ show state
+          Right _ -> print$  "Program finished by going to the end to state" ++ show state
diff --git a/src/Eval.hs b/src/Eval.hs
index 9047469..c454843 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -1,11 +1,13 @@
+{-# LANGUAGE TupleSections #-}
 module Eval
-  ()
+  (runProgram)
   where
 import Syntax
 import Typecheck ()
 
 import Control.Monad.State.Lazy
 import Control.Monad.Except
+import Control.Monad.Reader
 data Value = VInt Int
             | VRecord  [(Idnt,Value)]
             | VVariant Idnt Value
@@ -17,8 +19,11 @@ type Variables = [(Idnt,Value)]
 type Heap = (Int,[(Int,Value)])
 
 data ProgramState= ProgramState Variables Heap
+  deriving (Show)
+
+type EvalMonad = ReaderT [(Idnt,FuncDecl)] (ExceptT String (State ProgramState))
+--type EvalMonad = ExceptT String (State ProgramState)
 
-type EvalMonad = ExceptT String (State ProgramState)
 
 assertInt :: Value -> EvalMonad Int
 assertInt (VInt i) = return i
@@ -163,10 +168,10 @@ runCom (Save var expr) = do
     Just x -> return x
   put $ ProgramState vars (heapCnt,heap')
   get
-runCom (SMatch e cases) = do
+runCom c@(SMatch e cases) = do
   v <- evalExpr e
   (label,value) <- assertVar v
-  case lookup label (map (\(a,b,c)-> (a,(b,c)) )cases) of
+  case lookup label (map (\(a,b,c)-> (a,(b,c)) ) cases) of
     Just (bind,com) -> do
       st@(ProgramState vars heap) <- get
       put $ ProgramState ((bind,value):vars) heap
@@ -176,15 +181,38 @@ runCom (SMatch e cases) = do
       put $ ProgramState vars' heap
       get
     Nothing -> throwError $ "Unsupported label"++ show label ++ "in case" ++ show c
-runCom (FunctionCall var fname arugments) = undefined --TODO
-
-  
-  
-  
-  
-  
-  
-
-  
-
+runCom (FunctionCall var fname arguments) = do
+   funcs <- ask
+   case lookup fname funcs of
+     Nothing -> throwError "no such function defined"
+     Just (Func _ args locals body ret) ->do
+       (ProgramState vars heap) <- get
+       vargs <- mapM evalExpr arguments -- evaluate arguments
+       --evaluate local variables in new environment
+       put $ ProgramState (zip (map fst args) vargs) heap
+       vlocals <- mapM (\(var,expr) -> (var,) <$> evalExpr expr) locals
+       --evaluate function body and return in newer environment
+       (ProgramState vars' heap') <- get
+       put $ ProgramState (vlocals++vars') heap'
+       runCom body
+       vret <- evalExpr ret
+       --restore old local variables with new heap
+       (ProgramState _ newheap) <- get
+       put (ProgramState vars newheap)
+       get
+       
+       
+       
+       
+       
+       
 
+runProgram :: Program -> (Either String ProgramState,ProgramState)
+runProgram (Program decls locals com) =
+   let dec = map ( \d@(Func n _ _ _ _)-> (n,d) ) decls in
+   runState ( runExceptT ( runReaderT (do
+            env <- mapM (\(var,expr) -> (var,) <$> evalExpr expr) locals
+            put (ProgramState env (0,[]))
+            runCom com
+        ) dec) )(ProgramState [] (0,[]))
+  --runState ( runExceptT  (runReaderT (_) decls)) (ProgramState [] [])
diff --git a/src/Lib.hs b/src/Lib.hs
deleted file mode 100644
index d36ff27..0000000
--- a/src/Lib.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Lib
-    ( someFunc
-    ) where
-
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"
diff --git a/src/Syntax.hs b/src/Syntax.hs
index 18949d2..065f91d 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -6,7 +6,7 @@ data Typ = TInt
          | TRecord  TypeDict
          | TVariant TypeDict
          | TPtr Typ
-           deriving(Eq,Show)
+           deriving(Eq,Show,Read)
 type TypeDict = [(Idnt,Typ)]
 
 data Expr = Var Idnt
@@ -20,7 +20,7 @@ data Expr = Var Idnt
           | Match Expr [(Idnt, Idnt, Expr)] -- Variant,Binder, Expression
           | Proj Idnt Expr 
           | Annot Expr Typ
-           deriving(Eq,Show)
+           deriving(Eq,Show,Read)
 data Com = Skip
          | Seq Com Com
          | If Expr Com Com
@@ -31,13 +31,13 @@ data Com = Skip
          | Save Idnt Expr
          | SMatch Expr [(Idnt, Idnt, Com)]
          | FunctionCall Idnt Idnt [Expr] -- variable function_name parameters
-           deriving(Eq,Show)
+           deriving(Eq,Show,Read)
          
 data FuncDecl = Func Idnt [(Idnt, Typ)] [(Idnt,Expr)] Com Expr -- function_name [parameters]  [local variables] body return_val
-           deriving(Eq,Show)
+           deriving(Eq,Show,Read)
 data FuncSign = FuncSign [Typ] Typ
                 deriving(Eq,Show)
 type FuncEnv = [(Idnt,FuncSign)]
-data Program = P [FuncDecl] [(Idnt, Int)] Com
-           deriving(Eq,Show)
+data Program = Program [FuncDecl] [(Idnt, Expr)] Com
+           deriving(Eq,Show,Read)
 
diff --git a/src/Typecheck.hs b/src/Typecheck.hs
index 7136e64..8c1755f 100644
--- a/src/Typecheck.hs
+++ b/src/Typecheck.hs
@@ -3,8 +3,10 @@ module Typecheck
 (inferExpr,
  checkExpr,
  wellFormed,
+ wfProgram,
  Environment,
- bool
+ bool,
+ Error
  )
   where
 import Syntax
@@ -171,6 +173,26 @@ wellFormed c@(FunctionCall v f args) env fa= do
             argsOk xs ys 
           
   
+getFuncSign :: FuncDecl -> Error (Idnt,FuncSign)
+getFuncSign (Func name arguments locals body ret) = do
+  localTypes <- mapM (\(var,expr)-> (var,) <$> inferExpr expr arguments) locals
+  ret <- inferExpr ret (localTypes++arguments)
+  return $ (name,FuncSign (map snd arguments) ret)
+
+wfFunction :: FuncDecl-> FuncEnv -> Error ()
+wfFunction (Func name params locals body ret) fe = do
+  localTypes <- mapM (\(var,expr)-> (var,) <$> inferExpr expr params) locals
+  wellFormed body (localTypes++params) fe
+  inferExpr ret (localTypes++params)
+  return ()
+
+wfProgram :: Program -> Error ()
+wfProgram (Program decls locals main) =do
+  fe <- mapM getFuncSign decls
+  localTypes <- mapM (\(var,expr)-> (var,) <$> inferExpr expr []) locals
+  wellFormed main localTypes fe
+  
+