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 <j...@cs.ox.ac.uk> 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 _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
