#include "HsVersions.h"
-import Match ( matchWrapper, matchSimply, matchSinglePat )
+import Match ( matchWrapper, matchSinglePat, matchEquations )
import MatchLit ( dsLit, dsOverLit )
import DsBinds ( dsLHsBinds, dsCoercion )
import DsGRHSs ( dsGuarded )
import DsListComp ( dsListComp, dsPArrComp )
import DsUtils ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
extractMatchResult, cantFailMatchResult, matchCanFail,
- mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence )
+ mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence, selectMatchVar )
import DsArrows ( dsProcExpr )
import DsMonad
ds_val_bind (NonRecursive, hsbinds) body
| [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
(L loc bind : null_binds) <- bagToList binds,
- or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
- || isBangHsBind bind
+ isBangHsBind bind
+ || isUnboxedTupleBind bind
+ || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
= let
body_w_exports = foldr bind_export body exports
bind_export (tvs, g, l, _) body = ASSERT( null tvs )
returnDs (bindNonRec fun rhs body_w_exports)
PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
- -> putSrcSpanDs loc $
- dsGuarded grhss ty `thenDs` \ rhs ->
- mk_error_app pat `thenDs` \ error_expr ->
- matchSimply rhs PatBindRhs pat body_w_exports error_expr
+ -> -- let C x# y# = rhs in body
+ -- ==> case rhs of C x# y# -> body
+ putSrcSpanDs loc $
+ do { rhs <- dsGuarded grhss ty
+ ; let upat = unLoc pat
+ eqn = EqnInfo { eqn_wrap = idWrapper, eqn_pats = [upat],
+ eqn_rhs = cantFailMatchResult body_w_exports }
+ ; var <- selectMatchVar upat ty
+ ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
+ ; return (scrungleMatch var rhs result) }
other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
- where
- mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID
- (exprType body)
- (showSDoc (ppr pat))
+
-- Ordinary case for bindings; none should be unlifted
ds_val_bind (is_rec, binds) body
--
-- NB The previous case dealt with unlifted bindings, so we
-- only have to deal with lifted ones now; so Rec is ok
+
+isUnboxedTupleBind :: HsBind Id -> Bool
+isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
+isUnboxedTupleBind other = False
+
+scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+-- Returns something like (let var = scrut in body)
+-- but if var is an unboxed-tuple type, it inlines it in a fragile way
+-- Special case to handle unboxed tuple patterns; they can't appear nested
+-- The idea is that
+-- case e of (# p1, p2 #) -> rhs
+-- should desugar to
+-- case e of (# x1, x2 #) -> ... match p1, p2 ...
+-- NOT
+-- let x = e in case x of ....
+--
+-- But there may be a big
+-- let fail = ... in case e of ...
+-- wrapping the whole case, which complicates matters slightly
+-- It all seems a bit fragile. Test is dsrun013.
+
+scrungleMatch var scrut body
+ | isUnboxedTupleType (idType var) = scrungle body
+ | otherwise = bindNonRec var scrut body
+ where
+ scrungle (Case (Var x) bndr ty alts)
+ | x == var = Case scrut bndr ty alts
+ scrungle (Let binds body) = Let binds (scrungle body)
+ scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
\end{code}
%************************************************************************
= dsLExpr expr `thenDs` \ core_expr ->
returnDs (Note (CoreNote $ unpackFS fs) core_expr)
--- Special case to handle unboxed tuple patterns; they can't appear nested
--- The idea is that
--- case e of (# p1, p2 #) -> rhs
--- should desugar to
--- case e of (# x1, x2 #) -> ... match p1, p2 ...
--- NOT
--- let x = e in case x of ....
---
--- But there may be a big
--- let fail = ... in case e of ...
--- wrapping the whole case, which complicates matters slightly
--- It all seems a bit fragile. Test is dsrun013.
-
-dsExpr (HsCase discrim matches@(MatchGroup _ ty))
- | isUnboxedTupleType (funArgTy ty)
- = dsLExpr discrim `thenDs` \ core_discrim ->
- matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
- let
- scrungle (Case (Var x) bndr ty alts)
- | x == discrim_var = Case core_discrim bndr ty alts
- scrungle (Let binds body) = Let binds (scrungle body)
- scrungle other = panic ("dsLExpr: tuple pattern:\n" ++ showSDoc (ppr other))
- in
- returnDs (scrungle matching_code)
-
dsExpr (HsCase discrim matches)
= dsLExpr discrim `thenDs` \ core_discrim ->
matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
- returnDs (bindNonRec discrim_var core_discrim matching_code)
+ returnDs (scrungleMatch discrim_var core_discrim matching_code)
dsExpr (HsLet binds body)
= dsLExpr body `thenDs` \ body' ->
\section[Main_match]{The @match@ function}
\begin{code}
-module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where
+module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
#include "HsVersions.h"
where (pats, eqns_shadow) = check qs
incomplete = want_incomplete && (notNull pats)
want_incomplete = case ctx of
- DsMatchContext RecUpd _ _ ->
+ DsMatchContext RecUpd _ ->
dopt Opt_WarnIncompletePatternsRecUpd dflags
_ ->
dopt Opt_WarnIncompletePatterns dflags
\begin{code}
dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
-dsShadowWarn ctx@(DsMatchContext kind _ loc) qs
+dsShadowWarn ctx@(DsMatchContext kind loc) qs
= putSrcSpanDs loc (dsWarn warn)
where
warn | qs `lengthExceeds` maximum_output
dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
-dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats
+dsIncompleteWarn ctx@(DsMatchContext kind loc) pats
= putSrcSpanDs loc (dsWarn warn)
where
warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
| otherwise = empty
-pp_context (DsMatchContext kind pats _loc) msg rest_of_msg_fun
+pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
= vcat [ptext SLIT("Pattern match(es)") <+> msg,
sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
where
\begin{code}
matchWrapper ctxt (MatchGroup matches match_ty)
- = do { eqns_info <- mapM mk_eqn_info matches
- ; dflags <- getDOptsDs
- ; locn <- getSrcSpanDs
- ; let ds_ctxt = DsMatchContext ctxt arg_pats locn
- error_string = matchContextErrString ctxt
-
- ; new_vars <- selectMatchVars arg_pats pat_tys
- ; match_result <- match_fun dflags ds_ctxt new_vars rhs_ty eqns_info
-
- ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
- ; result_expr <- extractMatchResult match_result fail_expr
+ = do { eqns_info <- mapM mk_eqn_info matches
+ ; new_vars <- selectMatchVars arg_pats pat_tys
+ ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
; return (new_vars, result_expr) }
- where
+ where
arg_pats = map unLoc (hsLMatchPats (head matches))
n_pats = length arg_pats
(pat_tys, rhs_ty) = splitFunTysN n_pats match_ty
; match_result <- dsGRHSs ctxt upats grhss rhs_ty
; return (EqnInfo { eqn_wrap = idWrapper,
eqn_pats = upats,
- eqn_rhs = match_result}) }
+ eqn_rhs = match_result}) }
+
+matchEquations :: HsMatchContext Name
+ -> [Id] -> [EquationInfo] -> Type
+ -> DsM CoreExpr
+matchEquations ctxt vars eqns_info rhs_ty
+ = do { dflags <- getDOptsDs
+ ; locn <- getSrcSpanDs
+ ; let ds_ctxt = DsMatchContext ctxt locn
+ error_string = matchContextErrString ctxt
+
+ ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
+
+ ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+ ; extractMatchResult match_result fail_expr }
+ where
match_fun dflags ds_ctxt
= case ctxt of
LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
| dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
| otherwise = match
where
- ds_ctx = DsMatchContext hs_ctx [pat] locn
+ ds_ctx = DsMatchContext hs_ctx locn
in
match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper,
eqn_pats = [pat],
projects / ghc-hetmet.git / commitdiff