[commit: ghc] master: Dont allow hand-written Generic instances in Safe Haskell. (578fbec)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/578fbeca31dd3d755e24e910c3a7327f92bc4ee3/ghc

>---------------------------------------------------------------

commit 578fbeca31dd3d755e24e910c3a7327f92bc4ee3
Author: David Terei <code at davidterei.com>
Date:   Thu Dec 5 17:27:17 2013 -0800

    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.


>---------------------------------------------------------------

578fbeca31dd3d755e24e910c3a7327f92bc4ee3
 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 2c84e40..b2dec88 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 c3ba825..6ff8a2b 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:"))