HsPat.hs 20.7 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 #-}
15

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

Ian Lynagh's avatar
Ian Lynagh committed
19 20
        HsConDetails(..),
        HsConPatDetails, hsConPatArgs,
21
        HsRecFields(..), HsRecField(..), LHsRecField, hsRecFields,
Ian Lynagh's avatar
Ian Lynagh committed
22 23

        mkPrefixConPat, mkCharLitPat, mkNilPat,
24

25 26
        isStrictHsBind, looksLazyPatBind,
        isStrictLPat, hsPatNeedsParens,
27
        isIrrefutableHsPat,
28

29
        pprParendLPat, pprConArgs
30 31
    ) where

32
import {-# SOURCE #-} HsExpr            (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprUntypedSplice)
sof's avatar
sof committed
33

34
-- friends:
35 36
import HsBinds
import HsLit
37
import PlaceHolder ( PostTc,DataId )
38
import HsTypes
39
import TcEvidence
40
import BasicTypes
41
-- others:
Ian Lynagh's avatar
Ian Lynagh committed
42
import PprCore          ( {- instance OutputableBndr TyVar -} )
43 44
import TysWiredIn
import Var
Gergő Érdi's avatar
Gergő Érdi committed
45
import ConLike
46 47
import DataCon
import TyCon
Ian Lynagh's avatar
Ian Lynagh committed
48
import Outputable
49 50
import Type
import SrcLoc
51
import FastString
52
-- libraries:
53
import Data.Data hiding (TyCon,Fixity)
54
import Data.Maybe
55

Ian Lynagh's avatar
Ian Lynagh committed
56 57
type InPat id  = LPat id        -- No 'Out' constructors
type OutPat id = LPat id        -- No 'In' constructors
58 59

type LPat id = Located (Pat id)
60

Alan Zimmerman's avatar
Alan Zimmerman committed
61
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
62
data Pat id
Ian Lynagh's avatar
Ian Lynagh committed
63
  =     ------------ Simple patterns ---------------
64
    WildPat     (PostTc id Type)        -- Wild card
Ian Lynagh's avatar
Ian Lynagh committed
65 66
        -- The sole reason for a type on a WildPat is to
        -- support hsPatType :: Pat Id -> Type
67

Ian Lynagh's avatar
Ian Lynagh committed
68
  | VarPat      id                      -- Variable
69
  | LazyPat     (LPat id)               -- Lazy pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
70 71
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'

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

Ian Lynagh's avatar
Ian Lynagh committed
75 76
  | ParPat      (LPat id)               -- Parenthesised pattern
                                        -- See Note [Parens in HsSyn] in HsExpr
Alan Zimmerman's avatar
Alan Zimmerman committed
77 78
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
    --                                    'ApiAnnotation.AnnClose' @')'@
Ian Lynagh's avatar
Ian Lynagh committed
79
  | BangPat     (LPat id)               -- Bang pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
80
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
Ian Lynagh's avatar
Ian Lynagh committed
81 82

        ------------ Lists, tuples, arrays ---------------
83
  | ListPat     [LPat id]                            -- Syntactic list
84 85
                (PostTc id Type)                     -- The type of the elements
                (Maybe (PostTc id Type, SyntaxExpr id)) -- For rebindable syntax
86 87 88
                   -- 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
89 90
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
    --                                    'ApiAnnotation.AnnClose' @']'@
Ian Lynagh's avatar
Ian Lynagh committed
91

92 93 94 95 96
  | 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
97 98
        -- get the pattern type by getting the types of the sub-patterns.
        -- But it's essential
Ian Lynagh's avatar
Ian Lynagh committed
99 100 101 102 103 104 105 106 107 108
        --      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
109 110
        -- (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
111 112 113
    -- ^ - 'ApiAnnotation.AnnKeywordId' :
    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
Ian Lynagh's avatar
Ian Lynagh committed
114 115

  | PArrPat     [LPat id]               -- Syntactic parallel array
116
                (PostTc id Type)        -- The type of the elements
Alan Zimmerman's avatar
Alan Zimmerman committed
117 118
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
    --                                    'ApiAnnotation.AnnClose' @':]'@
Ian Lynagh's avatar
Ian Lynagh committed
119 120 121 122

        ------------ Constructor patterns ---------------
  | ConPatIn    (Located id)
                (HsConPatDetails id)
123

124
  | ConPatOut {
125 126 127
        pat_con     :: Located ConLike,
        pat_arg_tys :: [Type],          -- The univeral arg types, 1-1 with the universal
                                        -- tyvars of the constructor/pattern synonym
Austin Seipp's avatar
Austin Seipp committed
128
                                        --   Use (conLikeResTy pat_con pat_arg_tys) to get
129 130
                                        --   the type of the pattern

Ian Lynagh's avatar
Ian Lynagh committed
131 132 133 134 135 136
        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
137
        pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
138
    }
139

Ian Lynagh's avatar
Ian Lynagh committed
140
        ------------ View patterns ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
141
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
Ian Lynagh's avatar
Ian Lynagh committed
142
  | ViewPat       (LHsExpr id)
143
                  (LPat id)
144
                  (PostTc id Type)  -- The overall type of the pattern
145 146 147
                                    -- (= the argument type of the view function)
                                    -- for hsPatType.

gmainland's avatar
gmainland committed
148
        ------------ Pattern splices ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
149 150
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
  --        'ApiAnnotation.AnnClose' @')'@
gmainland's avatar
gmainland committed
151 152
  | SplicePat       (HsSplice id)

Ian Lynagh's avatar
Ian Lynagh committed
153 154
        ------------ Quasiquoted patterns ---------------
        -- See Note [Quasi-quote overview] in TcSplice
155 156
  | QuasiQuotePat   (HsQuasiQuote id)

Ian Lynagh's avatar
Ian Lynagh committed
157 158 159 160 161 162
        ------------ 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
163
                    (Located (HsOverLit id))    -- ALWAYS positive
Ian Lynagh's avatar
Ian Lynagh committed
164 165 166 167
                    (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
168
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
Ian Lynagh's avatar
Ian Lynagh committed
169
  | NPlusKPat       (Located id)        -- n+k pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
170
                    (Located (HsOverLit id)) -- It'll always be an HsIntegral
Ian Lynagh's avatar
Ian Lynagh committed
171 172 173 174
                    (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
175
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
176 177 178
  | SigPatIn        (LPat id)                  -- Pattern with a type signature
                    (HsWithBndrs id (LHsType id)) -- Signature can bind both
                                                  -- kind and type vars
Ian Lynagh's avatar
Ian Lynagh committed
179 180 181 182 183 184 185 186 187 188 189

  | 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'
190 191
  deriving (Typeable)
deriving instance (DataId id) => Data (Pat id)
192

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

195 196
data HsConDetails arg rec
  = PrefixCon [arg]             -- C p1 p2 p3
Ian Lynagh's avatar
Ian Lynagh committed
197 198
  | RecCon    rec               -- C { x = p1, y = p2 }
  | InfixCon  arg arg           -- p1 `C` p2
199
  deriving (Data, Typeable)
200 201 202 203 204

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

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

Austin Seipp's avatar
Austin Seipp committed
208
{-
209 210
However HsRecFields is used only for patterns and expressions
(not data type declarations)
Austin Seipp's avatar
Austin Seipp committed
211
-}
212

Ian Lynagh's avatar
Ian Lynagh committed
213 214 215
data HsRecFields id arg         -- A bunch of record fields
                                --      { x = 3, y = True }
        -- Used for both expressions and patterns
216
  = HsRecFields { rec_flds   :: [LHsRecField id arg],
Ian Lynagh's avatar
Ian Lynagh committed
217
                  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
218
  deriving (Data, Typeable)
219 220 221 222 223

-- Note [DotDot fields]
-- ~~~~~~~~~~~~~~~~~~~~
-- The rec_dotdot field means this:
--   Nothing => the normal case
Ian Lynagh's avatar
Ian Lynagh committed
224
--   Just n  => the group uses ".." notation,
225
--
Ian Lynagh's avatar
Ian Lynagh committed
226
-- In the latter case:
227 228 229
--
--   *before* renamer: rec_flds are exactly the n user-written fields
--
Ian Lynagh's avatar
Ian Lynagh committed
230 231 232
--   *after* renamer:  rec_flds includes *all* fields, with
--                     the first 'n' being the user-written ones
--                     and the remainder being 'filled in' implicitly
233

234
type LHsRecField id arg = Located (HsRecField id arg)
Alan Zimmerman's avatar
Alan Zimmerman committed
235
-- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
236
data HsRecField id arg = HsRecField {
Ian Lynagh's avatar
Ian Lynagh committed
237 238 239
        hsRecFieldId  :: Located id,
        hsRecFieldArg :: arg,           -- Filled in by renamer
        hsRecPun      :: Bool           -- Note [Punning]
240
  } deriving (Data, Typeable)
241 242 243 244

-- Note [Punning]
-- ~~~~~~~~~~~~~~
-- If you write T { x, y = v+1 }, the HsRecFields will be
Ian Lynagh's avatar
Ian Lynagh committed
245 246 247
--      HsRecField x x True ...
--      HsRecField y (v+1) False ...
-- That is, for "punned" field x is expanded (in the renamer)
248
-- to x=x; but with a punning flag so we can detect it later
249
-- (e.g. when pretty printing)
250 251 252
--
-- If the original field was qualified, we un-qualify it, thus
--    T { A.x } means T { A.x = x }
253 254

hsRecFields :: HsRecFields id arg -> [id]
255
hsRecFields rbinds = map (unLoc . hsRecFieldId . unLoc) (rec_flds rbinds)
256

Austin Seipp's avatar
Austin Seipp committed
257 258 259 260 261 262 263
{-
************************************************************************
*                                                                      *
*              Printing patterns
*                                                                      *
************************************************************************
-}
264

265 266 267
instance (OutputableBndr name) => Outputable (Pat name) where
    ppr = pprPat

268
pprPatBndr :: OutputableBndr name => name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
269
pprPatBndr var                  -- Print with type info if -dppr-debug is on
270 271
  = getPprStyle $ \ sty ->
    if debugStyle sty then
Ian Lynagh's avatar
Ian Lynagh committed
272 273
        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat
                                                -- but is it worth it?
274
    else
275
        pprPrefixOcc var
276

277 278 279 280
pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
pprParendLPat (L _ p) = pprParendPat p

pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
281 282
pprParendPat p | hsPatNeedsParens p = parens (pprPat p)
               | otherwise          = pprPat p
283

284
pprPat :: (OutputableBndr name) => Pat name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
285 286
pprPat (VarPat var)       = pprPatBndr var
pprPat (WildPat _)        = char '_'
287 288
pprPat (LazyPat pat)      = char '~' <> pprParendLPat pat
pprPat (BangPat pat)      = char '!' <> pprParendLPat pat
289
pprPat (AsPat name pat)   = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
290
pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
Ian Lynagh's avatar
Ian Lynagh committed
291
pprPat (ParPat pat)         = parens (ppr pat)
292
pprPat (ListPat pats _ _)     = brackets (interpp'SP pats)
293
pprPat (PArrPat pats _)     = paBrackets (interpp'SP pats)
batterseapower's avatar
batterseapower committed
294
pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
295

296
pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
Ian Lynagh's avatar
Ian Lynagh committed
297 298 299 300 301
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
302 303 304 305
        ppr con
          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                         , ppr binds])
          <+> pprConArgs details
306
    else pprUserCon (unLoc con) details
307

Ian Lynagh's avatar
Ian Lynagh committed
308
pprPat (LitPat s)           = ppr s
309 310
pprPat (NPat l Nothing  _)  = ppr l
pprPat (NPat l (Just _) _)  = char '-' <> ppr l
311
pprPat (NPlusKPat n k _ _)  = hcat [ppr n, char '+', ppr k]
312
pprPat (SplicePat splice)   = pprUntypedSplice splice
313
pprPat (QuasiQuotePat qq)   = ppr qq
Ian Lynagh's avatar
Ian Lynagh committed
314
pprPat (CoPat co pat _)     = pprHsWrapper (ppr pat) co
315 316
pprPat (SigPatIn pat ty)    = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty)   = ppr pat <+> dcolon <+> ppr ty
317

318 319 320
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
321

322
pprConArgs ::  OutputableBndr id => HsConPatDetails id -> SDoc
323 324
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
325 326 327 328 329
pprConArgs (RecCon rpats)   = ppr rpats

instance (OutputableBndr id, Outputable arg)
      => Outputable (HsRecFields id arg) where
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
Ian Lynagh's avatar
Ian Lynagh committed
330
        = braces (fsep (punctuate comma (map ppr flds)))
331
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
Ian Lynagh's avatar
Ian Lynagh committed
332 333 334
        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
        where
          dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds))
335 336 337

instance (OutputableBndr id, Outputable arg)
      => Outputable (HsRecField id arg) where
Ian Lynagh's avatar
Ian Lynagh committed
338 339
  ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
                    hsRecPun = pun })
340
    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
341

Austin Seipp's avatar
Austin Seipp committed
342 343 344 345 346 347 348
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
349

350
mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id
351
-- Make a vanilla Prefix constructor pattern
352
mkPrefixConPat dc pats tys
Gergő Érdi's avatar
Gergő Érdi committed
353
  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
Ian Lynagh's avatar
Ian Lynagh committed
354
                        pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
355
                        pat_arg_tys = tys, pat_wrap = idHsWrapper }
356

357
mkNilPat :: Type -> OutPat id
358
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
359

360 361 362
mkCharLitPat :: String -> Char -> OutPat id
mkCharLitPat src c = mkPrefixConPat charDataCon
                                    [noLoc $ LitPat (HsCharPrim src c)] []
363

Austin Seipp's avatar
Austin Seipp committed
364 365 366 367 368 369
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
370

371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392
\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.

393
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
394 395
-}

396 397 398 399 400 401 402 403
isStrictLPat :: LPat id -> Bool
isStrictLPat (L _ (ParPat p))             = isStrictLPat p
isStrictLPat (L _ (BangPat {}))           = True
isStrictLPat (L _ (TuplePat _ Unboxed _)) = True
isStrictLPat _                            = False

isStrictHsBind :: HsBind id -> Bool
-- A pattern binding with an outermost bang or unboxed tuple must be matched strictly
404
-- Defined in this module because HsPat is above HsBinds in the import graph
405 406 407 408 409
isStrictHsBind (PatBind { pat_lhs = p }) = isStrictLPat p
isStrictHsBind _                         = False

looksLazyPatBind :: HsBind id -> Bool
-- Returns True of anything *except*
Austin Seipp's avatar
Austin Seipp committed
410
--     a StrictHsBind (as above) or
411 412 413 414 415 416 417 418 419 420 421 422 423
--     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
424

425
isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
426 427
-- (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
428 429 430
--      (NB: this is not quite the same as the (silly) defn
--      in 3.17.2 of the Haskell 98 report.)
--
431
-- isIrrefutableHsPat returns False if it's in doubt; specifically
432
-- on a ConPatIn it doesn't know the size of the constructor family
433 434 435 436
-- But if it returns True, the pattern is definitely irrefutable
isIrrefutableHsPat pat
  = go pat
  where
437
    go (L _ pat) = go1 pat
438

439 440 441
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
442
    go1 (BangPat pat)       = go pat
443
    go1 (CoPat _ pat _)     = go1 pat
444 445
    go1 (ParPat pat)        = go pat
    go1 (AsPat _ pat)       = go pat
446
    go1 (ViewPat _ pat _)   = go pat
447 448 449
    go1 (SigPatIn pat _)    = go pat
    go1 (SigPatOut pat _)   = go pat
    go1 (TuplePat pats _ _) = all go pats
450
    go1 (ListPat {}) = False
Ian Lynagh's avatar
Ian Lynagh committed
451
    go1 (PArrPat {})        = False     -- ?
452

Ian Lynagh's avatar
Ian Lynagh committed
453
    go1 (ConPatIn {})       = False     -- Conservative
Gergő Érdi's avatar
Gergő Érdi committed
454
    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
Ian Lynagh's avatar
Ian Lynagh committed
455 456 457 458
        =  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
459 460
    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
        = False -- Conservative
461

462 463 464
    go1 (LitPat {})    = False
    go1 (NPat {})      = False
    go1 (NPlusKPat {}) = False
465

gmainland's avatar
gmainland committed
466 467
    -- Both should be gotten rid of by renamer before
    -- isIrrefutablePat is called
Austin Seipp's avatar
Austin Seipp committed
468
    go1 (SplicePat {})     = urk pat
gmainland's avatar
gmainland committed
469
    go1 (QuasiQuotePat {}) = urk pat
470 471

    urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
472 473

hsPatNeedsParens :: Pat a -> Bool
474
hsPatNeedsParens (NPlusKPat {})      = True
gmainland's avatar
gmainland committed
475
hsPatNeedsParens (SplicePat {})      = False
476 477 478 479 480 481 482
hsPatNeedsParens (QuasiQuotePat {})  = True
hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
hsPatNeedsParens (SigPatIn {})       = True
hsPatNeedsParens (SigPatOut {})      = True
hsPatNeedsParens (ViewPat {})        = True
hsPatNeedsParens (CoPat {})          = True
483 484 485 486 487 488 489 490
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
491 492 493
hsPatNeedsParens (PArrPat {})        = False
hsPatNeedsParens (LitPat {})         = False
hsPatNeedsParens (NPat {})           = False
494 495 496

conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon args) = not (null args)
497 498
conPatNeedsParens (InfixCon {})    = True
conPatNeedsParens (RecCon {})      = True