From 3810fcdcc4ad0d76193842271ce3392b3adba913 Mon Sep 17 00:00:00 2001
From: Paweł Dybiec <pawel.to.malpa@gmail.com>
Date: Mon, 20 Jan 2020 03:08:05 +0100
Subject: Add function calls in commands, and type annotations in expressions

---
 src/Syntax.hs    |  7 ++++++-
 src/Typecheck.hs | 58 +++++++++++++++++++++++++++++++++++++-------------------
 2 files changed, 44 insertions(+), 21 deletions(-)

diff --git a/src/Syntax.hs b/src/Syntax.hs
index f5d9c2d..18949d2 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -19,6 +19,7 @@ data Expr = Var Idnt
           | Deref Expr
           | Match Expr [(Idnt, Idnt, Expr)] -- Variant,Binder, Expression
           | Proj Idnt Expr 
+          | Annot Expr Typ
            deriving(Eq,Show)
 data Com = Skip
          | Seq Com Com
@@ -29,10 +30,14 @@ data Com = Skip
          | Alloc Idnt Expr Com
          | Save Idnt Expr
          | SMatch Expr [(Idnt, Idnt, Com)]
+         | FunctionCall Idnt Idnt [Expr] -- variable function_name parameters
            deriving(Eq,Show)
          
-data FuncDecl = Func Idnt [Idnt] [(Idnt,Expr)] Com Expr
+data FuncDecl = Func Idnt [(Idnt, Typ)] [(Idnt,Expr)] Com Expr -- function_name [parameters]  [local variables] body return_val
            deriving(Eq,Show)
+data FuncSign = FuncSign [Typ] Typ
+                deriving(Eq,Show)
+type FuncEnv = [(Idnt,FuncSign)]
 data Program = P [FuncDecl] [(Idnt, Int)] Com
            deriving(Eq,Show)
 
diff --git a/src/Typecheck.hs b/src/Typecheck.hs
index d8c0187..8f09627 100644
--- a/src/Typecheck.hs
+++ b/src/Typecheck.hs
@@ -90,6 +90,9 @@ inferExpr (Proj name e) env = do
   case lookup name tt of
     Just typ -> return typ
     Nothing -> throwError $ "Record " ++show e ++ "doesn't have field" ++ name
+inferExpr (Annot e t) env = do
+  checkExpr e  env t
+  return t
 
 checkExpr :: Expr -> Environment -> Typ -> Error ()
 checkExpr e@(Add e1 e2) env t = do
@@ -113,46 +116,61 @@ checkExpr e env t = do
 
 bool = TVariant [("True",TRecord []),("False", TRecord [])]
   
-cenvlookup :: Idnt -> TypeDict -> Com -> Error Typ
+cenvlookup ::(Show a,Eq a) => a-> [(a,b)] -> Com -> Error b
 cenvlookup name env c = case lookup name env of
   Just t -> return t
-  Nothing -> throwError $ "Variable "++ name ++ "not defined in expr" ++ show c
+  Nothing -> throwError $ "name "++ show name ++ "not visible in expr" ++ show c
 
-wellFormed :: Com ->Environment -> Error ()
-wellFormed Skip _= return ()
-wellFormed (Seq s1 s2) env = do
-  wellFormed s1 env
-  wellFormed s2 env
-wellFormed (If e c1 c2) env = do
+wellFormed :: Com ->Environment -> FuncEnv-> Error ()
+wellFormed Skip _ _= return ()
+wellFormed (Seq s1 s2) env fe = do
+  wellFormed s1 env fe
+  wellFormed s2 env fe
+wellFormed (If e c1 c2) env fe = do
   checkExpr e env bool
-  wellFormed c1 env
-  wellFormed c2 env
-wellFormed (While e c) env = do
+  wellFormed c1 env fe
+  wellFormed c2 env fe
+wellFormed (While e c) env  fe= do
   checkExpr e env bool
-  wellFormed c env
-wellFormed c@(Asgn v e) env = do
+  wellFormed c env fe
+wellFormed c@(Asgn v e) env _ = do
   vt <- cenvlookup v env c
   et <- inferExpr e env
   if vt==et then return ()
     else throwError $ "Variable " ++ show v ++ "::" ++ show vt ++ " was assigned expression " ++ show e ++ "::" ++ show et
-wellFormed (Decl v e c) env= do
+wellFormed (Decl v e c) env fe= do
   et <- inferExpr e env
-  wellFormed c (insert v et env)
-wellFormed (Alloc v e c) env = do
+  wellFormed c (insert v et env) fe
+wellFormed (Alloc v e c) env fe = do
   et <- inferExpr e env
-  wellFormed c (insert v (TPtr et) env)
-wellFormed c@(Save v e) env = do
+  wellFormed c (insert v (TPtr et) env) fe
+wellFormed c@(Save v e) env _ = do
   vt <- cenvlookup v env c
   et <- inferExpr e env
   if vt==TPtr et then return ()
     else throwError $ "Expression" ++ show e ++ "::" ++ show et ++ " was saved to pointer "++show v ++ " of type" ++ show vt
-wellFormed c@(SMatch e cases) env = do
+wellFormed c@(SMatch e cases) env fe= do
   varType <- inferExpr e env
   variants <- assertVar varType e
   mapM (\(v,bind,c) -> do
                         tt <- envlookup v variants e
-                        wellFormed c (insert bind tt env)) cases
+                        wellFormed c (insert bind tt env) fe) cases
   subset (map fst variants) (map (\(_,v,_)->v) cases) c
   return ()
+wellFormed c@(FunctionCall v f args) env fa= do
+  (FuncSign argTypes retType) <- cenvlookup f fa c
+  vt <- cenvlookup v env c
+  if vt/=retType then throwError $ "Returned function type"++show retType++" doesn't match up with variable type " ++show vt ++ " in " ++ show c
+    else argsOk args argTypes
+    where argsOk:: [Expr] ->[Typ] ->Error ()
+          argsOk [] [] =return ()
+          argsOk (_:_) [] = throwError $ "Too many arguments in function call" ++ show c
+          argsOk [] (_:_) = throwError $ "Not enough arguments in function call" ++ show c
+          argsOk (x:xs) (y:ys) = do
+            checkExpr x env y
+            argsOk xs ys 
+          
+  
+
   
   
-- 
cgit 1.4.1