Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

added test for bug. experimented with solutions, none found

Browse source
This commit is contained in:
sebastian 2023-03-26 16:57:34 +02:00
parent 2af7855a77
commit 4e92f86d60
1 changed files with 10 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

15
src/TypeChecker/TypeChecker.hs
View file

@ -12,6 +12,7 @@ import Control.Monad.State
import Data.Bifunctor (second) import Data.Bifunctor (second)
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Data.Foldable (traverse_) import Data.Foldable (traverse_)
import Data.Function (on)
import Data.List (foldl') import Data.List (foldl')
import Data.List.Extra (unsnoc) import Data.List.Extra (unsnoc)
import Data.Map (Map) import Data.Map (Map)
@ -149,6 +150,12 @@ typeEq t1 (T.TAll _ t2) = t1 `typeEq` t2
typeEq (T.TVar _) (T.TVar _) = True typeEq (T.TVar _) (T.TVar _) = True
typeEq _ _ = False typeEq _ _ = False
skolem :: T.Type -> T.Type
skolem (T.TVar (T.MkTVar a)) = T.TLit a
skolem (T.TAll x t) = T.TAll x (skolem t)
skolem (T.TFun t1 t2) = (T.TFun `on` skolem) t1 t2
skolem t = t
isMoreSpecificOrEq :: T.Type -> T.Type -> Bool isMoreSpecificOrEq :: T.Type -> T.Type -> Bool
isMoreSpecificOrEq t1 (T.TAll _ t2) = isMoreSpecificOrEq t1 t2 isMoreSpecificOrEq t1 (T.TAll _ t2) = isMoreSpecificOrEq t1 t2
isMoreSpecificOrEq (T.TFun a b) (T.TFun c d) = isMoreSpecificOrEq (T.TFun a b) (T.TFun c d) =
@ -181,7 +188,7 @@ instance CollectTVars Exp where
instance CollectTVars Type where instance CollectTVars Type where
collectTypeVars (TVar (MkTVar i)) = S.singleton (coerce i) collectTypeVars (TVar (MkTVar i)) = S.singleton (coerce i)
collectTypeVars (TAll _ t) = collectTypeVars t collectTypeVars (TAll _ t) = collectTypeVars t
collectTypeVars (TFun t1 t2) = collectTypeVars t1 `S.union` collectTypeVars t2 collectTypeVars (TFun t1 t2) = (S.union `on` collectTypeVars) t1 t2
collectTypeVars (TData _ ts) = foldl' (\acc x -> acc `S.union` collectTypeVars x) S.empty ts collectTypeVars (TData _ ts) = foldl' (\acc x -> acc `S.union` collectTypeVars x) S.empty ts
collectTypeVars _ = S.empty collectTypeVars _ = S.empty
@ -195,7 +202,7 @@ instance NewType Type T.Type where
toNew = \case toNew = \case
TLit i -> T.TLit $ coerce i TLit i -> T.TLit $ coerce i
TVar v -> T.TVar $ toNew v TVar v -> T.TVar $ toNew v
TFun t1 t2 -> T.TFun (toNew t1) (toNew t2) TFun t1 t2 -> (T.TFun `on` toNew) t1 t2
TAll b t -> T.TAll (toNew b) (toNew t) TAll b t -> T.TAll (toNew b) (toNew t)
TData i ts -> T.TData (coerce i) (map toNew ts) TData i ts -> T.TData (coerce i) (map toNew ts)
TEVar _ -> error "Should not exist after typechecker" TEVar _ -> error "Should not exist after typechecker"
@ -414,10 +421,8 @@ occurs i t =
-- | Generalize a type over all free variables in the substitution set -- | Generalize a type over all free variables in the substitution set
generalize :: Map T.Ident T.Type -> T.Type -> T.Type generalize :: Map T.Ident T.Type -> T.Type -> T.Type
generalize env t = go freeVars $ removeForalls t generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t)
where where
freeVars :: [T.Ident]
freeVars = S.toList $ free t S.\\ free env
go :: [T.Ident] -> T.Type -> T.Type go :: [T.Ident] -> T.Type -> T.Type
go [] t = t go [] t = t
go (x : xs) t = T.TAll (T.MkTVar x) (go xs t) go (x : xs) t = T.TAll (T.MkTVar x) (go xs t)