Fakultas Ilmu Komputer UI

Commit 548b576a authored by Sean Gillespie's avatar Sean Gillespie
Browse files

Update SystemF TypeChecker

Implement Type Application
parent 965ea5d0
......@@ -18,7 +18,7 @@ typecheck uniqs ctx (Var v) = tcVar uniqs ctx v
typecheck uniqs ctx (Abs n t body) = tcAbs uniqs ctx n t body
typecheck uniqs ctx (App e1 e2) = tcApp uniqs ctx e1 e2
typecheck uniqs ctx (TyAbs t body) = tcTyAbs uniqs ctx t body
typecheck _ _ _ = undefined
typecheck uniqs ctx (TyApp e ty) = tcTyApp uniqs ctx e ty
tcVar :: (Ord n, Eq n, PrettyPrint n)
=> UniqueSupply n
......@@ -67,12 +67,48 @@ tcTyAbs :: (Ord n, Eq n, PrettyPrint n)
tcTyAbs uniqs ctx ty body = TyForAll ty <$> typecheck uniqs ctx' body
where ctx' = insert ty (TyVar ty) ctx
tcTyApp :: (Ord n, Eq n, PrettyPrint n)
=> UniqueSupply n
-> Context n (Ty n)
-> SystemFExpr n n
-> Ty n
-> Either String (Ty n)
tcTyApp uniqs ctx (TyAbs t expr) ty = typecheck uniqs ctx expr'
where expr' = sub t ty expr
tcTyApp uniqs ctx expr ty = typecheck uniqs ctx expr
-- Utilities
unique :: UniqueSupply t
-> Either String t
unique (u:_) = return u
unique _ = fail "Unique supply ran out"
sub :: Eq n
=> n
-> Ty n
-> SystemFExpr n n
-> SystemFExpr n n
sub name ty (App e1 e2) = App (sub name ty e1) (sub name ty e2)
sub name ty (Abs n ty' e) = Abs n (subTy name ty ty') (sub name ty e)
sub name ty (TyAbs ty' e) = TyAbs ty' (sub name ty e)
sub name ty (TyApp e ty') = TyApp (sub name ty e) (subTy name ty ty')
sub name ty expr = expr
subTy :: Eq n
=> n
-> Ty n
-> Ty n
-> Ty n
subTy name ty (TyArrow t1 t2)
= TyArrow (subTy name ty t1) (subTy name ty t2)
subTy name ty ty'@(TyVar name')
| name == name' = ty
| otherwise = ty'
subTy name t1 t2@(TyForAll name' t2')
| name == name' = t2
| otherwise = TyForAll name' (subTy name t2 t2')
tyMismatchMsg :: (PrettyPrint t, PrettyPrint t')
=> t
-> t'
......
......@@ -5,9 +5,15 @@ import Data.Map
import Test.Hspec
import Language.Lambda.Util.PrettyPrint
import Language.SystemF.Expression
import Language.SystemF.TypeCheck
tc :: (Ord n, Eq n, PrettyPrint n)
=> UniqueSupply n
-> [(n, Ty n)]
-> SystemFExpr n n
-> Either String (Ty n)
tc uniqs ctx = typecheck uniqs (fromList ctx)
spec :: Spec
......@@ -51,6 +57,19 @@ spec = describe "typecheck" $ do
tc ["A"] [] (TyAbs "X" (Var "x")) `shouldBe` Right (TyForAll "X" (TyVar "A"))
it "typechecks type abstractions with simple abstraction" $
tc [] [] (TyAbs "X" (Abs "x" (TyVar "X") (Var "X"))) `shouldBe`
Right (TyForAll "X" (TyArrow (TyVar "X") (TyVar "X")))
tc [] [] (TyAbs "X" (Abs "x" (TyVar "X") (Var "x")))
`shouldBe` Right (TyForAll "X" (TyArrow (TyVar "X") (TyVar "X")))
it "typechecks type abstractions with application" $
tc [] [("y", TyVar "Y")]
(App (TyApp (TyAbs "X" (Abs "x" (TyVar "X") (Var "x"))) (TyVar "Y"))
(Var "y"))
`shouldBe` Right (TyVar "Y")
it "typechecks simple type applications" $
tc [] [("x", TyVar "A")] (TyApp (TyAbs "X" (Var "x")) (TyVar "X"))
`shouldBe` Right (TyVar "A")
it "typechecks type applications with simple abstraction" $
tc [] [] (TyApp (TyAbs "X" (Abs "x" (TyVar "X") (Var "x"))) (TyVar "Y"))
`shouldBe` Right (TyArrow (TyVar "Y") (TyVar "Y"))
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment