import CoreSyn
import Literal
import CoreUtils
+import MkCore
import DsMonad
import DsBinds
import DsGRHSs
import Maybes
import Util
import Name
+import FiniteMap
import Outputable
+import FastString
\end{code}
This function is a wrapper of @match@, it must be called from all the parts where
= putSrcSpanDs loc (warnDs warn)
where
warn | qs `lengthExceeds` maximum_output
- = pp_context ctx (ptext SLIT("are overlapped"))
+ = pp_context ctx (ptext (sLit "are overlapped"))
(\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
- ptext SLIT("..."))
+ ptext (sLit "..."))
| otherwise
- = pp_context ctx (ptext SLIT("are overlapped"))
+ = pp_context ctx (ptext (sLit "are overlapped"))
(\ f -> vcat $ map (ppr_eqn f kind) qs)
dsIncompleteWarn ctx@(DsMatchContext kind loc) pats
= putSrcSpanDs loc (warnDs warn)
where
- warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
- (\_ -> hang (ptext SLIT("Patterns not matched:"))
+ warn = pp_context ctx (ptext (sLit "are non-exhaustive"))
+ (\_ -> hang (ptext (sLit "Patterns not matched:"))
4 ((vcat $ map (ppr_incomplete_pats kind)
(take maximum_output pats))
$$ dots))
- dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
+ dots | pats `lengthExceeds` maximum_output = ptext (sLit "...")
| otherwise = empty
pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
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)]]
+ = vcat [ptext (sLit "Pattern match(es)") <+> msg,
+ sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
where
(ppr_match, pref)
= case kind of
ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
ppr_shadow_pats kind pats
- = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")]
+ = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]
ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc
ppr_incomplete_pats _ (pats,[]) = ppr_pats pats
ppr_incomplete_pats _ (pats,constraints) =
- sep [ppr_pats pats, ptext SLIT("with"),
+ sep [ppr_pats pats, ptext (sLit "with"),
sep (map ppr_constraint constraints)]
ppr_constraint :: (Name,[HsLit]) -> SDoc
-ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
+ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats]
ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc
ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
Handle any irrefutable (or ``twiddle'') @LazyPats@.
\end{itemize}
\item
-Now {\em unmix} the equations into {\em blocks} [w/ local function
+Now {\em unmix} the equations into {\em blocks} [w\/ local function
@unmix_eqns@], in which the equations in a block all have variable
patterns in column~1, or they all have constructor patterns in ...
(see ``the mixture rule'' in SLPJ).
corresponds roughly to @matchVarCon@.
\begin{code}
-match :: [Id] -- Variables rep'ing the exprs we're matching with
+match :: [Id] -- Variables rep\'ing the exprs we\'re matching with
-> Type -- Type of the case expression
-> [EquationInfo] -- Info about patterns, etc. (type synonym below)
-> DsM MatchResult -- Desugared result!
(aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
-- Group the equations and match each group in turn
-
- ; let grouped = (groupEquations tidy_eqns)
+ ; let grouped = groupEquations tidy_eqns
-- print the view patterns that are commoned up to help debug
; ifOptM Opt_D_dump_view_pattern_commoning (debug grouped)
match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
match_group eqns@((group,_) : _)
= case group of
+ PgCon _ -> matchConFamily vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
+ PgLit _ -> matchLiterals vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
+
PgAny -> matchVariables vars ty (dropGroup eqns)
- PgCon _ -> matchConFamily vars ty (subGroups eqns)
- PgLit _ -> matchLiterals vars ty (subGroups eqns)
- PgN _ -> matchNPats vars ty (subGroups eqns)
+ PgN _ -> matchNPats vars ty (dropGroup eqns)
PgNpK _ -> matchNPlusKPats vars ty (dropGroup eqns)
PgBang -> matchBangs vars ty (dropGroup eqns)
PgCo _ -> matchCoercion vars ty (dropGroup eqns)
Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
together with the binding @x = v@.
\item
-Replace the `as' pattern @xp@ with the pattern p and a binding @x = do v@.
+Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
\item
Removing lazy (irrefutable) patterns (you don't want to know...).
\item
tidy1 v (VarPatOut var binds)
= do { prs <- dsLHsBinds binds
- ; return (wrapBind var v . mkDsLet (Rec prs),
+ ; return (wrapBind var v . mkCoreLet (Rec prs),
WildPat (idType var)) }
-- case v of { x@p -> mr[] }
tidy1 v (LazyPat pat)
= do { sel_prs <- mkSelectorBinds pat (Var v)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
- ; return (mkDsLets sel_binds, WildPat (idType v)) }
+ ; return (mkCoreLets sel_binds, WildPat (idType v)) }
tidy1 _ (ListPat pats ty)
= return (idDsWrapper, unLoc list_ConPat)
= do { dflags <- getDOptsDs
; locn <- getSrcSpanDs
; let ds_ctxt = DsMatchContext ctxt locn
- error_string = matchContextErrString ctxt
+ error_doc = matchContextErrString ctxt
; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
- ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+ ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
; extractMatchResult match_result fail_expr }
where
match_fun dflags ds_ctxt
-- If the result is of form [g1, g2, g3],
-- (a) all the (pg,eq) pairs in g1 have the same pg
-- (b) none of the gi are empty
+-- The ordering of equations is unchanged
groupEquations eqns
= runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns]
where
same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
(pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
-subGroups :: [(PatGroup, EquationInfo)] -> [[EquationInfo]]
+subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
-- Input is a particular group. The result sub-groups the
-- equations by with particular constructor, literal etc they match.
--- The order may be swizzled, so the matching should be order-independent
-subGroups groups = map (map snd) (equivClasses cmp groups)
+-- Each sub-list in the result has the same PatGroup
+-- See Note [Take care with pattern order]
+subGroup group
+ = map reverse $ eltsFM $ foldl accumulate emptyFM group
where
- (pg1, _) `cmp` (pg2, _) = pg1 `cmp_pg` pg2
- (PgCon c1) `cmp_pg` (PgCon c2) = c1 `compare` c2
- (PgLit l1) `cmp_pg` (PgLit l2) = l1 `compare` l2
- (PgN l1) `cmp_pg` (PgN l2) = l1 `compare` l2
- -- These are the only cases that are every sub-grouped
+ accumulate pg_map (pg, eqn)
+ = case lookupFM pg_map pg of
+ Just eqns -> addToFM pg_map pg (eqn:eqns)
+ Nothing -> addToFM pg_map pg [eqn]
+
+ -- pg_map :: FiniteMap a [EquationInfo]
+ -- Equations seen so far in reverse order of appearance
+\end{code}
+Note [Take care with pattern order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the subGroup function we must be very careful about pattern re-ordering,
+Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
+Then in bringing together the patterns for True, we must not
+swap the Nothing and y!
+
+
+\begin{code}
sameGroup :: PatGroup -> PatGroup -> Bool
-- Same group means that a single case expression
-- or test will suffice to match both, *and* the order
sameGroup PgBang PgBang = True
sameGroup (PgCon _) (PgCon _) = True -- One case expression
sameGroup (PgLit _) (PgLit _) = True -- One case expression
-sameGroup (PgN _) (PgN _) = True -- Needs conditionals
-sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- Order is significant
- -- See Note [Order of n+k]
+sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant
+sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns]
sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2
-- CoPats are in the same goup only if the type of the
-- enclosed pattern is the same. The patterns outside the CoPat
-- equating different ways of writing a coercion)
wrap WpHole WpHole = True
wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
- wrap (WpCo c) (WpCo c') = tcEqType c c'
- wrap (WpApp d) (WpApp d') = d == d'
+ wrap (WpCast c) (WpCast c') = tcEqType c c'
+ wrap (WpApp d) (WpApp d') = d == d'
wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
-- Enhancement: could implement equality for more wrappers
-- if it seems useful (lams and lets)
patGroup pat = pprPanic "patGroup" (ppr pat)
\end{code}
-Note [Order of n+k]
-~~~~~~~~~~~~~~~~~~~
+Note [Grouping overloaded literal patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WATCH OUT! Consider
f (n+1) = ...
f (n+1) = ...
We can't group the first and third together, because the second may match
-the same thing as the first. Contrast
- f 1 = ...
- f 2 = ...
- f 1 = ...
-where we can group the first and third. Hence we don't regard (n+1) and
-(n+2) as part of the same group.
+the same thing as the first. Same goes for *overloaded* literal patterns
+ f 1 True = ...
+ f 2 False = ...
+ f 1 False = ...
+If the first arg matches '1' but the second does not match 'True', we
+cannot jump to the third equation! Because the same argument might
+match '2'!
+Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.