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

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

73
type LPat p = Located (Pat p)
74

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

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

86
       -- AZ:TODO above comment needs to be updated
Ben Gamari's avatar
Ben Gamari committed
87
  | VarPat      (Located (IdP p))  -- ^ Variable Pattern
88

89
                             -- See Note [Located RdrNames] in HsExpr
Ben Gamari's avatar
Ben Gamari committed
90
  | LazyPat     (LPat p)                -- ^ Lazy Pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
91 92
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'

93 94
    -- For details on above see note [Api annotations] in ApiAnnotation

Ben Gamari's avatar
Ben Gamari committed
95
  | AsPat       (Located (IdP p)) (LPat p)    -- ^ As pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
96 97
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'

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

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

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

109 110
    -- For details on above see note [Api annotations] in ApiAnnotation

Ian Lynagh's avatar
Ian Lynagh committed
111
        ------------ Lists, tuples, arrays ---------------
Ben Gamari's avatar
Ben Gamari committed
112
  | ListPat     [LPat p]
113 114 115 116
                (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
Ben Gamari's avatar
Ben Gamari committed
117
                   -- function to convert the scrutinee to a list value
118 119 120
    -- ^ Syntactic List
    --
    -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
Alan Zimmerman's avatar
Alan Zimmerman committed
121
    --                                    'ApiAnnotation.AnnClose' @']'@
Ian Lynagh's avatar
Ian Lynagh committed
122

123 124
    -- For details on above see note [Api annotations] in ApiAnnotation

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

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

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

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

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

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

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

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

  -- For details on above see note [Api annotations] in ApiAnnotation
Ben Gamari's avatar
Ben Gamari committed
199
  | ViewPat       (LHsExpr p)
200
                  (LPat p)
Ben Gamari's avatar
Ben Gamari committed
201 202 203
                  (PostTc p Type)   -- The overall type of the pattern
                                    -- (= the argument type of the view function)
                                    -- for hsPatType.
204
    -- ^ View Pattern
205

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

  -- For details on above see note [Api annotations] in ApiAnnotation
Ben Gamari's avatar
Ben Gamari committed
211
  | SplicePat       (HsSplice p)    -- ^ Splice Pattern (Includes quasi-quotes)
212

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

218 219
  | NPat                -- Natural Pattern
                        -- Used for all overloaded literals,
Ian Lynagh's avatar
Ian Lynagh committed
220
                        -- including overloaded strings with -XOverloadedStrings
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
Ben Gamari's avatar
Ben Gamari committed
226 227 228
                    (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
229

230 231 232
  -- ^ Natural Pattern
  --
  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
233 234

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

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

        ------------ Pattern type signatures ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
247
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
248 249

  -- For details on above see note [Api annotations] in ApiAnnotation
Ben Gamari's avatar
Ben Gamari committed
250 251 252 253 254 255 256
  | SigPatIn        (LPat p)                  -- Pattern with a type signature
                    (LHsSigWcType p)          -- Signature can bind both
                                              -- kind and type vars
    -- ^ Pattern with a type signature

  | SigPatOut       (LPat p)
                    Type
257
    -- ^ Pattern with a type signature
Ian Lynagh's avatar
Ian Lynagh committed
258 259

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

270
-- | Haskell Constructor Pattern Details
271
type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
272

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

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

290

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

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

-- | Located Haskell Record Field
309
type LHsRecField  p arg = Located (HsRecField  p arg)
310 311

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

314
-- | Haskell Record Field
315
type HsRecField    p arg = HsRecField' (FieldOcc p) arg
316 317

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

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

Adam Gundry's avatar
Adam Gundry committed
331

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

Adam Gundry's avatar
Adam Gundry committed
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 380 381 382

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

Ben Gamari's avatar
Ben Gamari committed
386
hsRecFields :: HsRecFields p arg -> [PostRn p (IdP p)]
Adam Gundry's avatar
Adam Gundry committed
387 388
hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)

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

Ben Gamari's avatar
Ben Gamari committed
393 394
hsRecFieldSel :: HsRecField pass arg -> Located (PostRn pass (IdP pass))
hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl
Adam Gundry's avatar
Adam Gundry committed
395

396
hsRecFieldId :: HsRecField GhcTc arg -> Located Id
Adam Gundry's avatar
Adam Gundry committed
397 398
hsRecFieldId = hsRecFieldSel

Ben Gamari's avatar
Ben Gamari committed
399
hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName
Adam Gundry's avatar
Adam Gundry committed
400 401
hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl

402
hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id
Ben Gamari's avatar
Ben Gamari committed
403
hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc
Adam Gundry's avatar
Adam Gundry committed
404

405
hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
Adam Gundry's avatar
Adam Gundry committed
406 407
hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl

408

Austin Seipp's avatar
Austin Seipp committed
409 410 411 412 413 414 415
{-
************************************************************************
*                                                                      *
*              Printing patterns
*                                                                      *
************************************************************************
-}
416

417
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where
418 419
    ppr = pprPat

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

429
pprParendLPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> SDoc
430 431
pprParendLPat (L _ p) = pprParendPat p

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

446
pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
Ben Gamari's avatar
Ben Gamari committed
447
pprPat (VarPat (L _ var))     = pprPatBndr var
448
pprPat (WildPat _)            = char '_'
Ben Gamari's avatar
Ben Gamari committed
449 450 451 452 453 454 455 456 457 458 459
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
460 461
                                                            then pprParendPat pat
                                                            else pprPat pat)
Ben Gamari's avatar
Ben Gamari committed
462 463 464 465 466 467 468
pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty)     = 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
469 470
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
471 472 473 474 475
  = 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
476 477 478 479
        ppr con
          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                         , ppr binds])
          <+> pprConArgs details
480
    else pprUserCon (unLoc con) details
481

Ben Gamari's avatar
Ben Gamari committed
482

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

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

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

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

Adam Gundry's avatar
Adam Gundry committed
509

Austin Seipp's avatar
Austin Seipp committed
510 511 512 513 514 515 516
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
517

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

525
mkNilPat :: Type -> OutPat p
526
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
527

528
mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
529
mkCharLitPat src c = mkPrefixConPat charDataCon
530
                          [noLoc $ LitPat (HsCharPrim src c)] []
531

Austin Seipp's avatar
Austin Seipp committed
532 533 534 535 536 537
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
538

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

561
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
562 563
-}

564
isBangedLPat :: LPat p -> Bool
Ben Gamari's avatar
Ben Gamari committed
565
isBangedLPat (L _ (ParPat p))   = isBangedLPat p
566 567
isBangedLPat (L _ (BangPat {})) = True
isBangedLPat _                  = False
568

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

582
looksLazyLPat :: LPat p -> Bool
Ben Gamari's avatar
Ben Gamari committed
583 584
looksLazyLPat (L _ (ParPat p))             = looksLazyLPat p
looksLazyLPat (L _ (AsPat _ p))            = looksLazyLPat p
585 586 587 588
looksLazyLPat (L _ (BangPat {}))           = False
looksLazyLPat (L _ (VarPat {}))            = False
looksLazyLPat (L _ (WildPat {}))           = False
looksLazyLPat _                            = True
589

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

608 609 610
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
Ben Gamari's avatar
Ben Gamari committed
611 612 613 614 615 616 617 618 619
    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 (SigPatIn pat _)    = go pat
    go1 (SigPatOut pat _)   = go pat
    go1 (TuplePat pats _ _) = all go pats
    go1 (SumPat _ _ _ _)    = False
620
                    -- See Note [Unboxed sum patterns aren't irrefutable]
621
    go1 (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
622
    go1 (PArrPat {})        = False     -- ?
623

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

633 634 635
    go1 (LitPat {})         = False
    go1 (NPat {})           = False
    go1 (NPlusKPat {})      = False
636

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

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

663 664
-- | Returns 'True' if a pattern must be parenthesized in order to parse
-- (e.g., the @(x :: Int)@ in @f (x :: Int) = x@).
665
hsPatNeedsParens :: Pat a -> Bool
666
hsPatNeedsParens (NPlusKPat {})      = True
gmainland's avatar
gmainland committed
667
hsPatNeedsParens (SplicePat {})      = False
668 669
hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
Ben Gamari's avatar
Ben Gamari committed
670 671
hsPatNeedsParens (SigPatIn {})       = True
hsPatNeedsParens (SigPatOut {})      = True
672
hsPatNeedsParens (ViewPat {})        = True
Ben Gamari's avatar
Ben Gamari committed
673
hsPatNeedsParens (CoPat _ p _)       = hsPatNeedsParens p
674 675 676 677 678 679 680
hsPatNeedsParens (WildPat {})        = False
hsPatNeedsParens (VarPat {})         = False
hsPatNeedsParens (LazyPat {})        = False
hsPatNeedsParens (BangPat {})        = False
hsPatNeedsParens (ParPat {})         = False
hsPatNeedsParens (AsPat {})          = False
hsPatNeedsParens (TuplePat {})       = False
681
hsPatNeedsParens (SumPat {})         = False
682
hsPatNeedsParens (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
683 684 685
hsPatNeedsParens (PArrPat {})        = False
hsPatNeedsParens (LitPat {})         = False
hsPatNeedsParens (NPat {})           = False
686

687 688
-- | Returns 'True' if a constructor pattern must be parenthesized in order
-- to parse.
689
conPatNeedsParens :: HsConDetails a b -> Bool
Alan Zimmerman's avatar
Alan Zimmerman committed
690 691 692
conPatNeedsParens (PrefixCon {}) = False
conPatNeedsParens (InfixCon {})  = True
conPatNeedsParens (RecCon {})    = False
693

694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743
-- | 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)
isCompoundPat (SigPatIn {})        = True
isCompoundPat (SigPatOut {})       = True
isCompoundPat (ViewPat {})         = True
isCompoundPat (CoPat _ p _)        = isCompoundPat p
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
isCompoundPat (LitPat p)           = isCompoundHsLit p
isCompoundPat (NPat (L _ p) _ _ _) = isCompoundHsOverLit p

-- | 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@.
parenthesizeCompoundPat :: LPat p -> LPat p
parenthesizeCompoundPat lp@(L loc p)
  | isCompoundPat p = L loc (ParPat lp)
  | otherwise       = lp

744 745 746 747 748
{-
% Collect all EvVars from all constructor patterns
-}

-- May need to add more cases
Ben Gamari's avatar
Ben Gamari committed
749
collectEvVarsPats :: [Pat p] -> Bag EvVar
750 751
collectEvVarsPats = unionManyBags . map collectEvVarsPat

Ben Gamari's avatar
Ben Gamari committed
752
collectEvVarsLPat :: LPat p -> Bag EvVar
753 754
collectEvVarsLPat (L _ pat) = collectEvVarsPat pat

Ben Gamari's avatar
Ben Gamari committed
755
collectEvVarsPat :: Pat p -> Bag EvVar
756 757
collectEvVarsPat pat =
  case pat of
Ben Gamari's avatar
Ben Gamari committed
758 759 760 761 762 763 764 765
    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
766
    ConPatOut {pat_dicts = dicts, pat_args  = args}
Ben Gamari's avatar
Ben Gamari committed
767
                      -> unionBags (listToBag dicts)
768 769 770
                                   $ unionManyBags
                                   $ map collectEvVarsLPat
                                   $ hsConPatArgs args
Ben Gamari's avatar
Ben Gamari committed
771 772 773 774 775
    SigPatOut p _     -> collectEvVarsLPat p
    CoPat _ p _       -> collectEvVarsPat  p
    ConPatIn _  _     -> panic "foldMapPatBag: ConPatIn"
    SigPatIn _ _      -> panic "foldMapPatBag: SigPatIn"
    _other_pat        -> emptyBag