HsPat.hs 31.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

5
\section[PatSyntax]{Abstract Haskell syntax---patterns}
Austin Seipp's avatar
Austin Seipp committed
6
-}
7

8
{-# LANGUAGE DeriveDataTypeable #-}
9 10 11
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
12 13 14 15 16
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                      -- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
Adam Gundry's avatar
Adam Gundry committed
17
{-# LANGUAGE TypeFamilies #-}
18

19
module HsPat (
Ian Lynagh's avatar
Ian Lynagh committed
20
        Pat(..), InPat, OutPat, LPat,
21
        ListPatTc(..),
22

Ian Lynagh's avatar
Ian Lynagh committed
23
        HsConPatDetails, hsConPatArgs,
Adam Gundry's avatar
Adam Gundry committed
24 25 26
        HsRecFields(..), HsRecField'(..), LHsRecField',
        HsRecField, LHsRecField,
        HsRecUpdField, LHsRecUpdField,
27
        hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,
Adam Gundry's avatar
Adam Gundry committed
28
        hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
Ian Lynagh's avatar
Ian Lynagh committed
29 30

        mkPrefixConPat, mkCharLitPat, mkNilPat,
31

Richard Eisenberg's avatar
Richard Eisenberg committed
32
        looksLazyPatBind,
33
        isBangedLPat,
34
        patNeedsParens, parenthesizePat,
35
        isIrrefutableHsPat,
36

37 38
        collectEvVarsPats,

39
        pprParendLPat, pprConArgs
40 41
    ) where

42 43
import GhcPrelude

44
import {-# SOURCE #-} HsExpr            (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice)
sof's avatar
sof committed
45

46
-- friends:
47 48
import HsBinds
import HsLit
49
import HsExtension
50
import HsTypes
51
import TcEvidence
52
import BasicTypes
53
-- others:
Ian Lynagh's avatar
Ian Lynagh committed
54
import PprCore          ( {- instance OutputableBndr TyVar -} )
55 56
import TysWiredIn
import Var
Adam Gundry's avatar
Adam Gundry committed
57
import RdrName ( RdrName )
cactus's avatar
cactus committed
58
import ConLike
59 60
import DataCon
import TyCon
Ian Lynagh's avatar
Ian Lynagh committed
61
import Outputable
62 63
import Type
import SrcLoc
64
import Bag -- collect ev vars from pats
65
import DynFlags( gopt, GeneralFlag(..) )
Adam Gundry's avatar
Adam Gundry committed
66
import Maybes
67
-- libraries:
68
import Data.Data hiding (TyCon,Fixity)
69

70 71
type InPat p  = LPat p        -- No 'Out' constructors
type OutPat p = LPat p        -- No 'In' constructors
72

73
type LPat p = Located (Pat p)
74

75 76 77
-- | Pattern
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
78 79

-- For details on above see note [Api annotations] in ApiAnnotation
80
data Pat p
Ian Lynagh's avatar
Ian Lynagh committed
81
  =     ------------ Simple patterns ---------------
82
    WildPat     (XWildPat p)        -- ^ Wildcard Pattern
Ian Lynagh's avatar
Ian Lynagh committed
83 84
        -- The sole reason for a type on a WildPat is to
        -- support hsPatType :: Pat Id -> Type
85

86
       -- AZ:TODO above comment needs to be updated
87 88
  | VarPat      (XVarPat p)
                (Located (IdP p))  -- ^ Variable Pattern
89

90
                             -- See Note [Located RdrNames] in HsExpr
91 92
  | LazyPat     (XLazyPat p)
                (LPat p)                -- ^ Lazy Pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
93 94
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'

95 96
    -- For details on above see note [Api annotations] in ApiAnnotation

97 98
  | AsPat       (XAsPat p)
                (Located (IdP p)) (LPat p)    -- ^ As pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
99 100
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'

101 102
    -- For details on above see note [Api annotations] in ApiAnnotation

103 104
  | ParPat      (XParPat p)
                (LPat p)                -- ^ Parenthesised pattern
Ian Lynagh's avatar
Ian Lynagh committed
105
                                        -- See Note [Parens in HsSyn] in HsExpr
Alan Zimmerman's avatar
Alan Zimmerman committed
106 107
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
    --                                    'ApiAnnotation.AnnClose' @')'@
108 109

    -- For details on above see note [Api annotations] in ApiAnnotation
110 111
  | BangPat     (XBangPat p)
                (LPat p)                -- ^ Bang pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
112
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
Ian Lynagh's avatar
Ian Lynagh committed
113

114 115
    -- For details on above see note [Api annotations] in ApiAnnotation

Ian Lynagh's avatar
Ian Lynagh committed
116
        ------------ Lists, tuples, arrays ---------------
117 118
  | ListPat     (XListPat p)
                [LPat p]
119 120
                   -- For OverloadedLists a Just (ty,fn) gives
                   -- overall type of the pattern, and the toList
121 122
-- function to convert the scrutinee to a list value

123 124 125
    -- ^ Syntactic List
    --
    -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
Alan Zimmerman's avatar
Alan Zimmerman committed
126
    --                                    'ApiAnnotation.AnnClose' @']'@
Ian Lynagh's avatar
Ian Lynagh committed
127

128 129
    -- For details on above see note [Api annotations] in ApiAnnotation

130 131 132
  | TuplePat    (XTuplePat p)
                  -- after typechecking, holds the types of the tuple components
                [LPat p]         -- Tuple sub-patterns
133
                Boxity           -- UnitPat is TuplePat []
134 135 136
        -- You might think that the post typechecking Type was redundant,
        -- because we can get the pattern type by getting the types of the
        -- sub-patterns.
137
        -- But it's essential
Ian Lynagh's avatar
Ian Lynagh committed
138 139 140 141 142 143 144 145 146 147
        --      data T a where
        --        T1 :: Int -> T Int
        --      f :: (T a, a) -> Int
        --      f (T1 x, z) = z
        -- When desugaring, we must generate
        --      f = /\a. \v::a.  case v of (t::T a, w::a) ->
        --                       case t of (T1 (x::Int)) ->
        -- Note the (w::a), NOT (w::Int), because we have not yet
        -- refined 'a' to Int.  So we must know that the second component
        -- of the tuple is of type 'a' not Int.  See selectMatchVar
148 149
        -- (June 14: I'm not sure this comment is right; the sub-patterns
        --           will be wrapped in CoPats, no?)
150 151 152
    -- ^ Tuple sub-patterns
    --
    -- - 'ApiAnnotation.AnnKeywordId' :
Alan Zimmerman's avatar
Alan Zimmerman committed
153 154
    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
Ian Lynagh's avatar
Ian Lynagh committed
155

156
  | SumPat      (XSumPat p)        -- PlaceHolder before typechecker, filled in
Ben Gamari's avatar
Ben Gamari committed
157 158
                                   -- afterwards with the types of the
                                   -- alternative
159 160 161
                (LPat p)           -- Sum sub-pattern
                ConTag             -- Alternative (one-based)
                Arity              -- Arity (INVARIANT: ≥ 2)
162 163 164
    -- ^ Anonymous sum pattern
    --
    -- - 'ApiAnnotation.AnnKeywordId' :
165 166 167
    --            'ApiAnnotation.AnnOpen' @'(#'@,
    --            'ApiAnnotation.AnnClose' @'#)'@

168
    -- For details on above see note [Api annotations] in ApiAnnotation
169 170
  | PArrPat     (XPArrPat p)   -- After typechecking,  the type of the elements
                [LPat p]       -- Syntactic parallel array
Alan Zimmerman's avatar
Alan Zimmerman committed
171 172
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
    --                                    'ApiAnnotation.AnnClose' @':]'@
Ian Lynagh's avatar
Ian Lynagh committed
173

174
    -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
175
        ------------ Constructor patterns ---------------
176 177
  | ConPatIn    (Located (IdP p))
                (HsConPatDetails p)
178
    -- ^ Constructor Pattern In
179

180
  | ConPatOut {
181
        pat_con     :: Located ConLike,
Gabor Greif's avatar
Gabor Greif committed
182
        pat_arg_tys :: [Type],          -- The universal arg types, 1-1 with the universal
183
                                        -- tyvars of the constructor/pattern synonym
Austin Seipp's avatar
Austin Seipp committed
184
                                        --   Use (conLikeResTy pat_con pat_arg_tys) to get
185 186
                                        --   the type of the pattern

187
        pat_tvs   :: [TyVar],           -- Existentially bound type variables
188
                                        -- in correctly-scoped order e.g. [k:*, x:k]
Ian Lynagh's avatar
Ian Lynagh committed
189 190 191
        pat_dicts :: [EvVar],           -- Ditto *coercion variables* and *dictionaries*
                                        -- One reason for putting coercion variable here, I think,
                                        --      is to ensure their kinds are zonked
192

Ian Lynagh's avatar
Ian Lynagh committed
193
        pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries
194
        pat_args  :: HsConPatDetails p,
cactus's avatar
cactus committed
195
        pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
196 197
                                        -- Only relevant for pattern-synonyms;
                                        --   ignored for data cons
198
    }
199
    -- ^ Constructor Pattern Out
200

Ian Lynagh's avatar
Ian Lynagh committed
201
        ------------ View patterns ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
202
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
203 204

  -- For details on above see note [Api annotations] in ApiAnnotation
205 206 207 208
  | ViewPat       (XViewPat p)     -- The overall type of the pattern
                                   -- (= the argument type of the view function)
                                   -- for hsPatType.
                  (LHsExpr p)
209
                  (LPat p)
210
    -- ^ View Pattern
211

gmainland's avatar
gmainland committed
212
        ------------ Pattern splices ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
213 214
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
  --        'ApiAnnotation.AnnClose' @')'@
215 216

  -- For details on above see note [Api annotations] in ApiAnnotation
217 218
  | SplicePat       (XSplicePat p)
                    (HsSplice p)    -- ^ Splice Pattern (Includes quasi-quotes)
219

Ian Lynagh's avatar
Ian Lynagh committed
220
        ------------ Literal and n+k patterns ---------------
221 222
  | LitPat          (XLitPat p)
                    (HsLit p)           -- ^ Literal Pattern
223
                                        -- Used for *non-overloaded* literal patterns:
Ian Lynagh's avatar
Ian Lynagh committed
224 225
                                        -- Int#, Char#, Int, Char, String, etc.

226 227
  | NPat                -- Natural Pattern
                        -- Used for all overloaded literals,
Ian Lynagh's avatar
Ian Lynagh committed
228
                        -- including overloaded strings with -XOverloadedStrings
229 230 231
                    (XNPat p)            -- Overall type of pattern. Might be
                                         -- different than the literal's type
                                         -- if (==) or negate changes the type
232 233 234 235 236
                    (Located (HsOverLit p))     -- ALWAYS positive
                    (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for
                                           -- negative patterns, Nothing
                                           -- otherwise
                    (SyntaxExpr p)       -- Equality checker, of type t->t->Bool
Ian Lynagh's avatar
Ian Lynagh committed
237

238 239 240
  -- ^ Natural Pattern
  --
  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
241 242

  -- For details on above see note [Api annotations] in ApiAnnotation
243 244
  | NPlusKPat       (XNPlusKPat p)           -- Type of overall pattern
                    (Located (IdP p))        -- n+k pattern
245 246
                    (Located (HsOverLit p))  -- It'll always be an HsIntegral
                    (HsOverLit p)       -- See Note [NPlusK patterns] in TcPat
247 248 249
                     -- NB: This could be (PostTc ...), but that induced a
                     -- a new hs-boot file. Not worth it.

250 251
                    (SyntaxExpr p)   -- (>=) function, of type t1->t2->Bool
                    (SyntaxExpr p)   -- Name of '-' (see RnEnv.lookupSyntaxName)
252
  -- ^ n+k pattern
Ian Lynagh's avatar
Ian Lynagh committed
253 254

        ------------ Pattern type signatures ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
255
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
256 257

  -- For details on above see note [Api annotations] in ApiAnnotation
258 259 260 261 262
  | SigPat          (XSigPat p)          -- Before typechecker
                                         --  Signature can bind both
                                         --  kind and type vars
                                         -- After typechecker: Type
                    (LPat p)                -- Pattern with a type signature
263
    -- ^ Pattern with a type signature
Ian Lynagh's avatar
Ian Lynagh committed
264 265

        ------------ Pattern coercions (translation only) ---------------
266 267
  | CoPat       (XCoPat p)
                HsWrapper           -- Coercion Pattern
268 269 270 271
                                    -- If co :: t1 ~ t2, p :: t2,
                                    -- then (CoPat co p) :: t1
                (Pat p)             -- Why not LPat?  Ans: existing locn will do
                Type                -- Type of whole pattern, t1
Ian Lynagh's avatar
Ian Lynagh committed
272 273
        -- During desugaring a (CoPat co pat) turns into a cast with 'co' on
        -- the scrutinee, followed by a match on 'pat'
274
    -- ^ Coercion Pattern
275 276 277 278 279 280 281

  -- | Trees that Grow extension point for new constructors
  | XPat
      (XXPat p)

-- ---------------------------------------------------------------------

282 283 284 285 286 287 288
data ListPatTc
  = ListPatTc
      Type                             -- The type of the elements
      (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax

type instance XWildPat GhcPs = NoExt
type instance XWildPat GhcRn = NoExt
289 290
type instance XWildPat GhcTc = Type

291 292 293 294 295
type instance XVarPat  (GhcPass _) = NoExt
type instance XLazyPat (GhcPass _) = NoExt
type instance XAsPat   (GhcPass _) = NoExt
type instance XParPat  (GhcPass _) = NoExt
type instance XBangPat (GhcPass _) = NoExt
296 297 298 299

-- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap
-- compiler, as it triggers https://ghc.haskell.org/trac/ghc/ticket/14396 for
-- `SyntaxExpr`
300 301 302
type instance XListPat GhcPs = NoExt
type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn)
type instance XListPat GhcTc = ListPatTc
303

304 305
type instance XTuplePat GhcPs = NoExt
type instance XTuplePat GhcRn = NoExt
306 307
type instance XTuplePat GhcTc = [Type]

308 309
type instance XSumPat GhcPs = NoExt
type instance XSumPat GhcRn = NoExt
310 311
type instance XSumPat GhcTc = [Type]

312 313
type instance XPArrPat GhcPs = NoExt
type instance XPArrPat GhcRn = NoExt
314 315
type instance XPArrPat GhcTc = Type

316 317
type instance XViewPat GhcPs = NoExt
type instance XViewPat GhcRn = NoExt
318 319
type instance XViewPat GhcTc = Type

320 321
type instance XSplicePat (GhcPass _) = NoExt
type instance XLitPat    (GhcPass _) = NoExt
322

323 324
type instance XNPat GhcPs = NoExt
type instance XNPat GhcRn = NoExt
325 326
type instance XNPat GhcTc = Type

327 328
type instance XNPlusKPat GhcPs = NoExt
type instance XNPlusKPat GhcRn = NoExt
329 330 331 332 333 334
type instance XNPlusKPat GhcTc = Type

type instance XSigPat GhcPs = (LHsSigWcType GhcPs)
type instance XSigPat GhcRn = (LHsSigWcType GhcRn)
type instance XSigPat GhcTc = Type

335 336
type instance XCoPat  (GhcPass _) = NoExt
type instance XXPat   (GhcPass _) = NoExt
337 338 339

-- ---------------------------------------------------------------------

340

341
-- | Haskell Constructor Pattern Details
342
type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
343

344
hsConPatArgs :: HsConPatDetails p -> [LPat p]
345
hsConPatArgs (PrefixCon ps)   = ps
346
hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs)
347 348
hsConPatArgs (InfixCon p1 p2) = [p1,p2]

349 350
-- | Haskell Record Fields
--
351 352
-- HsRecFields is used only for patterns and expressions (not data type
-- declarations)
353
data HsRecFields p arg         -- A bunch of record fields
Ian Lynagh's avatar
Ian Lynagh committed
354 355
                                --      { x = 3, y = True }
        -- Used for both expressions and patterns
356
  = HsRecFields { rec_flds   :: [LHsRecField p arg],
Ian Lynagh's avatar
Ian Lynagh committed
357
                  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
358
  deriving (Functor, Foldable, Traversable)
359

360

361 362 363 364
-- Note [DotDot fields]
-- ~~~~~~~~~~~~~~~~~~~~
-- The rec_dotdot field means this:
--   Nothing => the normal case
Ian Lynagh's avatar
Ian Lynagh committed
365
--   Just n  => the group uses ".." notation,
366
--
Ian Lynagh's avatar
Ian Lynagh committed
367
-- In the latter case:
368 369 370
--
--   *before* renamer: rec_flds are exactly the n user-written fields
--
Ian Lynagh's avatar
Ian Lynagh committed
371 372 373
--   *after* renamer:  rec_flds includes *all* fields, with
--                     the first 'n' being the user-written ones
--                     and the remainder being 'filled in' implicitly
374

375
-- | Located Haskell Record Field
376
type LHsRecField' p arg = Located (HsRecField' p arg)
377 378

-- | Located Haskell Record Field
379
type LHsRecField  p arg = Located (HsRecField  p arg)
380 381

-- | Located Haskell Record Update Field
382
type LHsRecUpdField p   = Located (HsRecUpdField p)
Adam Gundry's avatar
Adam Gundry committed
383

384
-- | Haskell Record Field
385
type HsRecField    p arg = HsRecField' (FieldOcc p) arg
386 387

-- | Haskell Record Update Field
388
type HsRecUpdField p     = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p)
389

390 391 392
-- | Haskell Record Field
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
Adam Gundry's avatar
Adam Gundry committed
393
--
394
-- For details on above see note [Api annotations] in ApiAnnotation
Adam Gundry's avatar
Adam Gundry committed
395 396 397 398
data HsRecField' id arg = HsRecField {
        hsRecFieldLbl :: Located id,
        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning
        hsRecPun      :: Bool           -- ^ Note [Punning]
399
  } deriving (Data, Functor, Foldable, Traversable)
400

Adam Gundry's avatar
Adam Gundry committed
401

402 403 404
-- Note [Punning]
-- ~~~~~~~~~~~~~~
-- If you write T { x, y = v+1 }, the HsRecFields will be
Ian Lynagh's avatar
Ian Lynagh committed
405 406 407
--      HsRecField x x True ...
--      HsRecField y (v+1) False ...
-- That is, for "punned" field x is expanded (in the renamer)
408
-- to x=x; but with a punning flag so we can detect it later
409
-- (e.g. when pretty printing)
410 411 412
--
-- If the original field was qualified, we un-qualify it, thus
--    T { A.x } means T { A.x = x }
413

Adam Gundry's avatar
Adam Gundry committed
414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442

-- Note [HsRecField and HsRecUpdField]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

-- A HsRecField (used for record construction and pattern matching)
-- contains an unambiguous occurrence of a field (i.e. a FieldOcc).
-- We can't just store the Name, because thanks to
-- DuplicateRecordFields this may not correspond to the label the user
-- wrote.
--
-- A HsRecUpdField (used for record update) contains a potentially
-- ambiguous occurrence of a field (an AmbiguousFieldOcc).  The
-- renamer will fill in the selector function if it can, but if the
-- selector is ambiguous the renamer will defer to the typechecker.
-- After the typechecker, a unique selector will have been determined.
--
-- The renamer produces an Unambiguous result if it can, rather than
-- just doing the lookup in the typechecker, so that completely
-- unambiguous updates can be represented by 'DsMeta.repUpdFields'.
--
-- For example, suppose we have:
--
--     data S = MkS { x :: Int }
--     data T = MkT { x :: Int }
--
--     f z = (z { x = 3 }) :: S
--
-- The parsed HsRecUpdField corresponding to the record update will have:
--
443
--     hsRecFieldLbl = Unambiguous "x" NoExt :: AmbiguousFieldOcc RdrName
Adam Gundry's avatar
Adam Gundry committed
444 445 446
--
-- After the renamer, this will become:
--
447
--     hsRecFieldLbl = Ambiguous   "x" NoExt :: AmbiguousFieldOcc Name
Adam Gundry's avatar
Adam Gundry committed
448 449 450 451 452
--
-- (note that the Unambiguous constructor is not type-correct here).
-- The typechecker will determine the particular selector:
--
--     hsRecFieldLbl = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id
453 454
--
-- See also Note [Disambiguating record fields] in TcExpr.
Adam Gundry's avatar
Adam Gundry committed
455

456
hsRecFields :: HsRecFields p arg -> [XFieldOcc p]
Adam Gundry's avatar
Adam Gundry committed
457 458
hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)

459
-- Probably won't typecheck at once, things have changed :/
460
hsRecFieldsArgs :: HsRecFields p arg -> [arg]
461 462
hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)

463 464
hsRecFieldSel :: HsRecField pass arg -> Located (XFieldOcc pass)
hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl
Adam Gundry's avatar
Adam Gundry committed
465

466
hsRecFieldId :: HsRecField GhcTc arg -> Located Id
Adam Gundry's avatar
Adam Gundry committed
467 468
hsRecFieldId = hsRecFieldSel

469
hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName
Adam Gundry's avatar
Adam Gundry committed
470 471
hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl

472
hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id
473
hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc
Adam Gundry's avatar
Adam Gundry committed
474

475
hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
Adam Gundry's avatar
Adam Gundry committed
476 477
hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl

478

Austin Seipp's avatar
Austin Seipp committed
479 480 481 482 483 484 485
{-
************************************************************************
*                                                                      *
*              Printing patterns
*                                                                      *
************************************************************************
-}
486

487
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where
488 489
    ppr = pprPat

490
pprPatBndr :: OutputableBndr name => name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
491
pprPatBndr var                  -- Print with type info if -dppr-debug is on
492 493
  = getPprStyle $ \ sty ->
    if debugStyle sty then
Ian Lynagh's avatar
Ian Lynagh committed
494 495
        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat
                                                -- but is it worth it?
496
    else
497
        pprPrefixOcc var
498

499 500 501
pprParendLPat :: (OutputableBndrId (GhcPass p))
              => PprPrec -> LPat (GhcPass p) -> SDoc
pprParendLPat p (L _ pat) = pprParendPat p pat
502

503 504 505 506 507 508
pprParendPat :: (OutputableBndrId (GhcPass p))
             => PprPrec -> Pat (GhcPass p) -> SDoc
pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
                     if need_parens dflags pat
                     then parens (pprPat pat)
                     else  pprPat pat
509
  where
510 511 512
    need_parens dflags pat
      | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags
      | otherwise       = patNeedsParens p pat
513 514 515 516
      -- For a CoPat we need parens if we are going to show it, which
      -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper)
      -- But otherwise the CoPat is discarded, so it
      -- is the pattern inside that matters.  Sigh.
517

518
pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
519 520
pprPat (VarPat _ (L _ var))     = pprPatBndr var
pprPat (WildPat _)              = char '_'
521 522
pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat appPrec pat
pprPat (BangPat _ pat)          = char '!' <> pprParendLPat appPrec pat
523
pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',
524
                                        pprParendLPat appPrec pat]
525 526 527 528 529 530 531
pprPat (ViewPat _ expr pat)     = hcat [pprLExpr expr, text " -> ", ppr pat]
pprPat (ParPat _ pat)           = parens (ppr pat)
pprPat (LitPat _ s)             = ppr s
pprPat (NPat _ l Nothing  _)    = ppr l
pprPat (NPat _ l (Just _) _)    = char '-' <> ppr l
pprPat (NPlusKPat _ n k _ _ _)  = hcat [ppr n, char '+', ppr k]
pprPat (SplicePat _ splice)     = pprSplice splice
532 533 534 535
pprPat (CoPat _ co pat _)       = pprHsWrapper co $ \parens
                                            -> if parens
                                                 then pprParendPat appPrec pat
                                                 else pprPat pat
536
pprPat (SigPat ty pat)          = ppr pat <+> dcolon <+> ppr ty
537
pprPat (ListPat _ pats)         = brackets (interpp'SP pats)
538 539 540 541 542
pprPat (PArrPat _ pats)         = paBrackets (interpp'SP pats)
pprPat (TuplePat _ pats bx)     = tupleParens (boxityTupleSort bx)
                                              (pprWithCommas ppr pats)
pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
pprPat (ConPatIn con details)   = pprUserCon (unLoc con) details
Ian Lynagh's avatar
Ian Lynagh committed
543 544
pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
                    pat_binds = binds, pat_args = details })
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
545 546 547 548 549
  = sdocWithDynFlags $ \dflags ->
       -- Tiresome; in TcBinds.tcRhs we print out a
       -- typechecked Pat in an error message,
       -- and we want to make sure it prints nicely
    if gopt Opt_PrintTypecheckerElaboration dflags then
cactus's avatar
cactus committed
550 551 552 553
        ppr con
          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                         , ppr binds])
          <+> pprConArgs details
554
    else pprUserCon (unLoc con) details
555
pprPat (XPat x)               = ppr x
556

Ben Gamari's avatar
Ben Gamari committed
557

558 559
pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
           => con -> HsConPatDetails (GhcPass p) -> SDoc
560 561
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
562

563 564
pprConArgs :: (OutputableBndrId (GhcPass p))
           => HsConPatDetails (GhcPass p) -> SDoc
565 566 567
pprConArgs (PrefixCon pats) = sep (map (pprParendLPat appPrec) pats)
pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
                                  , pprParendLPat appPrec p2 ]
568 569
pprConArgs (RecCon rpats)   = ppr rpats

Adam Gundry's avatar
Adam Gundry committed
570
instance (Outputable arg)
571
      => Outputable (HsRecFields p arg) where
572
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
Ian Lynagh's avatar
Ian Lynagh committed
573
        = braces (fsep (punctuate comma (map ppr flds)))
574
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
Ian Lynagh's avatar
Ian Lynagh committed
575 576
        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
        where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
577
          dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))
578

579 580
instance (Outputable p, Outputable arg)
      => Outputable (HsRecField' p arg) where
Adam Gundry's avatar
Adam Gundry committed
581
  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
Ian Lynagh's avatar
Ian Lynagh committed
582
                    hsRecPun = pun })
583
    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
584

Adam Gundry's avatar
Adam Gundry committed
585

Austin Seipp's avatar
Austin Seipp committed
586 587 588 589 590 591 592
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
593

594
mkPrefixConPat :: DataCon -> [OutPat p] -> [Type] -> OutPat p
595
-- Make a vanilla Prefix constructor pattern
596
mkPrefixConPat dc pats tys
cactus's avatar
cactus committed
597
  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
Ian Lynagh's avatar
Ian Lynagh committed
598
                        pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
599
                        pat_arg_tys = tys, pat_wrap = idHsWrapper }
600

601
mkNilPat :: Type -> OutPat p
602
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
603

604
mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
605
mkCharLitPat src c = mkPrefixConPat charDataCon
606
                          [noLoc $ LitPat NoExt (HsCharPrim src c)] []
607

Austin Seipp's avatar
Austin Seipp committed
608 609 610 611 612 613
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
614

615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636
\subsection[Pat-list-predicates]{Look for interesting things in patterns}

Unlike in the Wadler chapter, where patterns are either ``variables''
or ``constructors,'' here we distinguish between:
\begin{description}
\item[unfailable:]
Patterns that cannot fail to match: variables, wildcards, and lazy
patterns.

These are the irrefutable patterns; the two other categories
are refutable patterns.

\item[constructor:]
A non-literal constructor pattern (see next category).

\item[literal patterns:]
At least the numeric ones may be overloaded.
\end{description}

A pattern is in {\em exactly one} of the above three categories; `as'
patterns are treated specially, of course.

637
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
638 639
-}

640
isBangedLPat :: LPat p -> Bool
641
isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p
642 643
isBangedLPat (L _ (BangPat {})) = True
isBangedLPat _                  = False
644

645
looksLazyPatBind :: HsBind p -> Bool
646
-- Returns True of anything *except*
Austin Seipp's avatar
Austin Seipp committed
647
--     a StrictHsBind (as above) or
648 649
--     a VarPat
-- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
Richard Eisenberg's avatar
Richard Eisenberg committed
650 651 652 653 654 655 656
-- Looks through AbsBinds
looksLazyPatBind (PatBind { pat_lhs = p })
  = looksLazyLPat p
looksLazyPatBind (AbsBinds { abs_binds = binds })
  = anyBag (looksLazyPatBind . unLoc) binds
looksLazyPatBind _
  = False
657

658
looksLazyLPat :: LPat p -> Bool
659 660
looksLazyLPat (L _ (ParPat _ p))           = looksLazyLPat p
looksLazyLPat (L _ (AsPat _ _ p))          = looksLazyLPat p
661 662 663 664
looksLazyLPat (L _ (BangPat {}))           = False
looksLazyLPat (L _ (VarPat {}))            = False
looksLazyLPat (L _ (WildPat {}))           = False
looksLazyLPat _                            = True
665

666
isIrrefutableHsPat :: (OutputableBndrId p) => LPat p -> Bool
667 668
-- (isIrrefutableHsPat p) is true if matching against p cannot fail,
-- in the sense of falling through to the next pattern.
Ian Lynagh's avatar
Ian Lynagh committed
669 670 671
--      (NB: this is not quite the same as the (silly) defn
--      in 3.17.2 of the Haskell 98 report.)
--
672 673 674 675 676 677
-- WARNING: isIrrefutableHsPat returns False if it's in doubt.
-- Specifically on a ConPatIn, which is what it sees for a
-- (LPat Name) in the renamer, it doesn't know the size of the
-- constructor family, so it returns False.  Result: only
-- tuple patterns are considered irrefuable at the renamer stage.
--
678 679 680 681
-- But if it returns True, the pattern is definitely irrefutable
isIrrefutableHsPat pat
  = go pat
  where
682
    go (L _ pat) = go1 pat
683

684 685 686
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
687 688 689 690 691 692 693 694
    go1 (BangPat _ pat)     = go pat
    go1 (CoPat _ _ pat _)   = go1 pat
    go1 (ParPat _ pat)      = go pat
    go1 (AsPat _ _ pat)     = go pat
    go1 (ViewPat _ _ pat)   = go pat
    go1 (SigPat _ pat)      = go pat
    go1 (TuplePat _ pats _) = all go pats
    go1 (SumPat {})         = False
695
                    -- See Note [Unboxed sum patterns aren't irrefutable]
696
    go1 (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
697
    go1 (PArrPat {})        = False     -- ?
698

Ian Lynagh's avatar
Ian Lynagh committed
699
    go1 (ConPatIn {})       = False     -- Conservative
cactus's avatar
cactus committed
700
    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
Ian Lynagh's avatar
Ian Lynagh committed
701 702 703 704
        =  isJust (tyConSingleDataCon_maybe (dataConTyCon con))
           -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because
           -- the latter is false of existentials. See Trac #4439
        && all go (hsConPatArgs details)
cactus's avatar
cactus committed
705 706
    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
        = False -- Conservative
707

708 709 710
    go1 (LitPat {})         = False
    go1 (NPat {})           = False
    go1 (NPlusKPat {})      = False
711

712 713 714
    -- We conservatively assume that no TH splices are irrefutable
    -- since we cannot know until the splice is evaluated.
    go1 (SplicePat {})      = False
715

716 717
    go1 (XPat {})           = False

718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739
{- Note [Unboxed sum patterns aren't irrefutable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
patterns. A simple example that demonstrates this is from #14228:

  pattern Just' x = (# x | #)
  pattern Nothing' = (# | () #)

  foo x = case x of
    Nothing' -> putStrLn "nothing"
    Just'    -> putStrLn "just"

In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable,
as does not match an unboxed sum value of the same arity—namely, (# | y #)
(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the
minimum unboxed sum arity is 2.

Failing to mark unboxed sum patterns as non-irrefutable would cause the Just'
case in foo to be unreachable, as GHC would mistakenly believe that Nothing'
is the only thing that could possibly be matched!
-}

740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780
-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
-- parentheses under precedence @p@.
patNeedsParens :: PprPrec -> Pat p -> Bool
patNeedsParens p = go
  where
    go (NPlusKPat {})         = p > opPrec
    go (SplicePat {})         = False
    go (ConPatIn _ ds)        = conPatNeedsParens p ds
    go cp@(ConPatOut {})      = conPatNeedsParens p (pat_args cp)
    go (SigPat {})            = p > topPrec
    go (ViewPat {})           = True
    go (CoPat _ _ p _)        = go p
    go (WildPat {})           = False
    go (VarPat {})            = False
    go (LazyPat {})           = False
    go (BangPat {})           = False
    go (ParPat {})            = False
    go (AsPat {})             = False
    go (TuplePat {})          = False
    go (SumPat {})            = False
    go (ListPat {})           = False
    go (PArrPat {})           = False
    go (LitPat _ l)           = hsLitNeedsParens p l
    go (NPat _ (L _ ol) _ _)  = hsOverLitNeedsParens p ol
    go (XPat {})              = True -- conservative default

-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
-- needs parentheses under precedence @p@.
conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool
conPatNeedsParens p = go
  where
    go (PrefixCon args) = p >= appPrec && not (null args)
    go (InfixCon {})    = p >= opPrec
    go (RecCon {})      = False

-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat p lpat@(L loc pat)
  | patNeedsParens p pat = L loc (ParPat NoExt lpat)
  | otherwise            = lpat
781

782 783 784 785 786
{-
% Collect all EvVars from all constructor patterns
-}

-- May need to add more cases
787
collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
788 789
collectEvVarsPats = unionManyBags . map collectEvVarsPat

790
collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
791 792
collectEvVarsLPat (L _ pat) = collectEvVarsPat pat

793
collectEvVarsPat :: Pat GhcTc -> Bag EvVar
794 795
collectEvVarsPat pat =
  case pat of
796 797 798 799
    LazyPat _ p      -> collectEvVarsLPat p
    AsPat _ _ p      -> collectEvVarsLPat p
    ParPat  _ p      -> collectEvVarsLPat p
    BangPat _ p      -> collectEvVarsLPat p
800
    ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps
801 802 803
    TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps
    SumPat _ p _ _   -> collectEvVarsLPat p
    PArrPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps
804
    ConPatOut {pat_dicts = dicts, pat_args  = args}
805
                     -> unionBags (listToBag dicts)
806 807 808
                                   $ unionManyBags
                                   $ map collectEvVarsLPat
                                   $ hsConPatArgs args
809 810 811 812
    SigPat  _ p      -> collectEvVarsLPat p
    CoPat _ _ p _    -> collectEvVarsPat  p
    ConPatIn _  _    -> panic "foldMapPatBag: ConPatIn"
    _other_pat       -> emptyBag