git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Disallow orphan instances
19c27abGary Burgess
examples/failing/OrphanInstance.pursnew file+12
compare with golang
unifiedsplit
@@ -0,0 +1,12 @@
1+-- @shouldFailWith OrphanInstance
2+module Class where
3+
4+ class C a where
5+ op :: a -> a
6+
7+module Test where
8+
9+ import Class
10+
11+ instance cBoolean :: C Boolean where
12+ op a = a
src/Language/PureScript/Errors.hs+6−2
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.Error
3-- Module : Language.PureScript.Error
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -115,6 +115,7 @@ data SimpleErrorMessage
115 | PropertyIsMissing String Type
115 | PropertyIsMissing String Type
116 | CannotApplyFunction Type Expr
116 | CannotApplyFunction Type Expr
117 | TypeSynonymInstance
117 | TypeSynonymInstance
118+ | OrphanInstance Ident (Qualified ProperName) [Type]
118 | InvalidNewtype
119 | InvalidNewtype
119 | InvalidInstanceHead Type
120 | InvalidInstanceHead Type
120 | TransitiveExportError DeclarationRef [DeclarationRef]
121 | TransitiveExportError DeclarationRef [DeclarationRef]
@@ -226,6 +227,7 @@ errorCode em = case unwrapErrorMessage em of
226 (PropertyIsMissing _ _) -> "PropertyIsMissing"
227 (PropertyIsMissing _ _) -> "PropertyIsMissing"
227 (CannotApplyFunction _ _) -> "CannotApplyFunction"
228 (CannotApplyFunction _ _) -> "CannotApplyFunction"
228 TypeSynonymInstance -> "TypeSynonymInstance"
229 TypeSynonymInstance -> "TypeSynonymInstance"
230+ (OrphanInstance _ _ _) -> "OrphanInstance"
229 InvalidNewtype -> "InvalidNewtype"
231 InvalidNewtype -> "InvalidNewtype"
230 (InvalidInstanceHead _) -> "InvalidInstanceHead"
232 (InvalidInstanceHead _) -> "InvalidInstanceHead"
231 (TransitiveExportError _ _) -> "TransitiveExportError"
233 (TransitiveExportError _ _) -> "TransitiveExportError"
@@ -545,6 +547,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
545 ]
547 ]
546 goSimple TypeSynonymInstance =
548 goSimple TypeSynonymInstance =
547 line "Type synonym instances are disallowed"
549 line "Type synonym instances are disallowed"
550+ goSimple (OrphanInstance nm cnm ts) =
551+ line $ "Instance " ++ show nm ++ " for " ++ show cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance"
548 goSimple InvalidNewtype =
552 goSimple InvalidNewtype =
549 line "Newtypes must define a single constructor with a single argument"
553 line "Newtypes must define a single constructor with a single argument"
550 goSimple (InvalidInstanceHead ty) =
554 goSimple (InvalidInstanceHead ty) =
src/Language/PureScript/TypeChecker.hs+16−2
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.TypeChecker
3-- Module : Language.PureScript.TypeChecker
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -235,12 +235,26 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
235 goInstance d dictName deps className tys = do
235 goInstance d dictName deps className tys = do
236 mapM_ (checkTypeClassInstance moduleName) tys
236 mapM_ (checkTypeClassInstance moduleName) tys
237 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
237 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
238+ checkOrphanInstance moduleName className tys
238 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported
239 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported
239 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict
240 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict
240 return d
241 return d
241
242
242 where
243 where
243
244
245+ checkOrphanInstance :: ModuleName -> Qualified ProperName -> [Type] -> Check ()
246+ checkOrphanInstance mn (Qualified (Just mn') _) tys
247+ | mn == mn' || any checkType tys = return ()
248+ | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys
249+ where
250+ checkType :: Type -> Bool
251+ checkType (TypeVar _) = False
252+ checkType (TypeConstructor (Qualified (Just mn'') _)) = mn == mn''
253+ checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance"
254+ checkType (TypeApp t1 _) = checkType t1
255+ checkType _ = error "Invalid type in instance in checkOrphanInstance"
256+ checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"
257+
244 isInstanceExported :: Bool
258 isInstanceExported :: Bool
245 isInstanceExported = any exportsInstance exps
259 isInstanceExported = any exportsInstance exps
246
260