summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
b4dae16)
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(..),
-- Data types
DsMatchContext(..),
- EquationInfo(..), MatchResult(..),
+ EquationInfo(..), MatchResult(..), DsWrapper, idWrapper,
CanItFail(..), orFail
) where
CanItFail(..), orFail
) where
deriving ()
data EquationInfo
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
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
-- 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,
EquationInfo(..),
firstPat, shiftEqns,
MatchResult(..), CanItFail(..),
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
MatchResult(..), CanItFail(..),
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
- mkCoLetsMatchResult, mkCoLetMatchResult,
mkGuardedMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
mkGuardedMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
- bindInMatchResult, bindOneInMatchResult,
mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
mkIntExpr, mkCharExpr,
mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
mkIntExpr, mkCharExpr,
firstPat eqn = head (eqn_pats eqn)
shiftEqns :: [EquationInfo] -> [EquationInfo]
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
\end{code}
Functions on MatchResults
= MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
encl_fn body)
= 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
| 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
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) )
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
| 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) )
returnDs (foldr1 combineMatchResults match_results)
where
match_results = [ ASSERT( null (eqn_pats eqn) )
+ adjustMatchResult (eqn_wrap eqn) (eqn_rhs eqn)
| eqn <- eqns_info ]
\end{code}
| eqn <- eqns_info ]
\end{code}
-- NPlusKPat
-- but no other
-- 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
tidy1 :: Id -- The Id being scrutinised
+ -> DsWrapper -- Previous wrapping bindings
-> Pat Id -- The pattern against which it is to be matched
-> 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
-- 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
-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[] }
-- 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
= 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[] }
-- 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:
{- now, here we handle lazy patterns:
The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
-}
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]
= 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]
-- 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)
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)
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
-- 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)
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))
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
= 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
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
-- 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...
-- 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
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
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
eqn_rhs = match_result}) }
match_fun dflags ds_ctxt
-> Type -> MatchResult -> DsM MatchResult
matchSinglePat (Var var) ctx pat ty match_result
= getDOptsDs `thenDs` \ dflags ->
-> 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
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_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) }
- 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
-- 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]
\end{code}
Note [Existentials in shift_con_pat]
return (foldr1 combineMatchResults match_results) }
where
match_group :: [EquationInfo] -> DsM MatchResult
return (foldr1 combineMatchResults match_results) }
where
match_group :: [EquationInfo] -> DsM MatchResult
+ match_group (eqn1:eqns)
= do { pred_expr <- dsExpr (HsApp (noLoc eq_chk) (nlHsVar var))
= 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) }
- NPatOut _ _ eq_chk = firstPat (head eqns)
+ NPatOut _ _ eq_chk : pats1 = eqn_pats eqn1
+ eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
return (foldr1 combineMatchResults match_results) }
where
match_group :: [EquationInfo] -> DsM MatchResult
return (foldr1 combineMatchResults match_results) }
where
match_group :: [EquationInfo] -> DsM MatchResult
+ match_group (eqn1:eqns)
= do { ge_expr <- dsExpr (HsApp (noLoc ge) (nlHsVar var))
; minusk_expr <- dsExpr (HsApp (noLoc sub) (nlHsVar var))
= 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) $
- (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 }