diff options
| -rw-r--r-- | compiler/prelude/PrelNames.lhs | 3 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 31 |
2 files changed, 24 insertions, 10 deletions
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 2c84e40565..b2dec88c02 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -1084,6 +1084,9 @@ datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassK constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey +genericClassNames :: [Name] +genericClassNames = [genClassName, gen1ClassName] + -- GHCi things ghciIoClassName, ghciStepIoMName :: Name ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index c3ba825cd5..6ff8a2b0cf 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -51,8 +51,8 @@ import VarEnv import VarSet import CoreUnfold ( mkDFunUnfolding ) import CoreSyn ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps ) -import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames ) - +import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, + oldTypeableClassNames, genericClassNames ) import Bag import BasicTypes import DynFlags @@ -415,13 +415,16 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- hand written instances of old Typeable as then unsafe casts could be -- performed. Derived instances are OK. ; dflags <- getDynFlags - ; when (safeLanguageOn dflags) $ - mapM_ (\x -> when (typInstCheck x) - (addErrAt (getSrcSpan $ iSpec x) typInstErr)) - local_infos + ; when (safeLanguageOn dflags) $ forM_ local_infos $ \x -> case x of + _ | typInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (typInstErr x) + _ | genInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (genInstErr x) + _ -> return () + -- As above but for Safe Inference mode. - ; when (safeInferOn dflags) $ - mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos + ; when (safeInferOn dflags) $ forM_ local_infos $ \x -> case x of + _ | typInstCheck x -> recordUnsafeInfer + _ | genInstCheck x -> recordUnsafeInfer + _ -> return () ; return ( gbl_env , bagToList deriv_inst_info ++ local_infos @@ -442,8 +445,16 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls else (typeableInsts, i:otherInsts) typInstCheck ty = is_cls_nm (iSpec ty) `elem` oldTypeableClassNames - typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe" - ++ " Haskell! Can only derive them" + typInstErr i = hang (ptext (sLit $ "Typeable instances can only be " + ++ "derived in Safe Haskell.") $+$ + ptext (sLit "Replace the following instance:")) + 2 (pprInstanceHdr (iSpec i)) + + genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames + genInstErr i = hang (ptext (sLit $ "Generic instances can only be " + ++ "derived in Safe Haskell.") $+$ + ptext (sLit "Replace the following instance:")) + 2 (pprInstanceHdr (iSpec i)) instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; replace " ++ "the following instance:")) |