[commit: ghc] wip/T9968: Some more work (b81be33)

[git at git.haskell.org]

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

On branch  : wip/T9968
Link       : http://ghc.haskell.org/trac/ghc/changeset/b81be333a1920fbfc05a852a4dac5e2e8e29492d/ghc

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

commit b81be333a1920fbfc05a852a4dac5e2e8e29492d
Author: Jose Pedro Magalhaes <jpm at cs.ox.ac.uk>
Date:   Tue Feb 17 16:29:46 2015 +0000

    Some more work


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

b81be333a1920fbfc05a852a4dac5e2e8e29492d
 compiler/typecheck/TcDeriv.hs | 27 +++++++++++++++------------
 1 file changed, 15 insertions(+), 12 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index abf01ae..219bb2c 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -48,7 +48,7 @@ import ErrUtils
 import DataCon
 import Maybes
 import RdrName
--- import Id ( idType )
+import Id ( idType )
 import Name
 import NameSet
 import TyCon
@@ -1097,11 +1097,11 @@ inferConstraints std_cls 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])
-       ; dm_constraints <- return [] -- get_dm_constraints
+       ; dm_constraints <- get_dm_constraints
        ; let constraints = stupid_constraints ++ sc_constraints
                            ++ if std_cls
                               then extra_constraints ++ arg_constraints
-                              else dm_constraints
+                              else mkThetaOrigin DerivOrigin (concat dm_constraints)
        ; return constraints }
   where
     arg_constraints = con_arg_constraints cls get_std_constrained_tys
@@ -1141,20 +1141,23 @@ inferConstraints std_cls cls inst_tys rep_tc rep_tc_args
                     | 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 :: ClassOpItem -> TcM ThetaType
+      f (_, DefMeth    name) = tcLookupId name >>= return . g
+      f (_, GenDefMeth name) = tcLookupId name >>= return . g
       f x                    = pprPanic "dm_constraints" (ppr x)
-      g :: Id -> ThetaOrigin
-      g x = case getClassPredTys_maybe (idType x) of
-              Nothing      -> []
-              Just (_, ty) -> mkThetaOrigin DerivOrigin
--}
+
+      g :: Id -> ThetaType
+      g x = let (_, _, t)     = tcSplitSigmaTy (idType x) -- tcSplitDFunTy?
+                (_, ctx, _)   = tcSplitSigmaTy t
+                classTyVarSet = mkVarSet (classTyVars cls)
+                usefulCtx     = filter (\p -> tcTyVarsOfType p `subVarSet`
+                                                     classTyVarSet) ctx
+            in substTheta (zipOpenTvSubst (classTyVars cls) inst_tys) usefulCtx
+
         -- Constraints arising from superclasses
         -- See Note [Superclasses of derived instance]
     sc_constraints = mkThetaOrigin DerivOrigin $