Add mkHsCoerce to avoid junk in typechecked code

Avoiding identity coercions is a Good Thing generally, but
it turns out that the desugarer has trouble recognising 
'otherwise' and 'True' guards if they are wrapped in an
identity coercion; and that leads to bogus overlap warnings.

5 files changed, 25 insertions, 16 deletions

diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index 33f86edcf9..eea61bafb2 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -90,12 +90,16 @@ matchGuards [] ctx rhs rhs_ty
 	; return (cantFailMatchResult core_rhs) }
 
 	-- ExprStmts must be guards
-	-- Turn an "otherwise" guard is a no-op
+	-- Turn an "otherwise" guard is a no-op.  This ensures that 
+	-- you don't get a "non-exhaustive eqns" message when the guards 
+	-- finish in "otherwise".
+	-- NB:	The success of this clause depends on the typechecker not
+	-- 	wrapping the 'otherwise' in empty HsTyApp or HsCoerce constructors
+	--	If it does, you'll get bogus overlap warnings
 matchGuards (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty
   |  v `hasKey` otherwiseIdKey
   || v `hasKey` getUnique trueDataConId	
-	-- trueDataConId doesn't have the same 
-	-- unique as trueDataCon
+	-- trueDataConId doesn't have the same unique as trueDataCon
   = matchGuards stmts ctx rhs rhs_ty
 
 matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs
index 23f7fd05f0..0ff936d248 100644
--- a/ghc/compiler/hsSyn/HsUtils.lhs
+++ b/ghc/compiler/hsSyn/HsUtils.lhs
@@ -79,6 +79,10 @@ mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
 mkHsDictApp expr []	 = expr
 mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
 
+mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id
+mkHsCoerce co_fn e | isIdCoercion co_fn = e
+		   | otherwise		= HsCoerce co_fn e
+
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 	where
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 2040f53f1f..e732f01031 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -21,7 +21,7 @@ import HsSyn		( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
 			  LSig, Match(..), IPBind(..), Prag(..),
 			  HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, 
 			  isVanillaLSig, sigName, placeHolderNames, isPragLSig,
-			  LPat, GRHSs, MatchGroup(..), pprLHsBinds,
+			  LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce,
 			  collectHsBindBinders, collectPatBinders, pprPatBind
 			)
 import TcHsSyn		( zonkId )
@@ -444,7 +444,7 @@ tcSpecPrag poly_id hs_ty inl
 	; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty)
 	; extendLIEs lie
 	; let const_dicts = map instToId lie
-	; return (SpecPrag (HsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) }
+	; return (SpecPrag (mkHsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) }
   
 --------------
 -- If typechecking the binds fails, then return with each
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 8227e678ea..a572d36d8e 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -21,7 +21,8 @@ import qualified DsMeta
 #endif
 
 import HsSyn		( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
-			  HsMatchContext(..), HsRecordBinds, mkHsApp, mkHsDictApp, mkHsTyApp )
+			  HsMatchContext(..), HsRecordBinds, 
+			  mkHsCoerce, mkHsApp, mkHsDictApp, mkHsTyApp )
 import TcHsSyn		( hsLitType )
 import TcRnMonad
 import TcUnify		( tcInfer, tcSubExp, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
@@ -105,7 +106,7 @@ tcPolyExprNC expr res_ty
   = do	{ (gen_fn, expr') <- tcGen res_ty emptyVarSet (tcPolyExprNC expr)
 		-- Note the recursive call to tcPolyExpr, because the
 		-- type may have multiple layers of for-alls
-	; return (L (getLoc expr') (HsCoerce gen_fn (unLoc expr'))) }
+	; return (L (getLoc expr') (mkHsCoerce gen_fn (unLoc expr'))) }
 
   | otherwise
   = tcMonoExpr expr res_ty
@@ -181,7 +182,7 @@ tcExpr (HsIPVar ip) res_ty
 	; co_fn <- tcSubExp ip_ty res_ty
 	; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
 	; extendLIE inst
-	; return (HsCoerce co_fn (HsIPVar ip')) }
+	; return (mkHsCoerce co_fn (HsIPVar ip')) }
 
 tcExpr (HsApp e1 e2) res_ty 
   = go e1 [e2]
@@ -195,13 +196,13 @@ tcExpr (HsApp e1 e2) res_ty
 
 tcExpr (HsLam match) res_ty
   = do	{ (co_fn, match') <- tcMatchLambda match res_ty
-	; return (HsCoerce co_fn (HsLam match')) }
+	; return (mkHsCoerce co_fn (HsLam match')) }
 
 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
  = do	{ sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
 	; expr' <- tcPolyExpr expr sig_tc_ty
 	; co_fn <- tcSubExp sig_tc_ty res_ty
-	; return (HsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) }
+	; return (mkHsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) }
 
 tcExpr (HsType ty) res_ty
   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
@@ -247,7 +248,7 @@ tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
   = do	{ (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
 				   tcApp op 2 (tc_args arg1_ty') res_ty'
-	; return (HsCoerce co_fn (SectionR (L loc op') arg2')) }
+	; return (mkHsCoerce co_fn (SectionR (L loc op') arg2')) }
   where
     doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
 		<+> ptext SLIT("takes one argument")
@@ -489,7 +490,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
     extendLIEs dicts			`thenM_`
 
 	-- Phew!
-    returnM (HsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
+    returnM (mkHsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
 \end{code}
 
 
@@ -694,7 +695,7 @@ tcIdApp fun_name n_args arg_checker res_ty
 	-- tcFun work nicely for OpApp and Sections too
 	; fun' <- instFun fun_id qtvs qtys'' tv_theta_prs
 	; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
-	; return (HsCoerce co_fn' fun', args') }
+	; return (mkHsCoerce co_fn' fun', args') }
 \end{code}
 
 Note [Silly type synonyms in smart-app]
@@ -742,7 +743,7 @@ tcId orig fun_name res_ty
 
 	-- And pack up the results
 	; fun' <- instFun fun_id qtvs qtv_tys tv_theta_prs 
-	; return (HsCoerce co_fn fun') }
+	; return (mkHsCoerce co_fn fun') }
 
 -- 	Note [Push result type in]
 --
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index d6e66ef696..d62eacdc54 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -17,7 +17,7 @@ import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
 import HsSyn		( HsExpr(..), LHsExpr, MatchGroup(..),
 			  Match(..), LMatch, GRHSs(..), GRHS(..), 
 			  Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
-			  pprMatch, isIrrefutableHsPat,
+			  pprMatch, isIrrefutableHsPat, mkHsCoerce,
 			  pprMatchContext, pprStmtContext, 
 			  noSyntaxExpr, matchGroupArity, pprMatches,
 			  ExprCoFn )
@@ -471,7 +471,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_insid
 		-- poly_id may have a polymorphic type
 		-- but mono_ty is just a monomorphic type variable
 	     ; co_fn <- tcSubExp (idType poly_id) mono_ty
-	     ; return (HsCoerce co_fn (HsVar poly_id)) }
+	     ; return (mkHsCoerce co_fn (HsVar poly_id)) }
 
 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)