HsPat.hs 29.1 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
        isIrrefutableHsPat,
35

36 37
        collectEvVarsPats,

38
        pprParendLPat, pprConArgs
39 40
    ) where

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

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

67 68
type InPat p  = LPat p        -- No 'Out' constructors
type OutPat p = LPat p        -- No 'In' constructors
69

70
type LPat p = Located (Pat p)
71

72 73 74
-- | Pattern
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
75 76

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

83 84
       -- AZ:TODO above comment needs to be updated
  | VarPat      (Located (IdP p))  -- ^ Variable Pattern
85

86
                             -- See Note [Located RdrNames] in HsExpr
87
  | LazyPat     (LPat p)                -- ^ Lazy Pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
88 89
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'

90 91
    -- For details on above see note [Api annotations] in ApiAnnotation

92
  | AsPat       (Located (IdP p)) (LPat p)    -- ^ As pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
93 94
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'

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

97
  | ParPat      (LPat p)                -- ^ Parenthesised pattern
Ian Lynagh's avatar
Ian Lynagh committed
98
                                        -- See Note [Parens in HsSyn] in HsExpr
Alan Zimmerman's avatar
Alan Zimmerman committed
99 100
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
    --                                    'ApiAnnotation.AnnClose' @')'@
101 102

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

106 107
    -- For details on above see note [Api annotations] in ApiAnnotation

Ian Lynagh's avatar
Ian Lynagh committed
108
        ------------ Lists, tuples, arrays ---------------
109 110 111
  | ListPat     [LPat p]
                (PostTc p Type)                      -- The type of the elements
                (Maybe (PostTc p Type, SyntaxExpr p)) -- For rebindable syntax
112 113 114
                   -- For OverloadedLists a Just (ty,fn) gives
                   -- overall type of the pattern, and the toList
                   -- function to convert the scrutinee to a list value
115 116 117
    -- ^ Syntactic List
    --
    -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
Alan Zimmerman's avatar
Alan Zimmerman committed
118
    --                                    'ApiAnnotation.AnnClose' @']'@
Ian Lynagh's avatar
Ian Lynagh committed
119

120 121
    -- For details on above see note [Api annotations] in ApiAnnotation

122
  | TuplePat    [LPat p]         -- Tuple sub-patterns
123
                Boxity           -- UnitPat is TuplePat []
124
                [PostTc p Type]  -- [] before typechecker, filled in afterwards
125
                                 -- with the types of the tuple components
126
        -- You might think that the PostTc p Type was redundant, because we can
127 128
        -- get the pattern type by getting the types of the sub-patterns.
        -- But it's essential
Ian Lynagh's avatar
Ian Lynagh committed
129 130 131 132 133 134 135 136 137 138
        --      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
139 140
        -- (June 14: I'm not sure this comment is right; the sub-patterns
        --           will be wrapped in CoPats, no?)
141 142 143
    -- ^ Tuple sub-patterns
    --
    -- - 'ApiAnnotation.AnnKeywordId' :
Alan Zimmerman's avatar
Alan Zimmerman committed
144 145
    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
Ian Lynagh's avatar
Ian Lynagh committed
146

147
  | SumPat      (LPat p)           -- Sum sub-pattern
148
                ConTag             -- Alternative (one-based)
149
                Arity              -- Arity (INVARIANT: ≥ 2)
150
                (PostTc p [Type])  -- PlaceHolder before typechecker, filled in
151 152
                                   -- afterwards with the types of the
                                   -- alternative
153 154 155
    -- ^ Anonymous sum pattern
    --
    -- - 'ApiAnnotation.AnnKeywordId' :
156 157 158
    --            'ApiAnnotation.AnnOpen' @'(#'@,
    --            'ApiAnnotation.AnnClose' @'#)'@

159
    -- For details on above see note [Api annotations] in ApiAnnotation
160 161
  | PArrPat     [LPat p]                -- Syntactic parallel array
                (PostTc p Type)         -- The type of the elements
Alan Zimmerman's avatar
Alan Zimmerman committed
162 163
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
    --                                    'ApiAnnotation.AnnClose' @':]'@
Ian Lynagh's avatar
Ian Lynagh committed
164

165
    -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
166
        ------------ Constructor patterns ---------------
167 168
  | ConPatIn    (Located (IdP p))
                (HsConPatDetails p)
169
    -- ^ Constructor Pattern In
170

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

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

Ian Lynagh's avatar
Ian Lynagh committed
184
        pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries
185
        pat_args  :: HsConPatDetails p,
Gergő Érdi's avatar
Gergő Érdi committed
186
        pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
187 188
                                        -- Only relevant for pattern-synonyms;
                                        --   ignored for data cons
189
    }
190
    -- ^ Constructor Pattern Out
191

Ian Lynagh's avatar
Ian Lynagh committed
192
        ------------ View patterns ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
193
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
194 195

  -- For details on above see note [Api annotations] in ApiAnnotation
196 197 198
  | ViewPat       (LHsExpr p)
                  (LPat p)
                  (PostTc p Type)   -- The overall type of the pattern
199 200
                                    -- (= the argument type of the view function)
                                    -- for hsPatType.
201
    -- ^ View Pattern
202

gmainland's avatar
gmainland committed
203
        ------------ Pattern splices ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
204 205
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
  --        'ApiAnnotation.AnnClose' @')'@
206 207

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

Ian Lynagh's avatar
Ian Lynagh committed
210
        ------------ Literal and n+k patterns ---------------
211
  | LitPat          (HsLit p)           -- ^ Literal Pattern
212
                                        -- Used for *non-overloaded* literal patterns:
Ian Lynagh's avatar
Ian Lynagh committed
213 214
                                        -- Int#, Char#, Int, Char, String, etc.

215 216
  | NPat                -- Natural Pattern
                        -- Used for all overloaded literals,
Ian Lynagh's avatar
Ian Lynagh committed
217
                        -- including overloaded strings with -XOverloadedStrings
218 219 220 221 222 223 224 225
                    (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
                    (PostTc p Type)      -- Overall type of pattern. Might be
                                         -- different than the literal's type
                                         -- if (==) or negate changes the type
Ian Lynagh's avatar
Ian Lynagh committed
226

227 228 229
  -- ^ Natural Pattern
  --
  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
230 231

  -- For details on above see note [Api annotations] in ApiAnnotation
232 233 234
  | NPlusKPat       (Located (IdP p))        -- n+k pattern
                    (Located (HsOverLit p))  -- It'll always be an HsIntegral
                    (HsOverLit p)       -- See Note [NPlusK patterns] in TcPat
235 236 237
                     -- NB: This could be (PostTc ...), but that induced a
                     -- a new hs-boot file. Not worth it.

238 239 240
                    (SyntaxExpr p)   -- (>=) function, of type t1->t2->Bool
                    (SyntaxExpr p)   -- Name of '-' (see RnEnv.lookupSyntaxName)
                    (PostTc p Type)  -- Type of overall pattern
241
  -- ^ n+k pattern
Ian Lynagh's avatar
Ian Lynagh committed
242 243

        ------------ Pattern type signatures ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
244
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
245 246

  -- For details on above see note [Api annotations] in ApiAnnotation
247 248
  | SigPatIn        (LPat p)                  -- Pattern with a type signature
                    (LHsSigWcType p)          -- Signature can bind both
249
                                              -- kind and type vars
250
    -- ^ Pattern with a type signature
Ian Lynagh's avatar
Ian Lynagh committed
251

252
  | SigPatOut       (LPat p)
Ian Lynagh's avatar
Ian Lynagh committed
253
                    Type
254
    -- ^ Pattern with a type signature
Ian Lynagh's avatar
Ian Lynagh committed
255 256

        ------------ Pattern coercions (translation only) ---------------
257 258 259 260 261
  | CoPat       HsWrapper           -- Coercion Pattern
                                    -- 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
262 263
        -- During desugaring a (CoPat co pat) turns into a cast with 'co' on
        -- the scrutinee, followed by a match on 'pat'
264
    -- ^ Coercion Pattern
265
deriving instance (DataId p) => Data (Pat p)
266

267
-- | Haskell Constructor Pattern Details
268
type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
269

270
hsConPatArgs :: HsConPatDetails p -> [LPat p]
271
hsConPatArgs (PrefixCon ps)   = ps
272
hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs)
273 274
hsConPatArgs (InfixCon p1 p2) = [p1,p2]

275 276
-- | Haskell Record Fields
--
277 278
-- HsRecFields is used only for patterns and expressions (not data type
-- declarations)
279
data HsRecFields p arg         -- A bunch of record fields
Ian Lynagh's avatar
Ian Lynagh committed
280 281
                                --      { x = 3, y = True }
        -- Used for both expressions and patterns
282
  = HsRecFields { rec_flds   :: [LHsRecField p arg],
Ian Lynagh's avatar
Ian Lynagh committed
283
                  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
284
  deriving (Functor, Foldable, Traversable)
285
deriving instance (DataId p, Data arg) => Data (HsRecFields p arg)
286

287

288 289 290 291
-- Note [DotDot fields]
-- ~~~~~~~~~~~~~~~~~~~~
-- The rec_dotdot field means this:
--   Nothing => the normal case
Ian Lynagh's avatar
Ian Lynagh committed
292
--   Just n  => the group uses ".." notation,
293
--
Ian Lynagh's avatar
Ian Lynagh committed
294
-- In the latter case:
295 296 297
--
--   *before* renamer: rec_flds are exactly the n user-written fields
--
Ian Lynagh's avatar
Ian Lynagh committed
298 299 300
--   *after* renamer:  rec_flds includes *all* fields, with
--                     the first 'n' being the user-written ones
--                     and the remainder being 'filled in' implicitly
301

302
-- | Located Haskell Record Field
303
type LHsRecField' p arg = Located (HsRecField' p arg)
304 305

-- | Located Haskell Record Field
306
type LHsRecField  p arg = Located (HsRecField  p arg)
307 308

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

311
-- | Haskell Record Field
312
type HsRecField    p arg = HsRecField' (FieldOcc p) arg
313 314

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

317 318 319
-- | Haskell Record Field
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
Adam Gundry's avatar
Adam Gundry committed
320
--
321
-- For details on above see note [Api annotations] in ApiAnnotation
Adam Gundry's avatar
Adam Gundry committed
322 323 324 325
data HsRecField' id arg = HsRecField {
        hsRecFieldLbl :: Located id,
        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning
        hsRecPun      :: Bool           -- ^ Note [Punning]
326
  } deriving (Data, Functor, Foldable, Traversable)
327

Adam Gundry's avatar
Adam Gundry committed
328

329 330 331
-- Note [Punning]
-- ~~~~~~~~~~~~~~
-- If you write T { x, y = v+1 }, the HsRecFields will be
Ian Lynagh's avatar
Ian Lynagh committed
332 333 334
--      HsRecField x x True ...
--      HsRecField y (v+1) False ...
-- That is, for "punned" field x is expanded (in the renamer)
335
-- to x=x; but with a punning flag so we can detect it later
336
-- (e.g. when pretty printing)
337 338 339
--
-- If the original field was qualified, we un-qualify it, thus
--    T { A.x } means T { A.x = x }
340

Adam Gundry's avatar
Adam Gundry committed
341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379

-- 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
380 381
--
-- See also Note [Disambiguating record fields] in TcExpr.
Adam Gundry's avatar
Adam Gundry committed
382

383
hsRecFields :: HsRecFields p arg -> [PostRn p (IdP p)]
Adam Gundry's avatar
Adam Gundry committed
384 385
hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)

386
-- Probably won't typecheck at once, things have changed :/
387
hsRecFieldsArgs :: HsRecFields p arg -> [arg]
388 389
hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)

390
hsRecFieldSel :: HsRecField pass arg -> Located (PostRn pass (IdP pass))
Adam Gundry's avatar
Adam Gundry committed
391 392
hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl

393
hsRecFieldId :: HsRecField GhcTc arg -> Located Id
Adam Gundry's avatar
Adam Gundry committed
394 395
hsRecFieldId = hsRecFieldSel

396
hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName
Adam Gundry's avatar
Adam Gundry committed
397 398
hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl

399
hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id
Adam Gundry's avatar
Adam Gundry committed
400 401
hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc

402
hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
Adam Gundry's avatar
Adam Gundry committed
403 404
hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl

405

Austin Seipp's avatar
Austin Seipp committed
406 407 408 409 410 411 412
{-
************************************************************************
*                                                                      *
*              Printing patterns
*                                                                      *
************************************************************************
-}
413

414 415
instance (SourceTextX pass, OutputableBndrId pass)
       => Outputable (Pat pass) where
416 417
    ppr = pprPat

418
pprPatBndr :: OutputableBndr name => name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
419
pprPatBndr var                  -- Print with type info if -dppr-debug is on
420 421
  = getPprStyle $ \ sty ->
    if debugStyle sty then
Ian Lynagh's avatar
Ian Lynagh committed
422 423
        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat
                                                -- but is it worth it?
424
    else
425
        pprPrefixOcc var
426

427
pprParendLPat :: (SourceTextX pass, OutputableBndrId pass) => LPat pass -> SDoc
428 429
pprParendLPat (L _ p) = pprParendPat p

430
pprParendPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
431 432
pprParendPat p = sdocWithDynFlags $ \ dflags ->
                 if need_parens dflags p
433 434 435
                 then parens (pprPat p)
                 else  pprPat p
  where
436 437 438 439 440 441 442
    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.
443

444
pprPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
445
pprPat (VarPat (L _ var))     = pprPatBndr var
446 447 448 449 450 451 452
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
453 454 455
pprPat (NPat l Nothing  _ _)  = ppr l
pprPat (NPat l (Just _) _ _)  = char '-' <> ppr l
pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k]
456
pprPat (SplicePat splice)     = pprSplice splice
457 458 459
pprPat (CoPat co pat _)       = pprHsWrapper co (\parens -> if parens
                                                            then pprParendPat pat
                                                            else pprPat pat)
460 461
pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty
462
pprPat (ListPat pats _ _)     = brackets (interpp'SP pats)
463 464
pprPat (PArrPat pats _)       = paBrackets (interpp'SP pats)
pprPat (TuplePat pats bx _)   = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
465
pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity)
466
pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
Ian Lynagh's avatar
Ian Lynagh committed
467 468
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
469 470 471 472 473
  = 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
474 475 476 477
        ppr con
          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                         , ppr binds])
          <+> pprConArgs details
478
    else pprUserCon (unLoc con) details
479 480


481 482
pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p)
           => con -> HsConPatDetails p -> SDoc
483 484
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
485

486
pprConArgs :: (SourceTextX p, OutputableBndrId p) => HsConPatDetails p -> SDoc
487 488
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
489 490
pprConArgs (RecCon rpats)   = ppr rpats

Adam Gundry's avatar
Adam Gundry committed
491
instance (Outputable arg)
492
      => Outputable (HsRecFields p arg) where
493
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
Ian Lynagh's avatar
Ian Lynagh committed
494
        = braces (fsep (punctuate comma (map ppr flds)))
495
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
Ian Lynagh's avatar
Ian Lynagh committed
496 497
        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
        where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
498
          dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))
499

500 501
instance (Outputable p, Outputable arg)
      => Outputable (HsRecField' p arg) where
Adam Gundry's avatar
Adam Gundry committed
502
  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
Ian Lynagh's avatar
Ian Lynagh committed
503
                    hsRecPun = pun })
504
    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
505

Adam Gundry's avatar
Adam Gundry committed
506

Austin Seipp's avatar
Austin Seipp committed
507 508 509 510 511 512 513
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
514

515
mkPrefixConPat :: DataCon -> [OutPat p] -> [Type] -> OutPat p
516
-- Make a vanilla Prefix constructor pattern
517
mkPrefixConPat dc pats tys
Gergő Érdi's avatar
Gergő Érdi committed
518
  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
Ian Lynagh's avatar
Ian Lynagh committed
519
                        pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
520
                        pat_arg_tys = tys, pat_wrap = idHsWrapper }
521

522
mkNilPat :: Type -> OutPat p
523
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
524

525
mkCharLitPat :: (SourceTextX p) => SourceText -> Char -> OutPat p
526
mkCharLitPat src c = mkPrefixConPat charDataCon
527
                          [noLoc $ LitPat (HsCharPrim (setSourceText src) c)] []
528

Austin Seipp's avatar
Austin Seipp committed
529 530 531 532 533 534
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
535

536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557
\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.

558
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
559 560
-}

561
isBangedLPat :: LPat p -> Bool
562 563 564
isBangedLPat (L _ (ParPat p))   = isBangedLPat p
isBangedLPat (L _ (BangPat {})) = True
isBangedLPat _                  = False
565

566
looksLazyPatBind :: HsBind p -> Bool
567
-- Returns True of anything *except*
Austin Seipp's avatar
Austin Seipp committed
568
--     a StrictHsBind (as above) or
569 570
--     a VarPat
-- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
Richard Eisenberg's avatar
Richard Eisenberg committed
571 572 573 574 575 576 577
-- Looks through AbsBinds
looksLazyPatBind (PatBind { pat_lhs = p })
  = looksLazyLPat p
looksLazyPatBind (AbsBinds { abs_binds = binds })
  = anyBag (looksLazyPatBind . unLoc) binds
looksLazyPatBind _
  = False
578

579
looksLazyLPat :: LPat p -> Bool
580 581 582 583 584 585
looksLazyLPat (L _ (ParPat p))             = looksLazyLPat p
looksLazyLPat (L _ (AsPat _ p))            = looksLazyLPat p
looksLazyLPat (L _ (BangPat {}))           = False
looksLazyLPat (L _ (VarPat {}))            = False
looksLazyLPat (L _ (WildPat {}))           = False
looksLazyLPat _                            = True
586

587
isIrrefutableHsPat :: (SourceTextX p, OutputableBndrId p) => LPat p -> Bool
588 589
-- (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
590 591 592
--      (NB: this is not quite the same as the (silly) defn
--      in 3.17.2 of the Haskell 98 report.)
--
593 594 595 596 597 598
-- 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.
--
599 600 601 602
-- But if it returns True, the pattern is definitely irrefutable
isIrrefutableHsPat pat
  = go pat
  where
603
    go (L _ pat) = go1 pat
604

605 606 607
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
608
    go1 (BangPat pat)       = go pat
609
    go1 (CoPat _ pat _)     = go1 pat
610 611
    go1 (ParPat pat)        = go pat
    go1 (AsPat _ pat)       = go pat
612
    go1 (ViewPat _ pat _)   = go pat
613 614 615
    go1 (SigPatIn pat _)    = go pat
    go1 (SigPatOut pat _)   = go pat
    go1 (TuplePat pats _ _) = all go pats
616 617
    go1 (SumPat _ _ _ _)    = False
                    -- See Note [Unboxed sum patterns aren't irrefutable]
618
    go1 (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
619
    go1 (PArrPat {})        = False     -- ?
620

Ian Lynagh's avatar
Ian Lynagh committed
621
    go1 (ConPatIn {})       = False     -- Conservative
Gergő Érdi's avatar
Gergő Érdi committed
622
    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
Ian Lynagh's avatar
Ian Lynagh committed
623 624 625 626
        =  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
627 628
    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
        = False -- Conservative
629

630 631 632
    go1 (LitPat {})         = False
    go1 (NPat {})           = False
    go1 (NPlusKPat {})      = False
633

634 635 636
    -- We conservatively assume that no TH splices are irrefutable
    -- since we cannot know until the splice is evaluated.
    go1 (SplicePat {})      = False
637

638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659
{- 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!
-}

660
hsPatNeedsParens :: Pat a -> Bool
661
hsPatNeedsParens (NPlusKPat {})      = True
gmainland's avatar
gmainland committed
662
hsPatNeedsParens (SplicePat {})      = False
663 664 665 666 667
hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
hsPatNeedsParens (SigPatIn {})       = True
hsPatNeedsParens (SigPatOut {})      = True
hsPatNeedsParens (ViewPat {})        = True
668
hsPatNeedsParens (CoPat _ p _)       = hsPatNeedsParens p
669 670 671 672 673 674 675
hsPatNeedsParens (WildPat {})        = False
hsPatNeedsParens (VarPat {})         = False
hsPatNeedsParens (LazyPat {})        = False
hsPatNeedsParens (BangPat {})        = False
hsPatNeedsParens (ParPat {})         = False
hsPatNeedsParens (AsPat {})          = False
hsPatNeedsParens (TuplePat {})       = False
676
hsPatNeedsParens (SumPat {})         = False
677
hsPatNeedsParens (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
678 679 680
hsPatNeedsParens (PArrPat {})        = False
hsPatNeedsParens (LitPat {})         = False
hsPatNeedsParens (NPat {})           = False
681 682

conPatNeedsParens :: HsConDetails a b -> Bool
Alan Zimmerman's avatar
Alan Zimmerman committed
683 684 685
conPatNeedsParens (PrefixCon {}) = False
conPatNeedsParens (InfixCon {})  = True
conPatNeedsParens (RecCon {})    = False
686 687 688 689 690 691

{-
% Collect all EvVars from all constructor patterns
-}

-- May need to add more cases
692
collectEvVarsPats :: [Pat p] -> Bag EvVar
693 694
collectEvVarsPats = unionManyBags . map collectEvVarsPat

695
collectEvVarsLPat :: LPat p -> Bag EvVar
696 697
collectEvVarsLPat (L _ pat) = collectEvVarsPat pat

698
collectEvVarsPat :: Pat p -> Bag EvVar
699 700 701 702 703 704 705 706
collectEvVarsPat pat =
  case pat of
    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
707
    SumPat p _ _ _    -> collectEvVarsLPat p
708 709 710 711 712 713 714 715 716 717 718
    PArrPat  ps _     -> unionManyBags $ map collectEvVarsLPat ps
    ConPatOut {pat_dicts = dicts, pat_args  = args}
                      -> unionBags (listToBag dicts)
                                   $ unionManyBags
                                   $ map collectEvVarsLPat
                                   $ hsConPatArgs args
    SigPatOut p _     -> collectEvVarsLPat p
    CoPat _ p _       -> collectEvVarsPat  p
    ConPatIn _  _     -> panic "foldMapPatBag: ConPatIn"
    SigPatIn _ _      -> panic "foldMapPatBag: SigPatIn"
    _other_pat        -> emptyBag