Commit bdd90426 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor in TcMatches

* Move the several calls of tauifyMultipleMatches into tcMatches,
  so that it can be called only once, and the invariants are
  clearer

* I discovered in doing this that HsLamCase had a redundant and
  tiresome argument, so I removed it. That in turn allowed some
  modest but nice code simplification
parent 2e5e8223
......@@ -519,7 +519,7 @@ addTickHsExpr e@(HsOverLit _) = return e
addTickHsExpr e@(HsOverLabel _) = return e
addTickHsExpr e@(HsLit _) = return e
addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs)
addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs)
addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1)
(addTickLHsExpr e2)
addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
......
......@@ -226,10 +226,9 @@ dsExpr (NegApp expr neg_expr)
dsExpr (HsLam a_Match)
= uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
dsExpr (HsLamCase arg matches)
= do { arg_var <- newSysLocalDs arg
; ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
dsExpr (HsLamCase matches)
= do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
; return $ Lam discrim_var matching_code }
dsExpr e@(HsApp fun arg)
= mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg
......
......@@ -1086,7 +1086,7 @@ repE e@(HsRecFld f) = case f of
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l) = do { a <- repLiteral l; repLit a }
repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m
repE (HsLamCase _ (MG { mg_alts = L _ ms }))
repE (HsLamCase (MG { mg_alts = L _ ms }))
= do { ms' <- mapM repMatchTup ms
; core_ms <- coreList matchQTyConName ms'
; repLamCase core_ms }
......
......@@ -721,8 +721,7 @@ cvtl e = wrapL (cvt e)
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms
; return $ HsLamCase placeHolderType
(mkMatchGroup FromSource ms')
; return $ HsLamCase (mkMatchGroup FromSource ms')
}
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
-- Note [Dropping constructors]
......
......@@ -194,7 +194,7 @@ data HsExpr id
-- For details on above see note [Api annotations] in ApiAnnotation
| HsLamCase (PostTc id Type) (MatchGroup id (LHsExpr id)) -- ^ Lambda-case
| HsLamCase (MatchGroup id (LHsExpr id)) -- ^ Lambda-case
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
-- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',
......@@ -751,7 +751,7 @@ ppr_expr (ExplicitTuple exprs boxity)
ppr_expr (HsLam matches)
= pprMatches (LambdaExpr :: HsMatchContext id) matches
ppr_expr (HsLamCase _ matches)
ppr_expr (HsLamCase matches)
= sep [ sep [text "\\case {"],
nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
......@@ -1260,12 +1260,14 @@ isInfixMatch match = case m_fixity match of
isEmptyMatchGroup :: MatchGroup id body -> Bool
isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
-- | Is there only one RHS in this group?
isSingletonMatchGroup :: MatchGroup id body -> Bool
isSingletonMatchGroup (MG { mg_alts = L _ [match] })
| L _ (Match { m_grhss = GRHSs { grhssGRHSs = [_] } }) <- match
-- | Is there only one RHS in this list of matches?
isSingletonMatchGroup :: [LMatch id body] -> Bool
isSingletonMatchGroup matches
| [L _ match] <- matches
, Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match
= True
isSingletonMatchGroup _ = False
| otherwise
= False
matchGroupArity :: MatchGroup id body -> Arity
-- Precondition: MatchGroup is non-empty
......
......@@ -2151,7 +2151,7 @@ exp10 :: { LHsExpr RdrName }
(mj AnnLet $1:mj AnnIn $3
:(fst $ unLoc $2)) }
| '\\' 'lcase' altslist
{% ams (sLL $1 $> $ HsLamCase placeHolderType
{% ams (sLL $1 $> $ HsLamCase
(mkMatchGroup FromSource (snd $ unLoc $3)))
(mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
......
......@@ -220,10 +220,9 @@ rnExpr (HsLam matches)
= do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
; return (HsLam matches', fvMatch) }
rnExpr (HsLamCase _arg matches)
rnExpr (HsLamCase matches)
= do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
-- ; return (HsLamCase arg matches', fvs_ms) }
; return (HsLamCase placeHolderType matches', fvs_ms) }
; return (HsLamCase matches', fvs_ms) }
rnExpr (HsCase expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
......
......@@ -230,8 +230,8 @@ tcExpr e@(HsOverLabel l) res_ty -- See Note [Type-checking overloaded labels]
origin = OverLabelOrigin l
tcExpr (HsLam match) res_ty
= do { (co_fn, _, match') <- tcMatchLambda herald match_ctxt match res_ty
; return (mkHsWrap co_fn (HsLam match')) }
= do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
; return (mkHsWrap wrap (HsLam match')) }
where
match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
herald = sep [ text "The lambda expression" <+>
......@@ -240,15 +240,16 @@ tcExpr (HsLam match) res_ty
-- The pprSetDepth makes the abstraction print briefly
text "has"]
tcExpr e@(HsLamCase _ matches) res_ty
= do { (co_fn, ~[arg_ty], matches')
tcExpr e@(HsLamCase matches) res_ty
= do { (matches', wrap)
<- tcMatchLambda msg match_ctxt matches res_ty
-- The laziness annotation is because we don't want to fail here
-- if there are multiple arguments
; return (mkHsWrap co_fn $ HsLamCase arg_ty matches') }
where msg = sep [ text "The function" <+> quotes (ppr e)
, text "requires"]
match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
; return (mkHsWrap wrap $ HsLamCase matches') }
where
msg = sep [ text "The function" <+> quotes (ppr e)
, text "requires"]
match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
tcExpr e@(ExprWithTySig expr sig_ty) res_ty
= do { sig_info <- checkNoErrs $ -- Avoid error cascade
......
......@@ -623,10 +623,9 @@ zonkExpr env (HsLam matches)
= do new_matches <- zonkMatchGroup env zonkLExpr matches
return (HsLam new_matches)
zonkExpr env (HsLamCase arg matches)
= do new_arg <- zonkTcTypeToType env arg
new_matches <- zonkMatchGroup env zonkLExpr matches
return (HsLamCase new_arg new_matches)
zonkExpr env (HsLamCase matches)
= do new_matches <- zonkMatchGroup env zonkLExpr matches
return (HsLamCase new_matches)
zonkExpr env (HsApp e1 e2)
= do new_e1 <- zonkLExpr env e1
......
......@@ -90,8 +90,7 @@ tcMatchesFun fun_name matches exp_ty
<- matchExpectedFunTys herald arity exp_rho $
\ pat_tys rhs_ty ->
-- See Note [Case branches must never infer a non-tau type]
do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys)
; tcMatches match_ctxt pat_tys rhs_ty matches }
do { tcMatches match_ctxt pat_tys rhs_ty matches }
; return (wrap_fun, matches') }
; return (wrap_gen <.> wrap_fun, group) }
where
......@@ -115,24 +114,16 @@ tcMatchesCase :: (Outputable (body Name)) =>
-- wrapper goes from MatchGroup's ty to expected ty
tcMatchesCase ctxt scrut_ty matches res_ty
= do { [res_ty] <- tauifyMultipleMatches matches [res_ty]
; tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches }
= tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches
tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify
-> TcMatchCtxt HsExpr
-> MatchGroup Name (LHsExpr Name)
-> ExpRhoType -- deeply skolemised
-> TcM (HsWrapper, [TcSigmaType], MatchGroup TcId (LHsExpr TcId))
-- also returns the argument types
-> TcM (MatchGroup TcId (LHsExpr TcId), HsWrapper)
tcMatchLambda herald match_ctxt match res_ty
= do { ((match', pat_tys), wrap)
<- matchExpectedFunTys herald n_pats res_ty $
\ pat_tys rhs_ty ->
do { rhs_ty:pat_tys <- tauifyMultipleMatches match (rhs_ty:pat_tys)
; match' <- tcMatches match_ctxt pat_tys rhs_ty match
; pat_tys <- mapM readExpType pat_tys
; return (match', pat_tys) }
; return (wrap, pat_tys, match') }
= matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty match
where
n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case
| otherwise = matchGroupArity match
......@@ -188,7 +179,7 @@ still gets assigned a polytype.
-- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the
-- expected type into TauTvs.
-- See Note [Case branches must never infer a non-tau type]
tauifyMultipleMatches :: MatchGroup id body
tauifyMultipleMatches :: [LMatch id body]
-> [ExpType] -> TcM [ExpType]
tauifyMultipleMatches group exp_tys
| isSingletonMatchGroup group = return exp_tys
......@@ -214,7 +205,8 @@ data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module
tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
, mg_origin = origin })
= do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
= do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys)
; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
; pat_tys <- mapM readExpType pat_tys
; rhs_ty <- readExpType rhs_ty
; return (MG { mg_alts = L l matches'
......
......@@ -2821,7 +2821,7 @@ exprCtOrigin (HsIPVar ip) = IPOccOrigin ip
exprCtOrigin (HsOverLit lit) = LiteralOrigin lit
exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal"
exprCtOrigin (HsLam matches) = matchesCtOrigin matches
exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms
exprCtOrigin (HsLamCase ms) = matchesCtOrigin ms
exprCtOrigin (HsApp (L _ e1) _) = exprCtOrigin e1
exprCtOrigin (HsAppType (L _ e1) _) = exprCtOrigin e1
exprCtOrigin (HsAppTypeOut {}) = panic "exprCtOrigin HsAppTypeOut"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment