Fix Trac #3012: allow more free-wheeling in standalone deriving

In standalone deriving, we now do *not* check side conditions.
We simply generate the code and typecheck it.  If there's a type
error, it's the programmer's problem. 

This means that you can do 'deriving instance Show (T a)', where
T is a GADT, for example, provided of course that the boilerplate
code does in fact typecheck.

I put some work into getting a decent error message.  In particular
if there's a type error in a method, GHC will show the entire code
for that method (since, after all, the user did not write it).
Most of the changes are to achieve that goal.

Still to come: changes in the documentation.

8 files changed, 100 insertions, 69 deletions

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 04a9f2b263..18d202228b 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -533,7 +533,7 @@ mkGenericInstance clas (hs_ty, binds) = do
 	dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
 	ispec	   = mkLocalInstance dfun_id overlap_flag
 
-    return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] })
+    return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
 \end{code}
 
 
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index e121cc6e2e..a24f147314 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -288,12 +288,12 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
 	; overlap_flag <- getOverlapFlag
 	; let (infer_specs, given_specs) = splitEithers early_specs
-	; insts1 <- mapM (genInst overlap_flag) given_specs
+	; insts1 <- mapM (genInst True overlap_flag) given_specs
 
 	; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
 			 inferInstanceContexts overlap_flag infer_specs
 
-	; insts2 <- mapM (genInst overlap_flag) final_specs
+	; insts2 <- mapM (genInst False overlap_flag) final_specs
 
 		 -- Generate the generic to/from functions from each type declaration
 	; gen_binds <- mkGenericBinds is_boot
@@ -353,13 +353,14 @@ renameDeriv is_boot gen_binds insts
     rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived co })
 	= return (InstInfo { iSpec = inst, iBinds = NewTypeDerived co }, emptyFVs)
 
-    rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs })
+    rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
 	= 	-- Bring the right type variables into 
 		-- scope (yuk), and rename the method binds
 	   ASSERT( null sigs )
 	   bindLocalNames (map Var.varName tyvars) $
  	   do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
-	      ; return (InstInfo { iSpec = inst, iBinds = VanillaInst rn_binds [] }, fvs) }
+	      ; let binds' = VanillaInst rn_binds [] standalone_deriv
+	      ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) }
 	where
 	  (tyvars,_,clas,_) = instanceHead inst
 	  clas_nm  	    = className clas
@@ -651,12 +652,14 @@ mkDataTypeEqn :: InstOrigin
 
 mkDataTypeEqn orig dflags tvs cls cls_tys
               tycon tc_args rep_tc rep_tc_args mtheta
-  = case checkSideConditions dflags cls cls_tys rep_tc of
-	-- NB: pass the *representation* tycon to checkSideConditions
-	CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
-	NonDerivableClass	-> bale_out (nonStdErr cls)
-	DerivableClassError msg -> bale_out msg
+  | isJust mtheta = go_for_it	-- Do not test side conditions for standalone deriving
+  | otherwise     = case checkSideConditions dflags cls cls_tys rep_tc of
+		      -- NB: pass the *representation* tycon to checkSideConditions
+		      CanDerive               -> go_for_it
+		      NonDerivableClass	      -> bale_out (nonStdErr cls)
+		      DerivableClassError msg -> bale_out msg
   where
+    go_for_it    = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
     bale_out msg = failWithTc (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) msg)
 
 mk_data_eqn, mk_typeable_eqn
@@ -1022,18 +1025,18 @@ mkNewTypeEqn orig dflags tvs
 	; return (if isJust mtheta then Right spec
 				   else Left spec) }
 
+  | isJust mtheta = go_for_it	-- Do not check side conditions for standalone deriving
   | otherwise
-  = case check_conditions of
-      CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
-      		   	       	-- Use the standard H98 method
-      DerivableClassError msg -> bale_out msg		   -- Error with standard class
+  = case checkSideConditions dflags cls cls_tys rep_tycon of
+      CanDerive               -> go_for_it 	-- Use the standard H98 method
+      DerivableClassError msg -> bale_out msg	-- Error with standard class
       NonDerivableClass 	-- Must use newtype deriving
       	| newtype_deriving    -> bale_out cant_derive_err  -- Too hard, even with newtype deriving
       	| otherwise           -> bale_out non_std_err      -- Try newtype deriving!
   where
         newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags
-	check_conditions = checkSideConditions dflags cls cls_tys rep_tycon
-	bale_out msg = failWithTc (derivingThingErr cls cls_tys inst_ty msg)
+        go_for_it        = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
+	bale_out msg     = failWithTc (derivingThingErr cls cls_tys inst_ty msg)
 
 	non_std_err = nonStdErr cls $$
 		      ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
@@ -1347,26 +1350,25 @@ the renamer.  What a great hack!
 -- Representation tycons differ from the tycon in the instance signature in
 -- case of instances for indexed families.
 --
-genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
-genInst oflag spec
+genInst :: Bool 	-- True <=> standalone deriving
+	-> OverlapFlag
+        -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
+genInst standalone_deriv oflag spec
   | ds_newtype spec
   = return (InstInfo { iSpec  = mkInstance oflag (ds_theta spec) spec
 		     , iBinds = NewTypeDerived co }, [])
 
   | otherwise
-  = do	{ let loc	 = getSrcSpan (ds_name spec)
-	      inst	 = mkInstance oflag (ds_theta spec) spec
-   	      clas       = ds_cls spec
+  = do	{ let loc  = getSrcSpan (ds_name spec)
+	      inst = mkInstance oflag (ds_theta spec) spec
+   	      clas = ds_cls spec
 
           -- In case of a family instance, we need to use the representation
           -- tycon (after all, it has the data constructors)
 	; fix_env <- getFixityEnv
 	; let (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
-
-	-- Build the InstInfo
-	; return (InstInfo { iSpec = inst, 
-		  	     iBinds = VanillaInst meth_binds [] },
-		  aux_binds)
+	      binds = VanillaInst meth_binds [] standalone_deriv
+	; return (InstInfo { iSpec = inst, iBinds = binds }, aux_binds)
         }
   where
     rep_tycon   = ds_tc spec
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index d1a10cf271..055fc2cf88 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -640,6 +640,7 @@ data InstBindings a
 	(LHsBinds a)		-- Bindings for the instance methods
 	[LSig a]		-- User pragmas recorded for generating 
 				-- specialised instances
+	Bool			-- True <=> This code came from a standalone deriving clause
 
   | NewTypeDerived              -- Used for deriving instances of newtypes, where the
 	CoercionI		-- witness dictionary is identical to the argument 
@@ -655,8 +656,8 @@ pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info)
 pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
   where
-    details (VanillaInst b _)  = pprLHsBinds b
-    details (NewTypeDerived _) = text "Derived from the representation type"
+    details (VanillaInst b _ _) = pprLHsBinds b
+    details (NewTypeDerived _)  = text "Derived from the representation type"
 
 simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 3272f96862..c35e2d64b2 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -432,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
@@ -698,7 +698,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
 
@@ -730,8 +730,8 @@ 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
@@ -814,7 +814,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 
@@ -823,7 +823,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
@@ -838,12 +838,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
@@ -901,9 +903,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]
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index db9089c30e..3e0e8c013f 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -110,7 +110,8 @@ tcMatchLambda match res_ty
   where
     n_pats = matchGroupArity match
     doc = sep [ ptext (sLit "The lambda expression")
-		 <+> quotes (pprSetDepth 1 $ pprMatches (LambdaExpr :: HsMatchContext Name) match),
+		 <+> quotes (pprSetDepth (PartWay 1) $ 
+                             pprMatches (LambdaExpr :: HsMatchContext Name) match),
 			-- The pprSetDepth makes the abstraction print briefly
 		ptext (sLit "has") <+> speakNOf n_pats (ptext (sLit "argument"))]
     match_ctxt = MC { mc_what = LambdaExpr,
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index a8146ba445..386eae8bf3 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -363,8 +363,8 @@ traceOptTcRn flag doc = ifOptM flag $ do
 			{ ctxt <- getErrCtxt
 			; loc  <- getSrcSpanM
 			; env0 <- tcInitTidyEnv
-			; ctxt_msgs <- do_ctxt env0 ctxt 
-			; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
+			; err_info <- mkErrInfo env0 ctxt 
+			; let real_doc = mkLocMessage loc (doc $$ err_info)
 			; dumpTcRn real_doc }
 
 dumpTcRn :: SDoc -> TcRn ()
@@ -681,20 +681,23 @@ failIfErrsM = ifErrsM failM (return ())
 %************************************************************************
 
 \begin{code}
-getErrCtxt :: TcM ErrCtxt
+getErrCtxt :: TcM [ErrCtxt]
 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
 
-setErrCtxt :: ErrCtxt -> TcM a -> TcM a
+setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
 
 addErrCtxt :: Message -> TcM a -> TcM a
 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
 
 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
-addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
+addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
+
+addLandmarkErrCtxt :: Message -> TcM a -> TcM a
+addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
 
 -- Helper function for the above
-updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
+updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> 
 			   env { tcl_ctxt = upd ctxt })
 
@@ -763,8 +766,8 @@ addWarnTc msg = do { env0 <- tcInitTidyEnv
 addWarnTcM :: (TidyEnv, Message) -> TcM ()
 addWarnTcM (env0, msg)
  = do { ctxt <- getErrCtxt ;
-	ctxt_msgs <- do_ctxt env0 ctxt ;
-	addReport (vcat (ptext (sLit "Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }
+	err_info <- mkErrInfo env0 ctxt ;
+	addReport (vcat [ptext (sLit "Warning:") <+> msg, err_info]) }
 
 warnTc :: Bool -> Message -> TcM ()
 warnTc warn_if_true warn_msg
@@ -801,23 +804,30 @@ tcInitTidyEnv
 
 \begin{code}
 add_err_tcm :: TidyEnv -> Message -> SrcSpan
-            -> [TidyEnv -> TcM (TidyEnv, SDoc)]
+            -> [ErrCtxt]
             -> TcM ()
 add_err_tcm tidy_env err_msg loc ctxt
- = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
-	addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
-
-do_ctxt :: TidyEnv -> [TidyEnv -> TcM (TidyEnv, SDoc)] -> TcM [SDoc]
-do_ctxt _ []
- = return []
-do_ctxt tidy_env (c:cs)
- = do {	(tidy_env', m) <- c tidy_env  ;
-	ms	       <- do_ctxt tidy_env' cs  ;
-	return (m:ms) }
-
-ctxt_to_use :: [SDoc] -> [SDoc]
-ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
-		 | otherwise	      = take 3 ctxt
+ = do { err_info <- mkErrInfo tidy_env ctxt ;
+	addLongErrAt loc err_msg err_info }
+
+mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
+-- Tidy the error info, trimming excessive contexts
+mkErrInfo env ctxts
+ = go 0 env ctxts
+ where
+   go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
+   go _ _   [] = return empty
+   go n env ((is_landmark, ctxt) : ctxts)
+     | is_landmark || opt_PprStyle_Debug || n < mAX_CONTEXTS
+     = do { (env', msg) <- ctxt env
+	  ; let n' = if is_landmark then n else n+1
+          ; rest <- go n' env' ctxts
+	  ; return (msg $$ rest) }
+     | otherwise
+     = go n env ctxts
+
+mAX_CONTEXTS :: Int	-- No more than this number of non-landmark contexts
+mAX_CONTEXTS = 3
 \end{code}
 
 debugTc is useful for monadic debugging code
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 19432fa988..fd7e954b74 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -333,7 +333,7 @@ data TcLclEnv		-- Changes as we move inside an expression
 			-- Discarded after typecheck/rename; not passed on to desugarer
   = TcLclEnv {
 	tcl_loc  :: SrcSpan,		-- Source span
-	tcl_ctxt :: ErrCtxt,		-- Error context
+	tcl_ctxt :: [ErrCtxt],		-- Error context, innermost on top
 	tcl_errs :: TcRef Messages,	-- Place to accumulate errors
 
 	tcl_th_ctxt    :: ThStage,	      -- Template Haskell context
@@ -516,10 +516,13 @@ instance Outputable RefinementVisibility where
 \end{code}
 
 \begin{code}
-type ErrCtxt = [TidyEnv -> TcM (TidyEnv, Message)]	
-			-- Innermost first.  Monadic so that we have a chance
-			-- to deal with bound type variables just before error
-			-- message construction
+type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message))
+	-- Monadic so that we have a chance
+	-- to deal with bound type variables just before error
+	-- message construction
+
+	-- Bool:  True <=> this is a landmark context; do not
+	--		   discard it when trimming for display
 \end{code}
 
 
@@ -876,7 +879,7 @@ functions that deal with it.
 
 \begin{code}
 -------------------------------------------
-data InstLoc = InstLoc InstOrigin SrcSpan ErrCtxt
+data InstLoc = InstLoc InstOrigin SrcSpan [ErrCtxt]
 
 instLoc :: Inst -> InstLoc
 instLoc inst = tci_loc inst
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index bdad4d3eb1..5842c63d03 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -229,9 +229,9 @@ pprDeeperList f ds (PprUser q (PartWay n))
 pprDeeperList f ds other_sty
   = f ds other_sty
 
-pprSetDepth :: Int -> SDoc -> SDoc
-pprSetDepth  n d (PprUser q _) = d (PprUser q (PartWay n))
-pprSetDepth _n d other_sty     = d other_sty
+pprSetDepth :: Depth -> SDoc -> SDoc
+pprSetDepth depth  doc (PprUser q _) = doc (PprUser q depth)
+pprSetDepth _depth doc other_sty     = doc other_sty
 
 getPprStyle :: (PprStyle -> SDoc) -> SDoc
 getPprStyle df sty = df sty sty