aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--package.yaml3
-rw-r--r--src/Syntax.hs8
-rw-r--r--src/Typecheck.hs92
-rw-r--r--test/TypecheckTest.hs44
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 12:27:53 +0000