Commit 1b5211c8 authored by André Pacak's avatar André Pacak

fixed type checker and the current transformations

parent 34ba88d4
...@@ -109,7 +109,9 @@ inferType ctx tymap (Or t1 t2 _) = do ...@@ -109,7 +109,9 @@ inferType ctx tymap (Or t1 t2 _) = do
checkType ctx tymap t1 Bool checkType ctx tymap t1 Bool
checkType ctx tymap t2 Bool checkType ctx tymap t2 Bool
return Bool return Bool
inferType ctx _ (Var name _) = lookupVar ctx name inferType ctx tymap (Var name _) = do
ty <- lookupVar ctx name
matchTypeVar tymap ty
inferType ctx tymap (Let name t body _) = do inferType ctx tymap (Let name t body _) = do
tyt <- inferType ctx tymap t tyt <- inferType ctx tymap t
inferType (Bind ctx name tyt) tymap body inferType (Bind ctx name tyt) tymap body
...@@ -159,14 +161,9 @@ checkType ctx tymap (Match m cases _) ty = do ...@@ -159,14 +161,9 @@ checkType ctx tymap (Match m cases _) ty = do
let casechecks = map (\c -> do let casechecks = map (\c -> do
tys <- liftMaybe (M.lookup (labelOfCase c) cotrs) "Could not find constructor" :: Infer [Type] tys <- liftMaybe (M.lookup (labelOfCase c) cotrs) "Could not find constructor" :: Infer [Type]
if length (bindingsOfCase c) == length tys if length (bindingsOfCase c) == length tys
then then do
if not (null (bindingsOfCase c)) let ctx' = foldl (\r (b, bty) -> Bind r b bty) ctx (zip (bindingsOfCase c) tys)
then do checkType ctx' tymap (termOfCase c) ty
let bindchecks = map (\(b, bty) ->
checkType (Bind ctx b bty) tymap (termOfCase c) ty
) $ zip (bindingsOfCase c) tys
foldl (>>) (return ()) bindchecks
else checkType ctx tymap (termOfCase c) ty
else fail "number of bindings does not match number of args of constructor" else fail "number of bindings does not match number of args of constructor"
) cases ) cases
foldl (>>) (return ()) casechecks foldl (>>) (return ()) casechecks
......
...@@ -131,7 +131,6 @@ lookupCotr (Bind c x ty) y = case ty of ...@@ -131,7 +131,6 @@ lookupCotr (Bind c x ty) y = case ty of
else lookupCotr c y else lookupCotr c y
_ -> lookupCotr c y _ -> lookupCotr c y
inferType :: Ctx -> TypeMap -> Term -> Infer Type inferType :: Ctx -> TypeMap -> Term -> Infer Type
inferType _ _ (Zero _) = return Nat inferType _ _ (Zero _) = return Nat
inferType ctx tymap (Succ t _) = do inferType ctx tymap (Succ t _) = do
...@@ -158,7 +157,9 @@ inferType ctx tymap (Or t1 t2 _) = do ...@@ -158,7 +157,9 @@ inferType ctx tymap (Or t1 t2 _) = do
checkType ctx tymap t1 Bool checkType ctx tymap t1 Bool
checkType ctx tymap t2 Bool checkType ctx tymap t2 Bool
return Bool return Bool
inferType ctx _ (Var name _) = lookupVar ctx name inferType ctx tymap (Var name _) = do
ty <- lookupVar ctx name
matchTypeVar tymap ty
inferType ctx tymap (Let name t body _) = do inferType ctx tymap (Let name t body _) = do
tyt <- inferType ctx tymap t tyt <- inferType ctx tymap t
inferType (Bind ctx name tyt) tymap body inferType (Bind ctx name tyt) tymap body
...@@ -182,10 +183,10 @@ inferType ctx tymap (Cotr n ts p) = do ...@@ -182,10 +183,10 @@ inferType ctx tymap (Cotr n ts p) = do
if length ts == length tys if length ts == length tys
then do then do
-- check types accordingly to definition -- check types accordingly to definition
let subchecks = map (\(t, ty) -> do let subchecks = zipWith (\t ty -> do
ty' <- matchTypeVar tymap ty ty' <- matchTypeVar tymap ty
checkType ctx tymap t ty' checkType ctx tymap t ty'
) (zip ts tys) -- basically a map over the [(Term, Type)] and apply check ctx ) ts tys -- basically a map over the [(Term, Type)] and apply check ctx
foldl (>>) (return ()) subchecks foldl (>>) (return ()) subchecks
return adty return adty
else fail ["Expected number of arguments violated for " ++ show (Cotr n ts p)] else fail ["Expected number of arguments violated for " ++ show (Cotr n ts p)]
...@@ -208,14 +209,9 @@ checkType ctx tymap (Match m cases _) ty = do ...@@ -208,14 +209,9 @@ checkType ctx tymap (Match m cases _) ty = do
let casechecks = map (\c -> do let casechecks = map (\c -> do
tys <- liftMaybe (M.lookup (labelOfCase c) cotrs) "Could not find constructor" :: Infer [Type] tys <- liftMaybe (M.lookup (labelOfCase c) cotrs) "Could not find constructor" :: Infer [Type]
if length (bindingsOfCase c) == length tys if length (bindingsOfCase c) == length tys
then then do
if not (null (bindingsOfCase c)) let ctx' = foldl (\r (b, bty) -> Bind r b bty) ctx (zip (bindingsOfCase c) tys)
then do checkType ctx' tymap (termOfCase c) ty
let bindchecks = map (\(b, bty) ->
checkType (Bind ctx b bty) tymap (termOfCase c) ty
) $ zip (bindingsOfCase c) tys
foldl (>>) (return ()) bindchecks
else checkType ctx tymap (termOfCase c) ty
else fail ["number of bindings does not match number of args of constructor"] else fail ["number of bindings does not match number of args of constructor"]
) cases ) cases
foldl (>>) (return ()) casechecks foldl (>>) (return ()) casechecks
......
...@@ -133,7 +133,6 @@ lookupCotr (Bind c x ty) y = case ty of ...@@ -133,7 +133,6 @@ lookupCotr (Bind c x ty) y = case ty of
else lookupCotr c y else lookupCotr c y
_ -> lookupCotr c y _ -> lookupCotr c y
inferType :: Ctx -> TypeMap -> Term -> Infer Type inferType :: Ctx -> TypeMap -> Term -> Infer Type
inferType _ _ (Zero _) = return Nat inferType _ _ (Zero _) = return Nat
inferType ctx tymap (Succ t _) = do inferType ctx tymap (Succ t _) = do
...@@ -160,7 +159,9 @@ inferType ctx tymap (Or t1 t2 _) = do ...@@ -160,7 +159,9 @@ inferType ctx tymap (Or t1 t2 _) = do
checkType ctx tymap t1 checkType ctx tymap t1
checkType ctx tymap t2 checkType ctx tymap t2
return Bool return Bool
inferType ctx _ (Var name _) = lookupVar ctx name inferType ctx tymap (Var name _) = do
ty <- lookupVar ctx name
matchTypeVar tymap ty
inferType ctx tymap (Let name t body _) = do inferType ctx tymap (Let name t body _) = do
tyt <- inferType ctx tymap t tyt <- inferType ctx tymap t
inferType (Bind ctx name tyt) tymap body inferType (Bind ctx name tyt) tymap body
...@@ -179,14 +180,15 @@ inferType ctx tymap (LetData n adty t _) = ...@@ -179,14 +180,15 @@ inferType ctx tymap (LetData n adty t _) =
inferType ctx tymap (Cotr n ts p) = do inferType ctx tymap (Cotr n ts p) = do
-- TODO find better solution -- TODO find better solution
-- PROBLEM we need to find the binding that contains the constructor -- PROBLEM we need to find the binding that contains the constructor
(adty, tys) <- lookupCotr tymap n (adty, tys) <- lookupCotr tymap n
if length ts == length tys if length ts == length tys
then do then do
-- check types accordingly to definition -- check types accordingly to definition
let subchecks = map (\(t, ty) -> do let subchecks = zipWith (\t ty -> do
ty' <- matchTypeVar tymap ty ty' <- matchTypeVar tymap ty
checkType ctx tymap t checkType ctx tymap t
) (zip ts tys) -- basically a map over the [(Term, Type)] and apply check ctx ) ts tys -- basically a map over the [(Term, Type)] and apply check ctx
foldl (>>) (return ()) subchecks foldl (>>) (return ()) subchecks
return adty return adty
else fail ["Expected number of arguments violated for " ++ show (Cotr n ts p)] else fail ["Expected number of arguments violated for " ++ show (Cotr n ts p)]
...@@ -212,14 +214,9 @@ checkType ctx tymap p@(Match m cases _) = do ...@@ -212,14 +214,9 @@ checkType ctx tymap p@(Match m cases _) = do
let casechecks = map (\c -> do let casechecks = map (\c -> do
tys <- liftMaybe (M.lookup (labelOfCase c) cotrs) "Could not find constructor" :: Infer [Type] tys <- liftMaybe (M.lookup (labelOfCase c) cotrs) "Could not find constructor" :: Infer [Type]
if length (bindingsOfCase c) == length tys if length (bindingsOfCase c) == length tys
then then do
if not (null (bindingsOfCase c)) let ctx' = foldl (\r (b, bty) -> Bind r b bty) ctx (zip (bindingsOfCase c) tys)
then do checkType ctx' tymap (termOfCase c)
let bindchecks = map (\(b, bty) ->
checkType (Bind ctx b bty) tymap (termOfCase c)
) $ zip (bindingsOfCase c) tys
foldl (>>) (return ()) bindchecks
else checkType ctx tymap (termOfCase c)
else fail ["number of bindings does not match number of args of constructor"] else fail ["number of bindings does not match number of args of constructor"]
) cases ) cases
foldl (>>) (return ()) casechecks foldl (>>) (return ()) casechecks
...@@ -270,9 +267,22 @@ requiredType ctx tymap term = case parent term of ...@@ -270,9 +267,22 @@ requiredType ctx tymap term = case parent term of
(_, cotrs) <- matchADT mty' (show m) (_, cotrs) <- matchADT mty' (show m)
if length cases == length cotrs if length cases == length cotrs
then do then do
-- throw away ctx extension if bindingsOfCase c != null let maybeCase = find (\c -> termOfCase c == term) cases
-- let x = find (\c -> term == termOfCase c) cases case maybeCase of
let (Bind ctx' _ _) = ctx Just c -> do
requiredType ctx' tymap p tys <- liftMaybe (M.lookup (labelOfCase c) cotrs) "Could not find constructor" :: Infer [Type]
else fail ["cases do not match number of constructors of" ++ show m] let ctx' = foldl (\r (b, bty) -> let (Bind r' _ _) = r in r') ctx (zip (bindingsOfCase c) tys)
ty <- requiredType ctx' tymap p
return ty
Nothing -> fail ["could not find corresponding case"]
-- let casechecks = map (\c -> do
-- tys <- liftMaybe (M.lookup (labelOfCase c) cotrs) "Could not find constructor" :: Infer [Type]
-- if length (bindingsOfCase c) == length tys
-- then do
-- let ctx' = foldl (\r (b, bty) -> Bind r b bty) ctx (zip (bindingsOfCase c) tys)
-- checkType ctx' tymap (termOfCase c)
-- else fail ["number of bindings does not match number of args of constructor"]
-- ) cases
-- foldl (>>) (return ()) casechecks
else fail [""]
_ -> fail ["Could not determine required type"] _ -> fail ["Could not determine required type"]
...@@ -82,7 +82,6 @@ lookupCotr (Bind c x ty) y = case ty of ...@@ -82,7 +82,6 @@ lookupCotr (Bind c x ty) y = case ty of
else lookupCotr c y else lookupCotr c y
_ -> lookupCotr c y _ -> lookupCotr c y
inferType :: Ctx -> TypeMap -> Term -> Infer Type inferType :: Ctx -> TypeMap -> Term -> Infer Type
inferType _ _ (Zero _) = return Nat inferType _ _ (Zero _) = return Nat
inferType ctx tymap (Succ t _) = do inferType ctx tymap (Succ t _) = do
...@@ -109,7 +108,9 @@ inferType ctx tymap (Or t1 t2 _) = do ...@@ -109,7 +108,9 @@ inferType ctx tymap (Or t1 t2 _) = do
checkType ctx tymap t1 Bool checkType ctx tymap t1 Bool
checkType ctx tymap t2 Bool checkType ctx tymap t2 Bool
return Bool return Bool
inferType ctx _ (Var name _) = lookupVar ctx name inferType ctx tymap (Var name _) = do
ty <- lookupVar ctx name
matchTypeVar tymap ty
inferType ctx tymap (Let name t body _) = do inferType ctx tymap (Let name t body _) = do
tyt <- inferType ctx tymap t tyt <- inferType ctx tymap t
inferType (Bind ctx name tyt) tymap body inferType (Bind ctx name tyt) tymap body
...@@ -159,14 +160,9 @@ checkType ctx tymap (Match m cases _) ty = do ...@@ -159,14 +160,9 @@ checkType ctx tymap (Match m cases _) ty = do
let casechecks = map (\c -> do let casechecks = map (\c -> do
tys <- liftMaybe (M.lookup (labelOfCase c) cotrs) "Could not find constructor" :: Infer [Type] tys <- liftMaybe (M.lookup (labelOfCase c) cotrs) "Could not find constructor" :: Infer [Type]
if length (bindingsOfCase c) == length tys if length (bindingsOfCase c) == length tys
then then do
if not (null (bindingsOfCase c)) let ctx' = foldl (\r (b, bty) -> Bind r b bty) ctx (zip (bindingsOfCase c) tys)
then do checkType ctx' tymap (termOfCase c) ty
let bindchecks = map (\(b, bty) ->
checkType (Bind ctx b bty) tymap (termOfCase c) ty
) $ zip (bindingsOfCase c) tys
foldl (>>) (return ()) bindchecks
else checkType ctx tymap (termOfCase c) ty
else fail "number of bindings does not match number of args of constructor" else fail "number of bindings does not match number of args of constructor"
) cases ) cases
foldl (>>) (return ()) casechecks foldl (>>) (return ()) casechecks
......
...@@ -52,7 +52,7 @@ sharedSpec inferType = do ...@@ -52,7 +52,7 @@ sharedSpec inferType = do
it "should infer match with single binds" $ do it "should infer match with single binds" $ do
let res = convert $ inferType tOkMatchTwo in res `shouldBe` B.Inferred boolADT let res = convert $ inferType tOkMatchTwo in res `shouldBe` B.Inferred boolADT
it "should infer match with multiple binds" $ do it "should infer match with multiple binds" $ do
let res = convert $ inferType tOkMatchWithMultiplebinds in res `shouldBe` B.Inferred Nat let res = convert $ inferType tOkMatchWithMultiplebinds in res `shouldBe` B.Inferred expADT
it "should infer match for simple adt (bool)" $ do it "should infer match for simple adt (bool)" $ do
let res = convert $ inferType tOkMatchSingle in res `shouldBe` B.Inferred boolADT let res = convert $ inferType tOkMatchSingle in res `shouldBe` B.Inferred boolADT
......
...@@ -26,7 +26,7 @@ tOkCotrSingleArg = root (letdata "Bool" (ADT "Bool" (fromList [("True", []), ("F ...@@ -26,7 +26,7 @@ tOkCotrSingleArg = root (letdata "Bool" (ADT "Bool" (fromList [("True", []), ("F
tOkCotrTwoArg = root (letdata "Bool" (ADT "Bool" (fromList [("True", []), ("False", [])])) (letdata "Exp" (ADT "Exp" (fromList [("BoolExp", [TypeVar "Bool"]), ("AndExp", [TypeVar "Exp", TypeVar "Exp"]), ("NotExp", [TypeVar "Exp"])])) (cotr2 "AndExp" (cotr1 "BoolExp" (cotr0 "True")) (cotr1 "BoolExp" (cotr0 "False"))))) tOkCotrTwoArg = root (letdata "Bool" (ADT "Bool" (fromList [("True", []), ("False", [])])) (letdata "Exp" (ADT "Exp" (fromList [("BoolExp", [TypeVar "Bool"]), ("AndExp", [TypeVar "Exp", TypeVar "Exp"]), ("NotExp", [TypeVar "Exp"])])) (cotr2 "AndExp" (cotr1 "BoolExp" (cotr0 "True")) (cotr1 "BoolExp" (cotr0 "False")))))
tOkMatchSingle = root (letdata "Bool" (ADT "Bool" (fromList [("True", []), ("False", [])])) (anno boolADT (match2 (cotr0 "True") (case' "True" [] (cotr0 "False")) (case' "False" [] (cotr0 "True"))))) tOkMatchSingle = root (letdata "Bool" (ADT "Bool" (fromList [("True", []), ("False", [])])) (anno boolADT (match2 (cotr0 "True") (case' "True" [] (cotr0 "False")) (case' "False" [] (cotr0 "True")))))
tOkMatchTwo = root (letdata "Bool" (ADT "Bool" (fromList [("True", []), ("False", [])])) (anno boolADT (match2 (cotr0 "True") (case' "True" [] (cotr0 "False")) (case' "False" [] (cotr0 "True"))))) tOkMatchTwo = root (letdata "Bool" (ADT "Bool" (fromList [("True", []), ("False", [])])) (anno boolADT (match2 (cotr0 "True") (case' "True" [] (cotr0 "False")) (case' "False" [] (cotr0 "True")))))
tOkMatchWithMultiplebinds = root (letdata "Bool" (ADT "Bool" (fromList [("True", []), ("False", [])])) (letdata "Exp" (ADT "Exp" (fromList [("BoolExp", [TypeVar "Bool"]), ("AndExp", [TypeVar "Exp", TypeVar "Exp"]), ("NotExp", [TypeVar "Exp"])])) (anno Nat (match3 ((cotr2 "AndExp" (cotr1 "BoolExp" (cotr0 "True")) (cotr1 "BoolExp" (cotr0 "False")))) (case' "BoolExp" ["x"] zero) (case' "AndExp" ["x", "y"] (succ (succ zero))) (case' "NotExp" ["x"] (succ zero)))))) tOkMatchWithMultiplebinds = root (letdata "Bool" (ADT "Bool" (fromList [("True", []), ("False", [])])) (letdata "Exp" (ADT "Exp" (fromList [("BoolExp", [TypeVar "Bool"]), ("AndExp", [TypeVar "Exp", TypeVar "Exp"]), ("NotExp", [TypeVar "Exp"])])) (anno expADT (match3 ((cotr2 "AndExp" (cotr1 "BoolExp" (cotr0 "True")) (cotr1 "BoolExp" (cotr0 "False")))) (case' "BoolExp" ["x"] (cotr1 "NotExp" (cotr1 "BoolExp" (var "x")))) (case' "AndExp" ["x", "y"] (cotr2 "AndExp" (var "y") (var "x"))) (case' "NotExp" ["x"] (var "x"))))))
tFailArithmetic = root $ (add (succ $ succ zero) (mult (anno (Fun Nat Nat) (lam "f" (var "f"))) (succ $ succ $ succ $ succ zero))) tFailArithmetic = root $ (add (succ $ succ zero) (mult (anno (Fun Nat Nat) (lam "f" (var "f"))) (succ $ succ $ succ $ succ zero)))
tFailLambdaNoAnno = root $ (anno Nat (app (lam "b" (add (var "b") zero)) (succ $ succ zero))) tFailLambdaNoAnno = root $ (anno Nat (app (lam "b" (add (var "b") zero)) (succ $ succ zero)))
......
Markdown is supported
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