Migrate cvs diff from fptools-assoc branch

[ghc-hetmet.git] / compiler / typecheck / TcDeriv.lhs

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 95d9697..65c425d 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -31,10 +31,10 @@ import RnEnv                ( bindLocalNames )
 import HscTypes                ( FixityEnv )
 
 import Class           ( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Type            ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred )
+import Type            ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred, mkTyVarTy )
 import ErrUtils                ( dumpIfSet_dyn )
 import MkId            ( mkDictFunId )
-import DataCon         ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys )
+import DataCon         ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys, dataConInstOrigArgTys )
 import Maybes          ( catMaybes )
 import RdrName         ( RdrName )
 import Name            ( Name, getSrcLoc )
@@ -568,7 +568,7 @@ mkDataTypeEqn tycon clas
     ordinary_constraints
       = [ mkClassPred clas [arg_ty] 
         | data_con <- tyConDataCons tycon,
-          arg_ty   <- dataConOrigArgTys data_con,
+          arg_ty <- dataConInstOrigArgTys data_con (map mkTyVarTy (tyConTyVars tycon)),
           not (isUnLiftedType arg_ty)  -- No constraints for unlifted types?
         ]
 
@@ -729,9 +729,9 @@ solveDerivEqns overlap_flag orig_eqns
     gen_soln (_, clas, tc,tyvars,deriv_rhs)
       = setSrcSpan (srcLocSpan (getSrcLoc tc)) $
        do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)]
-          ; theta <- addErrCtxt (derivInstCtxt [] clas inst_tys) $
+          ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $
                      tcSimplifyDeriv tc tyvars deriv_rhs
-          ; addErrCtxt (derivInstCtxt theta clas inst_tys) $
+          ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $
             checkValidInstance tyvars theta clas inst_tys
           ; return (sortLe (<=) theta) }       -- Canonicalise before returning the soluction
       where
@@ -952,7 +952,7 @@ genTaggeryBinds infos
 \begin{code}
 derivingThingErr clas tys tycon tyvars why
   = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)],
-        parens why]
+        nest 2 (parens why)]
   where
     pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])
 
@@ -960,8 +960,12 @@ derivCtxt :: TyCon -> SDoc
 derivCtxt tycon
   = ptext SLIT("When deriving instances for") <+> quotes (ppr tycon)
 
-derivInstCtxt theta clas inst_tys
-  = hang (ptext SLIT("In the derived instance"))
-       2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, pprClassPred clas inst_tys])
+derivInstCtxt1 clas inst_tys
+  = ptext SLIT("When deriving the instance for") <+> quotes (pprClassPred clas inst_tys)
+
+derivInstCtxt2 theta clas inst_tys
+  = vcat [ptext SLIT("In the derived instance declaration"),
+          nest 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, 
+                                                 pprClassPred clas inst_tys])]
 \end{code}