HsPat.hs 28.4 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
32
        looksLazyPatBind,
        isBangedLPat, isBangedPatBind,
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
149
                ConTag             -- Alternative (one-based)
                Arity              -- Arity
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
498
          dotdot = text ".." <+> ifPprDebug (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
isBangedPatBind :: HsBind p -> Bool
562
563
564
isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat
isBangedPatBind _ = False

565
isBangedLPat :: LPat p -> Bool
566
567
568
isBangedLPat (L _ (ParPat p))   = isBangedLPat p
isBangedLPat (L _ (BangPat {})) = True
isBangedLPat _                  = False
569

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

585
looksLazyLPat :: LPat p -> Bool
586
587
588
589
590
591
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
592

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

611
612
613
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
614
    go1 (BangPat pat)       = go pat
615
    go1 (CoPat _ pat _)     = go1 pat
616
617
    go1 (ParPat pat)        = go pat
    go1 (AsPat _ pat)       = go pat
618
    go1 (ViewPat _ pat _)   = go pat
619
620
621
    go1 (SigPatIn pat _)    = go pat
    go1 (SigPatOut pat _)   = go pat
    go1 (TuplePat pats _ _) = all go pats
622
    go1 (SumPat pat _ _  _) = go pat
623
    go1 (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
624
    go1 (PArrPat {})        = False     -- ?
625

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

635
636
637
    go1 (LitPat {})         = False
    go1 (NPat {})           = False
    go1 (NPlusKPat {})      = False
638

639
640
641
    -- We conservatively assume that no TH splices are irrefutable
    -- since we cannot know until the splice is evaluated.
    go1 (SplicePat {})      = False
642
643

hsPatNeedsParens :: Pat a -> Bool
644
hsPatNeedsParens (NPlusKPat {})      = True
gmainland's avatar
gmainland committed
645
hsPatNeedsParens (SplicePat {})      = False
646
647
648
649
650
hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
hsPatNeedsParens (SigPatIn {})       = True
hsPatNeedsParens (SigPatOut {})      = True
hsPatNeedsParens (ViewPat {})        = True
651
hsPatNeedsParens (CoPat _ p _)       = hsPatNeedsParens p
652
653
654
655
656
657
658
hsPatNeedsParens (WildPat {})        = False
hsPatNeedsParens (VarPat {})         = False
hsPatNeedsParens (LazyPat {})        = False
hsPatNeedsParens (BangPat {})        = False
hsPatNeedsParens (ParPat {})         = False
hsPatNeedsParens (AsPat {})          = False
hsPatNeedsParens (TuplePat {})       = False
659
hsPatNeedsParens (SumPat {})         = False
660
hsPatNeedsParens (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
661
662
663
hsPatNeedsParens (PArrPat {})        = False
hsPatNeedsParens (LitPat {})         = False
hsPatNeedsParens (NPat {})           = False
664
665

conPatNeedsParens :: HsConDetails a b -> Bool
Alan Zimmerman's avatar
Alan Zimmerman committed
666
667
668
conPatNeedsParens (PrefixCon {}) = False
conPatNeedsParens (InfixCon {})  = True
conPatNeedsParens (RecCon {})    = False
669
670
671
672
673
674

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

-- May need to add more cases
675
collectEvVarsPats :: [Pat p] -> Bag EvVar
676
677
collectEvVarsPats = unionManyBags . map collectEvVarsPat

678
collectEvVarsLPat :: LPat p -> Bag EvVar
679
680
collectEvVarsLPat (L _ pat) = collectEvVarsPat pat

681
collectEvVarsPat :: Pat p -> Bag EvVar
682
683
684
685
686
687
688
689
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
690
    SumPat p _ _ _    -> collectEvVarsLPat p
691
692
693
694
695
696
697
698
699
700
701
    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