From 0c815fa3eb480ae5e05370699cead004d81cf65c Mon Sep 17 00:00:00 2001 From: Paweł Dybiec Date: Sun, 19 Jan 2020 22:59:54 +0100 Subject: Add Except monad, and destructors for records and variants --- package.yaml | 3 ++ src/Syntax.hs | 8 +++-- src/Typecheck.hs | 92 +++++++++++++++++++++++++++++++++++++++------------ test/TypecheckTest.hs | 44 ++++++++++++++---------- 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 = 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 -- cgit 1.4.1