HsPat.hs 33.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

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

        mkPrefixConPat, mkCharLitPat, mkNilPat,
30

Richard Eisenberg's avatar
Richard Eisenberg committed
31
        looksLazyPatBind,
32
        isBangedLPat,
33
        hsPatNeedsParens,
34
        isCompoundPat, parenthesizeCompoundPat,
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
import PlaceHolder
54
-- others:
Ian Lynagh's avatar
Ian Lynagh committed
55
import PprCore          ( {- instance OutputableBndr TyVar -} )
56 57
import TysWiredIn
import Var
Adam Gundry's avatar
Adam Gundry committed
58
import RdrName ( RdrName )
Gergő Érdi's avatar
Gergő Érdi committed
59
import ConLike
60 61
import DataCon
import TyCon
Ian Lynagh's avatar
Ian Lynagh committed
62
import Outputable
63 64
import Type
import SrcLoc
65
import Bag -- collect ev vars from pats
66
import DynFlags( gopt, GeneralFlag(..) )
Adam Gundry's avatar
Adam Gundry committed
67
import Maybes
68
-- libraries:
69
import Data.Data hiding (TyCon,Fixity)
70

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

74
type LPat p = Located (Pat p)
75

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
204
        ------------ View patterns ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
205
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
206 207

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

gmainland's avatar
gmainland committed
215
        ------------ Pattern splices ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
216 217
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
  --        'ApiAnnotation.AnnClose' @')'@
218 219

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

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

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

241 242 243
  -- ^ Natural Pattern
  --
  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
244 245

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

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

        ------------ Pattern type signatures ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
258
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
259 260

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

        ------------ Pattern coercions (translation only) ---------------
269 270
  | CoPat       (XCoPat p)
                HsWrapper           -- Coercion Pattern
271 272 273 274
                                    -- 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
275 276
        -- During desugaring a (CoPat co pat) turns into a cast with 'co' on
        -- the scrutinee, followed by a match on 'pat'
277
    -- ^ Coercion Pattern
278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335

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

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

type instance XWildPat GhcPs = PlaceHolder
type instance XWildPat GhcRn = PlaceHolder
type instance XWildPat GhcTc = Type

type instance XVarPat  (GhcPass _) = PlaceHolder
type instance XLazyPat (GhcPass _) = PlaceHolder
type instance XAsPat   (GhcPass _) = PlaceHolder
type instance XParPat  (GhcPass _) = PlaceHolder
type instance XBangPat (GhcPass _) = PlaceHolder

-- 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`
type instance XListPat (GhcPass _) = PlaceHolder

type instance XTuplePat GhcPs = PlaceHolder
type instance XTuplePat GhcRn = PlaceHolder
type instance XTuplePat GhcTc = [Type]

type instance XSumPat GhcPs = PlaceHolder
type instance XSumPat GhcRn = PlaceHolder
type instance XSumPat GhcTc = [Type]

type instance XPArrPat GhcPs = PlaceHolder
type instance XPArrPat GhcRn = PlaceHolder
type instance XPArrPat GhcTc = Type

type instance XViewPat GhcPs = PlaceHolder
type instance XViewPat GhcRn = PlaceHolder
type instance XViewPat GhcTc = Type

type instance XSplicePat (GhcPass _) = PlaceHolder
type instance XLitPat    (GhcPass _) = PlaceHolder

type instance XNPat GhcPs = PlaceHolder
type instance XNPat GhcRn = PlaceHolder
type instance XNPat GhcTc = Type

type instance XNPlusKPat GhcPs = PlaceHolder
type instance XNPlusKPat GhcRn = PlaceHolder
type instance XNPlusKPat GhcTc = Type

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

type instance XCoPat  (GhcPass _) = PlaceHolder
type instance XXPat   (GhcPass _) = PlaceHolder

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

336

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

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

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

356

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

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

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

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

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

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

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

Adam Gundry's avatar
Adam Gundry committed
397

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

Adam Gundry's avatar
Adam Gundry committed
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 437 438 439 440 441 442 443 444 445 446 447 448

-- 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:
--
--     hsRecFieldLbl = Unambiguous "x" PlaceHolder :: AmbiguousFieldOcc RdrName
--
-- After the renamer, this will become:
--
--     hsRecFieldLbl = Ambiguous   "x" PlaceHolder :: AmbiguousFieldOcc Name
--
-- (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
449 450
--
-- See also Note [Disambiguating record fields] in TcExpr.
Adam Gundry's avatar
Adam Gundry committed
451

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

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

459 460
hsRecFieldSel :: HsRecField pass arg -> Located (XFieldOcc pass)
hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl
Adam Gundry's avatar
Adam Gundry committed
461

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

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

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

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

474

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

483
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where
484 485
    ppr = pprPat

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

495
pprParendLPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> SDoc
496 497
pprParendLPat (L _ p) = pprParendPat p

498
pprParendPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
499 500
pprParendPat p = sdocWithDynFlags $ \ dflags ->
                 if need_parens dflags p
501 502 503
                 then parens (pprPat p)
                 else  pprPat p
  where
504 505 506 507 508 509 510
    need_parens dflags p
      | CoPat {} <- p = gopt Opt_PrintTypecheckerElaboration dflags
      | otherwise     = hsPatNeedsParens p
      -- 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 (GhcPass p)) => Pat (GhcPass p) -> SDoc
513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536
pprPat (VarPat _ (L _ var))     = pprPatBndr var
pprPat (WildPat _)              = char '_'
pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat pat
pprPat (BangPat _ pat)          = char '!' <> pprParendLPat pat
pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',
                                        pprParendLPat pat]
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
pprPat (CoPat _ co pat _)       = pprHsWrapper co (\parens
                                                   -> if parens
                                                        then pprParendPat pat
                                                        else pprPat pat)
pprPat (SigPat ty pat)          = ppr pat <+> dcolon <+> ppr ty
pprPat (ListPat _ pats _ _)     = brackets (interpp'SP pats)
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
537 538
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
539 540 541 542 543
  = 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
Gergő Érdi's avatar
Gergő Érdi committed
544 545 546 547
        ppr con
          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                         , ppr binds])
          <+> pprConArgs details
548
    else pprUserCon (unLoc con) details
549
pprPat (XPat x)               = ppr x
550

Ben Gamari's avatar
Ben Gamari committed
551

552 553
pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
           => con -> HsConPatDetails (GhcPass p) -> SDoc
554 555
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
556

557 558
pprConArgs :: (OutputableBndrId (GhcPass p))
           => HsConPatDetails (GhcPass p) -> SDoc
559 560
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
561 562
pprConArgs (RecCon rpats)   = ppr rpats

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

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

Adam Gundry's avatar
Adam Gundry committed
578

Austin Seipp's avatar
Austin Seipp committed
579 580 581 582 583 584 585
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
586

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

594
mkNilPat :: Type -> OutPat p
595
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
596

597
mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
598
mkCharLitPat src c = mkPrefixConPat charDataCon
599
                          [noLoc $ LitPat PlaceHolder (HsCharPrim src c)] []
600

Austin Seipp's avatar
Austin Seipp committed
601 602 603 604 605 606
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
607

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

630
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
631 632
-}

633
isBangedLPat :: LPat p -> Bool
634
isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p
635 636
isBangedLPat (L _ (BangPat {})) = True
isBangedLPat _                  = False
637

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

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

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

677 678 679
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
680 681 682 683 684 685 686 687
    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
688
                    -- See Note [Unboxed sum patterns aren't irrefutable]
689
    go1 (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
690
    go1 (PArrPat {})        = False     -- ?
691

Ian Lynagh's avatar
Ian Lynagh committed
692
    go1 (ConPatIn {})       = False     -- Conservative
Gergő Érdi's avatar
Gergő Érdi committed
693
    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
Ian Lynagh's avatar
Ian Lynagh committed
694 695 696 697
        =  isJust (tyConSingleDataCon_maybe (dataConTyCon con))
           -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because
           -- the latter is false of existentials. See Trac #4439
        && all go (hsConPatArgs details)
Gergő Érdi's avatar
Gergő Érdi committed
698 699
    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
        = False -- Conservative
700

701 702 703
    go1 (LitPat {})         = False
    go1 (NPat {})           = False
    go1 (NPlusKPat {})      = False
704

705 706 707
    -- We conservatively assume that no TH splices are irrefutable
    -- since we cannot know until the splice is evaluated.
    go1 (SplicePat {})      = False
708

709 710
    go1 (XPat {})           = False

711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732
{- 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!
-}

733 734
-- | Returns 'True' if a pattern must be parenthesized in order to parse
-- (e.g., the @(x :: Int)@ in @f (x :: Int) = x@).
735
hsPatNeedsParens :: Pat a -> Bool
736
hsPatNeedsParens (NPlusKPat {})      = True
gmainland's avatar
gmainland committed
737
hsPatNeedsParens (SplicePat {})      = False
738 739
hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
740
hsPatNeedsParens (SigPat {})         = True
741
hsPatNeedsParens (ViewPat {})        = True
742
hsPatNeedsParens (CoPat _ _ p _)     = hsPatNeedsParens p
743 744 745 746 747 748 749
hsPatNeedsParens (WildPat {})        = False
hsPatNeedsParens (VarPat {})         = False
hsPatNeedsParens (LazyPat {})        = False
hsPatNeedsParens (BangPat {})        = False
hsPatNeedsParens (ParPat {})         = False
hsPatNeedsParens (AsPat {})          = False
hsPatNeedsParens (TuplePat {})       = False
750
hsPatNeedsParens (SumPat {})         = False
751
hsPatNeedsParens (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
752 753 754
hsPatNeedsParens (PArrPat {})        = False
hsPatNeedsParens (LitPat {})         = False
hsPatNeedsParens (NPat {})           = False
755
hsPatNeedsParens (XPat {})           = True -- conservative default
756

757 758
-- | Returns 'True' if a constructor pattern must be parenthesized in order
-- to parse.
759
conPatNeedsParens :: HsConDetails a b -> Bool
Alan Zimmerman's avatar
Alan Zimmerman committed
760 761 762
conPatNeedsParens (PrefixCon {}) = False
conPatNeedsParens (InfixCon {})  = True
conPatNeedsParens (RecCon {})    = False
763

764 765 766 767 768 769 770 771 772 773 774 775 776
-- | Returns 'True' for compound patterns that need parentheses when used in
-- an argument position.
--
-- Note that this is different from 'hsPatNeedsParens', which only says if
-- a pattern needs to be parenthesized to parse in /any/ position, whereas
-- 'isCompountPat' says if a pattern needs to be parenthesized in an /argument/
-- position. In other words, @'hsPatNeedsParens' x@ implies
-- @'isCompoundPat' x@, but not necessarily the other way around.
isCompoundPat :: Pat a -> Bool
isCompoundPat (NPlusKPat {})       = True
isCompoundPat (SplicePat {})       = False
isCompoundPat (ConPatIn _ ds)      = isCompoundConPat ds
isCompoundPat p@(ConPatOut {})     = isCompoundConPat (pat_args p)
777
isCompoundPat (SigPat {})          = True
778
isCompoundPat (ViewPat {})         = True
779
isCompoundPat (CoPat _ _ p _)      = isCompoundPat p
780 781 782 783 784 785 786 787 788 789
isCompoundPat (WildPat {})         = False
isCompoundPat (VarPat {})          = False
isCompoundPat (LazyPat {})         = False
isCompoundPat (BangPat {})         = False
isCompoundPat (ParPat {})          = False
isCompoundPat (AsPat {})           = False
isCompoundPat (TuplePat {})        = False
isCompoundPat (SumPat {})          = False
isCompoundPat (ListPat {})         = False
isCompoundPat (PArrPat {})         = False
790 791 792
isCompoundPat (LitPat _ p)         = isCompoundHsLit p
isCompoundPat (NPat _ (L _ p) _ _) = isCompoundHsOverLit p
isCompoundPat (XPat {})            = False -- Assumption
793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808

-- | Returns 'True' for compound constructor patterns that need parentheses
-- when used in an argument position.
--
-- Note that this is different from 'conPatNeedsParens', which only says if
-- a constructor pattern needs to be parenthesized to parse in /any/ position,
-- whereas 'isCompountConPat' says if a pattern needs to be parenthesized in an
-- /argument/ position. In other words, @'conPatNeedsParens' x@ implies
-- @'isCompoundConPat' x@, but not necessarily the other way around.
isCompoundConPat :: HsConDetails a b -> Bool
isCompoundConPat (PrefixCon args) = not (null args)
isCompoundConPat (InfixCon {})    = True
isCompoundConPat (RecCon {})      = False

-- | @'parenthesizeCompoundPat' p@ checks if @'isCompoundPat' p@ is true, and
-- if so, surrounds @p@ with a 'ParPat'. Otherwise, it simply returns @p@.
809
parenthesizeCompoundPat :: LPat (GhcPass p) -> LPat (GhcPass p)
810
parenthesizeCompoundPat lp@(L loc p)
811
  | isCompoundPat p = L loc (ParPat PlaceHolder lp)
812 813
  | otherwise       = lp

814 815 816 817 818
{-
% Collect all EvVars from all constructor patterns
-}

-- May need to add more cases
819
collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
820 821
collectEvVarsPats = unionManyBags . map collectEvVarsPat

822
collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
823 824
collectEvVarsLPat (L _ pat) = collectEvVarsPat pat

825
collectEvVarsPat :: Pat GhcTc -> Bag EvVar
826 827
collectEvVarsPat pat =
  case pat of
828 829 830 831 832 833 834 835
    LazyPat _ p      -> collectEvVarsLPat p
    AsPat _ _ p      -> collectEvVarsLPat p
    ParPat  _ p      -> collectEvVarsLPat p
    BangPat _ p      -> collectEvVarsLPat p
    ListPat _ ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
    TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps
    SumPat _ p _ _   -> collectEvVarsLPat p
    PArrPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps
836
    ConPatOut {pat_dicts = dicts, pat_args  = args}
837
                     -> unionBags (listToBag dicts)
838 839 840
                                   $ unionManyBags
                                   $ map collectEvVarsLPat
                                   $ hsConPatArgs args
841 842 843 844
    SigPat  _ p      -> collectEvVarsLPat p
    CoPat _ _ p _    -> collectEvVarsPat  p
    ConPatIn _  _    -> panic "foldMapPatBag: ConPatIn"
    _other_pat       -> emptyBag