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