From 578fbeca31dd3d755e24e910c3a7327f92bc4ee3 Mon Sep 17 00:00:00 2001
From: David Terei <code@davidterei.com>
Date: Thu, 5 Dec 2013 17:27:17 -0800
Subject: [PATCH] Dont allow hand-written Generic instances in Safe Haskell.
While they aren't strictly unsafe, it is a similar situation to
Typeable. There are few instances where a programmer will write their
own instance, and having compiler assurance that the Generic
implementation is correct brings a lot of benefits.
---
compiler/prelude/PrelNames.lhs | 3 +++
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 2c84e40565aa..b2dec88c0232 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 c3ba825cd58d..6ff8a2b0cff8 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:"))
--
GitLab