HsPat.hs 21.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 #-}
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 63

-- For details on above see note [Api annotations] in ApiAnnotation
64
data Pat id
Ian Lynagh's avatar
Ian Lynagh committed
65
  =     ------------ Simple patterns ---------------
66
    WildPat     (PostTc id Type)        -- Wild card
Ian Lynagh's avatar
Ian Lynagh committed
67 68
        -- The sole reason for a type on a WildPat is to
        -- support hsPatType :: Pat Id -> Type
69

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

74 75
    -- For details on above see note [Api annotations] in ApiAnnotation

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

79 80
    -- For details on above see note [Api annotations] in ApiAnnotation

Ian Lynagh's avatar
Ian Lynagh committed
81 82
  | ParPat      (LPat id)               -- Parenthesised pattern
                                        -- See Note [Parens in HsSyn] in HsExpr
Alan Zimmerman's avatar
Alan Zimmerman committed
83 84
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
    --                                    'ApiAnnotation.AnnClose' @')'@
85 86

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

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

Ian Lynagh's avatar
Ian Lynagh committed
92
        ------------ Lists, tuples, arrays ---------------
93
  | ListPat     [LPat id]                            -- Syntactic list
94 95
                (PostTc id Type)                     -- The type of the elements
                (Maybe (PostTc id Type, SyntaxExpr id)) -- For rebindable syntax
96 97 98
                   -- 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
99 100
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
    --                                    'ApiAnnotation.AnnClose' @']'@
Ian Lynagh's avatar
Ian Lynagh committed
101

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

104 105 106 107 108
  | 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
109 110
        -- get the pattern type by getting the types of the sub-patterns.
        -- But it's essential
Ian Lynagh's avatar
Ian Lynagh committed
111 112 113 114 115 116 117 118 119 120
        --      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
121 122
        -- (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
123 124 125
    -- ^ - 'ApiAnnotation.AnnKeywordId' :
    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
Ian Lynagh's avatar
Ian Lynagh committed
126

127
    -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
128
  | PArrPat     [LPat id]               -- Syntactic parallel array
129
                (PostTc id Type)        -- The type of the elements
Alan Zimmerman's avatar
Alan Zimmerman committed
130 131
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
    --                                    'ApiAnnotation.AnnClose' @':]'@
Ian Lynagh's avatar
Ian Lynagh committed
132

133
    -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
134 135 136
        ------------ Constructor patterns ---------------
  | ConPatIn    (Located id)
                (HsConPatDetails id)
137

138
  | ConPatOut {
139 140 141
        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
142
                                        --   Use (conLikeResTy pat_con pat_arg_tys) to get
143 144
                                        --   the type of the pattern

Ian Lynagh's avatar
Ian Lynagh committed
145 146 147 148 149 150
        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
151
        pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
152
    }
153

Ian Lynagh's avatar
Ian Lynagh committed
154
        ------------ View patterns ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
155
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
156 157

  -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
158
  | ViewPat       (LHsExpr id)
159
                  (LPat id)
160
                  (PostTc id Type)  -- The overall type of the pattern
161 162 163
                                    -- (= the argument type of the view function)
                                    -- for hsPatType.

gmainland's avatar
gmainland committed
164
        ------------ Pattern splices ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
165 166
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
  --        'ApiAnnotation.AnnClose' @')'@
167 168

  -- For details on above see note [Api annotations] in ApiAnnotation
gmainland's avatar
gmainland committed
169 170
  | SplicePat       (HsSplice id)

Ian Lynagh's avatar
Ian Lynagh committed
171 172
        ------------ Quasiquoted patterns ---------------
        -- See Note [Quasi-quote overview] in TcSplice
173 174
  | QuasiQuotePat   (HsQuasiQuote id)

Ian Lynagh's avatar
Ian Lynagh committed
175 176 177 178 179 180
        ------------ 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
181
                    (Located (HsOverLit id))    -- ALWAYS positive
Ian Lynagh's avatar
Ian Lynagh committed
182 183 184 185
                    (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
186
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
187 188

  -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
189
  | NPlusKPat       (Located id)        -- n+k pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
190
                    (Located (HsOverLit id)) -- It'll always be an HsIntegral
Ian Lynagh's avatar
Ian Lynagh committed
191 192 193 194
                    (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
195
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
196 197

  -- For details on above see note [Api annotations] in ApiAnnotation
198 199 200
  | 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
201 202 203 204 205 206 207 208 209 210 211

  | 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'
212 213
  deriving (Typeable)
deriving instance (DataId id) => Data (Pat id)
214

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

217 218
data HsConDetails arg rec
  = PrefixCon [arg]             -- C p1 p2 p3
Ian Lynagh's avatar
Ian Lynagh committed
219 220
  | RecCon    rec               -- C { x = p1, y = p2 }
  | InfixCon  arg arg           -- p1 `C` p2
221
  deriving (Data, Typeable)
222 223 224 225 226

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

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

Austin Seipp's avatar
Austin Seipp committed
230
{-
231 232
However HsRecFields is used only for patterns and expressions
(not data type declarations)
Austin Seipp's avatar
Austin Seipp committed
233
-}
234

Ian Lynagh's avatar
Ian Lynagh committed
235 236 237
data HsRecFields id arg         -- A bunch of record fields
                                --      { x = 3, y = True }
        -- Used for both expressions and patterns
238
  = HsRecFields { rec_flds   :: [LHsRecField id arg],
Ian Lynagh's avatar
Ian Lynagh committed
239
                  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
240
  deriving (Data, Typeable)
241 242 243 244 245

-- Note [DotDot fields]
-- ~~~~~~~~~~~~~~~~~~~~
-- The rec_dotdot field means this:
--   Nothing => the normal case
Ian Lynagh's avatar
Ian Lynagh committed
246
--   Just n  => the group uses ".." notation,
247
--
Ian Lynagh's avatar
Ian Lynagh committed
248
-- In the latter case:
249 250 251
--
--   *before* renamer: rec_flds are exactly the n user-written fields
--
Ian Lynagh's avatar
Ian Lynagh committed
252 253 254
--   *after* renamer:  rec_flds includes *all* fields, with
--                     the first 'n' being the user-written ones
--                     and the remainder being 'filled in' implicitly
255

256
type LHsRecField id arg = Located (HsRecField id arg)
Alan Zimmerman's avatar
Alan Zimmerman committed
257
-- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
258 259

-- For details on above see note [Api annotations] in ApiAnnotation
260
data HsRecField id arg = HsRecField {
Ian Lynagh's avatar
Ian Lynagh committed
261 262 263
        hsRecFieldId  :: Located id,
        hsRecFieldArg :: arg,           -- Filled in by renamer
        hsRecPun      :: Bool           -- Note [Punning]
264
  } deriving (Data, Typeable)
265 266 267 268

-- Note [Punning]
-- ~~~~~~~~~~~~~~
-- If you write T { x, y = v+1 }, the HsRecFields will be
Ian Lynagh's avatar
Ian Lynagh committed
269 270 271
--      HsRecField x x True ...
--      HsRecField y (v+1) False ...
-- That is, for "punned" field x is expanded (in the renamer)
272
-- to x=x; but with a punning flag so we can detect it later
273
-- (e.g. when pretty printing)
274 275 276
--
-- If the original field was qualified, we un-qualify it, thus
--    T { A.x } means T { A.x = x }
277 278

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

Austin Seipp's avatar
Austin Seipp committed
281 282 283 284 285 286 287
{-
************************************************************************
*                                                                      *
*              Printing patterns
*                                                                      *
************************************************************************
-}
288

289 290 291
instance (OutputableBndr name) => Outputable (Pat name) where
    ppr = pprPat

292
pprPatBndr :: OutputableBndr name => name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
293
pprPatBndr var                  -- Print with type info if -dppr-debug is on
294 295
  = getPprStyle $ \ sty ->
    if debugStyle sty then
Ian Lynagh's avatar
Ian Lynagh committed
296 297
        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat
                                                -- but is it worth it?
298
    else
299
        pprPrefixOcc var
300

301 302 303 304
pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
pprParendLPat (L _ p) = pprParendPat p

pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
305 306
pprParendPat p | hsPatNeedsParens p = parens (pprPat p)
               | otherwise          = pprPat p
307

308
pprPat :: (OutputableBndr name) => Pat name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
309 310
pprPat (VarPat var)       = pprPatBndr var
pprPat (WildPat _)        = char '_'
311 312
pprPat (LazyPat pat)      = char '~' <> pprParendLPat pat
pprPat (BangPat pat)      = char '!' <> pprParendLPat pat
313
pprPat (AsPat name pat)   = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
314
pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
Ian Lynagh's avatar
Ian Lynagh committed
315
pprPat (ParPat pat)         = parens (ppr pat)
316
pprPat (ListPat pats _ _)     = brackets (interpp'SP pats)
317
pprPat (PArrPat pats _)     = paBrackets (interpp'SP pats)
batterseapower's avatar
batterseapower committed
318
pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
319

320
pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
Ian Lynagh's avatar
Ian Lynagh committed
321 322 323 324 325
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
326 327 328 329
        ppr con
          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                         , ppr binds])
          <+> pprConArgs details
330
    else pprUserCon (unLoc con) details
331

Ian Lynagh's avatar
Ian Lynagh committed
332
pprPat (LitPat s)           = ppr s
333 334
pprPat (NPat l Nothing  _)  = ppr l
pprPat (NPat l (Just _) _)  = char '-' <> ppr l
335
pprPat (NPlusKPat n k _ _)  = hcat [ppr n, char '+', ppr k]
336
pprPat (SplicePat splice)   = pprUntypedSplice splice
337
pprPat (QuasiQuotePat qq)   = ppr qq
Ian Lynagh's avatar
Ian Lynagh committed
338
pprPat (CoPat co pat _)     = pprHsWrapper (ppr pat) co
339 340
pprPat (SigPatIn pat ty)    = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty)   = ppr pat <+> dcolon <+> ppr ty
341

342 343 344
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
345

346
pprConArgs ::  OutputableBndr id => HsConPatDetails id -> SDoc
347 348
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
349 350 351 352 353
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
354
        = braces (fsep (punctuate comma (map ppr flds)))
355
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
Ian Lynagh's avatar
Ian Lynagh committed
356 357 358
        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
        where
          dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds))
359 360 361

instance (OutputableBndr id, Outputable arg)
      => Outputable (HsRecField id arg) where
Ian Lynagh's avatar
Ian Lynagh committed
362 363
  ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
                    hsRecPun = pun })
364
    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
365

Austin Seipp's avatar
Austin Seipp committed
366 367 368 369 370 371 372
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
373

374
mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id
375
-- Make a vanilla Prefix constructor pattern
376
mkPrefixConPat dc pats tys
Gergő Érdi's avatar
Gergő Érdi committed
377
  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
Ian Lynagh's avatar
Ian Lynagh committed
378
                        pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
379
                        pat_arg_tys = tys, pat_wrap = idHsWrapper }
380

381
mkNilPat :: Type -> OutPat id
382
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
383

384 385 386
mkCharLitPat :: String -> Char -> OutPat id
mkCharLitPat src c = mkPrefixConPat charDataCon
                                    [noLoc $ LitPat (HsCharPrim src c)] []
387

Austin Seipp's avatar
Austin Seipp committed
388 389 390 391 392 393
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
394

395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416
\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.

417
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
418 419
-}

420 421 422 423 424 425 426 427
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
428
-- Defined in this module because HsPat is above HsBinds in the import graph
429 430 431 432 433
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
434
--     a StrictHsBind (as above) or
435 436 437 438 439 440 441 442 443 444 445 446 447
--     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
448

449
isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
450 451
-- (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
452 453 454
--      (NB: this is not quite the same as the (silly) defn
--      in 3.17.2 of the Haskell 98 report.)
--
455
-- isIrrefutableHsPat returns False if it's in doubt; specifically
456
-- on a ConPatIn it doesn't know the size of the constructor family
457 458 459 460
-- But if it returns True, the pattern is definitely irrefutable
isIrrefutableHsPat pat
  = go pat
  where
461
    go (L _ pat) = go1 pat
462

463 464 465
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
466
    go1 (BangPat pat)       = go pat
467
    go1 (CoPat _ pat _)     = go1 pat
468 469
    go1 (ParPat pat)        = go pat
    go1 (AsPat _ pat)       = go pat
470
    go1 (ViewPat _ pat _)   = go pat
471 472 473
    go1 (SigPatIn pat _)    = go pat
    go1 (SigPatOut pat _)   = go pat
    go1 (TuplePat pats _ _) = all go pats
474
    go1 (ListPat {}) = False
Ian Lynagh's avatar
Ian Lynagh committed
475
    go1 (PArrPat {})        = False     -- ?
476

Ian Lynagh's avatar
Ian Lynagh committed
477
    go1 (ConPatIn {})       = False     -- Conservative
Gergő Érdi's avatar
Gergő Érdi committed
478
    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
Ian Lynagh's avatar
Ian Lynagh committed
479 480 481 482
        =  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
483 484
    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
        = False -- Conservative
485

486 487 488
    go1 (LitPat {})    = False
    go1 (NPat {})      = False
    go1 (NPlusKPat {}) = False
489

gmainland's avatar
gmainland committed
490 491
    -- Both should be gotten rid of by renamer before
    -- isIrrefutablePat is called
Austin Seipp's avatar
Austin Seipp committed
492
    go1 (SplicePat {})     = urk pat
gmainland's avatar
gmainland committed
493
    go1 (QuasiQuotePat {}) = urk pat
494 495

    urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
496 497

hsPatNeedsParens :: Pat a -> Bool
498
hsPatNeedsParens (NPlusKPat {})      = True
gmainland's avatar
gmainland committed
499
hsPatNeedsParens (SplicePat {})      = False
500 501 502 503 504 505 506
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
507 508 509 510 511 512 513 514
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
515 516 517
hsPatNeedsParens (PArrPat {})        = False
hsPatNeedsParens (LitPat {})         = False
hsPatNeedsParens (NPat {})           = False
518 519 520

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