X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=479bd670be57296dd9ee7dd03c1c7e7f42887b3e;hb=f04dead93a15af1cb818172f207b8a81d2c81298;hp=cf03e7116b838f1afacdef20d5b19e4d7be6052b;hpb=46f02d59813499ba2aa44e7831e0b69ec6d8f25d;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index cf03e71..479bd67 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -29,7 +29,6 @@ import TcSimplify
 import Type
 import Coercion
 import TyCon
-import TypeRep
 import DataCon
 import Class
 import Var
@@ -433,7 +432,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
               ispec          = mkLocalInstance dfun overlap_flag
 
         ; return (InstInfo { iSpec  = ispec,
-                              iBinds = VanillaInst binds uprags },
+                             iBinds = VanillaInst binds uprags False },
                   idx_tycons)
         }
   where
@@ -601,9 +600,10 @@ tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id)
 -- see Note [Newtype deriving superclasses] in TcDeriv.lhs
 
 tc_inst_decl2 dfun_id (NewTypeDerived coi)
-  = do  { let rigid_info   = InstSkol
-              origin       = SigOrigin rigid_info
-              inst_ty      = idType dfun_id
+  = do  { let rigid_info = InstSkol
+              origin     = SigOrigin rigid_info
+              inst_ty    = idType dfun_id
+	      inst_tvs   = fst (tcSplitForAllTys inst_ty)
         ; (inst_tvs', theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
                 -- inst_head_ty is a PredType
 
@@ -616,7 +616,13 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi)
               (rep_ty, wrapper) 
 	         = case coi of
 	      	     IdCo   -> (last_ty, idHsWrapper)
-		     ACo co -> (snd (coercionKind co), WpCast (mk_full_coercion co))
+		     ACo co -> (snd (coercionKind co'), WpCast (mk_full_coercion co'))
+			    where
+			       co' = substTyWith inst_tvs (mkTyVarTys inst_tvs') co
+				-- NB: the free variable of coi are bound by the
+				-- universally quantified variables of the dfun_id
+				-- This is weird, and maybe we should make NewTypeDerived
+				-- carry a type-variable list too; but it works fine
 
 		 -----------------------
 		 --        mk_full_coercion
@@ -699,7 +705,7 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi)
 ------------------------
 -- Ordinary instances
 
-tc_inst_decl2 dfun_id (VanillaInst monobinds uprags)
+tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
   = do { let rigid_info = InstSkol
              inst_ty    = idType dfun_id
 
@@ -731,13 +737,13 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags)
 	     dfun_lam_vars = map instToVar dfun_dicts	-- Includes equalities
 	     prag_fn	= mkPragFun uprags 
              loc        = getSrcSpan dfun_id
-	     tc_meth    = tcInstanceMethod loc clas inst_tyvars'
-	     		  	 dfun_dicts
+	     tc_meth    = tcInstanceMethod loc standalone_deriv 
+                                 clas inst_tyvars' dfun_dicts
                         	 dfun_theta' inst_tys'
 	     			 this_dict dfun_id
                              	 prag_fn monobinds
        ; (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars'  $
-				mapAndUnzipM tc_meth op_items 
+				     mapAndUnzipM tc_meth op_items 
 
          -- Figure out bindings for the superclass context
          -- Don't include this_dict in the 'givens', else
@@ -815,7 +821,7 @@ tcInstanceMethod
 - Use tcValBinds to do the checking
 
 \begin{code}
-tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Inst]
+tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst]
 	 	 -> TcThetaType -> [TcType]
 		 -> Inst -> Id
           	 -> TcPragFun -> LHsBinds Name 
@@ -824,7 +830,7 @@ tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Inst]
 	-- The returned inst_meth_ids all have types starting
 	--	forall tvs. theta => ...
 
-tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys 
+tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts theta inst_tys 
 		 this_dict dfun_id prag_fn binds_in (sel_id, dm_info)
   = do	{ cloned_this <- cloneDict this_dict
 		-- Need to clone the dict in case it is floated out, and
@@ -839,12 +845,14 @@ tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys
 		-- involved; otherwise overlap is not possible
 		-- See Note [Subtle interaction of recursion and overlap]	
 
-	      tc_body rn_bind = do { (meth_id, tc_binds) <- tcInstanceMethodBody 
+	      tc_body rn_bind 
+                = add_meth_ctxt rn_bind $
+                  do { (meth_id, tc_binds) <- tcInstanceMethodBody 
 						InstSkol clas tyvars dfun_dicts theta inst_tys
 						mb_this_bind sel_id 
 						local_meth_name
 						meth_sig_fn meth_prag_fn rn_bind
-				   ; return (wrapId meth_wrapper meth_id, tc_binds) }
+		     ; return (wrapId meth_wrapper meth_id, tc_binds) }
 
 	; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of
 		-- There is a user-supplied method binding, so use it
@@ -902,9 +910,21 @@ tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys
     dfun_lam_vars = map instToVar dfun_dicts
     meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars)
 
+	-- For instance decls that come from standalone deriving clauses
+	-- we want to print out the full source code if there's an error
+	-- because otherwise the user won't see the code at all
+    add_meth_ctxt rn_bind thing 
+      | standalone_deriv = addLandmarkErrCtxt (derivBindCtxt clas inst_tys rn_bind) thing
+      | otherwise        = thing
 
 wrapId :: HsWrapper -> id -> HsExpr id
 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
+
+derivBindCtxt :: Class -> [Type ] -> LHsBind Name -> SDoc
+derivBindCtxt clas tys bind
+   = vcat [ ptext (sLit "When typechecking a standalone-derived method for")
+	    <+> quotes (pprClassPred clas tys) <> colon
+	  , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
 \end{code}
 
 Note [Default methods in instances]