HsPat.hs 28.2 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 PlaceHolder
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

Ian Lynagh's avatar
Ian Lynagh committed
67 68
type InPat id  = LPat id        -- No 'Out' constructors
type OutPat id = LPat id        -- No 'In' constructors
69 70

type LPat id = Located (Pat id)
71

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

-- For details on above see note [Api annotations] in ApiAnnotation
77
data Pat id
Ian Lynagh's avatar
Ian Lynagh committed
78
  =     ------------ Simple patterns ---------------
79
    WildPat     (PostTc id 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
  | VarPat      (Located id) -- ^ Variable Pattern

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

214 215
  | NPat                -- Natural Pattern
                        -- Used for all overloaded literals,
Ian Lynagh's avatar
Ian Lynagh committed
216
                        -- including overloaded strings with -XOverloadedStrings
Alan Zimmerman's avatar
Alan Zimmerman committed
217
                    (Located (HsOverLit id))    -- ALWAYS positive
Ian Lynagh's avatar
Ian Lynagh committed
218 219 220
                    (Maybe (SyntaxExpr id))     -- Just (Name of 'negate') for negative
                                                -- patterns, Nothing otherwise
                    (SyntaxExpr id)             -- Equality checker, of type t->t->Bool
221 222 223
                    (PostTc id 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
224

225 226 227
  -- ^ Natural Pattern
  --
  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
228 229

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

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

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

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

250
  | SigPatOut       (LPat id)
Ian Lynagh's avatar
Ian Lynagh committed
251
                    Type
252
    -- ^ Pattern with a type signature
Ian Lynagh's avatar
Ian Lynagh committed
253 254

        ------------ Pattern coercions (translation only) ---------------
255 256
  | CoPat       HsWrapper               -- Coercion Pattern
                                        -- If co :: t1 ~ t2, p :: t2,
Ian Lynagh's avatar
Ian Lynagh committed
257 258 259 260 261
                                        -- then (CoPat co p) :: t1
                (Pat id)                -- Why not LPat?  Ans: existing locn will do
                Type                    -- Type of whole pattern, t1
        -- During desugaring a (CoPat co pat) turns into a cast with 'co' on
        -- the scrutinee, followed by a match on 'pat'
262
    -- ^ Coercion Pattern
263
deriving instance (DataId id) => Data (Pat id)
264

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

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

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

285

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

300
-- | Located Haskell Record Field
Adam Gundry's avatar
Adam Gundry committed
301
type LHsRecField' id arg = Located (HsRecField' id arg)
302 303

-- | Located Haskell Record Field
Adam Gundry's avatar
Adam Gundry committed
304
type LHsRecField  id arg = Located (HsRecField  id arg)
305 306

-- | Located Haskell Record Update Field
Adam Gundry's avatar
Adam Gundry committed
307 308
type LHsRecUpdField id   = Located (HsRecUpdField id)

309
-- | Haskell Record Field
Adam Gundry's avatar
Adam Gundry committed
310
type HsRecField    id arg = HsRecField' (FieldOcc id) arg
311 312

-- | Haskell Record Update Field
Adam Gundry's avatar
Adam Gundry committed
313
type HsRecUpdField id     = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id)
314

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

Adam Gundry's avatar
Adam Gundry committed
326

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

Adam Gundry's avatar
Adam Gundry committed
339 340 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

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

hsRecFields :: HsRecFields id arg -> [PostRn id id]
hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)

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

Adam Gundry's avatar
Adam Gundry committed
388 389 390 391 392 393 394 395 396 397 398 399 400 401 402
hsRecFieldSel :: HsRecField name arg -> Located (PostRn name name)
hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl

hsRecFieldId :: HsRecField Id arg -> Located Id
hsRecFieldId = hsRecFieldSel

hsRecUpdFieldRdr :: HsRecUpdField id -> Located RdrName
hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl

hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc Id) arg -> Located Id
hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc

hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc Id) arg -> LFieldOcc Id
hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl

403

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

412
instance (OutputableBndrId name) => Outputable (Pat name) where
413 414
    ppr = pprPat

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

424
pprParendLPat :: (OutputableBndrId name) => LPat name -> SDoc
425 426
pprParendLPat (L _ p) = pprParendPat p

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

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


478
pprUserCon :: (OutputableBndr con, OutputableBndrId id)
479
           => con -> HsConPatDetails id -> SDoc
480 481
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
482

483
pprConArgs :: (OutputableBndrId id) => HsConPatDetails id -> SDoc
484 485
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
486 487
pprConArgs (RecCon rpats)   = ppr rpats

Adam Gundry's avatar
Adam Gundry committed
488
instance (Outputable arg)
489 490
      => Outputable (HsRecFields id arg) where
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
Ian Lynagh's avatar
Ian Lynagh committed
491
        = braces (fsep (punctuate comma (map ppr flds)))
492
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
Ian Lynagh's avatar
Ian Lynagh committed
493 494
        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
        where
495
          dotdot = text ".." <+> ifPprDebug (ppr (drop n flds))
496

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

Adam Gundry's avatar
Adam Gundry committed
503

Austin Seipp's avatar
Austin Seipp committed
504 505 506 507 508 509 510
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
511

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

519
mkNilPat :: Type -> OutPat id
520
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
521

Alan Zimmerman's avatar
Alan Zimmerman committed
522
mkCharLitPat :: SourceText -> Char -> OutPat id
523 524
mkCharLitPat src c = mkPrefixConPat charDataCon
                                    [noLoc $ LitPat (HsCharPrim src c)] []
525

Austin Seipp's avatar
Austin Seipp committed
526 527 528 529 530 531
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
532

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

555
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
556 557
-}

558 559 560 561 562 563 564 565
isBangedPatBind :: HsBind id -> Bool
isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat
isBangedPatBind _ = False

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

looksLazyPatBind :: HsBind id -> Bool
-- Returns True of anything *except*
Austin Seipp's avatar
Austin Seipp committed
569
--     a StrictHsBind (as above) or
570 571
--     a VarPat
-- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
Richard Eisenberg's avatar
Richard Eisenberg committed
572 573 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 (AbsBindsSig { abs_sig_bind = L _ bind })
  = looksLazyPatBind bind
looksLazyPatBind _
  = False
581 582 583 584 585 586 587 588

looksLazyLPat :: LPat id -> Bool
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
589

590
isIrrefutableHsPat :: (OutputableBndrId id) => LPat id -> 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
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
611
    go1 (BangPat pat)       = go pat
612
    go1 (CoPat _ pat _)     = go1 pat
613 614
    go1 (ParPat pat)        = go pat
    go1 (AsPat _ pat)       = go pat
615
    go1 (ViewPat _ pat _)   = go pat
616 617 618
    go1 (SigPatIn pat _)    = go pat
    go1 (SigPatOut pat _)   = go pat
    go1 (TuplePat pats _ _) = all go pats
619
    go1 (SumPat pat _ _  _) = go pat
620
    go1 (ListPat {}) = False
Ian Lynagh's avatar
Ian Lynagh committed
621
    go1 (PArrPat {})        = False     -- ?
622

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

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

gmainland's avatar
gmainland committed
636 637
    -- Both should be gotten rid of by renamer before
    -- isIrrefutablePat is called
Austin Seipp's avatar
Austin Seipp committed
638
    go1 (SplicePat {})     = urk pat
639 640

    urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
641 642

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

conPatNeedsParens :: HsConDetails a b -> Bool
Alan Zimmerman's avatar
Alan Zimmerman committed
665 666 667
conPatNeedsParens (PrefixCon {}) = False
conPatNeedsParens (InfixCon {})  = True
conPatNeedsParens (RecCon {})    = False
668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688

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

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

collectEvVarsLPat :: LPat id -> Bag EvVar
collectEvVarsLPat (L _ pat) = collectEvVarsPat pat

collectEvVarsPat :: Pat id -> Bag EvVar
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
689
    SumPat p _ _ _    -> collectEvVarsLPat p
690 691 692 693 694 695 696 697 698 699 700
    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