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

31 32 33
        isUnliftedHsBind, looksLazyPatBind,
        isUnliftedLPat, isBangedLPat, isBangedPatBind,
        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

Alan Zimmerman's avatar
Alan Zimmerman committed
72
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
73 74

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

81 82
  | VarPat      (Located id) -- Variable
                             -- See Note [Located RdrNames] in HsExpr
83
  | LazyPat     (LPat id)               -- Lazy pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
84 85
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'

86 87
    -- For details on above see note [Api annotations] in ApiAnnotation

Ian Lynagh's avatar
Ian Lynagh committed
88
  | AsPat       (Located id) (LPat id)  -- As pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
89 90
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'

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

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

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

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

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

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

116 117 118 119 120
  | 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
121 122
        -- get the pattern type by getting the types of the sub-patterns.
        -- But it's essential
Ian Lynagh's avatar
Ian Lynagh committed
123 124 125 126 127 128 129 130 131 132
        --      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
133 134
        -- (June 14: I'm not sure this comment is right; the sub-patterns
        --           will be wrapped in CoPats, no?)
Alan Zimmerman's avatar
Alan Zimmerman committed
135 136 137
    -- ^ - 'ApiAnnotation.AnnKeywordId' :
    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
Ian Lynagh's avatar
Ian Lynagh committed
138

139 140 141 142 143 144 145 146 147 148
  | 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
    -- ^ - 'ApiAnnotation.AnnKeywordId' :
    --            'ApiAnnotation.AnnOpen' @'(#'@,
    --            'ApiAnnotation.AnnClose' @'#)'@

149
    -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
150
  | PArrPat     [LPat id]               -- Syntactic parallel array
151
                (PostTc id Type)        -- The type of the elements
Alan Zimmerman's avatar
Alan Zimmerman committed
152 153
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
    --                                    'ApiAnnotation.AnnClose' @':]'@
Ian Lynagh's avatar
Ian Lynagh committed
154

155
    -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
156 157 158
        ------------ Constructor patterns ---------------
  | ConPatIn    (Located id)
                (HsConPatDetails id)
159

160
  | ConPatOut {
161
        pat_con     :: Located ConLike,
Gabor Greif's avatar
Gabor Greif committed
162
        pat_arg_tys :: [Type],          -- The universal arg types, 1-1 with the universal
163
                                        -- tyvars of the constructor/pattern synonym
Austin Seipp's avatar
Austin Seipp committed
164
                                        --   Use (conLikeResTy pat_con pat_arg_tys) to get
165 166
                                        --   the type of the pattern

167
        pat_tvs   :: [TyVar],           -- Existentially bound type variables
Ian Lynagh's avatar
Ian Lynagh committed
168 169 170
        pat_dicts :: [EvVar],           -- Ditto *coercion variables* and *dictionaries*
                                        -- One reason for putting coercion variable here, I think,
                                        --      is to ensure their kinds are zonked
171

Ian Lynagh's avatar
Ian Lynagh committed
172 173
        pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries
        pat_args  :: HsConPatDetails id,
Gergő Érdi's avatar
Gergő Érdi committed
174
        pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
175 176
                                        -- Only relevant for pattern-synonyms;
                                        --   ignored for data cons
177
    }
178

Ian Lynagh's avatar
Ian Lynagh committed
179
        ------------ View patterns ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
180
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
181 182

  -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
183
  | ViewPat       (LHsExpr id)
184
                  (LPat id)
185
                  (PostTc id Type)  -- The overall type of the pattern
186 187 188
                                    -- (= the argument type of the view function)
                                    -- for hsPatType.

gmainland's avatar
gmainland committed
189
        ------------ Pattern splices ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
190 191
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
  --        'ApiAnnotation.AnnClose' @')'@
192 193

  -- For details on above see note [Api annotations] in ApiAnnotation
194
  | SplicePat       (HsSplice id)   -- Includes quasi-quotes
195

Ian Lynagh's avatar
Ian Lynagh committed
196 197 198 199 200 201
        ------------ Literal and n+k patterns ---------------
  | LitPat          HsLit               -- Used for *non-overloaded* literal patterns:
                                        -- Int#, Char#, Int, Char, String, etc.

  | NPat                -- Used for all overloaded literals,
                        -- including overloaded strings with -XOverloadedStrings
Alan Zimmerman's avatar
Alan Zimmerman committed
202
                    (Located (HsOverLit id))    -- ALWAYS positive
Ian Lynagh's avatar
Ian Lynagh committed
203 204 205
                    (Maybe (SyntaxExpr id))     -- Just (Name of 'negate') for negative
                                                -- patterns, Nothing otherwise
                    (SyntaxExpr id)             -- Equality checker, of type t->t->Bool
206 207 208
                    (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
209

Alan Zimmerman's avatar
Alan Zimmerman committed
210
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
211 212

  -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
213
  | NPlusKPat       (Located id)        -- n+k pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
214
                    (Located (HsOverLit id)) -- It'll always be an HsIntegral
215 216 217 218 219
                    (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
220
                    (SyntaxExpr id)     -- Name of '-' (see RnEnv.lookupSyntaxName)
221
                    (PostTc id Type)    -- Type of overall pattern
Ian Lynagh's avatar
Ian Lynagh committed
222 223

        ------------ Pattern type signatures ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
224
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
225 226

  -- For details on above see note [Api annotations] in ApiAnnotation
227 228 229
  | SigPatIn        (LPat id)                 -- Pattern with a type signature
                    (LHsSigWcType id)         -- Signature can bind both
                                              -- kind and type vars
Ian Lynagh's avatar
Ian Lynagh committed
230 231 232 233 234 235 236 237 238 239 240

  | SigPatOut       (LPat id)           -- Pattern with a type signature
                    Type

        ------------ Pattern coercions (translation only) ---------------
  | CoPat       HsWrapper               -- If co :: t1 ~ t2, p :: t2,
                                        -- 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'
241
deriving instance (DataId id) => Data (Pat id)
242

243 244 245 246
type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))

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

250 251
-- HsRecFields is used only for patterns and expressions (not data type
-- declarations)
252

Ian Lynagh's avatar
Ian Lynagh committed
253 254 255
data HsRecFields id arg         -- A bunch of record fields
                                --      { x = 3, y = True }
        -- Used for both expressions and patterns
256
  = HsRecFields { rec_flds   :: [LHsRecField id arg],
Ian Lynagh's avatar
Ian Lynagh committed
257
                  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
258
  deriving (Functor, Foldable, Traversable)
Adam Gundry's avatar
Adam Gundry committed
259
deriving instance (DataId id, Data arg) => Data (HsRecFields id arg)
260

261

262 263 264 265
-- Note [DotDot fields]
-- ~~~~~~~~~~~~~~~~~~~~
-- The rec_dotdot field means this:
--   Nothing => the normal case
Ian Lynagh's avatar
Ian Lynagh committed
266
--   Just n  => the group uses ".." notation,
267
--
Ian Lynagh's avatar
Ian Lynagh committed
268
-- In the latter case:
269 270 271
--
--   *before* renamer: rec_flds are exactly the n user-written fields
--
Ian Lynagh's avatar
Ian Lynagh committed
272 273 274
--   *after* renamer:  rec_flds includes *all* fields, with
--                     the first 'n' being the user-written ones
--                     and the remainder being 'filled in' implicitly
275

Adam Gundry's avatar
Adam Gundry committed
276 277 278 279 280 281
type LHsRecField' id arg = Located (HsRecField' id arg)
type LHsRecField  id arg = Located (HsRecField  id arg)
type LHsRecUpdField id   = Located (HsRecUpdField id)

type HsRecField    id arg = HsRecField' (FieldOcc id) arg
type HsRecUpdField id     = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id)
282

Adam Gundry's avatar
Adam Gundry committed
283 284
-- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
--
285
-- For details on above see note [Api annotations] in ApiAnnotation
Adam Gundry's avatar
Adam Gundry committed
286 287 288 289
data HsRecField' id arg = HsRecField {
        hsRecFieldLbl :: Located id,
        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning
        hsRecPun      :: Bool           -- ^ Note [Punning]
290
  } deriving (Data, Functor, Foldable, Traversable)
291

Adam Gundry's avatar
Adam Gundry committed
292

293 294 295
-- Note [Punning]
-- ~~~~~~~~~~~~~~
-- If you write T { x, y = v+1 }, the HsRecFields will be
Ian Lynagh's avatar
Ian Lynagh committed
296 297 298
--      HsRecField x x True ...
--      HsRecField y (v+1) False ...
-- That is, for "punned" field x is expanded (in the renamer)
299
-- to x=x; but with a punning flag so we can detect it later
300
-- (e.g. when pretty printing)
301 302 303
--
-- If the original field was qualified, we un-qualify it, thus
--    T { A.x } means T { A.x = x }
304

Adam Gundry's avatar
Adam Gundry committed
305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343

-- 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
344 345
--
-- See also Note [Disambiguating record fields] in TcExpr.
Adam Gundry's avatar
Adam Gundry committed
346 347 348 349

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

350 351 352 353
-- 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
354 355 356 357 358 359 360 361 362 363 364 365 366 367 368
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

369

Austin Seipp's avatar
Austin Seipp committed
370 371 372 373 374 375 376
{-
************************************************************************
*                                                                      *
*              Printing patterns
*                                                                      *
************************************************************************
-}
377

378
instance (OutputableBndrId name) => Outputable (Pat name) where
379 380
    ppr = pprPat

381
pprPatBndr :: OutputableBndr name => name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
382
pprPatBndr var                  -- Print with type info if -dppr-debug is on
383 384
  = getPprStyle $ \ sty ->
    if debugStyle sty then
Ian Lynagh's avatar
Ian Lynagh committed
385 386
        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat
                                                -- but is it worth it?
387
    else
388
        pprPrefixOcc var
389

390
pprParendLPat :: (OutputableBndrId name) => LPat name -> SDoc
391 392
pprParendLPat (L _ p) = pprParendPat p

393
pprParendPat :: (OutputableBndrId name) => Pat name -> SDoc
394 395
pprParendPat p = sdocWithDynFlags $ \ dflags ->
                 if need_parens dflags p
396 397 398
                 then parens (pprPat p)
                 else  pprPat p
  where
399 400 401 402 403 404 405
    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.
406

407
pprPat :: (OutputableBndrId name) => Pat name -> SDoc
408
pprPat (VarPat (L _ var))     = pprPatBndr var
409 410 411 412 413 414 415
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
416 417 418
pprPat (NPat l Nothing  _ _)  = ppr l
pprPat (NPat l (Just _) _ _)  = char '-' <> ppr l
pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k]
419
pprPat (SplicePat splice)     = pprSplice splice
420 421 422
pprPat (CoPat co pat _)       = pprHsWrapper co (\parens -> if parens
                                                            then pprParendPat pat
                                                            else pprPat pat)
423 424
pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty
425
pprPat (ListPat pats _ _)     = brackets (interpp'SP pats)
426 427
pprPat (PArrPat pats _)       = paBrackets (interpp'SP pats)
pprPat (TuplePat pats bx _)   = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
428
pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity)
429
pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
Ian Lynagh's avatar
Ian Lynagh committed
430 431
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
432 433 434 435 436
  = 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
437 438 439 440
        ppr con
          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                         , ppr binds])
          <+> pprConArgs details
441
    else pprUserCon (unLoc con) details
442 443


444 445
pprUserCon :: (OutputableBndr con, OutputableBndrId id)
           => con -> HsConPatDetails id -> SDoc
446 447
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
448

449
pprConArgs :: (OutputableBndrId id) => HsConPatDetails id -> SDoc
450 451
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
452 453
pprConArgs (RecCon rpats)   = ppr rpats

Adam Gundry's avatar
Adam Gundry committed
454
instance (Outputable arg)
455 456
      => Outputable (HsRecFields id arg) where
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
Ian Lynagh's avatar
Ian Lynagh committed
457
        = braces (fsep (punctuate comma (map ppr flds)))
458
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
Ian Lynagh's avatar
Ian Lynagh committed
459 460
        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
        where
461
          dotdot = text ".." <+> ifPprDebug (ppr (drop n flds))
462

Adam Gundry's avatar
Adam Gundry committed
463 464 465
instance (Outputable id, Outputable arg)
      => Outputable (HsRecField' id arg) where
  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
Ian Lynagh's avatar
Ian Lynagh committed
466
                    hsRecPun = pun })
467
    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
468

Adam Gundry's avatar
Adam Gundry committed
469

Austin Seipp's avatar
Austin Seipp committed
470 471 472 473 474 475 476
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
477

478
mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id
479
-- Make a vanilla Prefix constructor pattern
480
mkPrefixConPat dc pats tys
Gergő Érdi's avatar
Gergő Érdi committed
481
  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
Ian Lynagh's avatar
Ian Lynagh committed
482
                        pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
483
                        pat_arg_tys = tys, pat_wrap = idHsWrapper }
484

485
mkNilPat :: Type -> OutPat id
486
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
487

488 489 490
mkCharLitPat :: String -> Char -> OutPat id
mkCharLitPat src c = mkPrefixConPat charDataCon
                                    [noLoc $ LitPat (HsCharPrim src c)] []
491

Austin Seipp's avatar
Austin Seipp committed
492 493 494 495 496 497
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
498

499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520
\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.

521
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
522 523
-}

524 525 526
isUnliftedLPat :: LPat id -> Bool
isUnliftedLPat (L _ (ParPat p))             = isUnliftedLPat p
isUnliftedLPat (L _ (TuplePat _ Unboxed _)) = True
527
isUnliftedLPat (L _ (SumPat _ _ _ _))       = True
528
isUnliftedLPat _                            = False
529

530
isUnliftedHsBind :: HsBind id -> Bool
531 532
-- A pattern binding with an outermost bang or unboxed tuple or sum must be
-- matched strictly.
533
-- Defined in this module because HsPat is above HsBinds in the import graph
534 535 536 537 538 539 540 541 542 543 544
isUnliftedHsBind (PatBind { pat_lhs = p }) = isUnliftedLPat p
isUnliftedHsBind _                         = False

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
545 546 547

looksLazyPatBind :: HsBind id -> Bool
-- Returns True of anything *except*
Austin Seipp's avatar
Austin Seipp committed
548
--     a StrictHsBind (as above) or
549 550 551 552 553 554 555 556 557 558
--     a VarPat
-- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p
looksLazyPatBind _                         = False

looksLazyLPat :: LPat id -> Bool
looksLazyLPat (L _ (ParPat p))             = looksLazyLPat p
looksLazyLPat (L _ (AsPat _ p))            = looksLazyLPat p
looksLazyLPat (L _ (BangPat {}))           = False
looksLazyLPat (L _ (TuplePat _ Unboxed _)) = False
559
looksLazyLPat (L _ (SumPat _ _ _ _))       = False
560 561 562
looksLazyLPat (L _ (VarPat {}))            = False
looksLazyLPat (L _ (WildPat {}))           = False
looksLazyLPat _                            = True
563

564
isIrrefutableHsPat :: (OutputableBndrId id) => LPat id -> Bool
565 566
-- (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
567 568 569
--      (NB: this is not quite the same as the (silly) defn
--      in 3.17.2 of the Haskell 98 report.)
--
570 571 572 573 574 575
-- 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.
--
576 577 578 579
-- But if it returns True, the pattern is definitely irrefutable
isIrrefutableHsPat pat
  = go pat
  where
580
    go (L _ pat) = go1 pat
581

582 583 584
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
585
    go1 (BangPat pat)       = go pat
586
    go1 (CoPat _ pat _)     = go1 pat
587 588
    go1 (ParPat pat)        = go pat
    go1 (AsPat _ pat)       = go pat
589
    go1 (ViewPat _ pat _)   = go pat
590 591 592
    go1 (SigPatIn pat _)    = go pat
    go1 (SigPatOut pat _)   = go pat
    go1 (TuplePat pats _ _) = all go pats
593
    go1 (SumPat pat _ _  _) = go pat
594
    go1 (ListPat {}) = False
Ian Lynagh's avatar
Ian Lynagh committed
595
    go1 (PArrPat {})        = False     -- ?
596

Ian Lynagh's avatar
Ian Lynagh committed
597
    go1 (ConPatIn {})       = False     -- Conservative
Gergő Érdi's avatar
Gergő Érdi committed
598
    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
Ian Lynagh's avatar
Ian Lynagh committed
599 600 601 602
        =  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
603 604
    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
        = False -- Conservative
605

606 607 608
    go1 (LitPat {})    = False
    go1 (NPat {})      = False
    go1 (NPlusKPat {}) = False
609

gmainland's avatar
gmainland committed
610 611
    -- Both should be gotten rid of by renamer before
    -- isIrrefutablePat is called
Austin Seipp's avatar
Austin Seipp committed
612
    go1 (SplicePat {})     = urk pat
613 614

    urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
615 616

hsPatNeedsParens :: Pat a -> Bool
617
hsPatNeedsParens (NPlusKPat {})      = True
gmainland's avatar
gmainland committed
618
hsPatNeedsParens (SplicePat {})      = False
619 620 621 622 623
hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
hsPatNeedsParens (SigPatIn {})       = True
hsPatNeedsParens (SigPatOut {})      = True
hsPatNeedsParens (ViewPat {})        = True
624
hsPatNeedsParens (CoPat _ p _)       = hsPatNeedsParens p
625 626 627 628 629 630 631
hsPatNeedsParens (WildPat {})        = False
hsPatNeedsParens (VarPat {})         = False
hsPatNeedsParens (LazyPat {})        = False
hsPatNeedsParens (BangPat {})        = False
hsPatNeedsParens (ParPat {})         = False
hsPatNeedsParens (AsPat {})          = False
hsPatNeedsParens (TuplePat {})       = False
632
hsPatNeedsParens (SumPat {})         = False
633
hsPatNeedsParens (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
634 635 636
hsPatNeedsParens (PArrPat {})        = False
hsPatNeedsParens (LitPat {})         = False
hsPatNeedsParens (NPat {})           = False
637 638 639

conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon args) = not (null args)
640 641
conPatNeedsParens (InfixCon {})    = True
conPatNeedsParens (RecCon {})      = True
642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662

{-
% 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
663
    SumPat p _ _ _    -> collectEvVarsLPat p
664 665 666 667 668 669 670 671 672 673 674
    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