[commit: ghc] wip/T9968: Start fixing T9968 (ecfc5ad)
git at git.haskell.org
git at git.haskell.org
Mon Feb 16 15:20:04 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T9968
Link : http://ghc.haskell.org/trac/ghc/changeset/ecfc5adbc4af7e1e7ce37010d7cf5f1787dc84b9/ghc
>---------------------------------------------------------------
commit ecfc5adbc4af7e1e7ce37010d7cf5f1787dc84b9
Author: Jose Pedro Magalhaes <jpm at cs.ox.ac.uk>
Date: Mon Feb 16 15:17:15 2015 +0000
Start fixing T9968
>---------------------------------------------------------------
ecfc5adbc4af7e1e7ce37010d7cf5f1787dc84b9
compiler/typecheck/TcDeriv.hs | 56 ++++++++++++++++++++++++++++++-------------
1 file changed, 39 insertions(+), 17 deletions(-)
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 9073720..abf01ae 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -48,6 +48,7 @@ import ErrUtils
import DataCon
import Maybes
import RdrName
+-- import Id ( idType )
import Name
import NameSet
import TyCon
@@ -723,8 +724,7 @@ deriveTyData :: Bool -- False <=> data/newtype
deriveTyData is_instance tvs tc tc_args (L loc deriv_pred)
= setSrcSpan loc $ -- Use the location of the 'deriving' item
do { (deriv_tvs, cls, cls_tys, cls_arg_kind)
- <- tcExtendTyVarEnv tvs $
- tcHsDeriv deriv_pred
+ <- tcExtendTyVarEnv tvs (tcHsDeriv deriv_pred)
-- Deriving preds may (now) mention
-- the type variables for the type constructor, hence tcExtendTyVarenv
-- The "deriv_pred" is a LHsType to take account of the fact that for
@@ -1007,21 +1007,23 @@ mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
-- NB: pass the *representation* tycon to checkSideConditions
NonDerivableClass msg -> bale_out (nonStdErr cls $$ msg)
DerivableClassError msg -> bale_out msg
- CanDerive -> go_for_it
- DerivableViaInstance -> go_for_it
+ CanDerive -> go_for_it True
+ DerivableViaInstance -> go_for_it False
where
- go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
- bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
+ go_for_it std_cls = mk_data_eqn overlap_mode std_cls tvs cls cls_tys tycon
+ tc_args rep_tc rep_tc_args mtheta
+ bale_out msg = failWithTc (derivingThingErr False cls cls_tys
+ (mkTyConApp tycon tc_args) msg)
-mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class
+mk_data_eqn :: Maybe OverlapMode -> Bool -> [TyVar] -> Class -> [Type]
-> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
-mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+mk_data_eqn overlap_mode std_cls tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
= do loc <- getSrcSpanM
dfun_name <- new_dfun_name cls tycon
case mtheta of
Nothing -> do --Infer context
- inferred_constraints <- inferConstraints cls inst_tys rep_tc rep_tc_args
+ inferred_constraints <- inferConstraints std_cls cls inst_tys rep_tc rep_tc_args
return $ InferTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs
@@ -1040,7 +1042,7 @@ mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
, ds_overlap = overlap_mode
, ds_newtype = False }
where
- inst_tys = [mkTyConApp tycon tc_args]
+ inst_tys = cls_tys ++ [mkTyConApp tycon tc_args]
----------------------
@@ -1076,13 +1078,14 @@ mkPolyKindedTypeableEqn cls tc
tc_args = mkTyVarTys kvs
tc_app = mkTyConApp tc tc_args
-inferConstraints :: Class -> [TcType]
+inferConstraints :: Bool
+ -> Class -> [TcType]
-> TyCon -> [TcType]
-> TcM ThetaOrigin
-- Generate a sufficiently large set of constraints that typechecking the
-- generated method definitions should succeed. This set will be simplified
-- before being used in the instance declaration
-inferConstraints cls inst_tys rep_tc rep_tc_args
+inferConstraints std_cls cls inst_tys rep_tc rep_tc_args
| cls `hasKey` genClassKey -- Generic constraints are easy
= return []
@@ -1094,9 +1097,12 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
| otherwise -- The others are a bit more complicated
= ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
do { traceTc "inferConstraints" (vcat [ppr cls <+> ppr inst_tys, ppr arg_constraints])
- ; return (stupid_constraints ++ extra_constraints
- ++ sc_constraints
- ++ arg_constraints) }
+ ; dm_constraints <- return [] -- get_dm_constraints
+ ; let constraints = stupid_constraints ++ sc_constraints
+ ++ if std_cls
+ then extra_constraints ++ arg_constraints
+ else dm_constraints
+ ; return constraints }
where
arg_constraints = con_arg_constraints cls get_std_constrained_tys
@@ -1134,6 +1140,21 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
= rep_tc_args ++ [mkTyVarTy last_tv]
| otherwise = rep_tc_args
+ -- Constraints arising from default methods (only for DeriveAnyClass)
+{-
+ get_dm_constraints = mapM f dms where
+
+ dms = filter ((/= NoDefMeth) . snd) (classOpItems cls)
+
+ f :: ClassOpItem -> TcM Type
+ f (_, DefMeth name) = tcLookupId name >>= return . idType
+ f (_, GenDefMeth name) = tcLookupId name >>= return . getClassPredTys_maybe . idType
+ f x = pprPanic "dm_constraints" (ppr x)
+ g :: Id -> ThetaOrigin
+ g x = case getClassPredTys_maybe (idType x) of
+ Nothing -> []
+ Just (_, ty) -> mkThetaOrigin DerivOrigin
+-}
-- Constraints arising from superclasses
-- See Note [Superclasses of derived instance]
sc_constraints = mkThetaOrigin DerivOrigin $
@@ -1584,8 +1605,9 @@ mkNewTypeEqn dflags overlap_mode tvs
where
newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
deriveAnyClass = xopt Opt_DeriveAnyClass dflags
- go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args
- rep_tycon rep_tc_args mtheta
+ go_for_it = mk_data_eqn overlap_mode (not deriveAnyClass) tvs
+ cls cls_tys tycon tc_args
+ rep_tycon rep_tc_args mtheta
bale_out = bale_out' newtype_deriving
bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty
More information about the ghc-commits
mailing list