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 c31e6aa..65c425d 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -15,6 +15,7 @@ import DynFlags       ( DynFlag(..) )
 
 import Generics                ( mkTyConGenericBinds )
 import TcRnMonad
+import TcMType         ( checkValidInstance )
 import TcEnv           ( newDFunName, pprInstInfoDetails, 
                          InstInfo(..), InstBindings(..), simpleInstInfoClsTy,
                          tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
@@ -30,10 +31,10 @@ import RnEnv                ( bindLocalNames )
 import HscTypes                ( FixityEnv )
 
 import Class           ( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Type            ( zipOpenTvSubst, substTheta )
+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 )
@@ -341,7 +342,7 @@ makeDerivEqns overlap_flag tycl_decls
     mk_eqn (new_or_data, tycon_name, hs_deriv_ty)
       = tcLookupTyCon tycon_name               `thenM` \ tycon ->
        setSrcSpan (srcLocSpan (getSrcLoc tycon))               $
-        addErrCtxt (derivCtxt Nothing tycon)   $
+        addErrCtxt (derivCtxt tycon)           $
        tcExtendTyVarEnv (tyConTyVars tycon)    $       -- Deriving preds may (now) mention
                                                        -- the type variables for the type constructor
        tcHsDeriv hs_deriv_ty                   `thenM` \ (deriv_tvs, clas, tys) ->
@@ -567,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?
         ]
 
@@ -726,10 +727,15 @@ solveDerivEqns overlap_flag orig_eqns
 
     ------------------------------------------------------------------
     gen_soln (_, clas, tc,tyvars,deriv_rhs)
-      = setSrcSpan (srcLocSpan (getSrcLoc tc))         $
-       addErrCtxt (derivCtxt (Just clas) tc)   $
-       tcSimplifyDeriv tc tyvars deriv_rhs     `thenM` \ theta ->
-       returnM (sortLe (<=) theta)     -- Canonicalise before returning the soluction
+      = setSrcSpan (srcLocSpan (getSrcLoc tc)) $
+       do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)]
+          ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $
+                     tcSimplifyDeriv tc tyvars deriv_rhs
+          ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $
+            checkValidInstance tyvars theta clas inst_tys
+          ; return (sortLe (<=) theta) }       -- Canonicalise before returning the soluction
+      where
+       
 
     ------------------------------------------------------------------
     mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta
@@ -828,7 +834,7 @@ genInst spec
        -- *non-renamed* auxiliary bindings
        ; (rn_meth_binds, _fvs) <- discardWarnings $ 
                                   bindLocalNames (map varName tyvars)  $
-                                  rnMethodBinds clas_nm [] meth_binds
+                                  rnMethodBinds clas_nm (\n -> []) [] meth_binds
 
        -- Build the InstInfo
        ; return (InstInfo { iSpec = spec, 
@@ -946,16 +952,20 @@ 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)])
 
-derivCtxt :: Maybe Class -> TyCon -> SDoc
-derivCtxt maybe_cls tycon
-  = ptext SLIT("When deriving") <+> cls <+> ptext SLIT("for type") <+> quotes (ppr tycon)
-  where
-    cls = case maybe_cls of
-           Nothing -> ptext SLIT("instances")
-           Just c  -> ptext SLIT("the") <+> quotes (ppr c) <+> ptext SLIT("instance")
+derivCtxt :: TyCon -> SDoc
+derivCtxt tycon
+  = ptext SLIT("When deriving instances for") <+> quotes (ppr tycon)
+
+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}