git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Disallow type synonym instances #177
554c9a0Phil Freeman
examples/failing/TypeSynonyms2.pursnew file+9
compare with golang
unifiedsplit
@@ -0,0 +1,9 @@
1+module TypeSynonyms2 where
2+
3+class Foo a where
4+ foo :: a -> String
5+
6+type Bar = String
7+
8+instance Foo Bar where
9+ foo s = s
examples/failing/TypeSynonyms3.pursnew file+13
@@ -0,0 +1,13 @@
1+module TypeSynonyms2 where
2+
3+class Foo a where
4+ foo :: a -> String
5+
6+type Bar = String
7+
8+module M where
9+
10+import TypeSynonyms2
11+
12+instance TypeSynonyms2.Foo Bar where
13+ foo s = s
src/Language/PureScript/TypeChecker.hs+11
@@ -90,6 +90,15 @@ addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
90addTypeClassDictionaries entries = do
90addTypeClassDictionaries entries = do
91 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
91 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
92
92
93+checkTypeClassInstance :: ModuleName -> Type -> Check ()
94+checkTypeClassInstance _ (TypeVar _) = return ()
95+checkTypeClassInstance m (TypeConstructor ctor) = do
96+ env <- getEnv
97+ when (canonicalizeType m env ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"
98+ return ()
99+checkTypeClassInstance m (TypeApp ty (TypeVar _)) = checkTypeClassInstance m ty
100+checkTypeClassInstance _ _ = throwError "Type class instance must be of the form T a1 ... an"
101+
93-- |
102-- |
94-- Type check all declarations in a module
103-- Type check all declarations in a module
95--
104--
@@ -242,6 +251,8 @@ typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
242typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
251typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
243 env <- getEnv
252 env <- getEnv
244 dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
253 dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
254+ checkTypeClassInstance moduleName ty
255+ forM_ deps $ checkTypeClassInstance moduleName . snd
245 addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env
256 addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env
246 [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])
257 [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])
247 ds <- typeCheckAll moduleName rest
258 ds <- typeCheckAll moduleName rest