git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Disallow orphan instances
commit19c27ab792d9ac8a31812e3460504602d0fa176d authorGary Burgess <gary.burgess@gmail.com> dateThu 13 Aug 2015, 12:41 (11 years ago) parent256497c
3 files changed+34−4
compare with golang
unifiedsplit
examples/failing/OrphanInstance.purs+12 src/Language/PureScript/Errors.hs+6−2 src/Language/PureScript/TypeChecker.hs+16−2
examples/failing/OrphanInstance.pursnew file+12
@@ -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 @@
11-----------------------------------------------------------------------------
22--
33-- Module : Language.PureScript.Error
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5+-- License : MIT (http://opensource.org/licenses/MIT)
66--
77-- Maintainer : Phil Freeman <paf31@cantab.net>
88-- Stability : experimental
@@ -115,6 +115,7 @@ data SimpleErrorMessage
115115 | PropertyIsMissing String Type
116116 | CannotApplyFunction Type Expr
117117 | TypeSynonymInstance
118+ | OrphanInstance Ident (Qualified ProperName) [Type]
118119 | InvalidNewtype
119120 | InvalidInstanceHead Type
120121 | TransitiveExportError DeclarationRef [DeclarationRef]
@@ -226,6 +227,7 @@ errorCode em = case unwrapErrorMessage em of
226227 (PropertyIsMissing _ _) -> "PropertyIsMissing"
227228 (CannotApplyFunction _ _) -> "CannotApplyFunction"
228229 TypeSynonymInstance -> "TypeSynonymInstance"
230+ (OrphanInstance _ _ _) -> "OrphanInstance"
229231 InvalidNewtype -> "InvalidNewtype"
230232 (InvalidInstanceHead _) -> "InvalidInstanceHead"
231233 (TransitiveExportError _ _) -> "TransitiveExportError"
@@ -545,6 +547,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
545547 ]
546548 goSimple TypeSynonymInstance =
547549 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"
548552 goSimple InvalidNewtype =
549553 line "Newtypes must define a single constructor with a single argument"
550554 goSimple (InvalidInstanceHead ty) =
src/Language/PureScript/TypeChecker.hs+16−2
@@ -1,8 +1,8 @@
11-----------------------------------------------------------------------------
22--
33-- Module : Language.PureScript.TypeChecker
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5+-- License : MIT (http://opensource.org/licenses/MIT)
66--
77-- Maintainer : Phil Freeman <paf31@cantab.net>
88-- Stability : experimental
@@ -235,12 +235,26 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
235235 goInstance d dictName deps className tys = do
236236 mapM_ (checkTypeClassInstance moduleName) tys
237237 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
238+ checkOrphanInstance moduleName className tys
238239 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported
239240 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict
240241 return d
241242
242243 where
243244
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+
244258 isInstanceExported :: Bool
245259 isInstanceExported = any exportsInstance exps
246260