Pat.hs 31.7 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
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
Sylvain Henry's avatar
Sylvain Henry committed
15
                                      -- in module GHC.Hs.PlaceHolder
16
{-# LANGUAGE ConstraintKinds #-}
Adam Gundry's avatar
Adam Gundry committed
17
{-# LANGUAGE TypeFamilies #-}
18 19
{-# LANGUAGE ViewPatterns      #-}
{-# LANGUAGE FlexibleInstances #-}
20

Sylvain Henry's avatar
Sylvain Henry committed
21
module GHC.Hs.Pat (
Ian Lynagh's avatar
Ian Lynagh committed
22
        Pat(..), InPat, OutPat, LPat,
23
        ListPatTc(..),
24

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

        mkPrefixConPat, mkCharLitPat, mkNilPat,
33

Richard Eisenberg's avatar
Richard Eisenberg committed
34
        looksLazyPatBind,
35
        isBangedLPat,
36
        patNeedsParens, parenthesizePat,
37
        isIrrefutableHsPat,
38

39
        collectEvVarsPat, collectEvVarsPats,
40

41
        pprParendLPat, pprConArgs
42 43
    ) where

44 45
import GhcPrelude

Sylvain Henry's avatar
Sylvain Henry committed
46
import {-# SOURCE #-} GHC.Hs.Expr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice)
sof's avatar
sof committed
47

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

72 73
type InPat p  = LPat p        -- No 'Out' constructors
type OutPat p = LPat p        -- No 'In' constructors
74

75
type LPat p = XRec p Pat
76

77 78 79
-- | Pattern
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
80 81

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

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

Sylvain Henry's avatar
Sylvain Henry committed
92
                             -- See Note [Located RdrNames] in GHC.Hs.Expr
93 94
  | LazyPat     (XLazyPat p)
                (LPat p)                -- ^ Lazy Pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
95 96
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'

97 98
    -- For details on above see note [Api annotations] in ApiAnnotation

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

103 104
    -- For details on above see note [Api annotations] in ApiAnnotation

105 106
  | ParPat      (XParPat p)
                (LPat p)                -- ^ Parenthesised pattern
Sylvain Henry's avatar
Sylvain Henry committed
107
                                        -- See Note [Parens in HsSyn] in GHC.Hs.Expr
Alan Zimmerman's avatar
Alan Zimmerman committed
108 109
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
    --                                    'ApiAnnotation.AnnClose' @')'@
110 111

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

116 117
    -- For details on above see note [Api annotations] in ApiAnnotation

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

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

130 131
    -- For details on above see note [Api annotations] in ApiAnnotation

132 133 134
  | TuplePat    (XTuplePat p)
                  -- after typechecking, holds the types of the tuple components
                [LPat p]         -- Tuple sub-patterns
135
                Boxity           -- UnitPat is TuplePat []
136 137 138
        -- 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.
139
        -- But it's essential
Ian Lynagh's avatar
Ian Lynagh committed
140 141 142 143 144 145 146 147 148 149
        --      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
150 151
        -- (June 14: I'm not sure this comment is right; the sub-patterns
        --           will be wrapped in CoPats, no?)
152 153 154
    -- ^ Tuple sub-patterns
    --
    -- - 'ApiAnnotation.AnnKeywordId' :
Alan Zimmerman's avatar
Alan Zimmerman committed
155 156
    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
Ian Lynagh's avatar
Ian Lynagh committed
157

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

170
    -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
171 172

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

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

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

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

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

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

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

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

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

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

235 236 237
  -- ^ Natural Pattern
  --
  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
238 239

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

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

        ------------ Pattern type signatures ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
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 258 259
                    (LHsSigWcType (NoGhcTc p)) --  Signature can bind both
                                               --  kind and type vars

260
    -- ^ Pattern with a type signature
Ian Lynagh's avatar
Ian Lynagh committed
261 262

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

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

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

279 280 281 282 283
data ListPatTc
  = ListPatTc
      Type                             -- The type of the elements
      (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax

284 285
type instance XWildPat GhcPs = NoExtField
type instance XWildPat GhcRn = NoExtField
286 287
type instance XWildPat GhcTc = Type

288 289 290 291 292
type instance XVarPat  (GhcPass _) = NoExtField
type instance XLazyPat (GhcPass _) = NoExtField
type instance XAsPat   (GhcPass _) = NoExtField
type instance XParPat  (GhcPass _) = NoExtField
type 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`
297
type instance XListPat GhcPs = NoExtField
298 299
type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn)
type instance XListPat GhcTc = ListPatTc
300

301 302
type instance XTuplePat GhcPs = NoExtField
type instance XTuplePat GhcRn = NoExtField
303 304
type instance XTuplePat GhcTc = [Type]

305 306
type instance XSumPat GhcPs = NoExtField
type instance XSumPat GhcRn = NoExtField
307 308
type instance XSumPat GhcTc = [Type]

309 310
type instance XViewPat GhcPs = NoExtField
type instance XViewPat GhcRn = NoExtField
311 312
type instance XViewPat GhcTc = Type

313 314
type instance XSplicePat (GhcPass _) = NoExtField
type instance XLitPat    (GhcPass _) = NoExtField
315

316 317
type instance XNPat GhcPs = NoExtField
type instance XNPat GhcRn = NoExtField
318 319
type instance XNPat GhcTc = Type

320 321
type instance XNPlusKPat GhcPs = NoExtField
type instance XNPlusKPat GhcRn = NoExtField
322 323
type instance XNPlusKPat GhcTc = Type

324 325
type instance XSigPat GhcPs = NoExtField
type instance XSigPat GhcRn = NoExtField
326 327
type instance XSigPat GhcTc = Type

328
type instance XCoPat  (GhcPass _) = NoExtField
329

330
type instance XXPat   (GhcPass _) = NoExtCon
331 332 333

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

334

335
-- | Haskell Constructor Pattern Details
336
type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
337

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

343 344
-- | Haskell Record Fields
--
345 346
-- HsRecFields is used only for patterns and expressions (not data type
-- declarations)
347
data HsRecFields p arg         -- A bunch of record fields
Ian Lynagh's avatar
Ian Lynagh committed
348 349
                                --      { x = 3, y = True }
        -- 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 356 357 358
-- Note [DotDot fields]
-- ~~~~~~~~~~~~~~~~~~~~
-- The rec_dotdot field means this:
--   Nothing => the normal case
Ian Lynagh's avatar
Ian Lynagh committed
359
--   Just n  => the group uses ".." notation,
360
--
Ian Lynagh's avatar
Ian Lynagh committed
361
-- In the latter case:
362 363 364
--
--   *before* renamer: rec_flds are exactly the n user-written fields
--
Ian Lynagh's avatar
Ian Lynagh committed
365 366 367
--   *after* renamer:  rec_flds includes *all* fields, with
--                     the first 'n' being the user-written ones
--                     and the remainder being 'filled in' implicitly
368

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

-- | Located Haskell Record Field
373
type LHsRecField  p arg = Located (HsRecField  p arg)
374 375

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

378
-- | Haskell Record Field
379
type HsRecField    p arg = HsRecField' (FieldOcc p) arg
380 381

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

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

Adam Gundry's avatar
Adam Gundry committed
395

396 397 398
-- Note [Punning]
-- ~~~~~~~~~~~~~~
-- If you write T { x, y = v+1 }, the HsRecFields will be
Ian Lynagh's avatar
Ian Lynagh committed
399 400 401
--      HsRecField x x True ...
--      HsRecField y (v+1) False ...
-- 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 406
--
-- If the original field was qualified, we un-qualify it, thus
--    T { A.x } means T { A.x = x }
407

Adam Gundry's avatar
Adam Gundry committed
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 434 435 436

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

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

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

457
hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass)
458
hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl
Adam Gundry's avatar
Adam Gundry committed
459

460
hsRecFieldId :: HsRecField GhcTc arg -> Located Id
Adam Gundry's avatar
Adam Gundry committed
461 462
hsRecFieldId = hsRecFieldSel

463
hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName
Adam Gundry's avatar
Adam Gundry committed
464 465
hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl

466
hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id
467
hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc
Adam Gundry's avatar
Adam Gundry committed
468

469
hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
Adam Gundry's avatar
Adam Gundry committed
470 471
hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl

472

Austin Seipp's avatar
Austin Seipp committed
473 474 475 476 477 478 479
{-
************************************************************************
*                                                                      *
*              Printing patterns
*                                                                      *
************************************************************************
-}
480

481
instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
482 483
    ppr = pprPat

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

493
pprParendLPat :: (OutputableBndrId p)
494
              => PprPrec -> LPat (GhcPass p) -> SDoc
495
pprParendLPat p = pprParendPat p . unLoc
496

497
pprParendPat :: (OutputableBndrId p)
498 499 500 501 502
             => PprPrec -> Pat (GhcPass p) -> SDoc
pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
                     if need_parens dflags pat
                     then parens (pprPat pat)
                     else  pprPat pat
503
  where
504 505 506
    need_parens dflags pat
      | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags
      | otherwise       = patNeedsParens p pat
507 508 509 510
      -- 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.
511

512
pprPat :: (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
513
pprPat (VarPat _ lvar)          = pprPatBndr (unLoc lvar)
514
pprPat (WildPat _)              = char '_'
515 516
pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat appPrec pat
pprPat (BangPat _ pat)          = char '!' <> pprParendLPat appPrec pat
517
pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',
518
                                        pprParendLPat appPrec pat]
519 520 521 522 523 524 525
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
526 527 528 529
pprPat (CoPat _ co pat _)       = pprHsWrapper co $ \parens
                                            -> if parens
                                                 then pprParendPat appPrec pat
                                                 else pprPat pat
530
pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr ty
531
pprPat (ListPat _ pats)         = brackets (interpp'SP pats)
532 533 534 535 536 537 538 539
pprPat (TuplePat _ pats bx)
    -- Special-case unary boxed tuples so that they are pretty-printed as
    -- `Unit x`, not `(x)`
  | [pat] <- pats
  , Boxed <- bx
  = hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat]
  | otherwise
  = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
540 541
pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
pprPat (ConPatIn con details)   = pprUserCon (unLoc con) details
542 543 544 545 546
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
547 548 549 550 551
  = 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
552 553 554 555
        ppr con
          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                         , ppr binds])
          <+> pprConArgs details
556
    else pprUserCon (unLoc con) details
557
pprPat (XPat n)                 = noExtCon n
558

Ben Gamari's avatar
Ben Gamari committed
559

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

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

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

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

Adam Gundry's avatar
Adam Gundry committed
587

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

596 597
mkPrefixConPat :: DataCon ->
                  [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p)
598
-- Make a vanilla Prefix constructor pattern
599
mkPrefixConPat dc pats tys
600 601 602 603 604 605 606 607 608
  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc)
                      , pat_tvs = []
                      , pat_dicts = []
                      , pat_binds = emptyTcEvBinds
                      , pat_args = PrefixCon pats
                      , pat_arg_tys = tys
                      , pat_wrap = idHsWrapper }

mkNilPat :: Type -> OutPat (GhcPass p)
609
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
610

611
mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
612
mkCharLitPat src c = mkPrefixConPat charDataCon
613
                          [noLoc $ LitPat noExtField (HsCharPrim src c)] []
614

Austin Seipp's avatar
Austin Seipp committed
615 616 617 618 619 620
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
621

622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643
\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.

644
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
645 646
-}

647 648
isBangedLPat :: LPat (GhcPass p) -> Bool
isBangedLPat = isBangedPat . unLoc
649

650 651 652 653 654 655
isBangedPat :: Pat (GhcPass p) -> Bool
isBangedPat (ParPat _ p) = isBangedLPat p
isBangedPat (BangPat {}) = True
isBangedPat _            = False

looksLazyPatBind :: HsBind (GhcPass p) -> Bool
656
-- Returns True of anything *except*
Austin Seipp's avatar
Austin Seipp committed
657
--     a StrictHsBind (as above) or
658 659
--     a VarPat
-- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
Richard Eisenberg's avatar
Richard Eisenberg committed
660 661 662 663 664 665 666
-- Looks through AbsBinds
looksLazyPatBind (PatBind { pat_lhs = p })
  = looksLazyLPat p
looksLazyPatBind (AbsBinds { abs_binds = binds })
  = anyBag (looksLazyPatBind . unLoc) binds
looksLazyPatBind _
  = False
667

668 669 670 671 672 673 674 675 676 677
looksLazyLPat :: LPat (GhcPass p) -> Bool
looksLazyLPat = looksLazyPat . unLoc

looksLazyPat :: Pat (GhcPass p) -> Bool
looksLazyPat (ParPat _ p)  = looksLazyLPat p
looksLazyPat (AsPat _ _ p) = looksLazyLPat p
looksLazyPat (BangPat {})  = False
looksLazyPat (VarPat {})   = False
looksLazyPat (WildPat {})  = False
looksLazyPat _             = True
678

679
isIrrefutableHsPat :: (OutputableBndrId p) => LPat (GhcPass p) -> Bool
680 681
-- (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
682 683 684
--      (NB: this is not quite the same as the (silly) defn
--      in 3.17.2 of the Haskell 98 report.)
--
685 686 687 688
-- 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
689
-- tuple patterns are considered irrefutable at the renamer stage.
690
--
691
-- But if it returns True, the pattern is definitely irrefutable
692 693
isIrrefutableHsPat
  = goL
694
  where
695 696 697 698 699 700 701 702 703 704 705 706 707
    goL = go . unLoc

    go (WildPat {})        = True
    go (VarPat {})         = True
    go (LazyPat {})        = True
    go (BangPat _ pat)     = goL pat
    go (CoPat _ _ pat _)   = go  pat
    go (ParPat _ pat)      = goL pat
    go (AsPat _ _ pat)     = goL pat
    go (ViewPat _ _ pat)   = goL pat
    go (SigPat _ pat _)    = goL pat
    go (TuplePat _ pats _) = all goL pats
    go (SumPat {})         = False
708
                    -- See Note [Unboxed sum patterns aren't irrefutable]
709 710 711 712
    go (ListPat {})        = False

    go (ConPatIn {})       = False     -- Conservative
    go (ConPatOut
713
        { pat_con  = L _ (RealDataCon con)
714 715 716 717
        , pat_args = details })
                           =
      isJust (tyConSingleDataCon_maybe (dataConTyCon con))
      -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because
718
      -- the latter is false of existentials. See #4439
719 720
      && all goL (hsConPatArgs details)
    go (ConPatOut
721
        { pat_con = L _ (PatSynCon _pat) })
722 723 724 725
                           = False -- Conservative
    go (LitPat {})         = False
    go (NPat {})           = False
    go (NPlusKPat {})      = False
726

727 728
    -- We conservatively assume that no TH splices are irrefutable
    -- since we cannot know until the splice is evaluated.
729
    go (SplicePat {})      = False
730

731
    go (XPat {})           = False
732

733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754
{- 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!
-}

755 756 757 758 759
-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
-- parentheses under precedence @p@.
patNeedsParens :: PprPrec -> Pat p -> Bool
patNeedsParens p = go
  where
760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778
    go (NPlusKPat {})    = p > opPrec
    go (SplicePat {})    = False
    go (ConPatIn _ ds)   = conPatNeedsParens p ds
    go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp)
    go (SigPat {})       = p >= sigPrec
    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 _ lol _ _)  = hsOverLitNeedsParens p (unLoc lol)
    go (XPat {})         = True -- conservative default
779 780 781 782 783 784 785 786 787 788 789 790 791

-- | @'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)
792 793
parenthesizePat p lpat@(L loc pat)
  | patNeedsParens p pat = L loc (ParPat noExtField lpat)
794
  | otherwise            = lpat
795

796 797 798 799 800
{-
% Collect all EvVars from all constructor patterns
-}

-- May need to add more cases
801
collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
802 803
collectEvVarsPats = unionManyBags . map collectEvVarsPat

804
collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
805
collectEvVarsLPat = collectEvVarsPat . unLoc
806

807
collectEvVarsPat :: Pat GhcTc -> Bag EvVar
808 809
collectEvVarsPat pat =
  case pat of
810 811 812 813
    LazyPat _ p      -> collectEvVarsLPat p
    AsPat _ _ p      -> collectEvVarsLPat p
    ParPat  _ p      -> collectEvVarsLPat p
    BangPat _ p      -> collectEvVarsLPat p
814
    ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps
815 816
    TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps
    SumPat _ p _ _   -> collectEvVarsLPat p
817
    ConPatOut {pat_dicts = dicts, pat_args  = args}
818
                     -> unionBags (listToBag dicts)
819 820 821
                                   $ unionManyBags
                                   $ map collectEvVarsLPat
                                   $ hsConPatArgs args
822
    SigPat  _ p _    -> collectEvVarsLPat p
823 824 825
    CoPat _ _ p _    -> collectEvVarsPat  p
    ConPatIn _  _    -> panic "foldMapPatBag: ConPatIn"
    _other_pat       -> emptyBag