never executed always true always false
1
2 {-# LANGUAGE MonadComprehensions #-}
3 {-# LANGUAGE OverloadedLists #-}
4 {-# LANGUAGE PatternSynonyms #-}
5 {-# LANGUAGE TypeFamilies #-}
6 {-# LANGUAGE ViewPatterns #-}
7
8 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
9 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
10
11 {-
12 (c) The University of Glasgow 2006
13 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
14
15
16 The @match@ function
17 -}
18
19 module GHC.HsToCore.Match
20 ( match, matchEquations, matchWrapper, matchSimply
21 , matchSinglePat, matchSinglePatVar
22 )
23 where
24
25 import GHC.Prelude
26 import GHC.Platform
27
28 import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
29
30 import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) )
31 import GHC.Types.SourceText
32 import GHC.Driver.Session
33 import GHC.Hs
34 import GHC.Hs.Syn.Type
35 import GHC.Tc.Types.Evidence
36 import GHC.Tc.Utils.Monad
37 import GHC.HsToCore.Pmc
38 import GHC.HsToCore.Pmc.Types ( Nablas, initNablas )
39 import GHC.Core
40 import GHC.Types.Literal
41 import GHC.Core.Utils
42 import GHC.Core.Make
43 import GHC.HsToCore.Monad
44 import GHC.HsToCore.Binds
45 import GHC.HsToCore.GuardedRHSs
46 import GHC.HsToCore.Utils
47 import GHC.Types.Id
48 import GHC.Core.ConLike
49 import GHC.Core.DataCon
50 import GHC.Core.PatSyn
51 import GHC.HsToCore.Errors.Types
52 import GHC.HsToCore.Match.Constructor
53 import GHC.HsToCore.Match.Literal
54 import GHC.Core.Type
55 import GHC.Core.Coercion ( eqCoercion )
56 import GHC.Core.TyCon ( isNewTyCon )
57 import GHC.Core.Multiplicity
58 import GHC.Builtin.Types
59 import GHC.Types.SrcLoc
60 import GHC.Data.Maybe
61 import GHC.Utils.Misc
62 import GHC.Types.Name
63 import GHC.Utils.Outputable
64 import GHC.Utils.Panic
65 import GHC.Utils.Panic.Plain
66 import GHC.Data.FastString
67 import GHC.Types.Unique
68 import GHC.Types.Unique.DFM
69
70 import Control.Monad ( zipWithM, unless, when )
71 import Data.List.NonEmpty (NonEmpty(..))
72 import qualified Data.List.NonEmpty as NEL
73 import qualified Data.Map as Map
74
75 {-
76 ************************************************************************
77 * *
78 The main matching function
79 * *
80 ************************************************************************
81
82 The function @match@ is basically the same as in the Wadler chapter
83 from "The Implementation of Functional Programming Languages",
84 except it is monadised, to carry around the name supply, info about
85 annotations, etc.
86
87 Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
88 \begin{enumerate}
89 \item
90 A list of $n$ variable names, those variables presumably bound to the
91 $n$ expressions being matched against the $n$ patterns. Using the
92 list of $n$ expressions as the first argument showed no benefit and
93 some inelegance.
94
95 \item
96 The second argument, a list giving the ``equation info'' for each of
97 the $m$ equations:
98 \begin{itemize}
99 \item
100 the $n$ patterns for that equation, and
101 \item
102 a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
103 the front'' of the matching code, as in:
104 \begin{verbatim}
105 let <binds>
106 in <matching-code>
107 \end{verbatim}
108 \item
109 and finally: (ToDo: fill in)
110
111 The right way to think about the ``after-match function'' is that it
112 is an embryonic @CoreExpr@ with a ``hole'' at the end for the
113 final ``else expression''.
114 \end{itemize}
115
116 There is a data type, @EquationInfo@, defined in module @GHC.HsToCore.Monad@.
117
118 An experiment with re-ordering this information about equations (in
119 particular, having the patterns available in column-major order)
120 showed no benefit.
121
122 \item
123 A default expression---what to evaluate if the overall pattern-match
124 fails. This expression will (almost?) always be
125 a measly expression @Var@, unless we know it will only be used once
126 (as we do in @glue_success_exprs@).
127
128 Leaving out this third argument to @match@ (and slamming in lots of
129 @Var "fail"@s) is a positively {\em bad} idea, because it makes it
130 impossible to share the default expressions. (Also, it stands no
131 chance of working in our post-upheaval world of @Locals@.)
132 \end{enumerate}
133
134 Note: @match@ is often called via @matchWrapper@ (end of this module),
135 a function that does much of the house-keeping that goes with a call
136 to @match@.
137
138 It is also worth mentioning the {\em typical} way a block of equations
139 is desugared with @match@. At each stage, it is the first column of
140 patterns that is examined. The steps carried out are roughly:
141 \begin{enumerate}
142 \item
143 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
144 bindings to the second component of the equation-info):
145 \item
146 Now {\em unmix} the equations into {\em blocks} [w\/ local function
147 @match_groups@], in which the equations in a block all have the same
148 match group.
149 (see ``the mixture rule'' in SLPJ).
150 \item
151 Call the right match variant on each block of equations; it will do the
152 appropriate thing for each kind of column-1 pattern.
153 \end{enumerate}
154
155 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
156 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
157 And gluing the ``success expressions'' together isn't quite so pretty.
158
159 This @match@ uses @tidyEqnInfo@
160 to get `as'- and `twiddle'-patterns out of the way (tidying), before
161 applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em
162 un}mixes the equations], producing a list of equation-info
163 blocks, each block having as its first column patterns compatible with each other.
164
165 Note [Match Ids]
166 ~~~~~~~~~~~~~~~~
167 Most of the matching functions take an Id or [Id] as argument. This Id
168 is the scrutinee(s) of the match. The desugared expression may
169 sometimes use that Id in a local binding or as a case binder. So it
170 should not have an External name; Lint rejects non-top-level binders
171 with External names (#13043).
172
173 See also Note [Localise pattern binders] in GHC.HsToCore.Utils
174 -}
175
176 type MatchId = Id -- See Note [Match Ids]
177
178 match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with
179 -- ^ See Note [Match Ids]
180 --
181 -- ^ Note that the Match Ids carry not only a name, but
182 -- ^ also the multiplicity at which each column has been
183 -- ^ type checked.
184 -> Type -- ^ Type of the case expression
185 -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below)
186 -> DsM (MatchResult CoreExpr) -- ^ Desugared result!
187
188 match [] ty eqns
189 = assertPpr (not (null eqns)) (ppr ty) $
190 return (foldr1 combineMatchResults match_results)
191 where
192 match_results = [ assert (null (eqn_pats eqn)) $
193 eqn_rhs eqn
194 | eqn <- eqns ]
195
196 match (v:vs) ty eqns -- Eqns *can* be empty
197 = assertPpr (all (isInternalName . idName) vars) (ppr vars) $
198 do { dflags <- getDynFlags
199 ; let platform = targetPlatform dflags
200 -- Tidy the first pattern, generating
201 -- auxiliary bindings if necessary
202 ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
203 -- Group the equations and match each group in turn
204 ; let grouped = groupEquations platform tidy_eqns
205
206 -- print the view patterns that are commoned up to help debug
207 ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
208
209 ; match_results <- match_groups grouped
210 ; return $ foldr (.) id aux_binds <$>
211 foldr1 combineMatchResults match_results
212 }
213 where
214 vars = v :| vs
215
216 dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
217 dropGroup = fmap snd
218
219 match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr))
220 -- Result list of [MatchResult CoreExpr] is always non-empty
221 match_groups [] = matchEmpty v ty
222 match_groups (g:gs) = mapM match_group $ g :| gs
223
224 match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr)
225 match_group eqns@((group,_) :| _)
226 = case group of
227 PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
228 PgSyn {} -> matchPatSyn vars ty (dropGroup eqns)
229 PgLit {} -> matchLiterals vars ty (ne $ subGroupOrd [(l,e) | (PgLit l, e) <- eqns'])
230 PgAny -> matchVariables vars ty (dropGroup eqns)
231 PgN {} -> matchNPats vars ty (dropGroup eqns)
232 PgOverS {}-> matchNPats vars ty (dropGroup eqns)
233 PgNpK {} -> matchNPlusKPats vars ty (dropGroup eqns)
234 PgBang -> matchBangs vars ty (dropGroup eqns)
235 PgCo {} -> matchCoercion vars ty (dropGroup eqns)
236 PgView {} -> matchView vars ty (dropGroup eqns)
237 where eqns' = NEL.toList eqns
238 ne l = case NEL.nonEmpty l of
239 Just nel -> nel
240 Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty"
241
242 -- FIXME: we should also warn about view patterns that should be
243 -- commoned up but are not
244
245 -- print some stuff to see what's getting grouped
246 -- use -dppr-debug to see the resolution of overloaded literals
247 debug eqns =
248 let gs = map (\group -> foldr (\ (p,_) -> \acc ->
249 case p of PgView e _ -> e:acc
250 _ -> acc) [] group) eqns
251 maybeWarn [] = return ()
252 maybeWarn l = diagnosticDs (DsAggregatedViewExpressions l)
253 in
254 maybeWarn $ filter (not . null) gs
255
256 matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
257 -- See Note [Empty case expressions]
258 matchEmpty var res_ty
259 = return [MR_Fallible mk_seq]
260 where
261 mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty
262 [Alt DEFAULT [] fail]
263
264 matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
265 -- Real true variables, just like in matchVar, SLPJ p 94
266 -- No binding to do: they'll all be wildcards by now (done in tidy)
267 matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns
268
269 matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
270 matchBangs (var :| vars) ty eqns
271 = do { match_result <- match (var:vars) ty $ NEL.toList $
272 decomposeFirstPat getBangPat <$> eqns
273 ; return (mkEvalMatchResult var ty match_result) }
274
275 matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
276 -- Apply the coercion to the match variable and then match that
277 matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
278 = do { let XPat (CoPat co pat _) = firstPat eqn1
279 ; let pat_ty' = hsPatType pat
280 ; var' <- newUniqueId var (idMult var) pat_ty'
281 ; match_result <- match (var':vars) ty $ NEL.toList $
282 decomposeFirstPat getCoPat <$> eqns
283 ; core_wrap <- dsHsWrapper co
284 ; let bind = NonRec var' (core_wrap (Var var))
285 ; return (mkCoLetMatchResult bind match_result) }
286
287 matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
288 -- Apply the view function to the match variable and then match that
289 matchView (var :| vars) ty (eqns@(eqn1 :| _))
290 = do { -- we could pass in the expr from the PgView,
291 -- but this needs to extract the pat anyway
292 -- to figure out the type of the fresh variable
293 let TcViewPat viewExpr pat = firstPat eqn1
294 -- do the rest of the compilation
295 ; let pat_ty' = hsPatType pat
296 ; var' <- newUniqueId var (idMult var) pat_ty'
297 ; match_result <- match (var':vars) ty $ NEL.toList $
298 decomposeFirstPat getViewPat <$> eqns
299 -- compile the view expressions
300 ; viewExpr' <- dsExpr viewExpr
301 ; return (mkViewMatchResult var'
302 (mkCoreAppDs (text "matchView") viewExpr' (Var var))
303 match_result) }
304
305 -- decompose the first pattern and leave the rest alone
306 decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
307 decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
308 = eqn { eqn_pats = extractpat pat : pats}
309 decomposeFirstPat _ _ = panic "decomposeFirstPat"
310
311 getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
312 getCoPat (XPat (CoPat _ pat _)) = pat
313 getCoPat _ = panic "getCoPat"
314 getBangPat (BangPat _ pat ) = unLoc pat
315 getBangPat _ = panic "getBangPat"
316 getViewPat (TcViewPat _ pat) = pat
317 getViewPat _ = panic "getViewPat"
318
319 -- | Use this pattern synonym to match on a 'ViewPat'.
320 --
321 -- N.B.: View patterns can occur inside HsExpansions.
322 pattern TcViewPat :: HsExpr GhcTc -> Pat GhcTc -> Pat GhcTc
323 pattern TcViewPat viewExpr pat <- (getTcViewPat -> (viewExpr, pat))
324
325 getTcViewPat :: Pat GhcTc -> (HsExpr GhcTc, Pat GhcTc)
326 getTcViewPat (ViewPat _ viewLExpr pat) = (unLoc viewLExpr, unLoc pat)
327 getTcViewPat (XPat (ExpansionPat _ p)) = getTcViewPat p
328 getTcViewPat p = pprPanic "getTcViewPat" (ppr p)
329
330 {-
331 Note [Empty case alternatives]
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
333 The list of EquationInfo can be empty, arising from
334 case x of {} or \case {}
335 In that situation we desugar to
336 case x of { _ -> error "pattern match failure" }
337 The *desugarer* isn't certain whether there really should be no
338 alternatives, so it adds a default case, as it always does. A later
339 pass may remove it if it's inaccessible. (See also Note [Empty case
340 alternatives] in GHC.Core.)
341
342 We do *not* desugar simply to
343 error "empty case"
344 or some such, because 'x' might be bound to (error "hello"), in which
345 case we want to see that "hello" exception, not (error "empty case").
346 See also Note [Case elimination: lifted case] in GHC.Core.Opt.Simplify.
347
348
349 ************************************************************************
350 * *
351 Tidying patterns
352 * *
353 ************************************************************************
354
355 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
356 which will be scrutinised.
357
358 This makes desugaring the pattern match simpler by transforming some of
359 the patterns to simpler forms. (Tuples to Constructor Patterns)
360
361 Among other things in the resulting Pattern:
362 * Variables and irrefutable(lazy) patterns are replaced by Wildcards
363 * As patterns are replaced by the patterns they wrap.
364
365 The bindings created by the above patterns are put into the returned wrapper
366 instead.
367
368 This means a definition of the form:
369 f x = rhs
370 when called with v get's desugared to the equivalent of:
371 let x = v
372 in
373 f _ = rhs
374
375 The same principle holds for as patterns (@) and
376 irrefutable/lazy patterns (~).
377 In the case of irrefutable patterns the irrefutable pattern is pushed into
378 the binding.
379
380 Pattern Constructors which only represent syntactic sugar are converted into
381 their desugared representation.
382 This usually means converting them to Constructor patterns but for some
383 depends on enabled extensions. (Eg OverloadedLists)
384
385 GHC also tries to convert overloaded Literals into regular ones.
386
387 The result of this tidying is that the column of patterns will include
388 only these which can be assigned a PatternGroup (see patGroup).
389
390 -}
391
392 tidyEqnInfo :: Id -> EquationInfo
393 -> DsM (DsWrapper, EquationInfo)
394 -- DsM'd because of internal call to dsLHsBinds
395 -- and mkSelectorBinds.
396 -- "tidy1" does the interesting stuff, looking at
397 -- one pattern and fiddling the list of bindings.
398 --
399 -- POST CONDITION: head pattern in the EqnInfo is
400 -- one of these for which patGroup is defined.
401
402 tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
403 = panic "tidyEqnInfo"
404
405 tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
406 = do { (wrap, pat') <- tidy1 v orig pat
407 ; return (wrap, eqn { eqn_pats = pat' : pats }) }
408
409 tidy1 :: Id -- The Id being scrutinised
410 -> Origin -- Was this a pattern the user wrote?
411 -> Pat GhcTc -- The pattern against which it is to be matched
412 -> DsM (DsWrapper, -- Extra bindings to do before the match
413 Pat GhcTc) -- Equivalent pattern
414
415 -------------------------------------------------------
416 -- (pat', mr') = tidy1 v pat mr
417 -- tidies the *outer level only* of pat, giving pat'
418 -- It eliminates many pattern forms (as-patterns, variable patterns,
419 -- list patterns, etc) and returns any created bindings in the wrapper.
420
421 tidy1 v o (ParPat _ _ pat _) = tidy1 v o (unLoc pat)
422 tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat)
423 tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty)
424 tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
425
426 -- case v of { x -> mr[] }
427 -- = case v of { _ -> let x=v in mr[] }
428 tidy1 v _ (VarPat _ (L _ var))
429 = return (wrapBind var v, WildPat (idType var))
430
431 -- case v of { x@p -> mr[] }
432 -- = case v of { p -> let x=v in mr[] }
433 tidy1 v o (AsPat _ (L _ var) pat)
434 = do { (wrap, pat') <- tidy1 v o (unLoc pat)
435 ; return (wrapBind var v . wrap, pat') }
436
437 {- now, here we handle lazy patterns:
438 tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
439 v2 = case v of p -> v2 : ... : bs )
440
441 where the v_i's are the binders in the pattern.
442
443 ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
444
445 The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
446 -}
447
448 tidy1 v _ (LazyPat _ pat)
449 -- This is a convenient place to check for unlifted types under a lazy pattern.
450 -- Doing this check during type-checking is unsatisfactory because we may
451 -- not fully know the zonked types yet. We sure do here.
452 = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)
453 ; unless (null unlifted_bndrs) $
454 putSrcSpanDs (getLocA pat) $
455 diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs)
456
457 ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
458 ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
459 ; return (mkCoreLets sel_binds, WildPat (idType v)) }
460
461 tidy1 _ _ (ListPat ty pats)
462 = return (idDsWrapper, unLoc list_ConPat)
463 where
464 list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
465 (mkNilPat ty)
466 pats
467
468 tidy1 _ _ (TuplePat tys pats boxity)
469 = return (idDsWrapper, unLoc tuple_ConPat)
470 where
471 arity = length pats
472 tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys'
473 tys' = case boxity of
474 Unboxed -> map getRuntimeRep tys ++ tys
475 Boxed -> tys
476 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
477
478 tidy1 _ _ (SumPat tys pat alt arity)
479 = return (idDsWrapper, unLoc sum_ConPat)
480 where
481 sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys)
482 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
483
484 -- LitPats: we *might* be able to replace these w/ a simpler form
485 tidy1 _ o (LitPat _ lit)
486 = do { unless (isGenerated o) $
487 warnAboutOverflowedLit lit
488 ; return (idDsWrapper, tidyLitPat lit) }
489
490 -- NPats: we *might* be able to replace these w/ a simpler form
491 tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
492 = do { unless (isGenerated o) $
493 let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
494 | otherwise = lit
495 in warnAboutOverflowedOverLit lit'
496 ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
497
498 -- NPlusKPat: we may want to warn about the literals
499 tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
500 = do { unless (isGenerated o) $ do
501 warnAboutOverflowedOverLit lit1
502 warnAboutOverflowedOverLit lit2
503 ; return (idDsWrapper, n) }
504
505 -- Everything else goes through unchanged...
506 tidy1 _ _ non_interesting_pat
507 = return (idDsWrapper, non_interesting_pat)
508
509 --------------------
510 tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc
511 -> DsM (DsWrapper, Pat GhcTc)
512
513 -- Discard par/sig under a bang
514 tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p
515 tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
516
517 -- Push the bang-pattern inwards, in the hope that
518 -- it may disappear next time
519 tidy_bang_pat v o l (AsPat x v' p)
520 = tidy1 v o (AsPat x v' (L l (BangPat noExtField p)))
521 tidy_bang_pat v o l (XPat (CoPat w p t))
522 = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t)
523
524 -- Discard bang around strict pattern
525 tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p
526 tidy_bang_pat v o _ p@(ListPat {}) = tidy1 v o p
527 tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p
528 tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p
529
530 -- Data/newtype constructors
531 tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
532 , pat_args = args
533 , pat_con_ext = ConPatTc
534 { cpt_arg_tys = arg_tys
535 }
536 })
537 -- Newtypes: push bang inwards (#9844)
538 =
539 if isNewTyCon (dataConTyCon dc)
540 then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
541 else tidy1 v o p -- Data types: discard the bang
542 where
543 (ty:_) = dataConInstArgTys dc arg_tys
544
545 -------------------
546 -- Default case, leave the bang there:
547 -- VarPat,
548 -- LazyPat,
549 -- WildPat,
550 -- ViewPat,
551 -- pattern synonyms (ConPatOut with PatSynCon)
552 -- NPat,
553 -- NPlusKPat
554 --
555 -- For LazyPat, remember that it's semantically like a VarPat
556 -- i.e. !(~p) is not like ~p, or p! (#8952)
557 --
558 -- NB: SigPatIn, ConPatIn should not happen
559
560 tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))
561
562 -------------------
563 push_bang_into_newtype_arg :: SrcSpanAnnA
564 -> Type -- The type of the argument we are pushing
565 -- onto
566 -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
567 -- See Note [Bang patterns and newtypes]
568 -- We are transforming !(N p) into (N !p)
569 push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args))
570 = assert (null args) $
571 PrefixCon ts [L l (BangPat noExtField arg)]
572 push_bang_into_newtype_arg l _ty (RecCon rf)
573 | HsRecFields { rec_flds = L lf fld : flds } <- rf
574 , HsFieldBind { hfbRHS = arg } <- fld
575 = assert (null flds) $
576 RecCon (rf { rec_flds = [L lf (fld { hfbRHS
577 = L l (BangPat noExtField arg) })] })
578 push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
579 | HsRecFields { rec_flds = [] } <- rf
580 = PrefixCon [] [L l (BangPat noExtField (noLocA (WildPat ty)))]
581 push_bang_into_newtype_arg _ _ cd
582 = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
583
584 {-
585 Note [Bang patterns and newtypes]
586 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
587 For the pattern !(Just pat) we can discard the bang, because
588 the pattern is strict anyway. But for !(N pat), where
589 newtype NT = N Int
590 we definitely can't discard the bang. #9844.
591
592 So what we do is to push the bang inwards, in the hope that it will
593 get discarded there. So we transform
594 !(N pat) into (N !pat)
595
596 But what if there is nothing to push the bang onto? In at least one instance
597 a user has written !(N {}) which we translate into (N !_). See #13215
598
599
600 \noindent
601 {\bf Previous @matchTwiddled@ stuff:}
602
603 Now we get to the only interesting part; note: there are choices for
604 translation [from Simon's notes]; translation~1:
605 \begin{verbatim}
606 deTwiddle [s,t] e
607 \end{verbatim}
608 returns
609 \begin{verbatim}
610 [ w = e,
611 s = case w of [s,t] -> s
612 t = case w of [s,t] -> t
613 ]
614 \end{verbatim}
615
616 Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
617 evaluation of \tr{e}. An alternative translation (No.~2):
618 \begin{verbatim}
619 [ w = case e of [s,t] -> (s,t)
620 s = case w of (s,t) -> s
621 t = case w of (s,t) -> t
622 ]
623 \end{verbatim}
624
625 ************************************************************************
626 * *
627 \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
628 * *
629 ************************************************************************
630
631 We might be able to optimise unmixing when confronted by
632 only-one-constructor-possible, of which tuples are the most notable
633 examples. Consider:
634 \begin{verbatim}
635 f (a,b,c) ... = ...
636 f d ... (e:f) = ...
637 f (g,h,i) ... = ...
638 f j ... = ...
639 \end{verbatim}
640 This definition would normally be unmixed into four equation blocks,
641 one per equation. But it could be unmixed into just one equation
642 block, because if the one equation matches (on the first column),
643 the others certainly will.
644
645 You have to be careful, though; the example
646 \begin{verbatim}
647 f j ... = ...
648 -------------------
649 f (a,b,c) ... = ...
650 f d ... (e:f) = ...
651 f (g,h,i) ... = ...
652 \end{verbatim}
653 {\em must} be broken into two blocks at the line shown; otherwise, you
654 are forcing unnecessary evaluation. In any case, the top-left pattern
655 always gives the cue. You could then unmix blocks into groups of...
656 \begin{description}
657 \item[all variables:]
658 As it is now.
659 \item[constructors or variables (mixed):]
660 Need to make sure the right names get bound for the variable patterns.
661 \item[literals or variables (mixed):]
662 Presumably just a variant on the constructor case (as it is now).
663 \end{description}
664
665 ************************************************************************
666 * *
667 * matchWrapper: a convenient way to call @match@ *
668 * *
669 ************************************************************************
670 \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
671
672 Calls to @match@ often involve similar (non-trivial) work; that work
673 is collected here, in @matchWrapper@. This function takes as
674 arguments:
675 \begin{itemize}
676 \item
677 Typechecked @Matches@ (of a function definition, or a case or lambda
678 expression)---the main input;
679 \item
680 An error message to be inserted into any (runtime) pattern-matching
681 failure messages.
682 \end{itemize}
683
684 As results, @matchWrapper@ produces:
685 \begin{itemize}
686 \item
687 A list of variables (@Locals@) that the caller must ``promise'' to
688 bind to appropriate values; and
689 \item
690 a @CoreExpr@, the desugared output (main result).
691 \end{itemize}
692
693 The main actions of @matchWrapper@ include:
694 \begin{enumerate}
695 \item
696 Flatten the @[TypecheckedMatch]@ into a suitable list of
697 @EquationInfo@s.
698 \item
699 Create as many new variables as there are patterns in a pattern-list
700 (in any one of the @EquationInfo@s).
701 \item
702 Create a suitable ``if it fails'' expression---a call to @error@ using
703 the error-string input; the {\em type} of this fail value can be found
704 by examining one of the RHS expressions in one of the @EquationInfo@s.
705 \item
706 Call @match@ with all of this information!
707 \end{enumerate}
708 -}
709
710 matchWrapper
711 :: HsMatchContext GhcRn -- ^ For shadowing warning messages
712 -> Maybe (LHsExpr GhcTc) -- ^ Scrutinee. (Just scrut) for a case expr
713 -- case scrut of { p1 -> e1 ... }
714 -- (and in this case the MatchGroup will
715 -- have all singleton patterns)
716 -- Nothing for a function definition
717 -- f p1 q1 = ... -- No "scrutinee"
718 -- f p2 q2 = ... -- in this case
719 -> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared
720 -> DsM ([Id], CoreExpr) -- ^ Results (usually passed to 'match')
721
722 {-
723 There is one small problem with the Lambda Patterns, when somebody
724 writes something similar to:
725 \begin{verbatim}
726 (\ (x:xs) -> ...)
727 \end{verbatim}
728 he/she don't want a warning about incomplete patterns, that is done with
729 the flag @opt_WarnSimplePatterns@.
730 This problem also appears in the:
731 \begin{itemize}
732 \item @do@ patterns, but if the @do@ can fail
733 it creates another equation if the match can fail
734 (see @GHC.HsToCore.Expr.doDo@ function)
735 \item @let@ patterns, are treated by @matchSimply@
736 List Comprension Patterns, are treated by @matchSimply@ also
737 \end{itemize}
738
739 We can't call @matchSimply@ with Lambda patterns,
740 due to the fact that lambda patterns can have more than
741 one pattern, and match simply only accepts one pattern.
742
743 JJQC 30-Nov-1997
744 -}
745
746 matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
747 , mg_ext = MatchGroupTc arg_tys rhs_ty
748 , mg_origin = origin })
749 = do { dflags <- getDynFlags
750 ; locn <- getSrcSpanDs
751
752 ; new_vars <- case matches of
753 [] -> newSysLocalsDs arg_tys
754 (m:_) ->
755 selectMatchVars (zipWithEqual "matchWrapper"
756 (\a b -> (scaledMult a, unLoc b))
757 arg_tys
758 (hsLMatchPats m))
759
760 -- Pattern match check warnings for /this match-group/.
761 -- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
762 -- Each Match will split off one Nablas for its RHSs from this.
763 ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt
764 then addHsScrutTmCs mb_scr new_vars $
765 -- See Note [Long-distance information]
766 pmcMatches (DsMatchContext ctxt locn) new_vars matches
767 else pure (initNablasMatches matches)
768
769 ; eqns_info <- zipWithM mk_eqn_info matches matches_nablas
770
771 ; result_expr <- handleWarnings $
772 matchEquations ctxt new_vars eqns_info rhs_ty
773 ; return (new_vars, result_expr) }
774 where
775 -- Called once per equation in the match, or alternative in the case
776 mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
777 mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)
778 = do { dflags <- getDynFlags
779 ; let upats = map (unLoc . decideBangHood dflags) pats
780 -- pat_nablas is the covered set *after* matching the pattern, but
781 -- before any of the GRHSs. We extend the environment with pat_nablas
782 -- (via updPmNablas) so that the where-clause of 'grhss' can profit
783 -- from that knowledge (#18533)
784 ; match_result <- updPmNablas pat_nablas $
785 dsGRHSs ctxt grhss rhs_ty rhss_nablas
786 ; return EqnInfo { eqn_pats = upats
787 , eqn_orig = FromSource
788 , eqn_rhs = match_result } }
789
790 handleWarnings = if isGenerated origin
791 then discardWarningsDs
792 else id
793
794 initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
795 initNablasMatches ms
796 = map (\(L _ m) -> (initNablas, initNablasGRHSs (m_grhss m))) ms
797
798 initNablasGRHSs :: GRHSs GhcTc b -> NonEmpty Nablas
799 initNablasGRHSs m = expectJust "GRHSs non-empty"
800 $ NEL.nonEmpty
801 $ replicate (length (grhssGRHSs m)) initNablas
802
803
804 matchEquations :: HsMatchContext GhcRn
805 -> [MatchId] -> [EquationInfo] -> Type
806 -> DsM CoreExpr
807 matchEquations ctxt vars eqns_info rhs_ty
808 = do { match_result <- match vars rhs_ty eqns_info
809
810 ; fail_expr <- mkFailExpr ctxt rhs_ty
811
812 ; extractMatchResult match_result fail_expr }
813
814 -- | @matchSimply@ is a wrapper for 'match' which deals with the
815 -- situation where we want to match a single expression against a single
816 -- pattern. It returns an expression.
817 matchSimply :: CoreExpr -- ^ Scrutinee
818 -> HsMatchContext GhcRn -- ^ Match kind
819 -> LPat GhcTc -- ^ Pattern it should match
820 -> CoreExpr -- ^ Return this if it matches
821 -> CoreExpr -- ^ Return this if it doesn't
822 -> DsM CoreExpr
823 -- Some reasons 'matchSimply' is not defined using 'matchWrapper' (#18572):
824 -- * Some call sites like in 'deBindComp' specify a @fail_expr@ that isn't a
825 -- straight @patError@
826 -- * It receives an already desugared 'CoreExpr' for the scrutinee, not an
827 -- 'HsExpr' like 'matchWrapper' expects
828 -- * Filling in all the phony fields for the 'MatchGroup' for a single pattern
829 -- match is awkward
830 -- * And we still export 'matchSinglePatVar', so not much is gained if we
831 -- don't also implement it in terms of 'matchWrapper'
832 matchSimply scrut hs_ctx pat result_expr fail_expr = do
833 let
834 match_result = cantFailMatchResult result_expr
835 rhs_ty = exprType fail_expr
836 -- Use exprType of fail_expr, because won't refine in the case of failure!
837 match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
838 extractMatchResult match_result' fail_expr
839
840 matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc
841 -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
842 -- matchSinglePat ensures that the scrutinee is a variable
843 -- and then calls matchSinglePatVar
844 --
845 -- matchSinglePat does not warn about incomplete patterns
846 -- Used for things like [ e | pat <- stuff ], where
847 -- incomplete patterns are just fine
848
849 matchSinglePat (Var var) ctx pat ty match_result
850 | not (isExternalName (idName var))
851 = matchSinglePatVar var Nothing ctx pat ty match_result
852
853 matchSinglePat scrut hs_ctx pat ty match_result
854 = do { var <- selectSimpleMatchVarL Many pat
855 -- matchSinglePat is only used in matchSimply, which
856 -- is used in list comprehension, arrow notation,
857 -- and to create field selectors. All of which only
858 -- bind unrestricted variables, hence the 'Many'
859 -- above.
860 ; match_result' <- matchSinglePatVar var (Just scrut) hs_ctx pat ty match_result
861 ; return $ bindNonRec var scrut <$> match_result'
862 }
863
864 matchSinglePatVar :: Id -- See Note [Match Ids]
865 -> Maybe CoreExpr -- ^ The scrutinee the match id is bound to
866 -> HsMatchContext GhcRn -> LPat GhcTc
867 -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
868 matchSinglePatVar var mb_scrut ctx pat ty match_result
869 = assertPpr (isInternalName (idName var)) (ppr var) $
870 do { dflags <- getDynFlags
871 ; locn <- getSrcSpanDs
872 -- Pattern match check warnings
873 ; when (isMatchContextPmChecked dflags FromSource ctx) $
874 addCoreScrutTmCs mb_scrut [var] $
875 pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
876
877 ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
878 , eqn_orig = FromSource
879 , eqn_rhs = match_result }
880 ; match [var] ty [eqn_info] }
881
882
883 {-
884 ************************************************************************
885 * *
886 Pattern classification
887 * *
888 ************************************************************************
889 -}
890
891 data PatGroup
892 = PgAny -- Immediate match: variables, wildcards,
893 -- lazy patterns
894 | PgCon DataCon -- Constructor patterns (incl list, tuple)
895 | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
896 | PgLit Literal -- Literal patterns
897 | PgN FractionalLit -- Overloaded numeric literals;
898 -- see Note [Don't use Literal for PgN]
899 | PgOverS FastString -- Overloaded string literals
900 | PgNpK Integer -- n+k patterns
901 | PgBang -- Bang patterns
902 | PgCo Type -- Coercion patterns; the type is the type
903 -- of the pattern *inside*
904 | PgView (LHsExpr GhcTc) -- view pattern (e -> p):
905 -- the LHsExpr is the expression e
906 Type -- the Type is the type of p (equivalently, the result type of e)
907
908 {- Note [Don't use Literal for PgN]
909 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
910 Previously we had, as PatGroup constructors
911
912 | ...
913 | PgN Literal -- Overloaded literals
914 | PgNpK Literal -- n+k patterns
915 | ...
916
917 But Literal is really supposed to represent an *unboxed* literal, like Int#.
918 We were sticking the literal from, say, an overloaded numeric literal pattern
919 into a LitInt constructor. This didn't really make sense; and we now have
920 the invariant that value in a LitInt must be in the range of the target
921 machine's Int# type, and an overloaded literal could meaningfully be larger.
922
923 Solution: For pattern grouping purposes, just store the literal directly in
924 the PgN constructor as a FractionalLit if numeric, and add a PgOverStr constructor
925 for overloaded strings.
926 -}
927
928 groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
929 -- If the result is of form [g1, g2, g3],
930 -- (a) all the (pg,eq) pairs in g1 have the same pg
931 -- (b) none of the gi are empty
932 -- The ordering of equations is unchanged
933 groupEquations platform eqns
934 = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
935 -- comprehension on NonEmpty
936 where
937 same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
938 (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
939
940 -- TODO Make subGroup1 using a NonEmptyMap
941 subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems
942 -> m -- Map.empty
943 -> (a -> m -> Maybe (NonEmpty EquationInfo)) -- Map.lookup
944 -> (a -> NonEmpty EquationInfo -> m -> m) -- Map.insert
945 -> [(a, EquationInfo)] -> [NonEmpty EquationInfo]
946 -- Input is a particular group. The result sub-groups the
947 -- equations by with particular constructor, literal etc they match.
948 -- Each sub-list in the result has the same PatGroup
949 -- See Note [Take care with pattern order]
950 -- Parameterized by map operations to allow different implementations
951 -- and constraints, eg. types without Ord instance.
952 subGroup elems empty lookup insert group
953 = fmap NEL.reverse $ elems $ foldl' accumulate empty group
954 where
955 accumulate pg_map (pg, eqn)
956 = case lookup pg pg_map of
957 Just eqns -> insert pg (NEL.cons eqn eqns) pg_map
958 Nothing -> insert pg [eqn] pg_map
959 -- pg_map :: Map a [EquationInfo]
960 -- Equations seen so far in reverse order of appearance
961
962 subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
963 subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert
964
965 subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
966 subGroupUniq =
967 subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)
968
969 {- Note [Pattern synonym groups]
970 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
971 If we see
972 f (P a) = e1
973 f (P b) = e2
974 ...
975 where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the
976 same group? We can if P is a constructor, but /not/ if P is a pattern synonym.
977 Consider (#11224)
978 -- readMaybe :: Read a => String -> Maybe a
979 pattern PRead :: Read a => () => a -> String
980 pattern PRead a <- (readMaybe -> Just a)
981
982 f (PRead (x::Int)) = e1
983 f (PRead (y::Bool)) = e2
984 This is all fine: we match the string by trying to read an Int; if that
985 fails we try to read a Bool. But clearly we can't combine the two into a single
986 match.
987
988 Conclusion: we can combine when we invoke PRead /at the same type/. Hence
989 in PgSyn we record the instantiating types, and use them in sameGroup.
990
991 Note [Take care with pattern order]
992 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
993 In the subGroup function we must be very careful about pattern re-ordering,
994 Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
995 Then in bringing together the patterns for True, we must not
996 swap the Nothing and y!
997 -}
998
999 sameGroup :: PatGroup -> PatGroup -> Bool
1000 -- Same group means that a single case expression
1001 -- or test will suffice to match both, *and* the order
1002 -- of testing within the group is insignificant.
1003 sameGroup PgAny PgAny = True
1004 sameGroup PgBang PgBang = True
1005 sameGroup (PgCon _) (PgCon _) = True -- One case expression
1006 sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
1007 -- eqTypes: See Note [Pattern synonym groups]
1008 sameGroup (PgLit _) (PgLit _) = True -- One case expression
1009 sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant
1010 -- Order is significant, match PgN after PgLit
1011 -- If the exponents are small check for value equality rather than syntactic equality
1012 -- This is implemented in the Eq instance for FractionalLit, we do this to avoid
1013 -- computing the value of excessivly large rationals.
1014 sameGroup (PgOverS s1) (PgOverS s2) = s1==s2
1015 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns]
1016 sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2
1017 -- CoPats are in the same goup only if the type of the
1018 -- enclosed pattern is the same. The patterns outside the CoPat
1019 -- always have the same type, so this boils down to saying that
1020 -- the two coercions are identical.
1021 sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
1022 -- ViewPats are in the same group iff the expressions
1023 -- are "equal"---conservatively, we use syntactic equality
1024 sameGroup _ _ = False
1025
1026 -- An approximation of syntactic equality used for determining when view
1027 -- exprs are in the same group.
1028 -- This function can always safely return false;
1029 -- but doing so will result in the application of the view function being repeated.
1030 --
1031 -- Currently: compare applications of literals and variables
1032 -- and anything else that we can do without involving other
1033 -- HsSyn types in the recursion
1034 --
1035 -- NB we can't assume that the two view expressions have the same type. Consider
1036 -- f (e1 -> True) = ...
1037 -- f (e2 -> "hi") = ...
1038 viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool
1039 viewLExprEq (e1,_) (e2,_) = lexp e1 e2
1040 where
1041 lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
1042 lexp e e' = exp (unLoc e) (unLoc e')
1043
1044 ---------
1045 exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
1046 -- real comparison is on HsExpr's
1047 -- strip parens
1048 exp (HsPar _ _ (L _ e) _) e' = exp e e'
1049 exp e (HsPar _ _ (L _ e') _) = exp e e'
1050 -- because the expressions do not necessarily have the same type,
1051 -- we have to compare the wrappers
1052 exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap h' e'))) =
1053 wrap h h' && exp e e'
1054 exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) =
1055 exp b b'
1056 exp (HsVar _ i) (HsVar _ i') = i == i'
1057 exp (XExpr (ConLikeTc c _ _)) (XExpr (ConLikeTc c' _ _)) = c == c'
1058 -- the instance for IPName derives using the id, so this works if the
1059 -- above does
1060 exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
1061 exp (HsOverLit _ l) (HsOverLit _ l') =
1062 -- Overloaded lits are equal if they have the same type
1063 -- and the data is the same.
1064 -- this is coarser than comparing the SyntaxExpr's in l and l',
1065 -- which resolve the overloading (e.g., fromInteger 1),
1066 -- because these expressions get written as a bunch of different variables
1067 -- (presumably to improve sharing)
1068 eqType (overLitType l) (overLitType l') && l == l'
1069 exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
1070 -- the fixities have been straightened out by now, so it's safe
1071 -- to ignore them?
1072 exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
1073 lexp l l' && lexp o o' && lexp ri ri'
1074 exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
1075 exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
1076 lexp e1 e1' && lexp e2 e2'
1077 exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
1078 lexp e1 e1' && lexp e2 e2'
1079 exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
1080 eq_list tup_arg es1 es2
1081 exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
1082 exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
1083 lexp e e' && lexp e1 e1' && lexp e2 e2'
1084
1085 -- Enhancement: could implement equality for more expressions
1086 -- if it seems useful
1087 -- But no need for HsLit, ExplicitList, ExplicitTuple,
1088 -- because they cannot be functions
1089 exp _ _ = False
1090
1091 ---------
1092 syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
1093 syn_exp (SyntaxExprTc { syn_expr = expr1
1094 , syn_arg_wraps = arg_wraps1
1095 , syn_res_wrap = res_wrap1 })
1096 (SyntaxExprTc { syn_expr = expr2
1097 , syn_arg_wraps = arg_wraps2
1098 , syn_res_wrap = res_wrap2 })
1099 = exp expr1 expr2 &&
1100 and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&
1101 wrap res_wrap1 res_wrap2
1102 syn_exp NoSyntaxExprTc NoSyntaxExprTc = True
1103 syn_exp _ _ = False
1104
1105 ---------
1106 tup_arg (Present _ e1) (Present _ e2) = lexp e1 e2
1107 tup_arg (Missing (Scaled _ t1)) (Missing (Scaled _ t2)) = eqType t1 t2
1108 tup_arg _ _ = False
1109
1110 ---------
1111 wrap :: HsWrapper -> HsWrapper -> Bool
1112 -- Conservative, in that it demands that wrappers be
1113 -- syntactically identical and doesn't look under binders
1114 --
1115 -- Coarser notions of equality are possible
1116 -- (e.g., reassociating compositions,
1117 -- equating different ways of writing a coercion)
1118 wrap WpHole WpHole = True
1119 wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
1120 wrap (WpFun w1 w2 _) (WpFun w1' w2' _) = wrap w1 w1' && wrap w2 w2'
1121 wrap (WpCast co) (WpCast co') = co `eqCoercion` co'
1122 wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2
1123 wrap (WpTyApp t) (WpTyApp t') = eqType t t'
1124 -- Enhancement: could implement equality for more wrappers
1125 -- if it seems useful (lams and lets)
1126 wrap _ _ = False
1127
1128 ---------
1129 ev_term :: EvTerm -> EvTerm -> Bool
1130 ev_term (EvExpr (Var a)) (EvExpr (Var b))
1131 = idType a `eqType` idType b
1132 -- The /type/ of the evidence matters, not its precise proof term.
1133 -- Caveat: conceivably a sufficiently exotic use of incoherent instances
1134 -- could make a difference, but remember this is only used within the
1135 -- pattern matches for a single function, so it's hard to see how that
1136 -- could really happen. And we don't want accidentally different proofs
1137 -- to prevent spotting equalities, and hence degrade pattern-match
1138 -- overlap checking.
1139 ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b))
1140 = a `eqCoercion` b
1141 ev_term _ _ = False
1142
1143 ---------
1144 eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
1145 eq_list _ [] [] = True
1146 eq_list _ [] (_:_) = False
1147 eq_list _ (_:_) [] = False
1148 eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
1149
1150 patGroup :: Platform -> Pat GhcTc -> PatGroup
1151 patGroup _ (ConPat { pat_con = L _ con
1152 , pat_con_ext = ConPatTc { cpt_arg_tys = tys }
1153 })
1154 | RealDataCon dcon <- con = PgCon dcon
1155 | PatSynCon psyn <- con = PgSyn psyn tys
1156 patGroup _ (WildPat {}) = PgAny
1157 patGroup _ (BangPat {}) = PgBang
1158 patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =
1159 case (oval, isJust mb_neg) of
1160 (HsIntegral i, is_neg) -> PgN (integralFractionalLit is_neg (if is_neg
1161 then negate (il_value i)
1162 else il_value i))
1163 (HsFractional f, is_neg)
1164 | is_neg -> PgN $! negateFractionalLit f
1165 | otherwise -> PgN f
1166 (HsIsString _ s, _) -> assert (isNothing mb_neg) $
1167 PgOverS s
1168 patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
1169 case oval of
1170 HsIntegral i -> PgNpK (il_value i)
1171 _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
1172 patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p))
1173 patGroup platform (LitPat _ lit) = PgLit (hsLitKey platform lit)
1174 patGroup platform (XPat ext) = case ext of
1175 CoPat _ p _ -> PgCo (hsPatType p) -- Type of innelexp pattern
1176 ExpansionPat _ p -> patGroup platform p
1177 patGroup _ pat = pprPanic "patGroup" (ppr pat)
1178
1179 {-
1180 Note [Grouping overloaded literal patterns]
1181 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1182 WATCH OUT! Consider
1183
1184 f (n+1) = ...
1185 f (n+2) = ...
1186 f (n+1) = ...
1187
1188 We can't group the first and third together, because the second may match
1189 the same thing as the first. Same goes for *overloaded* literal patterns
1190 f 1 True = ...
1191 f 2 False = ...
1192 f 1 False = ...
1193 If the first arg matches '1' but the second does not match 'True', we
1194 cannot jump to the third equation! Because the same argument might
1195 match '2'!
1196 Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
1197 -}