never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE DeriveDataTypeable #-}
4 {-# LANGUAGE FlexibleContexts #-}
5 {-# LANGUAGE FlexibleInstances #-}
6 {-# LANGUAGE LambdaCase #-}
7 {-# LANGUAGE ScopedTypeVariables #-}
8 {-# LANGUAGE TypeApplications #-}
9 {-# LANGUAGE TypeFamilies #-}
10 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
11 -- in module Language.Haskell.Syntax.Extension
12
13 {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable
14
15 {-
16 (c) The University of Glasgow 2006
17 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
18
19 \section[PatSyntax]{Abstract Haskell syntax---patterns}
20 -}
21
22 module GHC.Hs.Pat (
23 Pat(..), LPat,
24 EpAnnSumPat(..),
25 ConPatTc (..),
26 ConLikeP,
27 HsPatExpansion(..),
28 XXPatGhcTc(..),
29
30 HsConPatDetails, hsConPatArgs,
31 HsRecFields(..), HsFieldBind(..), LHsFieldBind,
32 HsRecField, LHsRecField,
33 HsRecUpdField, LHsRecUpdField,
34 hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,
35 hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
36
37 mkPrefixConPat, mkCharLitPat, mkNilPat,
38
39 isSimplePat,
40 looksLazyPatBind,
41 isBangedLPat,
42 gParPat, patNeedsParens, parenthesizePat,
43 isIrrefutableHsPat,
44
45 collectEvVarsPat, collectEvVarsPats,
46
47 pprParendLPat, pprConArgs,
48 pprLPat
49 ) where
50
51 import GHC.Prelude
52
53 import Language.Haskell.Syntax.Pat
54 import Language.Haskell.Syntax.Expr ( HsExpr )
55
56 import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice)
57
58 -- friends:
59 import GHC.Hs.Binds
60 import GHC.Hs.Lit
61 import Language.Haskell.Syntax.Extension
62 import GHC.Parser.Annotation
63 import GHC.Hs.Extension
64 import GHC.Hs.Type
65 import GHC.Tc.Types.Evidence
66 import GHC.Types.Basic
67 import GHC.Types.SourceText
68 -- others:
69 import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )
70 import GHC.Builtin.Types
71 import GHC.Types.Var
72 import GHC.Types.Name.Reader ( RdrName )
73 import GHC.Core.ConLike
74 import GHC.Core.DataCon
75 import GHC.Core.TyCon
76 import GHC.Utils.Outputable
77 import GHC.Core.Type
78 import GHC.Types.SrcLoc
79 import GHC.Data.Bag -- collect ev vars from pats
80 import GHC.Data.Maybe
81 import GHC.Types.Name (Name)
82 import GHC.Driver.Session
83 import qualified GHC.LanguageExtensions as LangExt
84 import Data.Data
85 import Data.Void
86
87
88 type instance XWildPat GhcPs = NoExtField
89 type instance XWildPat GhcRn = NoExtField
90 type instance XWildPat GhcTc = Type
91
92 type instance XVarPat (GhcPass _) = NoExtField
93
94 type instance XLazyPat GhcPs = EpAnn [AddEpAnn] -- For '~'
95 type instance XLazyPat GhcRn = NoExtField
96 type instance XLazyPat GhcTc = NoExtField
97
98 type instance XAsPat GhcPs = EpAnn [AddEpAnn] -- For '@'
99 type instance XAsPat GhcRn = NoExtField
100 type instance XAsPat GhcTc = NoExtField
101
102 type instance XParPat (GhcPass _) = EpAnnCO
103
104 type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!'
105 type instance XBangPat GhcRn = NoExtField
106 type instance XBangPat GhcTc = NoExtField
107
108 type instance XListPat GhcPs = EpAnn AnnList
109 -- After parsing, ListPat can refer to a built-in Haskell list pattern
110 -- or an overloaded list pattern.
111 type instance XListPat GhcRn = NoExtField
112 -- Built-in list patterns only.
113 -- After renaming, overloaded list patterns are expanded to view patterns.
114 -- See Note [Desugaring overloaded list patterns]
115 type instance XListPat GhcTc = Type
116 -- List element type, for use in hsPatType.
117
118 type instance XTuplePat GhcPs = EpAnn [AddEpAnn]
119 type instance XTuplePat GhcRn = NoExtField
120 type instance XTuplePat GhcTc = [Type]
121
122 type instance XSumPat GhcPs = EpAnn EpAnnSumPat
123 type instance XSumPat GhcRn = NoExtField
124 type instance XSumPat GhcTc = [Type]
125
126 type instance XConPat GhcPs = EpAnn [AddEpAnn]
127 type instance XConPat GhcRn = NoExtField
128 type instance XConPat GhcTc = ConPatTc
129
130 type instance XViewPat GhcPs = EpAnn [AddEpAnn]
131 type instance XViewPat GhcRn = Maybe (HsExpr GhcRn)
132 -- The @HsExpr GhcRn@ gives an inverse to the view function.
133 -- This is used for overloaded lists in particular.
134 -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn.
135
136 type instance XViewPat GhcTc = Type
137 -- Overall type of the pattern
138 -- (= the argument type of the view function), for hsPatType.
139
140 type instance XSplicePat GhcPs = NoExtField
141 type instance XSplicePat GhcRn = NoExtField
142 type instance XSplicePat GhcTc = Void -- See Note [Constructor cannot occur]
143
144 type instance XLitPat (GhcPass _) = NoExtField
145
146 type instance XNPat GhcPs = EpAnn [AddEpAnn]
147 type instance XNPat GhcRn = EpAnn [AddEpAnn]
148 type instance XNPat GhcTc = Type
149
150 type instance XNPlusKPat GhcPs = EpAnn EpaLocation -- Of the "+"
151 type instance XNPlusKPat GhcRn = NoExtField
152 type instance XNPlusKPat GhcTc = Type
153
154 type instance XSigPat GhcPs = EpAnn [AddEpAnn]
155 type instance XSigPat GhcRn = NoExtField
156 type instance XSigPat GhcTc = Type
157
158 type instance XXPat GhcPs = NoExtCon
159 type instance XXPat GhcRn = HsPatExpansion (Pat GhcRn) (Pat GhcRn)
160 -- Original pattern and its desugaring/expansion.
161 -- See Note [Rebindable syntax and HsExpansion].
162 type instance XXPat GhcTc = XXPatGhcTc
163 -- After typechecking, we add extra constructors: CoPat and HsExpansion.
164 -- HsExpansion allows us to handle RebindableSyntax in pattern position:
165 -- see "XXExpr GhcTc" for the counterpart in expressions.
166
167 type instance ConLikeP GhcPs = RdrName -- IdP GhcPs
168 type instance ConLikeP GhcRn = Name -- IdP GhcRn
169 type instance ConLikeP GhcTc = ConLike
170
171 type instance XHsFieldBind _ = EpAnn [AddEpAnn]
172
173 -- ---------------------------------------------------------------------
174
175 -- API Annotations types
176
177 data EpAnnSumPat = EpAnnSumPat
178 { sumPatParens :: [AddEpAnn]
179 , sumPatVbarsBefore :: [EpaLocation]
180 , sumPatVbarsAfter :: [EpaLocation]
181 } deriving Data
182
183 -- ---------------------------------------------------------------------
184
185 -- | Extension constructor for Pat, added after typechecking.
186 data XXPatGhcTc
187 = -- | Coercion Pattern (translation only)
188 --
189 -- During desugaring a (CoPat co pat) turns into a cast with 'co' on the
190 -- scrutinee, followed by a match on 'pat'.
191 CoPat
192 { -- | Coercion Pattern
193 -- If co :: t1 ~ t2, p :: t2,
194 -- then (CoPat co p) :: t1
195 co_cpt_wrap :: HsWrapper
196
197 , -- | Why not LPat? Ans: existing locn will do
198 co_pat_inner :: Pat GhcTc
199
200 , -- | Type of whole pattern, t1
201 co_pat_ty :: Type
202 }
203 -- | Pattern expansion: original pattern, and desugared pattern,
204 -- for RebindableSyntax and other overloaded syntax such as OverloadedLists.
205 -- See Note [Rebindable syntax and HsExpansion].
206 | ExpansionPat (Pat GhcRn) (Pat GhcTc)
207
208
209 -- See Note [Rebindable syntax and HsExpansion].
210 data HsPatExpansion a b
211 = HsPatExpanded a b
212 deriving Data
213
214 -- | This is the extension field for ConPat, added after typechecking
215 -- It adds quite a few extra fields, to support elaboration of pattern matching.
216 data ConPatTc
217 = ConPatTc
218 { -- | The universal arg types 1-1 with the universal
219 -- tyvars of the constructor/pattern synonym
220 -- Use (conLikeResTy pat_con cpt_arg_tys) to get
221 -- the type of the pattern
222 cpt_arg_tys :: [Type]
223
224 , -- | Existentially bound type variables
225 -- in correctly-scoped order e.g. [k:* x:k]
226 cpt_tvs :: [TyVar]
227
228 , -- | Ditto *coercion variables* and *dictionaries*
229 -- One reason for putting coercion variable here I think
230 -- is to ensure their kinds are zonked
231 cpt_dicts :: [EvVar]
232
233 , -- | Bindings involving those dictionaries
234 cpt_binds :: TcEvBinds
235
236 , -- ^ Extra wrapper to pass to the matcher
237 -- Only relevant for pattern-synonyms;
238 -- ignored for data cons
239 cpt_wrap :: HsWrapper
240 }
241
242 hsRecFieldId :: HsRecField GhcTc arg -> Id
243 hsRecFieldId = hsRecFieldSel
244
245 hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName
246 hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . reLoc . hfbLHS
247
248 hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id
249 hsRecUpdFieldId = fmap foExt . reLoc . hsRecUpdFieldOcc
250
251 hsRecUpdFieldOcc :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
252 hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS
253
254
255 {-
256 ************************************************************************
257 * *
258 * Printing patterns
259 * *
260 ************************************************************************
261 -}
262
263 instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
264 ppr = pprPat
265
266 -- See Note [Rebindable syntax and HsExpansion].
267 instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where
268 ppr (HsPatExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)
269
270 pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc
271 pprLPat (L _ e) = pprPat e
272
273 -- | Print with type info if -dppr-debug is on
274 pprPatBndr :: OutputableBndr name => name -> SDoc
275 pprPatBndr var
276 = getPprDebug $ \case
277 True -> parens (pprBndr LambdaBind var) -- Could pass the site to pprPat
278 -- but is it worth it?
279 False -> pprPrefixOcc var
280
281 pprParendLPat :: (OutputableBndrId p)
282 => PprPrec -> LPat (GhcPass p) -> SDoc
283 pprParendLPat p = pprParendPat p . unLoc
284
285 pprParendPat :: forall p. OutputableBndrId p
286 => PprPrec
287 -> Pat (GhcPass p)
288 -> SDoc
289 pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_elab ->
290 if need_parens print_tc_elab pat
291 then parens (pprPat pat)
292 else pprPat pat
293 where
294 need_parens print_tc_elab pat
295 | GhcTc <- ghcPass @p
296 , XPat (CoPat {}) <- pat
297 = print_tc_elab
298
299 | otherwise
300 = patNeedsParens p pat
301 -- For a CoPat we need parens if we are going to show it, which
302 -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper)
303 -- But otherwise the CoPat is discarded, so it
304 -- is the pattern inside that matters. Sigh.
305
306 pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
307 pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar)
308 pprPat (WildPat _) = char '_'
309 pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat
310 pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat
311 pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@',
312 pprParendLPat appPrec pat]
313 pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat]
314 pprPat (ParPat _ _ pat _) = parens (ppr pat)
315 pprPat (LitPat _ s) = ppr s
316 pprPat (NPat _ l Nothing _) = ppr l
317 pprPat (NPat _ l (Just _) _) = char '-' <> ppr l
318 pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr_n, char '+', ppr k]
319 where ppr_n = case ghcPass @p of
320 GhcPs -> ppr n
321 GhcRn -> ppr n
322 GhcTc -> ppr n
323 pprPat (SplicePat _ splice) = pprSplice splice
324 pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty
325 pprPat (ListPat _ pats) = brackets (interpp'SP pats)
326 pprPat (TuplePat _ pats bx)
327 -- Special-case unary boxed tuples so that they are pretty-printed as
328 -- `Solo x`, not `(x)`
329 | [pat] <- pats
330 , Boxed <- bx
331 = hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat]
332 | otherwise
333 = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
334 pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
335 pprPat (ConPat { pat_con = con
336 , pat_args = details
337 , pat_con_ext = ext
338 }
339 )
340 = case ghcPass @p of
341 GhcPs -> pprUserCon (unLoc con) details
342 GhcRn -> pprUserCon (unLoc con) details
343 GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case
344 False -> pprUserCon (unLoc con) details
345 True ->
346 -- Tiresome; in 'GHC.Tc.Gen.Bind.tcRhs' we print out a typechecked Pat in an
347 -- error message, and we want to make sure it prints nicely
348 ppr con
349 <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
350 , ppr binds ])
351 <+> pprConArgs details
352 where ConPatTc { cpt_tvs = tvs
353 , cpt_dicts = dicts
354 , cpt_binds = binds
355 } = ext
356
357 pprPat (XPat ext) = case ghcPass @p of
358 #if __GLASGOW_HASKELL__ < 811
359 GhcPs -> noExtCon ext
360 #endif
361 GhcRn -> case ext of
362 HsPatExpanded orig _ -> pprPat orig
363 GhcTc -> case ext of
364 CoPat co pat _ ->
365 pprHsWrapper co $ \parens ->
366 if parens
367 then pprParendPat appPrec pat
368 else pprPat pat
369 ExpansionPat orig _ -> pprPat orig
370
371 pprUserCon :: (OutputableBndr con, OutputableBndrId p,
372 Outputable (Anno (IdGhcP p)))
373 => con -> HsConPatDetails (GhcPass p) -> SDoc
374 pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
375 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
376
377 pprConArgs :: (OutputableBndrId p,
378 Outputable (Anno (IdGhcP p)))
379 => HsConPatDetails (GhcPass p) -> SDoc
380 pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats)
381 where pprTyArgs tyargs = fsep (map (\ty -> char '@' <> ppr ty) tyargs)
382 pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
383 , pprParendLPat appPrec p2 ]
384 pprConArgs (RecCon rpats) = ppr rpats
385
386 {-
387 ************************************************************************
388 * *
389 * Building patterns
390 * *
391 ************************************************************************
392 -}
393
394 mkPrefixConPat :: DataCon ->
395 [LPat GhcTc] -> [Type] -> LPat GhcTc
396 -- Make a vanilla Prefix constructor pattern
397 mkPrefixConPat dc pats tys
398 = noLocA $ ConPat { pat_con = noLocA (RealDataCon dc)
399 , pat_args = PrefixCon [] pats
400 , pat_con_ext = ConPatTc
401 { cpt_tvs = []
402 , cpt_dicts = []
403 , cpt_binds = emptyTcEvBinds
404 , cpt_arg_tys = tys
405 , cpt_wrap = idHsWrapper
406 }
407 }
408
409 mkNilPat :: Type -> LPat GhcTc
410 mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
411
412 mkCharLitPat :: SourceText -> Char -> LPat GhcTc
413 mkCharLitPat src c = mkPrefixConPat charDataCon
414 [noLocA $ LitPat noExtField (HsCharPrim src c)] []
415
416 {-
417 ************************************************************************
418 * *
419 * Predicates for checking things about pattern-lists in EquationInfo *
420 * *
421 ************************************************************************
422
423 \subsection[Pat-list-predicates]{Look for interesting things in patterns}
424
425 Unlike in the Wadler chapter, where patterns are either ``variables''
426 or ``constructors,'' here we distinguish between:
427 \begin{description}
428 \item[unfailable:]
429 Patterns that cannot fail to match: variables, wildcards, and lazy
430 patterns.
431
432 These are the irrefutable patterns; the two other categories
433 are refutable patterns.
434
435 \item[constructor:]
436 A non-literal constructor pattern (see next category).
437
438 \item[literal patterns:]
439 At least the numeric ones may be overloaded.
440 \end{description}
441
442 A pattern is in {\em exactly one} of the above three categories; `as'
443 patterns are treated specially, of course.
444
445 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
446 -}
447
448 isBangedLPat :: LPat (GhcPass p) -> Bool
449 isBangedLPat = isBangedPat . unLoc
450
451 isBangedPat :: Pat (GhcPass p) -> Bool
452 isBangedPat (ParPat _ _ p _) = isBangedLPat p
453 isBangedPat (BangPat {}) = True
454 isBangedPat _ = False
455
456 looksLazyPatBind :: HsBind (GhcPass p) -> Bool
457 -- Returns True of anything *except*
458 -- a StrictHsBind (as above) or
459 -- a VarPat
460 -- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
461 -- Looks through AbsBinds
462 looksLazyPatBind (PatBind { pat_lhs = p })
463 = looksLazyLPat p
464 looksLazyPatBind (AbsBinds { abs_binds = binds })
465 = anyBag (looksLazyPatBind . unLoc) binds
466 looksLazyPatBind _
467 = False
468
469 looksLazyLPat :: LPat (GhcPass p) -> Bool
470 looksLazyLPat = looksLazyPat . unLoc
471
472 looksLazyPat :: Pat (GhcPass p) -> Bool
473 looksLazyPat (ParPat _ _ p _) = looksLazyLPat p
474 looksLazyPat (AsPat _ _ p) = looksLazyLPat p
475 looksLazyPat (BangPat {}) = False
476 looksLazyPat (VarPat {}) = False
477 looksLazyPat (WildPat {}) = False
478 looksLazyPat _ = True
479
480 isIrrefutableHsPat :: forall p. (OutputableBndrId p)
481 => DynFlags -> LPat (GhcPass p) -> Bool
482 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
483 -- in the sense of falling through to the next pattern.
484 -- (NB: this is not quite the same as the (silly) defn
485 -- in 3.17.2 of the Haskell 98 report.)
486 --
487 -- WARNING: isIrrefutableHsPat returns False if it's in doubt.
488 -- Specifically on a ConPatIn, which is what it sees for a
489 -- (LPat Name) in the renamer, it doesn't know the size of the
490 -- constructor family, so it returns False. Result: only
491 -- tuple patterns are considered irrefutable at the renamer stage.
492 --
493 -- But if it returns True, the pattern is definitely irrefutable
494 isIrrefutableHsPat dflags =
495 isIrrefutableHsPat' (xopt LangExt.Strict dflags)
496
497 {-
498 Note [-XStrict and irrefutability]
499 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
500 When -XStrict is enabled the rules for irrefutability are slightly modified.
501 Specifically, the pattern in a program like
502
503 do ~(Just hi) <- expr
504
505 cannot be considered irrefutable. The ~ here merely disables the bang that
506 -XStrict would usually apply, rendering the program equivalent to the following
507 without -XStrict
508
509 do Just hi <- expr
510
511 To achieve make this pattern irrefutable with -XStrict the user would rather
512 need to write
513
514 do ~(~(Just hi)) <- expr
515
516 Failing to account for this resulted in #19027. To fix this isIrrefutableHsPat
517 takes care to check for two the irrefutability of the inner pattern when it
518 encounters a LazyPat and -XStrict is enabled.
519
520 See also Note [decideBangHood] in GHC.HsToCore.Utils.
521 -}
522
523 isIrrefutableHsPat' :: forall p. (OutputableBndrId p)
524 => Bool -- ^ Are we in a @-XStrict@ context?
525 -- See Note [-XStrict and irrefutability]
526 -> LPat (GhcPass p) -> Bool
527 isIrrefutableHsPat' is_strict = goL
528 where
529 goL :: LPat (GhcPass p) -> Bool
530 goL = go . unLoc
531
532 go :: Pat (GhcPass p) -> Bool
533 go (WildPat {}) = True
534 go (VarPat {}) = True
535 go (LazyPat _ p')
536 | is_strict
537 = isIrrefutableHsPat' False p'
538 | otherwise = True
539 go (BangPat _ pat) = goL pat
540 go (ParPat _ _ pat _) = goL pat
541 go (AsPat _ _ pat) = goL pat
542 go (ViewPat _ _ pat) = goL pat
543 go (SigPat _ pat _) = goL pat
544 go (TuplePat _ pats _) = all goL pats
545 go (SumPat {}) = False
546 -- See Note [Unboxed sum patterns aren't irrefutable]
547 go (ListPat {}) = False
548
549 go (ConPat
550 { pat_con = con
551 , pat_args = details })
552 = case ghcPass @p of
553 GhcPs -> False -- Conservative
554 GhcRn -> False -- Conservative
555 GhcTc -> case con of
556 L _ (PatSynCon _pat) -> False -- Conservative
557 L _ (RealDataCon con) ->
558 isJust (tyConSingleDataCon_maybe (dataConTyCon con))
559 && all goL (hsConPatArgs details)
560 go (LitPat {}) = False
561 go (NPat {}) = False
562 go (NPlusKPat {}) = False
563
564 -- We conservatively assume that no TH splices are irrefutable
565 -- since we cannot know until the splice is evaluated.
566 go (SplicePat {}) = False
567
568 go (XPat ext) = case ghcPass @p of
569 #if __GLASGOW_HASKELL__ < 811
570 GhcPs -> noExtCon ext
571 #endif
572 GhcRn -> case ext of
573 HsPatExpanded _ pat -> go pat
574 GhcTc -> case ext of
575 CoPat _ pat _ -> go pat
576 ExpansionPat _ pat -> go pat
577
578 -- | Is the pattern any of combination of:
579 --
580 -- - (pat)
581 -- - pat :: Type
582 -- - ~pat
583 -- - !pat
584 -- - x (variable)
585 isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x))
586 isSimplePat p = case unLoc p of
587 ParPat _ _ x _ -> isSimplePat x
588 SigPat _ x _ -> isSimplePat x
589 LazyPat _ x -> isSimplePat x
590 BangPat _ x -> isSimplePat x
591 VarPat _ x -> Just (unLoc x)
592 _ -> Nothing
593
594
595 {- Note [Unboxed sum patterns aren't irrefutable]
596 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
597 Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
598 patterns. A simple example that demonstrates this is from #14228:
599
600 pattern Just' x = (# x | #)
601 pattern Nothing' = (# | () #)
602
603 foo x = case x of
604 Nothing' -> putStrLn "nothing"
605 Just' -> putStrLn "just"
606
607 In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable,
608 as does not match an unboxed sum value of the same arity—namely, (# | y #)
609 (covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the
610 minimum unboxed sum arity is 2.
611
612 Failing to mark unboxed sum patterns as non-irrefutable would cause the Just'
613 case in foo to be unreachable, as GHC would mistakenly believe that Nothing'
614 is the only thing that could possibly be matched!
615 -}
616
617 -- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
618 -- parentheses under precedence @p@.
619 patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool
620 patNeedsParens p = go @p
621 where
622 -- Remark: go needs to be polymorphic, as we call it recursively
623 -- at a different GhcPass (see the case for GhcTc XPat below).
624 go :: forall q. IsPass q => Pat (GhcPass q) -> Bool
625 go (NPlusKPat {}) = p > opPrec
626 go (SplicePat {}) = False
627 go (ConPat { pat_args = ds })
628 = conPatNeedsParens p ds
629 go (SigPat {}) = p >= sigPrec
630 go (ViewPat {}) = True
631 go (XPat ext) = case ghcPass @q of
632 #if __GLASGOW_HASKELL__ < 901
633 GhcPs -> noExtCon ext
634 #endif
635 GhcRn -> case ext of
636 HsPatExpanded orig _ -> go orig
637 GhcTc -> case ext of
638 CoPat _ inner _ -> go inner
639 ExpansionPat orig _ -> go orig
640 -- ^^^^^^^
641 -- NB: recursive call of go at a different GhcPass.
642 go (WildPat {}) = False
643 go (VarPat {}) = False
644 go (LazyPat {}) = False
645 go (BangPat {}) = False
646 go (ParPat {}) = False
647 go (AsPat {}) = False
648 -- Special-case unary boxed tuple applications so that they are
649 -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)
650 -- See Note [One-tuples] in GHC.Builtin.Types
651 go (TuplePat _ [_] Boxed)
652 = p >= appPrec
653 go (TuplePat{}) = False
654 go (SumPat {}) = False
655 go (ListPat {}) = False
656 go (LitPat _ l) = hsLitNeedsParens p l
657 go (NPat _ lol _ _) = hsOverLitNeedsParens p (unLoc lol)
658
659 -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
660 -- needs parentheses under precedence @p@.
661 conPatNeedsParens :: PprPrec -> HsConDetails t a b -> Bool
662 conPatNeedsParens p = go
663 where
664 go (PrefixCon ts args) = p >= appPrec && (not (null args) || not (null ts))
665 go (InfixCon {}) = p >= opPrec -- type args should be empty in this case
666 go (RecCon {}) = False
667
668
669 -- | Parenthesize a pattern without token information
670 gParPat :: LPat (GhcPass pass) -> Pat (GhcPass pass)
671 gParPat p = ParPat noAnn noHsTok p noHsTok
672
673 -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
674 -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
675 parenthesizePat :: IsPass p
676 => PprPrec
677 -> LPat (GhcPass p)
678 -> LPat (GhcPass p)
679 parenthesizePat p lpat@(L loc pat)
680 | patNeedsParens p pat = L loc (gParPat lpat)
681 | otherwise = lpat
682
683 {-
684 % Collect all EvVars from all constructor patterns
685 -}
686
687 -- May need to add more cases
688 collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
689 collectEvVarsPats = unionManyBags . map collectEvVarsPat
690
691 collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
692 collectEvVarsLPat = collectEvVarsPat . unLoc
693
694 collectEvVarsPat :: Pat GhcTc -> Bag EvVar
695 collectEvVarsPat pat =
696 case pat of
697 LazyPat _ p -> collectEvVarsLPat p
698 AsPat _ _ p -> collectEvVarsLPat p
699 ParPat _ _ p _ -> collectEvVarsLPat p
700 BangPat _ p -> collectEvVarsLPat p
701 ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps
702 TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps
703 SumPat _ p _ _ -> collectEvVarsLPat p
704 ConPat
705 { pat_args = args
706 , pat_con_ext = ConPatTc
707 { cpt_dicts = dicts
708 }
709 }
710 -> unionBags (listToBag dicts)
711 $ unionManyBags
712 $ map collectEvVarsLPat
713 $ hsConPatArgs args
714 SigPat _ p _ -> collectEvVarsLPat p
715 XPat ext -> case ext of
716 CoPat _ p _ -> collectEvVarsPat p
717 ExpansionPat _ p -> collectEvVarsPat p
718 _other_pat -> emptyBag
719
720 {-
721 ************************************************************************
722 * *
723 \subsection{Anno instances}
724 * *
725 ************************************************************************
726 -}
727
728 type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA
729 type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns
730 type instance Anno ConLike = SrcSpanAnnN
731 type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA