From eb57096f08bbccf59e6551b135fbde5ed22a0fa8 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Mon, 30 Jan 2006 13:12:31 +0000 Subject: [PATCH] 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. --- ghc/compiler/deSugar/DsGRHSs.lhs | 10 +++++++--- ghc/compiler/hsSyn/HsUtils.lhs | 4 ++++ ghc/compiler/typecheck/TcBinds.lhs | 4 ++-- ghc/compiler/typecheck/TcExpr.lhs | 19 ++++++++++--------- ghc/compiler/typecheck/TcMatches.lhs | 4 ++-- 5 files changed, 25 insertions(+), 16 deletions(-) diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 33f86ed..eea61ba 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 23f7fd0..0ff936d 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 2040f53..e732f01 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 8227e67..a572d36 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 d6e66ef..d62eacd 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) -- 1.7.10.4