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.
; return (cantFailMatchResult core_rhs) }
-- ExprStmts must be guards
; 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
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
= matchGuards stmts ctx rhs rhs_ty
matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
mkHsDictApp expr [] = expr
mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
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
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
LSig, Match(..), IPBind(..), Prag(..),
HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames,
isVanillaLSig, sigName, placeHolderNames, isPragLSig,
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 )
collectHsBindBinders, collectPatBinders, pprPatBind
)
import TcHsSyn ( zonkId )
; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty)
; extendLIEs lie
; let const_dicts = map instToId lie
; (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
--------------
-- If typechecking the binds fails, then return with each
#endif
import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
#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,
import TcHsSyn ( hsLitType )
import TcRnMonad
import TcUnify ( tcInfer, tcSubExp, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
= 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
= 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
| otherwise
= tcMonoExpr expr res_ty
; co_fn <- tcSubExp ip_ty res_ty
; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
; extendLIE inst
; 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]
tcExpr (HsApp e1 e2) res_ty
= go e1 [e2]
tcExpr (HsLam match) res_ty
= do { (co_fn, match') <- tcMatchLambda match 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
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)
tcExpr (HsType ty) res_ty
= failWithTc (text "Can't handle type argument:" <+> ppr 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'
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")
where
doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
<+> ptext SLIT("takes one argument")
extendLIEs dicts `thenM_`
-- Phew!
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))
-- 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
-- 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]
\end{code}
Note [Silly type synonyms in smart-app]
-- And pack up the results
; fun' <- instFun fun_id qtvs qtv_tys tv_theta_prs
-- 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]
--
-- Note [Push result type in]
--
import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..),
Match(..), LMatch, GRHSs(..), GRHS(..),
Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..),
Match(..), LMatch, GRHSs(..), GRHS(..),
Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
- pprMatch, isIrrefutableHsPat,
+ pprMatch, isIrrefutableHsPat, mkHsCoerce,
pprMatchContext, pprStmtContext,
noSyntaxExpr, matchGroupArity, pprMatches,
ExprCoFn )
pprMatchContext, pprStmtContext,
noSyntaxExpr, matchGroupArity, pprMatches,
ExprCoFn )
-- poly_id may have a polymorphic type
-- but mono_ty is just a monomorphic type variable
; co_fn <- tcSubExp (idType poly_id) mono_ty
-- 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)
tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
= pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)