2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
9 module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
11 #include "HsVersions.h"
13 import {-#SOURCE#-} DsExpr (dsLExpr)
41 import Control.Monad( when )
42 import qualified Data.Map as Map
45 This function is a wrapper of @match@, it must be called from all the parts where
46 it was called match, but only substitutes the firs call, ....
47 if the associated flags are declared, warnings will be issued.
48 It can not be called matchWrapper because this name already exists :-(
53 matchCheck :: DsMatchContext
54 -> [Id] -- Vars rep'ing the exprs we're matching with
55 -> Type -- Type of the case expression
56 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
57 -> DsM MatchResult -- Desugared result!
59 matchCheck ctx vars ty qs
60 = do { dflags <- getDOptsDs
61 ; matchCheck_really dflags ctx vars ty qs }
63 matchCheck_really :: DynFlags
69 matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
70 = do { when shadow (dsShadowWarn ctx eqns_shadow)
71 ; when incomplete (dsIncompleteWarn ctx pats)
74 (pats, eqns_shadow) = check qs
75 incomplete = incomplete_flag hs_ctx && (notNull pats)
76 shadow = dopt Opt_WarnOverlappingPatterns dflags
77 && notNull eqns_shadow
79 incomplete_flag :: HsMatchContext id -> Bool
80 incomplete_flag (FunRhs {}) = dopt Opt_WarnIncompletePatterns dflags
81 incomplete_flag CaseAlt = dopt Opt_WarnIncompletePatterns dflags
83 incomplete_flag LambdaExpr = dopt Opt_WarnIncompleteUniPatterns dflags
84 incomplete_flag PatBindRhs = dopt Opt_WarnIncompleteUniPatterns dflags
85 incomplete_flag ProcExpr = dopt Opt_WarnIncompleteUniPatterns dflags
87 incomplete_flag RecUpd = dopt Opt_WarnIncompletePatternsRecUpd dflags
89 incomplete_flag ThPatQuote = False
90 incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns
91 -- in list comprehensions, pattern guards
92 -- etc. They are often *supposed* to be
96 This variable shows the maximum number of lines of output generated for warnings.
97 It will limit the number of patterns/equations displayed to@ maximum_output@.
99 (ToDo: add command-line option?)
102 maximum_output :: Int
106 The next two functions create the warning message.
109 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
110 dsShadowWarn ctx@(DsMatchContext kind loc) qs
111 = putSrcSpanDs loc (warnDs warn)
113 warn | qs `lengthExceeds` maximum_output
114 = pp_context ctx (ptext (sLit "are overlapped"))
115 (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
118 = pp_context ctx (ptext (sLit "are overlapped"))
119 (\ f -> vcat $ map (ppr_eqn f kind) qs)
122 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
123 dsIncompleteWarn ctx@(DsMatchContext kind loc) pats
124 = putSrcSpanDs loc (warnDs warn)
126 warn = pp_context ctx (ptext (sLit "are non-exhaustive"))
127 (\_ -> hang (ptext (sLit "Patterns not matched:"))
128 4 ((vcat $ map (ppr_incomplete_pats kind)
129 (take maximum_output pats))
132 dots | pats `lengthExceeds` maximum_output = ptext (sLit "...")
135 pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
136 pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
137 = vcat [ptext (sLit "Pattern match(es)") <+> msg,
138 sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
142 FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
143 _ -> (pprMatchContext kind, \ pp -> pp)
145 ppr_pats :: Outputable a => [a] -> SDoc
146 ppr_pats pats = sep (map ppr pats)
148 ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
149 ppr_shadow_pats kind pats
150 = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]
152 ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc
153 ppr_incomplete_pats _ (pats,[]) = ppr_pats pats
154 ppr_incomplete_pats _ (pats,constraints) =
155 sep [ppr_pats pats, ptext (sLit "with"),
156 sep (map ppr_constraint constraints)]
158 ppr_constraint :: (Name,[HsLit]) -> SDoc
159 ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats]
161 ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc
162 ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
166 %************************************************************************
168 The main matching function
170 %************************************************************************
172 The function @match@ is basically the same as in the Wadler chapter,
173 except it is monadised, to carry around the name supply, info about
176 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
179 A list of $n$ variable names, those variables presumably bound to the
180 $n$ expressions being matched against the $n$ patterns. Using the
181 list of $n$ expressions as the first argument showed no benefit and
185 The second argument, a list giving the ``equation info'' for each of
189 the $n$ patterns for that equation, and
191 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
192 the front'' of the matching code, as in:
198 and finally: (ToDo: fill in)
200 The right way to think about the ``after-match function'' is that it
201 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
202 final ``else expression''.
205 There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
207 An experiment with re-ordering this information about equations (in
208 particular, having the patterns available in column-major order)
212 A default expression---what to evaluate if the overall pattern-match
213 fails. This expression will (almost?) always be
214 a measly expression @Var@, unless we know it will only be used once
215 (as we do in @glue_success_exprs@).
217 Leaving out this third argument to @match@ (and slamming in lots of
218 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
219 impossible to share the default expressions. (Also, it stands no
220 chance of working in our post-upheaval world of @Locals@.)
223 Note: @match@ is often called via @matchWrapper@ (end of this module),
224 a function that does much of the house-keeping that goes with a call
227 It is also worth mentioning the {\em typical} way a block of equations
228 is desugared with @match@. At each stage, it is the first column of
229 patterns that is examined. The steps carried out are roughly:
232 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
233 bindings to the second component of the equation-info):
236 Remove the `as' patterns from column~1.
238 Make all constructor patterns in column~1 into @ConPats@, notably
239 @ListPats@ and @TuplePats@.
241 Handle any irrefutable (or ``twiddle'') @LazyPats@.
244 Now {\em unmix} the equations into {\em blocks} [w\/ local function
245 @unmix_eqns@], in which the equations in a block all have variable
246 patterns in column~1, or they all have constructor patterns in ...
247 (see ``the mixture rule'' in SLPJ).
249 Call @matchEqnBlock@ on each block of equations; it will do the
250 appropriate thing for each kind of column-1 pattern, usually ending up
251 in a recursive call to @match@.
254 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
255 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
256 And gluing the ``success expressions'' together isn't quite so pretty.
258 This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
259 (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
260 (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
261 un}mixes the equations], producing a list of equation-info
262 blocks, each block having as its first column of patterns either all
263 constructors, or all variables (or similar beasts), etc.
265 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
266 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
267 corresponds roughly to @matchVarCon@.
270 match :: [Id] -- Variables rep\'ing the exprs we\'re matching with
271 -> Type -- Type of the case expression
272 -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
273 -> DsM MatchResult -- Desugared result!
276 = ASSERT2( not (null eqns), ppr ty )
277 return (foldr1 combineMatchResults match_results)
279 match_results = [ ASSERT( null (eqn_pats eqn) )
283 match vars@(v:_) ty eqns
284 = ASSERT( not (null eqns ) )
285 do { -- Tidy the first pattern, generating
286 -- auxiliary bindings if necessary
287 (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
289 -- Group the equations and match each group in turn
290 ; let grouped = groupEquations tidy_eqns
292 -- print the view patterns that are commoned up to help debug
293 ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
295 ; match_results <- mapM match_group grouped
296 ; return (adjustMatchResult (foldr1 (.) aux_binds) $
297 foldr1 combineMatchResults match_results) }
299 dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
302 match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
303 match_group [] = panic "match_group"
304 match_group eqns@((group,_) : _)
306 PgCon _ -> matchConFamily vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
307 PgLit _ -> matchLiterals vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
308 PgAny -> matchVariables vars ty (dropGroup eqns)
309 PgN _ -> matchNPats vars ty (dropGroup eqns)
310 PgNpK _ -> matchNPlusKPats vars ty (dropGroup eqns)
311 PgBang -> matchBangs vars ty (dropGroup eqns)
312 PgCo _ -> matchCoercion vars ty (dropGroup eqns)
313 PgView _ _ -> matchView vars ty (dropGroup eqns)
315 -- FIXME: we should also warn about view patterns that should be
316 -- commoned up but are not
318 -- print some stuff to see what's getting grouped
319 -- use -dppr-debug to see the resolution of overloaded lits
321 let gs = map (\group -> foldr (\ (p,_) -> \acc ->
322 case p of PgView e _ -> e:acc
323 _ -> acc) [] group) eqns
324 maybeWarn [] = return ()
325 maybeWarn l = warnDs (vcat l)
327 maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
328 (filter (not . null) gs))
330 matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
331 -- Real true variables, just like in matchVar, SLPJ p 94
332 -- No binding to do: they'll all be wildcards by now (done in tidy)
333 matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
334 matchVariables [] _ _ = panic "matchVariables"
336 matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
337 matchBangs (var:vars) ty eqns
338 = do { match_result <- match (var:vars) ty $
339 map (decomposeFirstPat getBangPat) eqns
340 ; return (mkEvalMatchResult var ty match_result) }
341 matchBangs [] _ _ = panic "matchBangs"
343 matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
344 -- Apply the coercion to the match variable and then match that
345 matchCoercion (var:vars) ty (eqns@(eqn1:_))
346 = do { let CoPat co pat _ = firstPat eqn1
347 ; var' <- newUniqueId var (hsPatType pat)
348 ; match_result <- match (var':vars) ty $
349 map (decomposeFirstPat getCoPat) eqns
350 ; co' <- dsHsWrapper co
351 ; let rhs' = co' (Var var)
352 ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
353 matchCoercion _ _ _ = panic "matchCoercion"
355 matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
356 -- Apply the view function to the match variable and then match that
357 matchView (var:vars) ty (eqns@(eqn1:_))
358 = do { -- we could pass in the expr from the PgView,
359 -- but this needs to extract the pat anyway
360 -- to figure out the type of the fresh variable
361 let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
362 -- do the rest of the compilation
363 ; var' <- newUniqueId var (hsPatType pat)
364 ; match_result <- match (var':vars) ty $
365 map (decomposeFirstPat getViewPat) eqns
366 -- compile the view expressions
367 ; viewExpr' <- dsLExpr viewExpr
368 ; return (mkViewMatchResult var' viewExpr' var match_result) }
369 matchView _ _ _ = panic "matchView"
371 -- decompose the first pattern and leave the rest alone
372 decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
373 decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
374 = eqn { eqn_pats = extractpat pat : pats}
375 decomposeFirstPat _ _ = panic "decomposeFirstPat"
377 getCoPat, getBangPat, getViewPat :: Pat Id -> Pat Id
378 getCoPat (CoPat _ pat _) = pat
379 getCoPat _ = panic "getCoPat"
380 getBangPat (BangPat pat ) = unLoc pat
381 getBangPat _ = panic "getBangPat"
382 getViewPat (ViewPat _ pat _) = unLoc pat
383 getViewPat _ = panic "getBangPat"
386 %************************************************************************
390 %************************************************************************
392 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
393 which will be scrutinised. This means:
396 Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
397 together with the binding @x = v@.
399 Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
401 Removing lazy (irrefutable) patterns (you don't want to know...).
403 Converting explicit tuple-, list-, and parallel-array-pats into ordinary
406 Convert the literal pat "" to [].
409 The result of this tidying is that the column of patterns will include
413 The @VarPat@ information isn't needed any more after this.
416 @ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
418 \item[@LitPats@ and @NPats@:]
419 @LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
420 Float, Double, at least) are converted to unboxed form; e.g.,
421 \tr{(NPat (HsInt i) _ _)} is converted to:
423 (ConPat I# _ _ [LitPat (HsIntPrim i)])
428 tidyEqnInfo :: Id -> EquationInfo
429 -> DsM (DsWrapper, EquationInfo)
430 -- DsM'd because of internal call to dsLHsBinds
431 -- and mkSelectorBinds.
432 -- "tidy1" does the interesting stuff, looking at
433 -- one pattern and fiddling the list of bindings.
435 -- POST CONDITION: head pattern in the EqnInfo is
443 tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
444 = panic "tidyEqnInfo"
446 tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
447 = do { (wrap, pat') <- tidy1 v pat
448 ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
450 tidy1 :: Id -- The Id being scrutinised
451 -> Pat Id -- The pattern against which it is to be matched
452 -> DsM (DsWrapper, -- Extra bindings to do before the match
453 Pat Id) -- Equivalent pattern
455 -------------------------------------------------------
456 -- (pat', mr') = tidy1 v pat mr
457 -- tidies the *outer level only* of pat, giving pat'
458 -- It eliminates many pattern forms (as-patterns, variable patterns,
459 -- list patterns, etc) yielding one of:
466 tidy1 v (ParPat pat) = tidy1 v (unLoc pat)
467 tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
468 tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
470 -- case v of { x -> mr[] }
471 -- = case v of { _ -> let x=v in mr[] }
473 = return (wrapBind var v, WildPat (idType var))
475 -- case v of { x@p -> mr[] }
476 -- = case v of { p -> let x=v in mr[] }
477 tidy1 v (AsPat (L _ var) pat)
478 = do { (wrap, pat') <- tidy1 v (unLoc pat)
479 ; return (wrapBind var v . wrap, pat') }
481 {- now, here we handle lazy patterns:
482 tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
483 v2 = case v of p -> v2 : ... : bs )
485 where the v_i's are the binders in the pattern.
487 ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
489 The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
492 tidy1 v (LazyPat pat)
493 = do { sel_prs <- mkSelectorBinds pat (Var v)
494 ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
495 ; return (mkCoreLets sel_binds, WildPat (idType v)) }
497 tidy1 _ (ListPat pats ty)
498 = return (idDsWrapper, unLoc list_ConPat)
500 list_ty = mkListTy ty
501 list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
505 -- Introduce fake parallel array constructors to be able to handle parallel
506 -- arrays with the existing machinery for constructor pattern
507 tidy1 _ (PArrPat pats ty)
508 = return (idDsWrapper, unLoc parrConPat)
511 parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
513 tidy1 _ (TuplePat pats boxity ty)
514 = return (idDsWrapper, unLoc tuple_ConPat)
517 tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
519 -- LitPats: we *might* be able to replace these w/ a simpler form
521 = return (idDsWrapper, tidyLitPat lit)
523 -- NPats: we *might* be able to replace these w/ a simpler form
524 tidy1 _ (NPat lit mb_neg eq)
525 = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
527 -- BangPatterns: Pattern matching is already strict in constructors,
528 -- tuples etc, so the last case strips off the bang for thoses patterns.
529 tidy1 v (BangPat (L _ (LazyPat p))) = tidy1 v (BangPat p)
530 tidy1 v (BangPat (L _ (ParPat p))) = tidy1 v (BangPat p)
531 tidy1 _ p@(BangPat (L _(VarPat _))) = return (idDsWrapper, p)
532 tidy1 _ p@(BangPat (L _ (WildPat _))) = return (idDsWrapper, p)
533 tidy1 _ p@(BangPat (L _ (CoPat _ _ _))) = return (idDsWrapper, p)
534 tidy1 _ p@(BangPat (L _ (SigPatIn _ _))) = return (idDsWrapper, p)
535 tidy1 _ p@(BangPat (L _ (SigPatOut _ _))) = return (idDsWrapper, p)
536 tidy1 v (BangPat (L _ (AsPat (L _ var) pat)))
537 = do { (wrap, pat') <- tidy1 v (BangPat pat)
538 ; return (wrapBind var v . wrap, pat') }
539 tidy1 v (BangPat (L _ p)) = tidy1 v p
541 -- Everything else goes through unchanged...
543 tidy1 _ non_interesting_pat
544 = return (idDsWrapper, non_interesting_pat)
548 {\bf Previous @matchTwiddled@ stuff:}
550 Now we get to the only interesting part; note: there are choices for
551 translation [from Simon's notes]; translation~1:
558 s = case w of [s,t] -> s
559 t = case w of [s,t] -> t
563 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
564 evaluation of \tr{e}. An alternative translation (No.~2):
566 [ w = case e of [s,t] -> (s,t)
567 s = case w of (s,t) -> s
568 t = case w of (s,t) -> t
572 %************************************************************************
574 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
576 %************************************************************************
578 We might be able to optimise unmixing when confronted by
579 only-one-constructor-possible, of which tuples are the most notable
587 This definition would normally be unmixed into four equation blocks,
588 one per equation. But it could be unmixed into just one equation
589 block, because if the one equation matches (on the first column),
590 the others certainly will.
592 You have to be careful, though; the example
600 {\em must} be broken into two blocks at the line shown; otherwise, you
601 are forcing unnecessary evaluation. In any case, the top-left pattern
602 always gives the cue. You could then unmix blocks into groups of...
604 \item[all variables:]
606 \item[constructors or variables (mixed):]
607 Need to make sure the right names get bound for the variable patterns.
608 \item[literals or variables (mixed):]
609 Presumably just a variant on the constructor case (as it is now).
612 %************************************************************************
614 %* matchWrapper: a convenient way to call @match@ *
616 %************************************************************************
617 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
619 Calls to @match@ often involve similar (non-trivial) work; that work
620 is collected here, in @matchWrapper@. This function takes as
624 Typchecked @Matches@ (of a function definition, or a case or lambda
625 expression)---the main input;
627 An error message to be inserted into any (runtime) pattern-matching
631 As results, @matchWrapper@ produces:
634 A list of variables (@Locals@) that the caller must ``promise'' to
635 bind to appropriate values; and
637 a @CoreExpr@, the desugared output (main result).
640 The main actions of @matchWrapper@ include:
643 Flatten the @[TypecheckedMatch]@ into a suitable list of
646 Create as many new variables as there are patterns in a pattern-list
647 (in any one of the @EquationInfo@s).
649 Create a suitable ``if it fails'' expression---a call to @error@ using
650 the error-string input; the {\em type} of this fail value can be found
651 by examining one of the RHS expressions in one of the @EquationInfo@s.
653 Call @match@ with all of this information!
657 matchWrapper :: HsMatchContext Name -- For shadowing warning messages
658 -> MatchGroup Id -- Matches being desugared
659 -> DsM ([Id], CoreExpr) -- Results
662 There is one small problem with the Lambda Patterns, when somebody
663 writes something similar to:
667 he/she don't want a warning about incomplete patterns, that is done with
668 the flag @opt_WarnSimplePatterns@.
669 This problem also appears in the:
671 \item @do@ patterns, but if the @do@ can fail
672 it creates another equation if the match can fail
673 (see @DsExpr.doDo@ function)
674 \item @let@ patterns, are treated by @matchSimply@
675 List Comprension Patterns, are treated by @matchSimply@ also
678 We can't call @matchSimply@ with Lambda patterns,
679 due to the fact that lambda patterns can have more than
680 one pattern, and match simply only accepts one pattern.
685 matchWrapper ctxt (MatchGroup matches match_ty)
686 = ASSERT( notNull matches )
687 do { eqns_info <- mapM mk_eqn_info matches
688 ; new_vars <- selectMatchVars arg_pats
689 ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
690 ; return (new_vars, result_expr) }
692 arg_pats = map unLoc (hsLMatchPats (head matches))
693 n_pats = length arg_pats
694 (_, rhs_ty) = splitFunTysN n_pats match_ty
696 mk_eqn_info (L _ (Match pats _ grhss))
697 = do { let upats = map unLoc pats
698 ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
699 ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) }
702 matchEquations :: HsMatchContext Name
703 -> [Id] -> [EquationInfo] -> Type
705 matchEquations ctxt vars eqns_info rhs_ty
706 = do { locn <- getSrcSpanDs
707 ; let ds_ctxt = DsMatchContext ctxt locn
708 error_doc = matchContextErrString ctxt
710 ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info
712 ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
713 ; extractMatchResult match_result fail_expr }
716 %************************************************************************
718 \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
720 %************************************************************************
722 @mkSimpleMatch@ is a wrapper for @match@ which deals with the
723 situation where we want to match a single expression against a single
724 pattern. It returns an expression.
727 matchSimply :: CoreExpr -- Scrutinee
728 -> HsMatchContext Name -- Match kind
729 -> LPat Id -- Pattern it should match
730 -> CoreExpr -- Return this if it matches
731 -> CoreExpr -- Return this if it doesn't
733 -- Do not warn about incomplete patterns; see matchSinglePat comments
734 matchSimply scrut hs_ctx pat result_expr fail_expr = do
736 match_result = cantFailMatchResult result_expr
737 rhs_ty = exprType fail_expr
738 -- Use exprType of fail_expr, because won't refine in the case of failure!
739 match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
740 extractMatchResult match_result' fail_expr
742 matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
743 -> Type -> MatchResult -> DsM MatchResult
744 -- Do not warn about incomplete patterns
745 -- Used for things like [ e | pat <- stuff ], where
746 -- incomplete patterns are just fine
747 matchSinglePat (Var var) ctx (L _ pat) ty match_result
748 = do { locn <- getSrcSpanDs
749 ; matchCheck (DsMatchContext ctx locn)
751 [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] }
753 matchSinglePat scrut hs_ctx pat ty match_result
754 = do { var <- selectSimpleMatchVarL pat
755 ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
756 ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
760 %************************************************************************
762 Pattern classification
764 %************************************************************************
768 = PgAny -- Immediate match: variables, wildcards,
770 | PgCon DataCon -- Constructor patterns (incl list, tuple)
771 | PgLit Literal -- Literal patterns
772 | PgN Literal -- Overloaded literals
773 | PgNpK Literal -- n+k patterns
774 | PgBang -- Bang patterns
775 | PgCo Type -- Coercion patterns; the type is the type
776 -- of the pattern *inside*
777 | PgView (LHsExpr Id) -- view pattern (e -> p):
778 -- the LHsExpr is the expression e
779 Type -- the Type is the type of p (equivalently, the result type of e)
781 groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
782 -- If the result is of form [g1, g2, g3],
783 -- (a) all the (pg,eq) pairs in g1 have the same pg
784 -- (b) none of the gi are empty
785 -- The ordering of equations is unchanged
787 = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns]
789 same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
790 (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
792 subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
793 -- Input is a particular group. The result sub-groups the
794 -- equations by with particular constructor, literal etc they match.
795 -- Each sub-list in the result has the same PatGroup
796 -- See Note [Take care with pattern order]
798 = map reverse $ Map.elems $ foldl accumulate Map.empty group
800 accumulate pg_map (pg, eqn)
801 = case Map.lookup pg pg_map of
802 Just eqns -> Map.insert pg (eqn:eqns) pg_map
803 Nothing -> Map.insert pg [eqn] pg_map
805 -- pg_map :: Map a [EquationInfo]
806 -- Equations seen so far in reverse order of appearance
809 Note [Take care with pattern order]
810 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
811 In the subGroup function we must be very careful about pattern re-ordering,
812 Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
813 Then in bringing together the patterns for True, we must not
814 swap the Nothing and y!
818 sameGroup :: PatGroup -> PatGroup -> Bool
819 -- Same group means that a single case expression
820 -- or test will suffice to match both, *and* the order
821 -- of testing within the group is insignificant.
822 sameGroup PgAny PgAny = True
823 sameGroup PgBang PgBang = True
824 sameGroup (PgCon _) (PgCon _) = True -- One case expression
825 sameGroup (PgLit _) (PgLit _) = True -- One case expression
826 sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant
827 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns]
828 sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2
829 -- CoPats are in the same goup only if the type of the
830 -- enclosed pattern is the same. The patterns outside the CoPat
831 -- always have the same type, so this boils down to saying that
832 -- the two coercions are identical.
833 sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
834 -- ViewPats are in the same gorup iff the expressions
835 -- are "equal"---conservatively, we use syntactic equality
836 sameGroup _ _ = False
838 -- An approximation of syntactic equality used for determining when view
839 -- exprs are in the same group.
840 -- This function can always safely return false;
841 -- but doing so will result in the application of the view function being repeated.
843 -- Currently: compare applications of literals and variables
844 -- and anything else that we can do without involving other
845 -- HsSyn types in the recursion
847 -- NB we can't assume that the two view expressions have the same type. Consider
848 -- f (e1 -> True) = ...
849 -- f (e2 -> "hi") = ...
850 viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
851 viewLExprEq (e1,_) (e2,_) = lexp e1 e2
853 lexp :: LHsExpr Id -> LHsExpr Id -> Bool
854 lexp e e' = exp (unLoc e) (unLoc e')
857 exp :: HsExpr Id -> HsExpr Id -> Bool
858 -- real comparison is on HsExpr's
860 exp (HsPar (L _ e)) e' = exp e e'
861 exp e (HsPar (L _ e')) = exp e e'
862 -- because the expressions do not necessarily have the same type,
863 -- we have to compare the wrappers
864 exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
865 exp (HsVar i) (HsVar i') = i == i'
866 -- the instance for IPName derives using the id, so this works if the
868 exp (HsIPVar i) (HsIPVar i') = i == i'
869 exp (HsOverLit l) (HsOverLit l') =
870 -- Overloaded lits are equal if they have the same type
871 -- and the data is the same.
872 -- this is coarser than comparing the SyntaxExpr's in l and l',
873 -- which resolve the overloading (e.g., fromInteger 1),
874 -- because these expressions get written as a bunch of different variables
875 -- (presumably to improve sharing)
876 tcEqType (overLitType l) (overLitType l') && l == l'
877 exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
878 -- the fixities have been straightened out by now, so it's safe
880 exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
881 lexp l l' && lexp o o' && lexp ri ri'
882 exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
883 exp (SectionL e1 e2) (SectionL e1' e2') =
884 lexp e1 e1' && lexp e2 e2'
885 exp (SectionR e1 e2) (SectionR e1' e2') =
886 lexp e1 e1' && lexp e2 e2'
887 exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
888 eq_list tup_arg es1 es2
889 exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
890 lexp e e' && lexp e1 e1' && lexp e2 e2'
892 -- Enhancement: could implement equality for more expressions
893 -- if it seems useful
894 -- But no need for HsLit, ExplicitList, ExplicitTuple,
895 -- because they cannot be functions
899 tup_arg (Present e1) (Present e2) = lexp e1 e2
900 tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2
904 wrap :: HsWrapper -> HsWrapper -> Bool
905 -- Conservative, in that it demands that wrappers be
906 -- syntactically identical and doesn't look under binders
908 -- Coarser notions of equality are possible
909 -- (e.g., reassociating compositions,
910 -- equating different ways of writing a coercion)
911 wrap WpHole WpHole = True
912 wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
913 wrap (WpCast c) (WpCast c') = tcEqType c c'
914 wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
915 wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
916 -- Enhancement: could implement equality for more wrappers
917 -- if it seems useful (lams and lets)
921 ev_term :: EvTerm -> EvTerm -> Bool
922 ev_term (EvId a) (EvId b) = a==b
923 ev_term (EvCoercion a) (EvCoercion b) = tcEqType a b
927 eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
928 eq_list _ [] [] = True
929 eq_list _ [] (_:_) = False
930 eq_list _ (_:_) [] = False
931 eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
933 patGroup :: Pat Id -> PatGroup
934 patGroup (WildPat {}) = PgAny
935 patGroup (BangPat {}) = PgBang
936 patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc)
937 patGroup (LitPat lit) = PgLit (hsLitKey lit)
938 patGroup (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg))
939 patGroup (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False)
940 patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
941 patGroup (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
942 patGroup pat = pprPanic "patGroup" (ppr pat)
945 Note [Grouping overloaded literal patterns]
946 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
953 We can't group the first and third together, because the second may match
954 the same thing as the first. Same goes for *overloaded* literal patterns
958 If the first arg matches '1' but the second does not match 'True', we
959 cannot jump to the third equation! Because the same argument might
961 Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.