Add Except monad, and destructors for records and variants

4 files changed, 106 insertions, 41 deletions

diff --git a/package.yaml b/package.yaml
index ebbce42..7c48f52 100644
--- a/package.yaml
+++ b/package.yaml
@@ -21,6 +21,7 @@ description:         Please see the README on GitHub at <https://github.com/dyni
 
 dependencies:
 - base >= 4.7 && < 5
+- mtl >= 2.2
 
 library:
   source-dirs: src
@@ -33,6 +34,7 @@ executables:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
+    - -Wall
     dependencies:
     - wpp
 
@@ -44,6 +46,7 @@ tests:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
+    - -Wall
     dependencies:
     - wpp
     - hspec
diff --git a/src/Syntax.hs b/src/Syntax.hs
index c33f7b3..bbd8cbe 100644
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@@ -3,10 +3,11 @@ module Syntax
 
 type Idnt = String
 data Typ = TInt
-         | TRecord  [(Idnt, Typ)]
-         | TVariant [(Idnt, Typ)]
+         | TRecord  TypeDict
+         | TVariant TypeDict
          | TPtr Typ
            deriving(Eq,Show)
+type TypeDict = [(Idnt,Typ)]
 
 data Expr = Var Idnt
           | IntLit Int
@@ -16,6 +17,8 @@ data Expr = Var Idnt
           | Mult Expr Expr
           | Neg Expr
           | Deref Expr
+          | Match Expr [(Idnt, Expr)]
+          | Proj Idnt Expr 
            deriving(Eq,Show)
 data Com = Skip
          | Seq Com Com
@@ -25,6 +28,7 @@ data Com = Skip
          | Decl Idnt Expr Com
          | Alloc Idnt Expr
          | Save Idnt Expr
+         | SMatch Expr [(Idnt, Expr)]
            deriving(Eq,Show)
          
 data FuncDecl = Func Idnt [Idnt] [(Idnt,Expr)] Com Expr
diff --git a/src/Typecheck.hs b/src/Typecheck.hs
index c86187d..2ed189d 100644
--- a/src/Typecheck.hs
+++ b/src/Typecheck.hs
@@ -1,31 +1,46 @@
 {-# LANGUAGE TupleSections #-}
 module Typecheck
 (inferExpr,
- checkExpr)
+ checkExpr,
+ Environment)
   where
 import Syntax
-import Control.Monad
+--import Control.Monad
+import Control.Monad.Except
 type Environment = [(Idnt,Typ)]
 
-assertInt TInt = Just ()
-assertInt _ = Nothing
-assertRec (TRecord ts) = Just ts
-assertRec _ = Nothing
-assertVar (TVariant ts) = Just ts
-assertVar _ = Nothing
-assertPtr (TPtr t) = Just t
-assertPtr _ = Nothing
+type Error = Except String
 
+assertInt :: Typ -> Expr -> Error ()
+assertInt TInt _ = return ()
+assertInt t e = throwError $ "Expected type of expression "++ show e ++ " to be (TInt), instead got" ++ show t 
+  
+assertRec :: Typ -> Expr -> Error TypeDict
+assertRec (TRecord ts) _ = return ts
+assertRec t e = throwError $ "Expected type of expression "++ show e ++ " to be (TRecord _), instead got" ++ show t 
 
-inferExpr :: Expr -> Environment -> Maybe Typ
-inferExpr (Var name) env = lookup name env
-inferExpr (IntLit _) _ = Just TInt
+assertVar :: Typ -> Expr -> Error TypeDict
+assertVar (TVariant ts) _ = return ts
+assertVar t e = throwError $ "Expected type of expression "++ show e ++ " to be (TVariant _), instead got" ++ show t 
+
+assertPtr :: Typ -> Expr -> Error Typ
+assertPtr (TPtr t) _ = return t
+assertPtr t e = throwError $ "Expected type of expression "++ show e ++ " to be (TPtr _), instead got" ++ show t 
+
+envlookup :: Idnt -> TypeDict -> Expr -> Error Typ
+envlookup name env expr = case lookup name env of
+  Just t -> return t
+  Nothing -> throwError $ "Variable "++ name ++ "not defined in expr" ++ show expr
+
+inferExpr :: Expr -> Environment -> Error Typ
+inferExpr e@(Var name) env = envlookup name env e
+inferExpr (IntLit _) _ = return TInt
 inferExpr (Record ts) env = do
-  tts <- sequence $ map (\(v,e) -> (v,) <$> inferExpr e env) ts
+  tts <- mapM (\(v,e) -> (v,) <$> inferExpr e env) ts
   return $ TRecord tts
-inferExpr (Variant t v e) env = do
-  ts <- assertVar t
-  tt <- lookup v ts
+inferExpr ee@(Variant t v e) env = do
+  ts <- assertVar t e
+  tt <- envlookup v ts ee
   checkExpr e env tt
   return t
 inferExpr (Add e1 e2) env = do
@@ -41,11 +56,46 @@ inferExpr (Neg e) env = do
   return TInt
 inferExpr (Deref e1) env = do
   t <- inferExpr e1 env
-  tt <- assertPtr t
+  tt <- assertPtr t e1
   return tt
+inferExpr c@(Match e cases) env = do
+  varType <- inferExpr e env
+  variants <- assertVar varType e
+  -- TODO ensure variants and cases cover the same names
+  caseTypes <- mapM (\(v,e) ->(v,) <$> inferExpr e env) cases
+  ret <- allSame caseTypes
+  return $ snd ret
+  where
+    allSame :: [(Idnt,Typ)] -> Error (Idnt,Typ)
+    allSame (x:[]) = return x
+    allSame [] = throwError $ "Empty case "++ show c
+    allSame ((xx,x):xs) = do
+      (v,t) <- allSame xs
+      if t==x then return (v,t) else
+        throwError $ "Different types in branches " ++ show v ++ "," ++ show xx ++ "of expression" ++ show c
+inferExpr (Proj name e) env = do
+  t <- inferExpr e env
+  tt <- assertRec t e
+  case lookup name tt of
+    Just typ -> return typ
+    Nothing -> throwError $ "Record " ++show e ++ "doesn't have field" ++ name
 
-checkExpr :: Expr -> Environment -> Typ -> Maybe ()
+checkExpr :: Expr -> Environment -> Typ -> Error ()
+checkExpr e@(Add e1 e2) env t = do
+  assertInt t e
+  checkExpr e1 env TInt
+  checkExpr e2 env TInt
+checkExpr e@(Mult e1 e2) env t = do
+  assertInt t e
+  checkExpr e1 env TInt
+  checkExpr e2 env TInt
+checkExpr e@(Neg ee) env t = do
+  assertInt t e
+  checkExpr ee env TInt
+checkExpr (Deref e1) env t = do
+ checkExpr e1 env (TPtr t)
 checkExpr e env t = do
   t' <- inferExpr e env
-  guard (t==t')
-  return ()
+  if t == t' then return ()
+    else throwError $ "Expected type of expression " ++
+         show e ++ " to be"++ show t  ++" instead got" ++ show t'
diff --git a/test/TypecheckTest.hs b/test/TypecheckTest.hs
index 299c8c0..4e410ed 100644
--- a/test/TypecheckTest.hs
+++ b/test/TypecheckTest.hs
@@ -2,33 +2,41 @@ module TypecheckTest
   where
 import Typecheck
 import Syntax
+import Control.Monad.Except (runExcept)
 import Test.Hspec
+
+
 typecheckTest :: Spec
 typecheckTest = describe "inferExpr" $ do
   it "can infer variables" $ do
-    inferExpr (Var "a") [("a", TInt)] `shouldBe`  Just TInt
-    inferExpr (Var "a") [("a", TRecord [("b",TInt)])] `shouldBe`  (Just $ TRecord [("b",TInt)])
-    inferExpr (Var "a") [("a", TVariant [("b",TInt)])] `shouldBe` (Just $ TVariant[("b",TInt)])
-    inferExpr (Var "a") [("a", TPtr TInt)] `shouldBe` ( Just $ TPtr TInt )
+    infer (Var "a") [("a", TInt)] `shouldBe`  Just TInt
+    infer (Var "a") [("a", TRecord [("b",TInt)])] `shouldBe`  (Just $ TRecord [("b",TInt)])
+    infer (Var "a") [("a", TVariant [("b",TInt)])] `shouldBe` (Just $ TVariant[("b",TInt)])
+    infer (Var "a") [("a", TPtr TInt)] `shouldBe` ( Just $ TPtr TInt )
   it "shouldn't infer undefined variables" $ do
-    inferExpr (Var "a") [] `shouldBe` Nothing
+    infer (Var "a") [] `shouldBe` Nothing
   it "should be able to infer types of arithmetic expressions" $ do
-    inferExpr (IntLit 5) [] `shouldBe` (Just TInt)
-    inferExpr (Add (IntLit 1) (IntLit 3)) [] `shouldBe` (Just TInt)
-    inferExpr (Mult (IntLit 1) (IntLit 3)) [] `shouldBe` (Just TInt)
-    inferExpr (Neg (IntLit 3)) [] `shouldBe` (Just TInt)
+    infer (IntLit 5) [] `shouldBe` (Just TInt)
+    infer (Add (IntLit 1) (IntLit 3)) [] `shouldBe` (Just TInt)
+    infer (Mult (IntLit 1) (IntLit 3)) [] `shouldBe` (Just TInt)
+    infer (Neg (IntLit 3)) [] `shouldBe` (Just TInt)
   it "shouldn't be able to do arithmetic operations on pointer" $ do
-    inferExpr (Add (IntLit 1) (Var "a")) [("a",(TPtr TInt))] `shouldBe` Nothing
-    inferExpr (Add (Var "a") (IntLit 1)) [("a",(TPtr TInt))] `shouldBe` Nothing
-    inferExpr (Mult (IntLit 1) (Var "a")) [("a",(TPtr TInt))] `shouldBe` Nothing
-    inferExpr (Mult (Var "a") (IntLit 1)) [("a",(TPtr TInt))] `shouldBe` Nothing
-    inferExpr (Neg (Var "a")) [("a",(TPtr TInt))] `shouldBe` Nothing
+    infer (Add (IntLit 1) (Var "a")) [("a",(TPtr TInt))] `shouldBe` Nothing
+    infer (Add (Var "a") (IntLit 1)) [("a",(TPtr TInt))] `shouldBe` Nothing
+    infer (Mult (IntLit 1) (Var "a")) [("a",(TPtr TInt))] `shouldBe` Nothing
+    infer (Mult (Var "a") (IntLit 1)) [("a",(TPtr TInt))] `shouldBe` Nothing
+    infer (Neg (Var "a")) [("a",(TPtr TInt))] `shouldBe` Nothing
   it "should infer compound types" $ do
-    inferExpr (Variant (TVariant [("Cons",TInt),("Cons2",TPtr TInt)]) "Cons" (IntLit 5)) [] `shouldBe` (Just $ TVariant [("Cons",TInt),("Cons2",TPtr TInt)])
-    inferExpr (Record [("aa",Var "a"),("bb",Var "b")]) [("a",TInt), ("b",TPtr TInt)] `shouldBe` (Just $ TRecord [("aa",TInt),("bb",TPtr TInt)])
+    infer (Variant (TVariant [("Cons",TInt),("Cons2",TPtr TInt)]) "Cons" (IntLit 5)) [] `shouldBe` (Just $ TVariant [("Cons",TInt),("Cons2",TPtr TInt)])
+    infer (Record [("aa",Var "a"),("bb",Var "b")]) [("a",TInt), ("b",TPtr TInt)] `shouldBe` (Just $ TRecord [("aa",TInt),("bb",TPtr TInt)])
   it "should unpack Ptr for every dereference" $ do
-    inferExpr (Deref (Var "a")) [("a",TPtr TInt)] `shouldBe` (Just TInt)
-    inferExpr (Deref (Var "a")) [("a",TPtr $ TPtr TInt)] `shouldBe` (Just $ TPtr TInt)
+    infer (Deref (Var "a")) [("a",TPtr TInt)] `shouldBe` (Just TInt)
+    infer (Deref (Var "a")) [("a",TPtr $ TPtr TInt)] `shouldBe` (Just $ TPtr TInt)
+  where
+    infer :: Expr -> Environment -> Maybe Typ
+    infer e env=  eitherToMaybe $ runExcept $ inferExpr e env
+    eitherToMaybe (Right a) = Just a
+    eitherToMaybe (Left _) = Nothing