HsPat.hs 31.2 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
        collectEvVarsPat, collectEvVarsPats,
38

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
Ian Lynagh's avatar
Ian Lynagh committed
169 170

        ------------ Constructor patterns ---------------
171 172
  | ConPatIn    (Located (IdP p))
                (HsConPatDetails p)
173
    -- ^ Constructor Pattern In
174

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
196
        ------------ View patterns ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
197
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
198 199

  -- For details on above see note [Api annotations] in ApiAnnotation
200 201 202 203
  | ViewPat       (XViewPat p)     -- The overall type of the pattern
                                   -- (= the argument type of the view function)
                                   -- for hsPatType.
                  (LHsExpr p)
204
                  (LPat p)
205
    -- ^ View Pattern
206

gmainland's avatar
gmainland committed
207
        ------------ Pattern splices ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
208 209
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
  --        'ApiAnnotation.AnnClose' @')'@
210 211

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

Ian Lynagh's avatar
Ian Lynagh committed
215
        ------------ Literal and n+k patterns ---------------
216 217
  | LitPat          (XLitPat p)
                    (HsLit p)           -- ^ Literal Pattern
218
                                        -- Used for *non-overloaded* literal patterns:
Ian Lynagh's avatar
Ian Lynagh committed
219 220
                                        -- Int#, Char#, Int, Char, String, etc.

221 222
  | NPat                -- Natural Pattern
                        -- Used for all overloaded literals,
Ian Lynagh's avatar
Ian Lynagh committed
223
                        -- including overloaded strings with -XOverloadedStrings
224 225 226
                    (XNPat p)            -- Overall type of pattern. Might be
                                         -- different than the literal's type
                                         -- if (==) or negate changes the type
227 228 229 230 231
                    (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
232

233 234 235
  -- ^ Natural Pattern
  --
  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
236 237

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

245 246
                    (SyntaxExpr p)   -- (>=) function, of type t1->t2->Bool
                    (SyntaxExpr p)   -- Name of '-' (see RnEnv.lookupSyntaxName)
247
  -- ^ n+k pattern
Ian Lynagh's avatar
Ian Lynagh committed
248 249

        ------------ Pattern type signatures ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
250
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
251 252

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

        ------------ Pattern coercions (translation only) ---------------
261 262
  | CoPat       (XCoPat p)
                HsWrapper           -- Coercion Pattern
263 264 265 266
                                    -- 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
267 268
        -- During desugaring a (CoPat co pat) turns into a cast with 'co' on
        -- the scrutinee, followed by a match on 'pat'
269
    -- ^ Coercion Pattern
270 271 272 273 274 275 276

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

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

277 278 279 280 281 282 283
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
284 285
type instance XWildPat GhcTc = Type

286 287 288 289 290
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
291 292 293 294

-- 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`
295 296 297
type instance XListPat GhcPs = NoExt
type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn)
type instance XListPat GhcTc = ListPatTc
298

299 300
type instance XTuplePat GhcPs = NoExt
type instance XTuplePat GhcRn = NoExt
301 302
type instance XTuplePat GhcTc = [Type]

303 304
type instance XSumPat GhcPs = NoExt
type instance XSumPat GhcRn = NoExt
305 306
type instance XSumPat GhcTc = [Type]

307 308
type instance XViewPat GhcPs = NoExt
type instance XViewPat GhcRn = NoExt
309 310
type instance XViewPat GhcTc = Type

311 312
type instance XSplicePat (GhcPass _) = NoExt
type instance XLitPat    (GhcPass _) = NoExt
313

314 315
type instance XNPat GhcPs = NoExt
type instance XNPat GhcRn = NoExt
316 317
type instance XNPat GhcTc = Type

318 319
type instance XNPlusKPat GhcPs = NoExt
type instance XNPlusKPat GhcRn = NoExt
320 321 322 323 324 325
type instance XNPlusKPat GhcTc = Type

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

326 327
type instance XCoPat  (GhcPass _) = NoExt
type instance XXPat   (GhcPass _) = NoExt
328 329 330

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

331

332
-- | Haskell Constructor Pattern Details
333
type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
334

335
hsConPatArgs :: HsConPatDetails p -> [LPat p]
336
hsConPatArgs (PrefixCon ps)   = ps
337
hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs)
338 339
hsConPatArgs (InfixCon p1 p2) = [p1,p2]

340 341
-- | Haskell Record Fields
--
342 343
-- HsRecFields is used only for patterns and expressions (not data type
-- declarations)
344
data HsRecFields p arg         -- A bunch of record fields
Ian Lynagh's avatar
Ian Lynagh committed
345 346
                                --      { x = 3, y = True }
        -- Used for both expressions and patterns
347
  = HsRecFields { rec_flds   :: [LHsRecField p arg],
Ian Lynagh's avatar
Ian Lynagh committed
348
                  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
349
  deriving (Functor, Foldable, Traversable)
350

351

352 353 354 355
-- Note [DotDot fields]
-- ~~~~~~~~~~~~~~~~~~~~
-- The rec_dotdot field means this:
--   Nothing => the normal case
Ian Lynagh's avatar
Ian Lynagh committed
356
--   Just n  => the group uses ".." notation,
357
--
Ian Lynagh's avatar
Ian Lynagh committed
358
-- In the latter case:
359 360 361
--
--   *before* renamer: rec_flds are exactly the n user-written fields
--
Ian Lynagh's avatar
Ian Lynagh committed
362 363 364
--   *after* renamer:  rec_flds includes *all* fields, with
--                     the first 'n' being the user-written ones
--                     and the remainder being 'filled in' implicitly
365

366
-- | Located Haskell Record Field
367
type LHsRecField' p arg = Located (HsRecField' p arg)
368 369

-- | Located Haskell Record Field
370
type LHsRecField  p arg = Located (HsRecField  p arg)
371 372

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

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

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

381 382 383
-- | Haskell Record Field
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
Adam Gundry's avatar
Adam Gundry committed
384
--
385
-- For details on above see note [Api annotations] in ApiAnnotation
Adam Gundry's avatar
Adam Gundry committed
386 387 388 389
data HsRecField' id arg = HsRecField {
        hsRecFieldLbl :: Located id,
        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning
        hsRecPun      :: Bool           -- ^ Note [Punning]
390
  } deriving (Data, Functor, Foldable, Traversable)
391

Adam Gundry's avatar
Adam Gundry committed
392

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

Adam Gundry's avatar
Adam Gundry committed
405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433

-- 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:
--
434
--     hsRecFieldLbl = Unambiguous "x" NoExt :: AmbiguousFieldOcc RdrName
Adam Gundry's avatar
Adam Gundry committed
435 436 437
--
-- After the renamer, this will become:
--
438
--     hsRecFieldLbl = Ambiguous   "x" NoExt :: AmbiguousFieldOcc Name
Adam Gundry's avatar
Adam Gundry committed
439 440 441 442 443
--
-- (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
444 445
--
-- See also Note [Disambiguating record fields] in TcExpr.
Adam Gundry's avatar
Adam Gundry committed
446

447
hsRecFields :: HsRecFields p arg -> [XCFieldOcc p]
Adam Gundry's avatar
Adam Gundry committed
448 449
hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)

450
-- Probably won't typecheck at once, things have changed :/
451
hsRecFieldsArgs :: HsRecFields p arg -> [arg]
452 453
hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)

454
hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass)
455
hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl
Adam Gundry's avatar
Adam Gundry committed
456

457
hsRecFieldId :: HsRecField GhcTc arg -> Located Id
Adam Gundry's avatar
Adam Gundry committed
458 459
hsRecFieldId = hsRecFieldSel

460
hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName
Adam Gundry's avatar
Adam Gundry committed
461 462
hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl

463
hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id
464
hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc
Adam Gundry's avatar
Adam Gundry committed
465

466
hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
Adam Gundry's avatar
Adam Gundry committed
467 468
hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl

469

Austin Seipp's avatar
Austin Seipp committed
470 471 472 473 474 475 476
{-
************************************************************************
*                                                                      *
*              Printing patterns
*                                                                      *
************************************************************************
-}
477

478
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where
479 480
    ppr = pprPat

481
pprPatBndr :: OutputableBndr name => name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
482
pprPatBndr var                  -- Print with type info if -dppr-debug is on
483 484
  = getPprStyle $ \ sty ->
    if debugStyle sty then
Ian Lynagh's avatar
Ian Lynagh committed
485 486
        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat
                                                -- but is it worth it?
487
    else
488
        pprPrefixOcc var
489

490 491 492
pprParendLPat :: (OutputableBndrId (GhcPass p))
              => PprPrec -> LPat (GhcPass p) -> SDoc
pprParendLPat p (L _ pat) = pprParendPat p pat
493

494 495 496 497 498 499
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
500
  where
501 502 503
    need_parens dflags pat
      | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags
      | otherwise       = patNeedsParens p pat
504 505 506 507
      -- 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.
508

509
pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
510 511
pprPat (VarPat _ (L _ var))     = pprPatBndr var
pprPat (WildPat _)              = char '_'
512 513
pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat appPrec pat
pprPat (BangPat _ pat)          = char '!' <> pprParendLPat appPrec pat
514
pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',
515
                                        pprParendLPat appPrec pat]
516 517 518 519 520 521 522
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
523 524 525 526
pprPat (CoPat _ co pat _)       = pprHsWrapper co $ \parens
                                            -> if parens
                                                 then pprParendPat appPrec pat
                                                 else pprPat pat
527
pprPat (SigPat ty pat)          = ppr pat <+> dcolon <+> ppr ty
528
pprPat (ListPat _ pats)         = brackets (interpp'SP pats)
529 530 531 532
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
533 534
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
535 536 537 538 539
  = 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
540 541 542 543
        ppr con
          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                         , ppr binds])
          <+> pprConArgs details
544
    else pprUserCon (unLoc con) details
545
pprPat (XPat x)               = ppr x
546

Ben Gamari's avatar
Ben Gamari committed
547

548 549
pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
           => con -> HsConPatDetails (GhcPass p) -> SDoc
550 551
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
552

553 554
pprConArgs :: (OutputableBndrId (GhcPass p))
           => HsConPatDetails (GhcPass p) -> SDoc
555 556 557
pprConArgs (PrefixCon pats) = sep (map (pprParendLPat appPrec) pats)
pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
                                  , pprParendLPat appPrec p2 ]
558 559
pprConArgs (RecCon rpats)   = ppr rpats

Adam Gundry's avatar
Adam Gundry committed
560
instance (Outputable arg)
561
      => Outputable (HsRecFields p arg) where
562
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
Ian Lynagh's avatar
Ian Lynagh committed
563
        = braces (fsep (punctuate comma (map ppr flds)))
564
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
Ian Lynagh's avatar
Ian Lynagh committed
565 566
        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
        where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
567
          dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))
568

569 570
instance (Outputable p, Outputable arg)
      => Outputable (HsRecField' p arg) where
Adam Gundry's avatar
Adam Gundry committed
571
  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
Ian Lynagh's avatar
Ian Lynagh committed
572
                    hsRecPun = pun })
573
    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
574

Adam Gundry's avatar
Adam Gundry committed
575

Austin Seipp's avatar
Austin Seipp committed
576 577 578 579 580 581 582
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
583

584
mkPrefixConPat :: DataCon -> [OutPat p] -> [Type] -> OutPat p
585
-- Make a vanilla Prefix constructor pattern
586
mkPrefixConPat dc pats tys
cactus's avatar
cactus committed
587
  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
Ian Lynagh's avatar
Ian Lynagh committed
588
                        pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
589
                        pat_arg_tys = tys, pat_wrap = idHsWrapper }
590

591
mkNilPat :: Type -> OutPat p
592
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
593

594
mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
595
mkCharLitPat src c = mkPrefixConPat charDataCon
596
                          [noLoc $ LitPat NoExt (HsCharPrim src c)] []
597

Austin Seipp's avatar
Austin Seipp committed
598 599 600 601 602 603
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
604

605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626
\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.

627
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
628 629
-}

630
isBangedLPat :: LPat p -> Bool
631
isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p
632 633
isBangedLPat (L _ (BangPat {})) = True
isBangedLPat _                  = False
634

635
looksLazyPatBind :: HsBind p -> Bool
636
-- Returns True of anything *except*
Austin Seipp's avatar
Austin Seipp committed
637
--     a StrictHsBind (as above) or
638 639
--     a VarPat
-- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
Richard Eisenberg's avatar
Richard Eisenberg committed
640 641 642 643 644 645 646
-- Looks through AbsBinds
looksLazyPatBind (PatBind { pat_lhs = p })
  = looksLazyLPat p
looksLazyPatBind (AbsBinds { abs_binds = binds })
  = anyBag (looksLazyPatBind . unLoc) binds
looksLazyPatBind _
  = False
647

648
looksLazyLPat :: LPat p -> Bool
649 650
looksLazyLPat (L _ (ParPat _ p))           = looksLazyLPat p
looksLazyLPat (L _ (AsPat _ _ p))          = looksLazyLPat p
651 652 653 654
looksLazyLPat (L _ (BangPat {}))           = False
looksLazyLPat (L _ (VarPat {}))            = False
looksLazyLPat (L _ (WildPat {}))           = False
looksLazyLPat _                            = True
655

656
isIrrefutableHsPat :: (OutputableBndrId p) => LPat p -> Bool
657 658
-- (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
659 660 661
--      (NB: this is not quite the same as the (silly) defn
--      in 3.17.2 of the Haskell 98 report.)
--
662 663 664 665 666 667
-- 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.
--
668 669 670 671
-- But if it returns True, the pattern is definitely irrefutable
isIrrefutableHsPat pat
  = go pat
  where
672
    go (L _ pat) = go1 pat
673

674 675 676
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
677 678 679 680 681 682 683 684
    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
685
                    -- See Note [Unboxed sum patterns aren't irrefutable]
686
    go1 (ListPat {})        = False
687

Ian Lynagh's avatar
Ian Lynagh committed
688
    go1 (ConPatIn {})       = False     -- Conservative
cactus's avatar
cactus committed
689
    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
Ian Lynagh's avatar
Ian Lynagh committed
690 691 692 693
        =  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
694 695
    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
        = False -- Conservative
696

697 698 699
    go1 (LitPat {})         = False
    go1 (NPat {})           = False
    go1 (NPlusKPat {})      = False
700

701 702 703
    -- We conservatively assume that no TH splices are irrefutable
    -- since we cannot know until the splice is evaluated.
    go1 (SplicePat {})      = False
704

705 706
    go1 (XPat {})           = False

707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728
{- 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!
-}

729 730 731 732 733 734 735 736 737 738 739 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
-- | @'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 (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
769

770 771 772 773 774
{-
% Collect all EvVars from all constructor patterns
-}

-- May need to add more cases
775
collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
776 777
collectEvVarsPats = unionManyBags . map collectEvVarsPat

778
collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
779 780
collectEvVarsLPat (L _ pat) = collectEvVarsPat pat

781
collectEvVarsPat :: Pat GhcTc -> Bag EvVar
782 783
collectEvVarsPat pat =
  case pat of
784 785 786 787
    LazyPat _ p      -> collectEvVarsLPat p
    AsPat _ _ p      -> collectEvVarsLPat p
    ParPat  _ p      -> collectEvVarsLPat p
    BangPat _ p      -> collectEvVarsLPat p
788
    ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps
789 790
    TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps
    SumPat _ p _ _   -> collectEvVarsLPat p
791
    ConPatOut {pat_dicts = dicts, pat_args  = args}
792
                     -> unionBags (listToBag dicts)
793 794 795
                                   $ unionManyBags
                                   $ map collectEvVarsLPat
                                   $ hsConPatArgs args
796 797 798 799
    SigPat  _ p      -> collectEvVarsLPat p
    CoPat _ _ p _    -> collectEvVarsPat  p
    ConPatIn _  _    -> panic "foldMapPatBag: ConPatIn"
    _other_pat       -> emptyBag