Make desugaring of pattern-matching much more civilised.
Before this change we wrapped new bindings around the
right hand side; but that meant they ended up wrapped
in reverse order. Now we accumulate the bindings
separately, in the eqn_wrap field of an EqnInfo.
This cures a desugaring bug encountered by Akos Korosmezey
immortalised as ds055
-- Data types
DsMatchContext(..),
- EquationInfo(..), MatchResult(..),
+ EquationInfo(..), MatchResult(..), DsWrapper, idWrapper,
CanItFail(..), orFail
) where
deriving ()
data EquationInfo
- = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
+ = EqnInfo { eqn_wrap :: DsWrapper, -- Bindings
+ eqn_pats :: [Pat Id], -- The patterns for an eqn
eqn_rhs :: MatchResult } -- What to do after match
+type DsWrapper = CoreExpr -> CoreExpr
+idWrapper e = e
+
-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
-- \fail. wrap (case vs of { pats -> rhs fail })
-- where vs are not in the domain of wrap
EquationInfo(..),
firstPat, shiftEqns,
- mkDsLet,
+ mkDsLet, mkDsLets,
MatchResult(..), CanItFail(..),
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
- mkCoLetsMatchResult, mkCoLetMatchResult,
+ mkCoLetMatchResult,
mkGuardedMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
- bindInMatchResult, bindOneInMatchResult,
+ wrapBind, wrapBinds,
mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
mkIntExpr, mkCharExpr,
firstPat eqn = head (eqn_pats eqn)
shiftEqns :: [EquationInfo] -> [EquationInfo]
--- Drop the outermost layer of the first pattern in each equation
-shiftEqns eqns = [ eqn { eqn_pats = shiftPats (eqn_pats eqn) }
- | eqn <- eqns ]
-
-shiftPats :: [Pat Id] -> [Pat Id]
-shiftPats (ConPatOut _ _ _ _ (PrefixCon arg_pats) _ : pats) = map unLoc arg_pats ++ pats
-shiftPats (pat_with_no_sub_pats : pats) = pats
+-- Drop the first pattern in each equation
+shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
\end{code}
Functions on MatchResults
= MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
encl_fn body)
-bindInMatchResult :: [(Var,Var)] -> MatchResult -> MatchResult
-bindInMatchResult binds = adjustMatchResult (\e -> foldr bind e binds)
- where
- bind (new,old) body = bindMR new old body
-
-bindOneInMatchResult :: Var -> Var -> MatchResult -> MatchResult
-bindOneInMatchResult new old = adjustMatchResult (bindMR new old)
+wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
+wrapBinds [] e = e
+wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
-bindMR :: Var -> Var -> CoreExpr -> CoreExpr
-bindMR new old body
+wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
+wrapBind new old body
| new==old = body
| isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
| otherwise = Let (NonRec new (Var old)) body
-mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
-mkCoLetsMatchResult binds match_result
- = adjustMatchResult (mkDsLets binds) match_result
-
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult bind match_result
= adjustMatchResult (mkDsLet bind) match_result
mkCoAlgCaseMatchResult var ty match_alts
| isNewTyCon tycon -- Newtype case; use a let
= ASSERT( null (tail match_alts) && null (tail arg_ids1) )
- mkCoLetsMatchResult [NonRec arg_id1 newtype_rhs] match_result1
+ mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
| isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
= MatchResult CanFail mk_parrCase
returnDs (foldr1 combineMatchResults match_results)
where
match_results = [ ASSERT( null (eqn_pats eqn) )
- eqn_rhs eqn
+ adjustMatchResult (eqn_wrap eqn) (eqn_rhs eqn)
| eqn <- eqns_info ]
\end{code}
-- NPlusKPat
-- but no other
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_rhs = rhs })
- = tidy1 v pat rhs `thenDs` \ (pat', rhs') ->
- returnDs (eqn { eqn_pats = pat' : pats, eqn_rhs = rhs' })
+tidyEqnInfo v eqn@(EqnInfo { eqn_wrap = wrap, eqn_pats = pat : pats })
+ = tidy1 v wrap pat `thenDs` \ (wrap', pat') ->
+ returnDs (eqn { eqn_wrap = wrap', eqn_pats = pat' : pats })
tidy1 :: Id -- The Id being scrutinised
+ -> DsWrapper -- Previous wrapping bindings
-> Pat Id -- The pattern against which it is to be matched
- -> MatchResult -- What to do afterwards
- -> DsM (Pat Id, -- Equivalent pattern
- MatchResult) -- Extra bindings around what to do afterwards
+ -> DsM (DsWrapper, -- Extra bindings around what to do afterwards
+ Pat Id) -- Equivalent pattern
-- The extra bindings etc are all wrapped around the RHS of the match
-- so they are only available when matching is complete. But that's ok
-- NPat
-- NPlusKPat
-tidy1 v (ParPat pat) wrap = tidy1 v (unLoc pat) wrap
-tidy1 v (SigPatOut pat _) wrap = tidy1 v (unLoc pat) wrap
-tidy1 v (WildPat ty) wrap = returnDs (WildPat ty, wrap)
+tidy1 v wrap (ParPat pat) = tidy1 v wrap (unLoc pat)
+tidy1 v wrap (SigPatOut pat _) = tidy1 v wrap (unLoc pat)
+tidy1 v wrap (WildPat ty) = returnDs (wrap, WildPat ty)
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
-tidy1 v (VarPat var) rhs
- = returnDs (WildPat (idType var), bindOneInMatchResult var v rhs)
+tidy1 v wrap (VarPat var)
+ = returnDs (wrap . wrapBind var v, WildPat (idType var))
-tidy1 v (VarPatOut var binds) rhs
+tidy1 v wrap (VarPatOut var binds)
= do { prs <- dsHsNestedBinds binds
- ; return (WildPat (idType var),
- bindOneInMatchResult var v $
- mkCoLetMatchResult (Rec prs) rhs) }
+ ; return (wrap . wrapBind var v . mkDsLet (Rec prs),
+ WildPat (idType var)) }
-- case v of { x@p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
-tidy1 v (AsPat (L _ var) pat) rhs
- = tidy1 v (unLoc pat) (bindOneInMatchResult var v rhs)
+tidy1 v wrap (AsPat (L _ var) pat)
+ = tidy1 v (wrap . wrapBind var v) (unLoc pat)
{- now, here we handle lazy patterns:
The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
-}
-tidy1 v (LazyPat pat) rhs
+tidy1 v wrap (LazyPat pat)
= do { v' <- newSysLocalDs (idType v)
; sel_prs <- mkSelectorBinds pat (Var v)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
- ; returnDs (WildPat (idType v),
- bindOneInMatchResult v' v $
- mkCoLetsMatchResult sel_binds rhs) }
+ ; returnDs (wrap . wrapBind v' v . mkDsLets sel_binds,
+ WildPat (idType v)) }
-- re-express <con-something> as (ConPat ...) [directly]
-tidy1 v (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty) rhs
- = returnDs (ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty, rhs)
+tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty)
+ = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty)
where
tidy_ps = PrefixCon (tidy_con con pat_ty ps)
-tidy1 v (ListPat pats ty) rhs
- = returnDs (unLoc list_ConPat, rhs)
+tidy1 v wrap (ListPat pats ty)
+ = returnDs (wrap, unLoc list_ConPat)
where
list_ty = mkListTy ty
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
-- Introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
-tidy1 v (PArrPat pats ty) rhs
- = returnDs (unLoc parrConPat, rhs)
+tidy1 v wrap (PArrPat pats ty)
+ = returnDs (wrap, unLoc parrConPat)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
-tidy1 v (TuplePat pats boxity) rhs
- = returnDs (unLoc tuple_ConPat, rhs)
+tidy1 v wrap (TuplePat pats boxity)
+ = returnDs (wrap, unLoc tuple_ConPat)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats
(mkTupleTy boxity arity (map hsPatType pats))
-tidy1 v (DictPat dicts methods) rhs
+tidy1 v wrap (DictPat dicts methods)
= case num_of_d_and_ms of
- 0 -> tidy1 v (TuplePat [] Boxed) rhs
- 1 -> tidy1 v (unLoc (head dict_and_method_pats)) rhs
- _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) rhs
+ 0 -> tidy1 v wrap (TuplePat [] Boxed)
+ 1 -> tidy1 v wrap (unLoc (head dict_and_method_pats))
+ _ -> tidy1 v wrap (TuplePat dict_and_method_pats Boxed)
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map nlVarPat (dicts ++ methods)
-- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 v pat@(LitPat lit) rhs
- = returnDs (unLoc (tidyLitPat lit (noLoc pat)), rhs)
+tidy1 v wrap pat@(LitPat lit)
+ = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat)))
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 v pat@(NPatOut lit lit_ty _) rhs
- = returnDs (unLoc (tidyNPat lit lit_ty (noLoc pat)), rhs)
+tidy1 v wrap pat@(NPatOut lit lit_ty _)
+ = returnDs (wrap, unLoc (tidyNPat lit lit_ty (noLoc pat)))
-- and everything else goes through unchanged...
-tidy1 v non_interesting_pat rhs
- = returnDs (non_interesting_pat, rhs)
+tidy1 v wrap non_interesting_pat
+ = returnDs (wrap, non_interesting_pat)
tidy_con data_con pat_ty (PrefixCon ps) = ps
mk_eqn_info (L _ (Match pats _ grhss))
= do { let upats = map unLoc pats
; match_result <- dsGRHSs ctxt upats grhss rhs_ty
- ; return (EqnInfo { eqn_pats = upats,
+ ; return (EqnInfo { eqn_wrap = idWrapper,
+ eqn_pats = upats,
eqn_rhs = match_result}) }
match_fun dflags ds_ctxt
-> Type -> MatchResult -> DsM MatchResult
matchSinglePat (Var var) ctx pat ty match_result
= getDOptsDs `thenDs` \ dflags ->
- match_fn dflags [var] ty [EqnInfo { eqn_pats = [unLoc pat],
+ match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper,
+ eqn_pats = [unLoc pat],
eqn_rhs = match_result }]
where
match_fn dflags
match_con vars ty eqns
= do { -- Make new vars for the con arguments; avoid new locals where possible
arg_vars <- selectMatchVars (map unLoc arg_pats1) arg_tys
-
- ; match_result <- match (arg_vars ++ vars) ty (shiftEqns eqns)
-
- ; binds <- mapM ds_binds [ bind | ConPatOut _ _ _ bind _ _ <- pats,
- not (isEmptyLHsBinds bind) ]
-
- ; let match_result' = bindInMatchResult (line_up other_pats) $
- mkCoLetsMatchResult binds match_result
-
- ; return (data_con, tvs1 ++ dicts1 ++ arg_vars, match_result') }
+ ; eqns' <- mapM shift eqns
+ ; match_result <- match (arg_vars ++ vars) ty eqns'
+ ; return (con, tvs1 ++ dicts1 ++ arg_vars, match_result) }
where
- pats@(pat1 : other_pats) = map firstPat eqns
- ConPatOut (L _ data_con) tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = pat1
-
- ds_binds bind = do { prs <- dsHsNestedBinds bind; return (Rec prs) }
+ ConPatOut (L _ con) tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = firstPat (head eqns)
- line_up pats
- | null tvs1 && null dicts1 = [] -- Common case
- | otherwise = [ pr | ConPatOut _ ts ds _ _ _ <- pats,
- pr <- (ts `zip` tvs1) ++ (ds `zip` dicts1)]
+ shift eqn@(EqnInfo { eqn_wrap = wrap,
+ eqn_pats = ConPatOut _ tvs ds bind (PrefixCon arg_pats) _ : pats })
+ = do { prs <- dsHsNestedBinds bind
+ ; return (eqn { eqn_wrap = wrap . wrapBinds (tvs `zip` tvs1)
+ . wrapBinds (ds `zip` dicts1)
+ . mkDsLet (Rec prs),
+ eqn_pats = map unLoc arg_pats ++ pats }) }
-- Get the arg types, which we use to type the new vars
-- to match on, from the "outside"; the types of pats1 may
-- be more refined, and hence won't do
- arg_tys = substTys (zipTopTvSubst (dataConTyVars data_con) inst_tys)
- (dataConOrigArgTys data_con)
- inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes opaque!
- | otherwise = mkTyVarTys tvs1
+ arg_tys = substTys (zipTopTvSubst (dataConTyVars con) inst_tys)
+ (dataConOrigArgTys con)
+ inst_tys | isVanillaDataCon con = tcTyConAppArgs pat_ty -- Newtypes opaque!
+ | otherwise = mkTyVarTys tvs1
\end{code}
Note [Existentials in shift_con_pat]
return (foldr1 combineMatchResults match_results) }
where
match_group :: [EquationInfo] -> DsM MatchResult
- match_group eqns
+ match_group (eqn1:eqns)
= do { pred_expr <- dsExpr (HsApp (noLoc eq_chk) (nlHsVar var))
- ; match_result <- match vars ty (shiftEqns eqns)
- ; return (mkGuardedMatchResult pred_expr match_result) }
+ ; match_result <- match vars ty (eqn1' : shiftEqns eqns)
+ ; return (adjustMatchResult (eqn_wrap eqn1) $
+ -- Bring the eqn1 wrapper stuff into scope because
+ -- it may be used in pred_expr
+ mkGuardedMatchResult pred_expr match_result) }
where
- NPatOut _ _ eq_chk = firstPat (head eqns)
+ NPatOut _ _ eq_chk : pats1 = eqn_pats eqn1
+ eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
\end{code}
return (foldr1 combineMatchResults match_results) }
where
match_group :: [EquationInfo] -> DsM MatchResult
- match_group eqns
+ match_group (eqn1:eqns)
= do { ge_expr <- dsExpr (HsApp (noLoc ge) (nlHsVar var))
; minusk_expr <- dsExpr (HsApp (noLoc sub) (nlHsVar var))
- ; match_result <- match vars ty (shiftEqns eqns)
- ; return (mkGuardedMatchResult ge_expr $
- mkCoLetsMatchResult [NonRec n1 minusk_expr] $
- bindInMatchResult (map line_up other_pats) $
+ ; match_result <- match vars ty (eqn1' : map shift eqns)
+ ; return (adjustMatchResult (eqn_wrap eqn1) $
+ -- Bring the eqn1 wrapper stuff into scope because
+ -- it may be used in ge_expr, minusk_expr
+ mkGuardedMatchResult ge_expr $
+ mkCoLetMatchResult (NonRec n1 minusk_expr) $
match_result) }
where
- (NPlusKPatOut (L _ n1) _ ge sub : other_pats) = map firstPat eqns
- line_up (NPlusKPatOut (L _ n) _ _ _) = (n,n1)
+ NPlusKPatOut (L _ n1) _ ge sub : pats1 = eqn_pats eqn1
+ eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
+
+ shift eqn@(EqnInfo { eqn_wrap = wrap,
+ eqn_pats = NPlusKPatOut (L _ n) _ _ _ : pats })
+ = eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats }
\end{code}
projects / ghc-hetmet.git / commitdiff