[commit: ghc] ghc-7.2: Enable derived but not hand crafted Typeable instances in Safe Haskell (76c74a1)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-7.2

http://hackage.haskell.org/trac/ghc/changeset/76c74a1673295ed484c6861b2d1cdda8b0900daa

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

commit 76c74a1673295ed484c6861b2d1cdda8b0900daa
Author: Ian Lynagh <igloo at earth.li>
Date:   Sun Jul 24 16:04:57 2011 +0100

    Enable derived but not hand crafted Typeable instances in Safe Haskell
    
    Conflicts:
    
    	compiler/typecheck/TcInstDcls.lhs

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

 compiler/typecheck/TcInstDcls.lhs |   12 ++++++++++++
 1 files changed, 12 insertions(+), 0 deletions(-)

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index b28c8a5..8c59b8b 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -39,6 +39,8 @@ import Pair
 import CoreUtils  ( mkPiTypes )
 import CoreUnfold ( mkDFunUnfolding )
 import CoreSyn    ( Expr(Var), CoreExpr, varToCoreExpr )
+import PrelNames  ( typeableClassNames )
+
 import Id
 import MkId
 import Name
@@ -406,6 +408,16 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                     tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
                     addFamInsts deriv_ty_insts $
                     addInsts deriv_inst_info getGblEnv
+
+       -- Check that if the module is compiled with -XSafe, there are no
+       -- hand written instances of Typeable as then unsafe casts could be
+       -- performed. Derivied instances are OK.
+       ; dflags <- getDOpts
+       ; when (safeLanguageOn dflags) $
+             mapM_ (\x -> when (is_cls (iSpec x) `elem` typeableClassNames)
+                               (addErrAt (getSrcSpan $ iSpec x) typInstErr))
+                   local_info
+
        ; return ( addTcgDUs gbl_env deriv_dus,
                   deriv_inst_info ++ local_info,
                   aux_binds `plusHsValBinds` deriv_binds)