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