1 2{- 3(c) The University of Glasgow 2006 4(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 5 6\section[PatSyntax]{Abstract Haskell syntax---patterns} 7-} 8 9{-# LANGUAGE DeriveDataTypeable #-} 10{-# LANGUAGE DeriveFunctor #-} 11{-# LANGUAGE DeriveFoldable #-} 12{-# LANGUAGE DeriveTraversable #-} 13{-# LANGUAGE CPP #-} 14{-# LANGUAGE StandaloneDeriving #-} 15{-# LANGUAGE FlexibleContexts #-} 16{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] 17 -- in module GHC.Hs.Extension 18{-# LANGUAGE ConstraintKinds #-} 19{-# LANGUAGE TypeFamilies #-} 20{-# LANGUAGE ViewPatterns #-} 21{-# LANGUAGE FlexibleInstances #-} 22{-# LANGUAGE ScopedTypeVariables #-} 23{-# LANGUAGE TypeApplications #-} 24{-# LANGUAGE LambdaCase #-} 25 26module GHC.Hs.Pat ( 27 Pat(..), LPat, 28 ConPatTc (..), 29 CoPat (..), 30 ListPatTc(..), 31 ConLikeP, 32 33 HsConPatDetails, hsConPatArgs, 34 HsRecFields(..), HsRecField'(..), LHsRecField', 35 HsRecField, LHsRecField, 36 HsRecUpdField, LHsRecUpdField, 37 hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, 38 hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, 39 40 mkPrefixConPat, mkCharLitPat, mkNilPat, 41 42 isSimplePat, 43 looksLazyPatBind, 44 isBangedLPat, 45 patNeedsParens, parenthesizePat, 46 isIrrefutableHsPat, 47 48 collectEvVarsPat, collectEvVarsPats, 49 50 pprParendLPat, pprConArgs 51 ) where 52 53import GHC.Prelude 54 55import {-# SOURCE #-} GHC.Hs.Expr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice) 56 57-- friends: 58import GHC.Hs.Binds 59import GHC.Hs.Lit 60import GHC.Hs.Extension 61import GHC.Hs.Type 62import GHC.Tc.Types.Evidence 63import GHC.Types.Basic 64-- others: 65import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) 66import GHC.Builtin.Types 67import GHC.Types.Var 68import GHC.Types.Name.Reader ( RdrName ) 69import GHC.Core.ConLike 70import GHC.Core.DataCon 71import GHC.Core.TyCon 72import GHC.Utils.Outputable 73import GHC.Core.Type 74import GHC.Types.SrcLoc 75import GHC.Data.Bag -- collect ev vars from pats 76import GHC.Data.Maybe 77import GHC.Types.Name (Name) 78import GHC.Driver.Session 79import qualified GHC.LanguageExtensions as LangExt 80-- libraries: 81import Data.Data hiding (TyCon,Fixity) 82 83type LPat p = XRec p Pat 84 85-- | Pattern 86-- 87-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang' 88 89-- For details on above see note [Api annotations] in GHC.Parser.Annotation 90data Pat p 91 = ------------ Simple patterns --------------- 92 WildPat (XWildPat p) -- ^ Wildcard Pattern 93 -- The sole reason for a type on a WildPat is to 94 -- support hsPatType :: Pat Id -> Type 95 96 -- AZ:TODO above comment needs to be updated 97 | VarPat (XVarPat p) 98 (Located (IdP p)) -- ^ Variable Pattern 99 100 -- See Note [Located RdrNames] in GHC.Hs.Expr 101 | LazyPat (XLazyPat p) 102 (LPat p) -- ^ Lazy Pattern 103 -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnTilde' 104 105 -- For details on above see note [Api annotations] in GHC.Parser.Annotation 106 107 | AsPat (XAsPat p) 108 (Located (IdP p)) (LPat p) -- ^ As pattern 109 -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt' 110 111 -- For details on above see note [Api annotations] in GHC.Parser.Annotation 112 113 | ParPat (XParPat p) 114 (LPat p) -- ^ Parenthesised pattern 115 -- See Note [Parens in HsSyn] in GHC.Hs.Expr 116 -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, 117 -- 'GHC.Parser.Annotation.AnnClose' @')'@ 118 119 -- For details on above see note [Api annotations] in GHC.Parser.Annotation 120 | BangPat (XBangPat p) 121 (LPat p) -- ^ Bang pattern 122 -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang' 123 124 -- For details on above see note [Api annotations] in GHC.Parser.Annotation 125 126 ------------ Lists, tuples, arrays --------------- 127 | ListPat (XListPat p) 128 [LPat p] 129 -- For OverloadedLists a Just (ty,fn) gives 130 -- overall type of the pattern, and the toList 131-- function to convert the scrutinee to a list value 132 133 -- ^ Syntactic List 134 -- 135 -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@, 136 -- 'GHC.Parser.Annotation.AnnClose' @']'@ 137 138 -- For details on above see note [Api annotations] in GHC.Parser.Annotation 139 140 | TuplePat (XTuplePat p) 141 -- after typechecking, holds the types of the tuple components 142 [LPat p] -- Tuple sub-patterns 143 Boxity -- UnitPat is TuplePat [] 144 -- You might think that the post typechecking Type was redundant, 145 -- because we can get the pattern type by getting the types of the 146 -- sub-patterns. 147 -- But it's essential 148 -- data T a where 149 -- T1 :: Int -> T Int 150 -- f :: (T a, a) -> Int 151 -- f (T1 x, z) = z 152 -- When desugaring, we must generate 153 -- f = /\a. \v::a. case v of (t::T a, w::a) -> 154 -- case t of (T1 (x::Int)) -> 155 -- Note the (w::a), NOT (w::Int), because we have not yet 156 -- refined 'a' to Int. So we must know that the second component 157 -- of the tuple is of type 'a' not Int. See selectMatchVar 158 -- (June 14: I'm not sure this comment is right; the sub-patterns 159 -- will be wrapped in CoPats, no?) 160 -- ^ Tuple sub-patterns 161 -- 162 -- - 'GHC.Parser.Annotation.AnnKeywordId' : 163 -- 'GHC.Parser.Annotation.AnnOpen' @'('@ or @'(#'@, 164 -- 'GHC.Parser.Annotation.AnnClose' @')'@ or @'#)'@ 165 166 | SumPat (XSumPat p) -- after typechecker, types of the alternative 167 (LPat p) -- Sum sub-pattern 168 ConTag -- Alternative (one-based) 169 Arity -- Arity (INVARIANT: ≥ 2) 170 -- ^ Anonymous sum pattern 171 -- 172 -- - 'GHC.Parser.Annotation.AnnKeywordId' : 173 -- 'GHC.Parser.Annotation.AnnOpen' @'(#'@, 174 -- 'GHC.Parser.Annotation.AnnClose' @'#)'@ 175 176 -- For details on above see note [Api annotations] in GHC.Parser.Annotation 177 178 ------------ Constructor patterns --------------- 179 | ConPat { 180 pat_con_ext :: XConPat p, 181 pat_con :: Located (ConLikeP p), 182 pat_args :: HsConPatDetails p 183 } 184 -- ^ Constructor Pattern 185 186 ------------ View patterns --------------- 187 -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow' 188 189 -- For details on above see note [Api annotations] in GHC.Parser.Annotation 190 | ViewPat (XViewPat p) -- The overall type of the pattern 191 -- (= the argument type of the view function) 192 -- for hsPatType. 193 (LHsExpr p) 194 (LPat p) 195 -- ^ View Pattern 196 197 ------------ Pattern splices --------------- 198 -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@ 199 -- 'GHC.Parser.Annotation.AnnClose' @')'@ 200 201 -- For details on above see note [Api annotations] in GHC.Parser.Annotation 202 | SplicePat (XSplicePat p) 203 (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) 204 205 ------------ Literal and n+k patterns --------------- 206 | LitPat (XLitPat p) 207 (HsLit p) -- ^ Literal Pattern 208 -- Used for *non-overloaded* literal patterns: 209 -- Int#, Char#, Int, Char, String, etc. 210 211 | NPat -- Natural Pattern 212 -- Used for all overloaded literals, 213 -- including overloaded strings with -XOverloadedStrings 214 (XNPat p) -- Overall type of pattern. Might be 215 -- different than the literal's type 216 -- if (==) or negate changes the type 217 (Located (HsOverLit p)) -- ALWAYS positive 218 (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for 219 -- negative patterns, Nothing 220 -- otherwise 221 (SyntaxExpr p) -- Equality checker, of type t->t->Bool 222 223 -- ^ Natural Pattern 224 -- 225 -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVal' @'+'@ 226 227 -- For details on above see note [Api annotations] in GHC.Parser.Annotation 228 | NPlusKPat (XNPlusKPat p) -- Type of overall pattern 229 (Located (IdP p)) -- n+k pattern 230 (Located (HsOverLit p)) -- It'll always be an HsIntegral 231 (HsOverLit p) -- See Note [NPlusK patterns] in GHC.Tc.Gen.Pat 232 -- NB: This could be (PostTc ...), but that induced a 233 -- a new hs-boot file. Not worth it. 234 235 (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool 236 (SyntaxExpr p) -- Name of '-' (see GHC.Rename.Env.lookupSyntax) 237 -- ^ n+k pattern 238 239 ------------ Pattern type signatures --------------- 240 -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' 241 242 -- For details on above see note [Api annotations] in GHC.Parser.Annotation 243 | SigPat (XSigPat p) -- After typechecker: Type 244 (LPat p) -- Pattern with a type signature 245 (HsPatSigType (NoGhcTc p)) -- Signature can bind both 246 -- kind and type vars 247 248 -- ^ Pattern with a type signature 249 250 -- | Trees that Grow extension point for new constructors 251 | XPat 252 !(XXPat p) 253 254 255-- --------------------------------------------------------------------- 256 257data ListPatTc 258 = ListPatTc 259 Type -- The type of the elements 260 (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax 261 262type instance XWildPat GhcPs = NoExtField 263type instance XWildPat GhcRn = NoExtField 264type instance XWildPat GhcTc = Type 265 266type instance XVarPat (GhcPass _) = NoExtField 267type instance XLazyPat (GhcPass _) = NoExtField 268type instance XAsPat (GhcPass _) = NoExtField 269type instance XParPat (GhcPass _) = NoExtField 270type instance XBangPat (GhcPass _) = NoExtField 271 272-- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap 273-- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for 274-- `SyntaxExpr` 275type instance XListPat GhcPs = NoExtField 276type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) 277type instance XListPat GhcTc = ListPatTc 278 279type instance XTuplePat GhcPs = NoExtField 280type instance XTuplePat GhcRn = NoExtField 281type instance XTuplePat GhcTc = [Type] 282 283type instance XConPat GhcPs = NoExtField 284type instance XConPat GhcRn = NoExtField 285type instance XConPat GhcTc = ConPatTc 286 287type instance XSumPat GhcPs = NoExtField 288type instance XSumPat GhcRn = NoExtField 289type instance XSumPat GhcTc = [Type] 290 291type instance XViewPat GhcPs = NoExtField 292type instance XViewPat GhcRn = NoExtField 293type instance XViewPat GhcTc = Type 294 295type instance XSplicePat (GhcPass _) = NoExtField 296type instance XLitPat (GhcPass _) = NoExtField 297 298type instance XNPat GhcPs = NoExtField 299type instance XNPat GhcRn = NoExtField 300type instance XNPat GhcTc = Type 301 302type instance XNPlusKPat GhcPs = NoExtField 303type instance XNPlusKPat GhcRn = NoExtField 304type instance XNPlusKPat GhcTc = Type 305 306type instance XSigPat GhcPs = NoExtField 307type instance XSigPat GhcRn = NoExtField 308type instance XSigPat GhcTc = Type 309 310type instance XXPat GhcPs = NoExtCon 311type instance XXPat GhcRn = NoExtCon 312type instance XXPat GhcTc = CoPat 313 -- After typechecking, we add one extra constructor: CoPat 314 315type family ConLikeP x 316 317type instance ConLikeP GhcPs = RdrName -- IdP GhcPs 318type instance ConLikeP GhcRn = Name -- IdP GhcRn 319type instance ConLikeP GhcTc = ConLike 320 321-- --------------------------------------------------------------------- 322 323 324-- | Haskell Constructor Pattern Details 325type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) 326 327hsConPatArgs :: HsConPatDetails p -> [LPat p] 328hsConPatArgs (PrefixCon ps) = ps 329hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) 330hsConPatArgs (InfixCon p1 p2) = [p1,p2] 331 332-- | This is the extension field for ConPat, added after typechecking 333-- It adds quite a few extra fields, to support elaboration of pattern matching. 334data ConPatTc 335 = ConPatTc 336 { -- | The universal arg types 1-1 with the universal 337 -- tyvars of the constructor/pattern synonym 338 -- Use (conLikeResTy pat_con cpt_arg_tys) to get 339 -- the type of the pattern 340 cpt_arg_tys :: [Type] 341 342 , -- | Existentially bound type variables 343 -- in correctly-scoped order e.g. [k:* x:k] 344 cpt_tvs :: [TyVar] 345 346 , -- | Ditto *coercion variables* and *dictionaries* 347 -- One reason for putting coercion variable here I think 348 -- is to ensure their kinds are zonked 349 cpt_dicts :: [EvVar] 350 351 , -- | Bindings involving those dictionaries 352 cpt_binds :: TcEvBinds 353 354 , -- ^ Extra wrapper to pass to the matcher 355 -- Only relevant for pattern-synonyms; 356 -- ignored for data cons 357 cpt_wrap :: HsWrapper 358 } 359 360-- | Coercion Pattern (translation only) 361-- 362-- During desugaring a (CoPat co pat) turns into a cast with 'co' on the 363-- scrutinee, followed by a match on 'pat'. 364data CoPat 365 = CoPat 366 { -- | Coercion Pattern 367 -- If co :: t1 ~ t2, p :: t2, 368 -- then (CoPat co p) :: t1 369 co_cpt_wrap :: HsWrapper 370 371 , -- | Why not LPat? Ans: existing locn will do 372 co_pat_inner :: Pat GhcTc 373 374 , -- | Type of whole pattern, t1 375 co_pat_ty :: Type 376 } 377 378-- | Haskell Record Fields 379-- 380-- HsRecFields is used only for patterns and expressions (not data type 381-- declarations) 382data HsRecFields p arg -- A bunch of record fields 383 -- { x = 3, y = True } 384 -- Used for both expressions and patterns 385 = HsRecFields { rec_flds :: [LHsRecField p arg], 386 rec_dotdot :: Maybe (Located Int) } -- Note [DotDot fields] 387 deriving (Functor, Foldable, Traversable) 388 389 390-- Note [DotDot fields] 391-- ~~~~~~~~~~~~~~~~~~~~ 392-- The rec_dotdot field means this: 393-- Nothing => the normal case 394-- Just n => the group uses ".." notation, 395-- 396-- In the latter case: 397-- 398-- *before* renamer: rec_flds are exactly the n user-written fields 399-- 400-- *after* renamer: rec_flds includes *all* fields, with 401-- the first 'n' being the user-written ones 402-- and the remainder being 'filled in' implicitly 403 404-- | Located Haskell Record Field 405type LHsRecField' p arg = Located (HsRecField' p arg) 406 407-- | Located Haskell Record Field 408type LHsRecField p arg = Located (HsRecField p arg) 409 410-- | Located Haskell Record Update Field 411type LHsRecUpdField p = Located (HsRecUpdField p) 412 413-- | Haskell Record Field 414type HsRecField p arg = HsRecField' (FieldOcc p) arg 415 416-- | Haskell Record Update Field 417type HsRecUpdField p = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p) 418 419-- | Haskell Record Field 420-- 421-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual', 422-- 423-- For details on above see note [Api annotations] in GHC.Parser.Annotation 424data HsRecField' id arg = HsRecField { 425 hsRecFieldLbl :: Located id, 426 hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning 427 hsRecPun :: Bool -- ^ Note [Punning] 428 } deriving (Data, Functor, Foldable, Traversable) 429 430 431-- Note [Punning] 432-- ~~~~~~~~~~~~~~ 433-- If you write T { x, y = v+1 }, the HsRecFields will be 434-- HsRecField x x True ... 435-- HsRecField y (v+1) False ... 436-- That is, for "punned" field x is expanded (in the renamer) 437-- to x=x; but with a punning flag so we can detect it later 438-- (e.g. when pretty printing) 439-- 440-- If the original field was qualified, we un-qualify it, thus 441-- T { A.x } means T { A.x = x } 442 443 444-- Note [HsRecField and HsRecUpdField] 445-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 446 447-- A HsRecField (used for record construction and pattern matching) 448-- contains an unambiguous occurrence of a field (i.e. a FieldOcc). 449-- We can't just store the Name, because thanks to 450-- DuplicateRecordFields this may not correspond to the label the user 451-- wrote. 452-- 453-- A HsRecUpdField (used for record update) contains a potentially 454-- ambiguous occurrence of a field (an AmbiguousFieldOcc). The 455-- renamer will fill in the selector function if it can, but if the 456-- selector is ambiguous the renamer will defer to the typechecker. 457-- After the typechecker, a unique selector will have been determined. 458-- 459-- The renamer produces an Unambiguous result if it can, rather than 460-- just doing the lookup in the typechecker, so that completely 461-- unambiguous updates can be represented by 'GHC.HsToCore.Quote.repUpdFields'. 462-- 463-- For example, suppose we have: 464-- 465-- data S = MkS { x :: Int } 466-- data T = MkT { x :: Int } 467-- 468-- f z = (z { x = 3 }) :: S 469-- 470-- The parsed HsRecUpdField corresponding to the record update will have: 471-- 472-- hsRecFieldLbl = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName 473-- 474-- After the renamer, this will become: 475-- 476-- hsRecFieldLbl = Ambiguous "x" noExtField :: AmbiguousFieldOcc Name 477-- 478-- (note that the Unambiguous constructor is not type-correct here). 479-- The typechecker will determine the particular selector: 480-- 481-- hsRecFieldLbl = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id 482-- 483-- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Expr. 484 485hsRecFields :: HsRecFields p arg -> [XCFieldOcc p] 486hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) 487 488-- Probably won't typecheck at once, things have changed :/ 489hsRecFieldsArgs :: HsRecFields p arg -> [arg] 490hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds) 491 492hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass) 493hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl 494 495hsRecFieldId :: HsRecField GhcTc arg -> Located Id 496hsRecFieldId = hsRecFieldSel 497 498hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName 499hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl 500 501hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id 502hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc 503 504hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc 505hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl 506 507 508{- 509************************************************************************ 510* * 511* Printing patterns 512* * 513************************************************************************ 514-} 515 516instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where 517 ppr = pprPat 518 519-- | Print with type info if -dppr-debug is on 520pprPatBndr :: OutputableBndr name => name -> SDoc 521pprPatBndr var 522 = getPprDebug $ \case 523 True -> parens (pprBndr LambdaBind var) -- Could pass the site to pprPat 524 -- but is it worth it? 525 False -> pprPrefixOcc var 526 527pprParendLPat :: (OutputableBndrId p) 528 => PprPrec -> LPat (GhcPass p) -> SDoc 529pprParendLPat p = pprParendPat p . unLoc 530 531pprParendPat :: forall p. OutputableBndrId p 532 => PprPrec 533 -> Pat (GhcPass p) 534 -> SDoc 535pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_elab -> 536 if need_parens print_tc_elab pat 537 then parens (pprPat pat) 538 else pprPat pat 539 where 540 need_parens print_tc_elab pat 541 | GhcTc <- ghcPass @p 542 , XPat ext <- pat 543 , CoPat {} <- ext 544 = print_tc_elab 545 546 | otherwise 547 = patNeedsParens p pat 548 -- For a CoPat we need parens if we are going to show it, which 549 -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper) 550 -- But otherwise the CoPat is discarded, so it 551 -- is the pattern inside that matters. Sigh. 552 553pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc 554pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) 555pprPat (WildPat _) = char '_' 556pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat 557pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat 558pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@', 559 pprParendLPat appPrec pat] 560pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat] 561pprPat (ParPat _ pat) = parens (ppr pat) 562pprPat (LitPat _ s) = ppr s 563pprPat (NPat _ l Nothing _) = ppr l 564pprPat (NPat _ l (Just _) _) = char '-' <> ppr l 565pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k] 566pprPat (SplicePat _ splice) = pprSplice splice 567pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr_ty 568 where ppr_ty = case ghcPass @p of 569 GhcPs -> ppr ty 570 GhcRn -> ppr ty 571 GhcTc -> ppr ty 572pprPat (ListPat _ pats) = brackets (interpp'SP pats) 573pprPat (TuplePat _ pats bx) 574 -- Special-case unary boxed tuples so that they are pretty-printed as 575 -- `Solo x`, not `(x)` 576 | [pat] <- pats 577 , Boxed <- bx 578 = hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat] 579 | otherwise 580 = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) 581pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) 582pprPat (ConPat { pat_con = con 583 , pat_args = details 584 , pat_con_ext = ext 585 } 586 ) 587 = case ghcPass @p of 588 GhcPs -> pprUserCon (unLoc con) details 589 GhcRn -> pprUserCon (unLoc con) details 590 GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case 591 False -> pprUserCon (unLoc con) details 592 True -> 593 -- Tiresome; in 'GHC.Tc.Gen.Bind.tcRhs' we print out a typechecked Pat in an 594 -- error message, and we want to make sure it prints nicely 595 ppr con 596 <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) 597 , ppr binds ]) 598 <+> pprConArgs details 599 where ConPatTc { cpt_tvs = tvs 600 , cpt_dicts = dicts 601 , cpt_binds = binds 602 } = ext 603pprPat (XPat ext) = case ghcPass @p of 604#if __GLASGOW_HASKELL__ < 811 605 GhcPs -> noExtCon ext 606 GhcRn -> noExtCon ext 607#endif 608 GhcTc -> pprHsWrapper co $ \parens -> 609 if parens 610 then pprParendPat appPrec pat 611 else pprPat pat 612 where CoPat co pat _ = ext 613 614pprUserCon :: (OutputableBndr con, OutputableBndrId p) 615 => con -> HsConPatDetails (GhcPass p) -> SDoc 616pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 617pprUserCon c details = pprPrefixOcc c <+> pprConArgs details 618 619pprConArgs :: (OutputableBndrId p) 620 => HsConPatDetails (GhcPass p) -> SDoc 621pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats) 622pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 623 , pprParendLPat appPrec p2 ] 624pprConArgs (RecCon rpats) = ppr rpats 625 626instance (Outputable arg) 627 => Outputable (HsRecFields p arg) where 628 ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) 629 = braces (fsep (punctuate comma (map ppr flds))) 630 ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) }) 631 = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) 632 where 633 dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) 634 635instance (Outputable p, Outputable arg) 636 => Outputable (HsRecField' p arg) where 637 ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg, 638 hsRecPun = pun }) 639 = ppr f <+> (ppUnless pun $ equals <+> ppr arg) 640 641 642{- 643************************************************************************ 644* * 645* Building patterns 646* * 647************************************************************************ 648-} 649 650mkPrefixConPat :: DataCon -> 651 [LPat GhcTc] -> [Type] -> LPat GhcTc 652-- Make a vanilla Prefix constructor pattern 653mkPrefixConPat dc pats tys 654 = noLoc $ ConPat { pat_con = noLoc (RealDataCon dc) 655 , pat_args = PrefixCon pats 656 , pat_con_ext = ConPatTc 657 { cpt_tvs = [] 658 , cpt_dicts = [] 659 , cpt_binds = emptyTcEvBinds 660 , cpt_arg_tys = tys 661 , cpt_wrap = idHsWrapper 662 } 663 } 664 665mkNilPat :: Type -> LPat GhcTc 666mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] 667 668mkCharLitPat :: SourceText -> Char -> LPat GhcTc 669mkCharLitPat src c = mkPrefixConPat charDataCon 670 [noLoc $ LitPat noExtField (HsCharPrim src c)] [] 671 672{- 673************************************************************************ 674* * 675* Predicates for checking things about pattern-lists in EquationInfo * 676* * 677************************************************************************ 678 679\subsection[Pat-list-predicates]{Look for interesting things in patterns} 680 681Unlike in the Wadler chapter, where patterns are either ``variables'' 682or ``constructors,'' here we distinguish between: 683\begin{description} 684\item[unfailable:] 685Patterns that cannot fail to match: variables, wildcards, and lazy 686patterns. 687 688These are the irrefutable patterns; the two other categories 689are refutable patterns. 690 691\item[constructor:] 692A non-literal constructor pattern (see next category). 693 694\item[literal patterns:] 695At least the numeric ones may be overloaded. 696\end{description} 697 698A pattern is in {\em exactly one} of the above three categories; `as' 699patterns are treated specially, of course. 700 701The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. 702-} 703 704isBangedLPat :: LPat (GhcPass p) -> Bool 705isBangedLPat = isBangedPat . unLoc 706 707isBangedPat :: Pat (GhcPass p) -> Bool 708isBangedPat (ParPat _ p) = isBangedLPat p 709isBangedPat (BangPat {}) = True 710isBangedPat _ = False 711 712looksLazyPatBind :: HsBind (GhcPass p) -> Bool 713-- Returns True of anything *except* 714-- a StrictHsBind (as above) or 715-- a VarPat 716-- In particular, returns True of a pattern binding with a compound pattern, like (I# x) 717-- Looks through AbsBinds 718looksLazyPatBind (PatBind { pat_lhs = p }) 719 = looksLazyLPat p 720looksLazyPatBind (AbsBinds { abs_binds = binds }) 721 = anyBag (looksLazyPatBind . unLoc) binds 722looksLazyPatBind _ 723 = False 724 725looksLazyLPat :: LPat (GhcPass p) -> Bool 726looksLazyLPat = looksLazyPat . unLoc 727 728looksLazyPat :: Pat (GhcPass p) -> Bool 729looksLazyPat (ParPat _ p) = looksLazyLPat p 730looksLazyPat (AsPat _ _ p) = looksLazyLPat p 731looksLazyPat (BangPat {}) = False 732looksLazyPat (VarPat {}) = False 733looksLazyPat (WildPat {}) = False 734looksLazyPat _ = True 735 736isIrrefutableHsPat :: forall p. (OutputableBndrId p) 737 => DynFlags -> LPat (GhcPass p) -> Bool 738-- (isIrrefutableHsPat p) is true if matching against p cannot fail, 739-- in the sense of falling through to the next pattern. 740-- (NB: this is not quite the same as the (silly) defn 741-- in 3.17.2 of the Haskell 98 report.) 742-- 743-- WARNING: isIrrefutableHsPat returns False if it's in doubt. 744-- Specifically on a ConPatIn, which is what it sees for a 745-- (LPat Name) in the renamer, it doesn't know the size of the 746-- constructor family, so it returns False. Result: only 747-- tuple patterns are considered irrefutable at the renamer stage. 748-- 749-- But if it returns True, the pattern is definitely irrefutable 750isIrrefutableHsPat dflags = 751 isIrrefutableHsPat' (xopt LangExt.Strict dflags) 752 753{- 754Note [-XStrict and irrefutability] 755~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 756When -XStrict is enabled the rules for irrefutability are slightly modified. 757Specifically, the pattern in a program like 758 759 do ~(Just hi) <- expr 760 761cannot be considered irrefutable. The ~ here merely disables the bang that 762-XStrict would usually apply, rendering the program equivalent to the following 763without -XStrict 764 765 do Just hi <- expr 766 767To achieve make this pattern irrefutable with -XStrict the user would rather 768need to write 769 770 do ~(~(Just hi)) <- expr 771 772Failing to account for this resulted in #19027. To fix this isIrrefutableHsPat 773takes care to check for two the irrefutability of the inner pattern when it 774encounters a LazyPat and -XStrict is enabled. 775 776See also Note [decideBangHood] in GHC.HsToCore.Utils. 777-} 778 779isIrrefutableHsPat' :: forall p. (OutputableBndrId p) 780 => Bool -- ^ Are we in a @-XStrict@ context? 781 -- See Note [-XStrict and irrefutability] 782 -> LPat (GhcPass p) -> Bool 783isIrrefutableHsPat' is_strict = goL 784 where 785 goL :: LPat (GhcPass p) -> Bool 786 goL = go . unLoc 787 788 go :: Pat (GhcPass p) -> Bool 789 go (WildPat {}) = True 790 go (VarPat {}) = True 791 go (LazyPat _ p') 792 | is_strict 793 = isIrrefutableHsPat' False p' 794 | otherwise = True 795 go (BangPat _ pat) = goL pat 796 go (ParPat _ pat) = goL pat 797 go (AsPat _ _ pat) = goL pat 798 go (ViewPat _ _ pat) = goL pat 799 go (SigPat _ pat _) = goL pat 800 go (TuplePat _ pats _) = all goL pats 801 go (SumPat {}) = False 802 -- See Note [Unboxed sum patterns aren't irrefutable] 803 go (ListPat {}) = False 804 805 go (ConPat 806 { pat_con = con 807 , pat_args = details }) 808 = case ghcPass @p of 809 GhcPs -> False -- Conservative 810 GhcRn -> False -- Conservative 811 GhcTc -> case con of 812 L _ (PatSynCon _pat) -> False -- Conservative 813 L _ (RealDataCon con) -> 814 isJust (tyConSingleDataCon_maybe (dataConTyCon con)) 815 -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because 816 -- the latter is false of existentials. See #4439 817 && all goL (hsConPatArgs details) 818 go (LitPat {}) = False 819 go (NPat {}) = False 820 go (NPlusKPat {}) = False 821 822 -- We conservatively assume that no TH splices are irrefutable 823 -- since we cannot know until the splice is evaluated. 824 go (SplicePat {}) = False 825 826 go (XPat ext) = case ghcPass @p of 827#if __GLASGOW_HASKELL__ < 811 828 GhcPs -> noExtCon ext 829 GhcRn -> noExtCon ext 830#endif 831 GhcTc -> go pat 832 where CoPat _ pat _ = ext 833 834-- | Is the pattern any of combination of: 835-- 836-- - (pat) 837-- - pat :: Type 838-- - ~pat 839-- - !pat 840-- - x (variable) 841isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x)) 842isSimplePat p = case unLoc p of 843 ParPat _ x -> isSimplePat x 844 SigPat _ x _ -> isSimplePat x 845 LazyPat _ x -> isSimplePat x 846 BangPat _ x -> isSimplePat x 847 VarPat _ x -> Just (unLoc x) 848 _ -> Nothing 849 850 851{- Note [Unboxed sum patterns aren't irrefutable] 852~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 853Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as 854patterns. A simple example that demonstrates this is from #14228: 855 856 pattern Just' x = (# x | #) 857 pattern Nothing' = (# | () #) 858 859 foo x = case x of 860 Nothing' -> putStrLn "nothing" 861 Just' -> putStrLn "just" 862 863In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable, 864as does not match an unboxed sum value of the same arity—namely, (# | y #) 865(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the 866minimum unboxed sum arity is 2. 867 868Failing to mark unboxed sum patterns as non-irrefutable would cause the Just' 869case in foo to be unreachable, as GHC would mistakenly believe that Nothing' 870is the only thing that could possibly be matched! 871-} 872 873-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs 874-- parentheses under precedence @p@. 875patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool 876patNeedsParens p = go 877 where 878 go :: Pat (GhcPass p) -> Bool 879 go (NPlusKPat {}) = p > opPrec 880 go (SplicePat {}) = False 881 go (ConPat { pat_args = ds}) 882 = conPatNeedsParens p ds 883 go (SigPat {}) = p >= sigPrec 884 go (ViewPat {}) = True 885 go (XPat ext) = case ghcPass @p of 886 GhcPs -> noExtCon ext 887 GhcRn -> noExtCon ext 888 GhcTc -> go inner 889 where CoPat _ inner _ = ext 890 go (WildPat {}) = False 891 go (VarPat {}) = False 892 go (LazyPat {}) = False 893 go (BangPat {}) = False 894 go (ParPat {}) = False 895 go (AsPat {}) = False 896 go (TuplePat {}) = False 897 go (SumPat {}) = False 898 go (ListPat {}) = False 899 go (LitPat _ l) = hsLitNeedsParens p l 900 go (NPat _ lol _ _) = hsOverLitNeedsParens p (unLoc lol) 901 902-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ 903-- needs parentheses under precedence @p@. 904conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool 905conPatNeedsParens p = go 906 where 907 go (PrefixCon args) = p >= appPrec && not (null args) 908 go (InfixCon {}) = p >= opPrec 909 go (RecCon {}) = False 910 911-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and 912-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. 913parenthesizePat :: IsPass p 914 => PprPrec 915 -> LPat (GhcPass p) 916 -> LPat (GhcPass p) 917parenthesizePat p lpat@(L loc pat) 918 | patNeedsParens p pat = L loc (ParPat noExtField lpat) 919 | otherwise = lpat 920 921{- 922% Collect all EvVars from all constructor patterns 923-} 924 925-- May need to add more cases 926collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar 927collectEvVarsPats = unionManyBags . map collectEvVarsPat 928 929collectEvVarsLPat :: LPat GhcTc -> Bag EvVar 930collectEvVarsLPat = collectEvVarsPat . unLoc 931 932collectEvVarsPat :: Pat GhcTc -> Bag EvVar 933collectEvVarsPat pat = 934 case pat of 935 LazyPat _ p -> collectEvVarsLPat p 936 AsPat _ _ p -> collectEvVarsLPat p 937 ParPat _ p -> collectEvVarsLPat p 938 BangPat _ p -> collectEvVarsLPat p 939 ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps 940 TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps 941 SumPat _ p _ _ -> collectEvVarsLPat p 942 ConPat 943 { pat_args = args 944 , pat_con_ext = ConPatTc 945 { cpt_dicts = dicts 946 } 947 } 948 -> unionBags (listToBag dicts) 949 $ unionManyBags 950 $ map collectEvVarsLPat 951 $ hsConPatArgs args 952 SigPat _ p _ -> collectEvVarsLPat p 953 XPat (CoPat _ p _) -> collectEvVarsPat p 954 _other_pat -> emptyBag 955