[commit: ghc] new-typeable: Implement -XAutoDeriveTypeable, warn for manual instances (101334a)

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

On branch  : new-typeable

http://hackage.haskell.org/trac/ghc/changeset/101334a0aabea62ec9885e601397d935764b2bf7

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

commit 101334a0aabea62ec9885e601397d935764b2bf7
Author: Jose Pedro Magalhaes <[email protected]>
Date:   Mon Nov 26 13:53:01 2012 +0000

    Implement -XAutoDeriveTypeable, warn for manual instances

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

 compiler/main/DynFlags.hs         |    9 ++++++-
 compiler/typecheck/TcDeriv.lhs    |   15 +++++++++++++-
 compiler/typecheck/TcInstDcls.lhs |   40 +++++++++++++++++++++++++++++-------
 3 files changed, 53 insertions(+), 11 deletions(-)

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 1bb3966..b1bd8bc 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -415,6 +415,7 @@ data WarningFlag =
    | Opt_WarnPointlessPragmas
    | Opt_WarnUnsupportedCallingConventions
    | Opt_WarnInlineRuleShadowing
+   | Opt_WarnTypeableInstances
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -481,6 +482,7 @@ data ExtensionFlag
  
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
+   | Opt_AutoDeriveTypeable       -- Automatic derivation of Typeable
    | Opt_DeriveFunctor
    | Opt_DeriveTraversable
    | Opt_DeriveFoldable
@@ -2299,7 +2301,8 @@ fWarningFlags = [
   ( "warn-safe",                        Opt_WarnSafe, setWarnSafe ),
   ( "warn-pointless-pragmas",           Opt_WarnPointlessPragmas, nop ),
   ( "warn-unsupported-calling-conventions", Opt_WarnUnsupportedCallingConventions, nop ),
-  ( "warn-inline-rule-shadowing",       Opt_WarnInlineRuleShadowing, nop ) ]
+  ( "warn-inline-rule-shadowing",       Opt_WarnInlineRuleShadowing, nop ),
+  ( "warn-typeable-instances",          Opt_WarnTypeableInstances, nop ) ]
 
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
 negatableFlags :: [FlagSpec GeneralFlag]
@@ -2528,6 +2531,7 @@ xFlags = [
   ( "UnboxedTuples",                    Opt_UnboxedTuples, nop ),
   ( "StandaloneDeriving",               Opt_StandaloneDeriving, nop ),
   ( "DeriveDataTypeable",               Opt_DeriveDataTypeable, nop ),
+  ( "AutoDeriveTypeable",               Opt_AutoDeriveTypeable, nop ),
   ( "DeriveFunctor",                    Opt_DeriveFunctor, nop ),
   ( "DeriveTraversable",                Opt_DeriveTraversable, nop ),
   ( "DeriveFoldable",                   Opt_DeriveFoldable, nop ),
@@ -2681,7 +2685,8 @@ standardWarnings
         Opt_WarnAlternativeLayoutRuleTransitional,
         Opt_WarnPointlessPragmas,
         Opt_WarnUnsupportedCallingConventions,
-        Opt_WarnInlineRuleShadowing
+        Opt_WarnInlineRuleShadowing,
+        Opt_WarnTypeableInstances
       ]
 
 minusWOpts :: [WarningFlag]
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 59da454..0ad9790 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -308,7 +308,15 @@ tcDeriving tycl_decls inst_decls deriv_decls
                 -- And make the necessary "equations".
           is_boot <- tcIsHsBoot
         ; traceTc "tcDeriving" (ppr is_boot)
-        ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+
+        -- If -XAutoDeriveTypeable is on, add Typeable instances for each
+        -- datatype and class defined in this module
+        ; isAutoDeriveTypeable <- xoptM Opt_AutoDeriveTypeable
+        ; let deriv_decls' = deriv_decls ++ if isAutoDeriveTypeable
+                                              then deriveTypeable tycl_decls
+                                              else []
+
+        ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls'
 
         -- for each type, determine the auxliary declarations that are common
         -- to multiple derivations involving that type (e.g. Generic and
@@ -363,6 +371,11 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
     hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
 
+    deriveTypeable :: [LTyClDecl Name] -> [LDerivDecl Name]
+    deriveTypeable tys =
+      [ L l (DerivDecl (L l (HsAppTy (noLoc (HsTyVar typeableClassName))
+                                     (L l (HsTyVar (tcdName t))))))
+      | L l t <- tys ]
 
 
 -- As of 24 April 2012, this only shares MetaTyCons between derivations of
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index bb56bf9..e5a5baf 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -51,13 +51,14 @@ import VarSet     ( mkVarSet, subVarSet, varSetElems )
 import Pair
 import CoreUnfold ( mkDFunUnfolding )
 import CoreSyn    ( Expr(Var), CoreExpr )
-import PrelNames  ( typeableClassName, oldTypeableClassNames )
+import PrelNames  ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames )
 
 import Bag
 import BasicTypes
 import DynFlags
 import ErrUtils
 import FastString
+import HscTypes ( isHsBoot )
 import Id
 import MkId
 import Name
@@ -377,13 +378,17 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
             -- round)
 
             -- Do class and family instance declarations
+       ; env <- getGblEnv
        ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
        ; let (local_infos_s, fam_insts_s) = unzip stuff
-             local_infos = concat local_infos_s
-             fam_insts   = concat fam_insts_s
+             fam_insts    = concat fam_insts_s
+             local_infos' = concat local_infos_s
+             -- Handwritten instances of the poly-kinded Typeable class are
+             -- forbidden, so we handle those separately
+             (typeable_instances, local_infos) = splitTypeable env local_infos'
+
        ; addClsInsts local_infos $
          addFamInsts fam_insts   $ 
-
     do {    -- Compute instances from "deriving" clauses;
             -- This stuff computes a context for the derived instance
             -- decl, so it needs to know about all the instances possible
@@ -401,11 +406,14 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                          ; return (gbl_env, emptyBag, emptyValBindsOut) }
                  else tcDeriving tycl_decls inst_decls deriv_decls
 
+       -- Remove any handwritten instance of poly-kinded Typeable and warn
+       ; dflags <- getDynFlags
+       ; when (wopt Opt_WarnTypeableInstances dflags) $
+              mapM_ (addWarnTc . instMsg) typeable_instances
 
        -- Check that if the module is compiled with -XSafe, there are no
-       -- hand written instances of Typeable as then unsafe casts could be
+       -- 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))
@@ -419,11 +427,27 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                 , deriv_binds)
     }}
   where
-    typInstCheck ty = is_cls (iSpec ty) `elem`
-                        (typeableClassName : oldTypeableClassNames)
+    -- Separate the Typeable instances from the rest
+    splitTypeable _   []     = ([],[])
+    splitTypeable env (i:is) =
+      let (typeableInsts, otherInsts) = splitTypeable env is
+      in if -- We will filter out instances of Typeable
+            (typeableClassName == is_cls (iSpec i))
+            -- but not those that come from Data.Typeable.Internal
+            && tcg_mod env /= tYPEABLE_INTERNAL
+            -- nor those from an .hs-boot file (deriving can't be used there)
+            && not (isHsBoot (tcg_src env))
+         then (i:typeableInsts, otherInsts)
+         else (typeableInsts, i:otherInsts)
+
+    typInstCheck ty = is_cls (iSpec ty) `elem` oldTypeableClassNames
     typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
                               ++ " Haskell! Can only derive them"
 
+    instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; ignoring "
+                                 ++ "the following instance:"))
+                     2 (pprInstance (iSpec i))
+
 addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
 addClsInsts infos thing_inside
   = tcExtendLocalInstEnv (map iSpec infos) thing_inside