HsPat.hs 26.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 12 13 14
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                      -- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
Adam Gundry's avatar
Adam Gundry committed
15
{-# LANGUAGE TypeFamilies #-}
16

17
module HsPat (
Ian Lynagh's avatar
Ian Lynagh committed
18
        Pat(..), InPat, OutPat, LPat,
19

Ian Lynagh's avatar
Ian Lynagh committed
20 21
        HsConDetails(..),
        HsConPatDetails, hsConPatArgs,
Adam Gundry's avatar
Adam Gundry committed
22 23 24
        HsRecFields(..), HsRecField'(..), LHsRecField',
        HsRecField, LHsRecField,
        HsRecUpdField, LHsRecUpdField,
25
        hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,
Adam Gundry's avatar
Adam Gundry committed
26
        hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
Ian Lynagh's avatar
Ian Lynagh committed
27 28

        mkPrefixConPat, mkCharLitPat, mkNilPat,
29

30 31 32
        isUnliftedHsBind, looksLazyPatBind,
        isUnliftedLPat, isBangedLPat, isBangedPatBind,
        hsPatNeedsParens,
33
        isIrrefutableHsPat,
34

35 36
        collectEvVarsPats,

37
        pprParendLPat, pprConArgs
38 39
    ) where

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

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

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

type LPat id = Located (Pat id)
70

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

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

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

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

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

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
103
        ------------ Lists, tuples, arrays ---------------
104
  | ListPat     [LPat id]                            -- Syntactic list
105 106
                (PostTc id Type)                     -- The type of the elements
                (Maybe (PostTc id Type, SyntaxExpr id)) -- For rebindable syntax
107 108 109
                   -- 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
110 111
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
    --                                    'ApiAnnotation.AnnClose' @']'@
Ian Lynagh's avatar
Ian Lynagh committed
112

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

115 116 117 118 119
  | 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
120 121
        -- get the pattern type by getting the types of the sub-patterns.
        -- But it's essential
Ian Lynagh's avatar
Ian Lynagh committed
122 123 124 125 126 127 128 129 130 131
        --      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
132 133
        -- (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
134 135 136
    -- ^ - 'ApiAnnotation.AnnKeywordId' :
    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
Ian Lynagh's avatar
Ian Lynagh committed
137

138
    -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
139
  | PArrPat     [LPat id]               -- Syntactic parallel array
140
                (PostTc id Type)        -- The type of the elements
Alan Zimmerman's avatar
Alan Zimmerman committed
141 142
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
    --                                    'ApiAnnotation.AnnClose' @':]'@
Ian Lynagh's avatar
Ian Lynagh committed
143

144
    -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
145 146 147
        ------------ Constructor patterns ---------------
  | ConPatIn    (Located id)
                (HsConPatDetails id)
148

149
  | ConPatOut {
150
        pat_con     :: Located ConLike,
Gabor Greif's avatar
Gabor Greif committed
151
        pat_arg_tys :: [Type],          -- The universal arg types, 1-1 with the universal
152
                                        -- tyvars of the constructor/pattern synonym
Austin Seipp's avatar
Austin Seipp committed
153
                                        --   Use (conLikeResTy pat_con pat_arg_tys) to get
154 155
                                        --   the type of the pattern

Ian Lynagh's avatar
Ian Lynagh committed
156 157 158 159 160 161
        pat_tvs   :: [TyVar],           -- Existentially bound type variables (tyvars only)
        pat_dicts :: [EvVar],           -- Ditto *coercion variables* and *dictionaries*
                                        -- One reason for putting coercion variable here, I think,
                                        --      is to ensure their kinds are zonked
        pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries
        pat_args  :: HsConPatDetails id,
Gergő Érdi's avatar
Gergő Érdi committed
162
        pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
163 164
                                        -- Only relevant for pattern-synonyms;
                                        --   ignored for data cons
165
    }
166

Ian Lynagh's avatar
Ian Lynagh committed
167
        ------------ View patterns ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
168
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
169 170

  -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
171
  | ViewPat       (LHsExpr id)
172
                  (LPat id)
173
                  (PostTc id Type)  -- The overall type of the pattern
174 175 176
                                    -- (= the argument type of the view function)
                                    -- for hsPatType.

gmainland's avatar
gmainland committed
177
        ------------ Pattern splices ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
178 179
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
  --        'ApiAnnotation.AnnClose' @')'@
180 181

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

Ian Lynagh's avatar
Ian Lynagh committed
184 185 186 187 188 189
        ------------ 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
190
                    (Located (HsOverLit id))    -- ALWAYS positive
Ian Lynagh's avatar
Ian Lynagh committed
191 192 193 194
                    (Maybe (SyntaxExpr id))     -- Just (Name of 'negate') for negative
                                                -- patterns, Nothing otherwise
                    (SyntaxExpr id)             -- Equality checker, of type t->t->Bool

Alan Zimmerman's avatar
Alan Zimmerman committed
195
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
196 197

  -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
198
  | NPlusKPat       (Located id)        -- n+k pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
199
                    (Located (HsOverLit id)) -- It'll always be an HsIntegral
Ian Lynagh's avatar
Ian Lynagh committed
200 201 202 203
                    (SyntaxExpr id)     -- (>=) function, of type t->t->Bool
                    (SyntaxExpr id)     -- Name of '-' (see RnEnv.lookupSyntaxName)

        ------------ Pattern type signatures ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
204
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
205 206

  -- For details on above see note [Api annotations] in ApiAnnotation
207 208 209
  | 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
210 211 212 213 214 215 216 217 218 219 220

  | 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'
221 222
  deriving (Typeable)
deriving instance (DataId id) => Data (Pat id)
223

Austin Seipp's avatar
Austin Seipp committed
224
-- HsConDetails is use for patterns/expressions *and* for data type declarations
225

226 227
data HsConDetails arg rec
  = PrefixCon [arg]             -- C p1 p2 p3
Ian Lynagh's avatar
Ian Lynagh committed
228 229
  | RecCon    rec               -- C { x = p1, y = p2 }
  | InfixCon  arg arg           -- p1 `C` p2
230
  deriving (Data, Typeable)
231 232 233 234 235

type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))

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

Austin Seipp's avatar
Austin Seipp committed
239
{-
240 241
However HsRecFields is used only for patterns and expressions
(not data type declarations)
Austin Seipp's avatar
Austin Seipp committed
242
-}
243

Ian Lynagh's avatar
Ian Lynagh committed
244 245 246
data HsRecFields id arg         -- A bunch of record fields
                                --      { x = 3, y = True }
        -- Used for both expressions and patterns
247
  = HsRecFields { rec_flds   :: [LHsRecField id arg],
Ian Lynagh's avatar
Ian Lynagh committed
248
                  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
Adam Gundry's avatar
Adam Gundry committed
249 250
  deriving (Typeable)
deriving instance (DataId id, Data arg) => Data (HsRecFields id arg)
251 252 253 254 255

-- Note [DotDot fields]
-- ~~~~~~~~~~~~~~~~~~~~
-- The rec_dotdot field means this:
--   Nothing => the normal case
Ian Lynagh's avatar
Ian Lynagh committed
256
--   Just n  => the group uses ".." notation,
257
--
Ian Lynagh's avatar
Ian Lynagh committed
258
-- In the latter case:
259 260 261
--
--   *before* renamer: rec_flds are exactly the n user-written fields
--
Ian Lynagh's avatar
Ian Lynagh committed
262 263 264
--   *after* renamer:  rec_flds includes *all* fields, with
--                     the first 'n' being the user-written ones
--                     and the remainder being 'filled in' implicitly
265

Adam Gundry's avatar
Adam Gundry committed
266 267 268 269 270 271
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)
272

Adam Gundry's avatar
Adam Gundry committed
273 274
-- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
--
275
-- For details on above see note [Api annotations] in ApiAnnotation
Adam Gundry's avatar
Adam Gundry committed
276 277 278 279
data HsRecField' id arg = HsRecField {
        hsRecFieldLbl :: Located id,
        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning
        hsRecPun      :: Bool           -- ^ Note [Punning]
280
  } deriving (Data, Typeable)
281

Adam Gundry's avatar
Adam Gundry committed
282

283 284 285
-- Note [Punning]
-- ~~~~~~~~~~~~~~
-- If you write T { x, y = v+1 }, the HsRecFields will be
Ian Lynagh's avatar
Ian Lynagh committed
286 287 288
--      HsRecField x x True ...
--      HsRecField y (v+1) False ...
-- That is, for "punned" field x is expanded (in the renamer)
289
-- to x=x; but with a punning flag so we can detect it later
290
-- (e.g. when pretty printing)
291 292 293
--
-- If the original field was qualified, we un-qualify it, thus
--    T { A.x } means T { A.x = x }
294

Adam Gundry's avatar
Adam Gundry committed
295 296 297 298 299 300 301 302 303 304 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

-- 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
334 335
--
-- See also Note [Disambiguating record fields] in TcExpr.
Adam Gundry's avatar
Adam Gundry committed
336 337 338 339

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

340 341 342 343
-- 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
344 345 346 347 348 349 350 351 352 353 354 355 356 357 358
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

359

Austin Seipp's avatar
Austin Seipp committed
360 361 362 363 364 365 366
{-
************************************************************************
*                                                                      *
*              Printing patterns
*                                                                      *
************************************************************************
-}
367

368 369 370
instance (OutputableBndr name) => Outputable (Pat name) where
    ppr = pprPat

371
pprPatBndr :: OutputableBndr name => name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
372
pprPatBndr var                  -- Print with type info if -dppr-debug is on
373 374
  = getPprStyle $ \ sty ->
    if debugStyle sty then
Ian Lynagh's avatar
Ian Lynagh committed
375 376
        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat
                                                -- but is it worth it?
377
    else
378
        pprPrefixOcc var
379

380 381 382 383
pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
pprParendLPat (L _ p) = pprParendPat p

pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
384 385 386 387 388 389 390 391 392 393 394
pprParendPat p = getPprStyle $ \ sty ->
                 if need_parens sty p
                 then parens (pprPat p)
                 else  pprPat p
  where
    need_parens sty p
      | CoPat {} <- p          -- In debug style we print the cast
      , debugStyle sty = True  -- (see pprHsWrapper) so parens are needed
      | otherwise      = hsPatNeedsParens p
                         -- But otherwise the CoPat is discarded, so it
                         -- is the pattern inside that matters.  Sigh.
395

396
pprPat :: (OutputableBndr name) => Pat name -> SDoc
397
pprPat (VarPat (L _ var))     = pprPatBndr var
398 399 400 401 402 403 404 405 406 407 408 409 410 411
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
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 (ppr pat) co
pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty
412
pprPat (ListPat pats _ _)     = brackets (interpp'SP pats)
413 414
pprPat (PArrPat pats _)       = paBrackets (interpp'SP pats)
pprPat (TuplePat pats bx _)   = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
415
pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
Ian Lynagh's avatar
Ian Lynagh committed
416 417 418 419 420
pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
                    pat_binds = binds, pat_args = details })
  = getPprStyle $ \ sty ->      -- Tiresome; in TcBinds.tcRhs we print out a
    if debugStyle sty then      -- typechecked Pat in an error message,
                                -- and we want to make sure it prints nicely
Gergő Érdi's avatar
Gergő Érdi committed
421 422 423 424
        ppr con
          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                         , ppr binds])
          <+> pprConArgs details
425
    else pprUserCon (unLoc con) details
426 427


428 429 430
pprUserCon :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
431

432
pprConArgs ::  OutputableBndr id => HsConPatDetails id -> SDoc
433 434
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
435 436
pprConArgs (RecCon rpats)   = ppr rpats

Adam Gundry's avatar
Adam Gundry committed
437
instance (Outputable arg)
438 439
      => Outputable (HsRecFields id arg) where
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
Ian Lynagh's avatar
Ian Lynagh committed
440
        = braces (fsep (punctuate comma (map ppr flds)))
441
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
Ian Lynagh's avatar
Ian Lynagh committed
442 443 444
        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
        where
          dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds))
445

Adam Gundry's avatar
Adam Gundry committed
446 447 448
instance (Outputable id, Outputable arg)
      => Outputable (HsRecField' id arg) where
  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
Ian Lynagh's avatar
Ian Lynagh committed
449
                    hsRecPun = pun })
450
    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
451

Adam Gundry's avatar
Adam Gundry committed
452

Austin Seipp's avatar
Austin Seipp committed
453 454 455 456 457 458 459
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
460

461
mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id
462
-- Make a vanilla Prefix constructor pattern
463
mkPrefixConPat dc pats tys
Gergő Érdi's avatar
Gergő Érdi committed
464
  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
Ian Lynagh's avatar
Ian Lynagh committed
465
                        pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
466
                        pat_arg_tys = tys, pat_wrap = idHsWrapper }
467

468
mkNilPat :: Type -> OutPat id
469
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
470

471 472 473
mkCharLitPat :: String -> Char -> OutPat id
mkCharLitPat src c = mkPrefixConPat charDataCon
                                    [noLoc $ LitPat (HsCharPrim src c)] []
474

Austin Seipp's avatar
Austin Seipp committed
475 476 477 478 479 480
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
481

482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503
\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.

504
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
505 506
-}

507 508 509 510
isUnliftedLPat :: LPat id -> Bool
isUnliftedLPat (L _ (ParPat p))             = isUnliftedLPat p
isUnliftedLPat (L _ (TuplePat _ Unboxed _)) = True
isUnliftedLPat _                            = False
511

512
isUnliftedHsBind :: HsBind id -> Bool
513
-- A pattern binding with an outermost bang or unboxed tuple must be matched strictly
514
-- Defined in this module because HsPat is above HsBinds in the import graph
515 516 517 518 519 520 521 522 523 524 525
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
526 527 528

looksLazyPatBind :: HsBind id -> Bool
-- Returns True of anything *except*
Austin Seipp's avatar
Austin Seipp committed
529
--     a StrictHsBind (as above) or
530 531 532 533 534 535 536 537 538 539 540 541 542
--     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
looksLazyLPat (L _ (VarPat {}))            = False
looksLazyLPat (L _ (WildPat {}))           = False
looksLazyLPat _                            = True
543

544
isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
545 546
-- (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
547 548 549
--      (NB: this is not quite the same as the (silly) defn
--      in 3.17.2 of the Haskell 98 report.)
--
550 551 552 553 554 555
-- 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.
--
556 557 558 559
-- But if it returns True, the pattern is definitely irrefutable
isIrrefutableHsPat pat
  = go pat
  where
560
    go (L _ pat) = go1 pat
561

562 563 564
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
565
    go1 (BangPat pat)       = go pat
566
    go1 (CoPat _ pat _)     = go1 pat
567 568
    go1 (ParPat pat)        = go pat
    go1 (AsPat _ pat)       = go pat
569
    go1 (ViewPat _ pat _)   = go pat
570 571 572
    go1 (SigPatIn pat _)    = go pat
    go1 (SigPatOut pat _)   = go pat
    go1 (TuplePat pats _ _) = all go pats
573
    go1 (ListPat {}) = False
Ian Lynagh's avatar
Ian Lynagh committed
574
    go1 (PArrPat {})        = False     -- ?
575

Ian Lynagh's avatar
Ian Lynagh committed
576
    go1 (ConPatIn {})       = False     -- Conservative
Gergő Érdi's avatar
Gergő Érdi committed
577
    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
Ian Lynagh's avatar
Ian Lynagh committed
578 579 580 581
        =  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
582 583
    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
        = False -- Conservative
584

585 586 587
    go1 (LitPat {})    = False
    go1 (NPat {})      = False
    go1 (NPlusKPat {}) = False
588

gmainland's avatar
gmainland committed
589 590
    -- Both should be gotten rid of by renamer before
    -- isIrrefutablePat is called
Austin Seipp's avatar
Austin Seipp committed
591
    go1 (SplicePat {})     = urk pat
592 593

    urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
594 595

hsPatNeedsParens :: Pat a -> Bool
596
hsPatNeedsParens (NPlusKPat {})      = True
gmainland's avatar
gmainland committed
597
hsPatNeedsParens (SplicePat {})      = False
598 599 600 601 602
hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
hsPatNeedsParens (SigPatIn {})       = True
hsPatNeedsParens (SigPatOut {})      = True
hsPatNeedsParens (ViewPat {})        = True
603
hsPatNeedsParens (CoPat _ p _)       = hsPatNeedsParens p
604 605 606 607 608 609 610 611
hsPatNeedsParens (WildPat {})        = False
hsPatNeedsParens (VarPat {})         = False
hsPatNeedsParens (LazyPat {})        = False
hsPatNeedsParens (BangPat {})        = False
hsPatNeedsParens (ParPat {})         = False
hsPatNeedsParens (AsPat {})          = False
hsPatNeedsParens (TuplePat {})       = False
hsPatNeedsParens (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
612 613 614
hsPatNeedsParens (PArrPat {})        = False
hsPatNeedsParens (LitPat {})         = False
hsPatNeedsParens (NPat {})           = False
615 616 617

conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon args) = not (null args)
618 619
conPatNeedsParens (InfixCon {})    = True
conPatNeedsParens (RecCon {})      = True
620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651

{-
% 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
    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