38f06264a242c5e0afc31d2cb6cd9ad2404b81e2
[ghc.git] / compiler / hsSyn / HsPat.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5 \section[PatSyntax]{Abstract Haskell syntax---patterns}
6 -}
7
8 {-# LANGUAGE DeriveDataTypeable #-}
9 {-# LANGUAGE DeriveDataTypeable #-}
10 {-# LANGUAGE StandaloneDeriving #-}
11 {-# LANGUAGE FlexibleContexts #-}
12 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
13 -- in module PlaceHolder
14 {-# LANGUAGE ConstraintKinds #-}
15 {-# LANGUAGE TypeFamilies #-}
16
17 module HsPat (
18 Pat(..), InPat, OutPat, LPat,
19
20 HsConDetails(..),
21 HsConPatDetails, hsConPatArgs,
22 HsRecFields(..), HsRecField'(..), LHsRecField',
23 HsRecField, LHsRecField,
24 HsRecUpdField, LHsRecUpdField,
25 hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,
26 hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
27
28 mkPrefixConPat, mkCharLitPat, mkNilPat,
29
30 isUnliftedHsBind, looksLazyPatBind,
31 isUnliftedLPat, isBangedLPat, isBangedPatBind,
32 hsPatNeedsParens,
33 isIrrefutableHsPat,
34
35 collectEvVarsPats,
36
37 hasFreeVarsLPat, hasFreeVarsPat,
38
39 pprParendLPat, pprConArgs
40 ) where
41
42 import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice)
43
44 -- friends:
45 import HsBinds
46 import HsLit
47 import PlaceHolder -- ( PostRn,PostTc,DataId )
48 import HsTypes
49 import TcEvidence
50 import BasicTypes
51 -- others:
52 import PprCore ( {- instance OutputableBndr TyVar -} )
53 import TysWiredIn
54 import Var
55 import RdrName ( RdrName )
56 import ConLike
57 import DataCon
58 import TyCon
59 import Outputable
60 import Type
61 import SrcLoc
62 import FastString
63 import Bag -- collect ev vars from pats
64 import Maybes
65 -- libraries:
66 import Data.Data hiding (TyCon,Fixity)
67
68 type InPat id = LPat id -- No 'Out' constructors
69 type OutPat id = LPat id -- No 'In' constructors
70
71 type LPat id = Located (Pat id)
72
73 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
74
75 -- For details on above see note [Api annotations] in ApiAnnotation
76 data Pat id
77 = ------------ Simple patterns ---------------
78 WildPat (PostTc id Type) -- Wild card
79 -- The sole reason for a type on a WildPat is to
80 -- support hsPatType :: Pat Id -> Type
81
82 | VarPat (Located id) -- Variable
83 -- See Note [Located RdrNames] in HsExpr
84 | LazyPat (LPat id) -- Lazy pattern
85 -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
86
87 -- For details on above see note [Api annotations] in ApiAnnotation
88
89 | AsPat (Located id) (LPat id) -- As pattern
90 -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
91
92 -- For details on above see note [Api annotations] in ApiAnnotation
93
94 | ParPat (LPat id) -- Parenthesised pattern
95 -- See Note [Parens in HsSyn] in HsExpr
96 -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
97 -- 'ApiAnnotation.AnnClose' @')'@
98
99 -- For details on above see note [Api annotations] in ApiAnnotation
100 | BangPat (LPat id) -- Bang pattern
101 -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
102
103 -- For details on above see note [Api annotations] in ApiAnnotation
104
105 ------------ Lists, tuples, arrays ---------------
106 | ListPat [LPat id] -- Syntactic list
107 (PostTc id Type) -- The type of the elements
108 (Maybe (PostTc id Type, SyntaxExpr id)) -- For rebindable syntax
109 -- For OverloadedLists a Just (ty,fn) gives
110 -- overall type of the pattern, and the toList
111 -- function to convert the scrutinee to a list value
112 -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
113 -- 'ApiAnnotation.AnnClose' @']'@
114
115 -- For details on above see note [Api annotations] in ApiAnnotation
116
117 | TuplePat [LPat id] -- Tuple sub-patterns
118 Boxity -- UnitPat is TuplePat []
119 [PostTc id Type] -- [] before typechecker, filled in afterwards
120 -- with the types of the tuple components
121 -- You might think that the PostTc id Type was redundant, because we can
122 -- get the pattern type by getting the types of the sub-patterns.
123 -- But it's essential
124 -- data T a where
125 -- T1 :: Int -> T Int
126 -- f :: (T a, a) -> Int
127 -- f (T1 x, z) = z
128 -- When desugaring, we must generate
129 -- f = /\a. \v::a. case v of (t::T a, w::a) ->
130 -- case t of (T1 (x::Int)) ->
131 -- Note the (w::a), NOT (w::Int), because we have not yet
132 -- refined 'a' to Int. So we must know that the second component
133 -- of the tuple is of type 'a' not Int. See selectMatchVar
134 -- (June 14: I'm not sure this comment is right; the sub-patterns
135 -- will be wrapped in CoPats, no?)
136 -- ^ - 'ApiAnnotation.AnnKeywordId' :
137 -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
138 -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@
139
140 -- For details on above see note [Api annotations] in ApiAnnotation
141 | PArrPat [LPat id] -- Syntactic parallel array
142 (PostTc id Type) -- The type of the elements
143 -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
144 -- 'ApiAnnotation.AnnClose' @':]'@
145
146 -- For details on above see note [Api annotations] in ApiAnnotation
147 ------------ Constructor patterns ---------------
148 | ConPatIn (Located id)
149 (HsConPatDetails id)
150
151 | ConPatOut {
152 pat_con :: Located ConLike,
153 pat_arg_tys :: [Type], -- The universal arg types, 1-1 with the universal
154 -- tyvars of the constructor/pattern synonym
155 -- Use (conLikeResTy pat_con pat_arg_tys) to get
156 -- the type of the pattern
157
158 pat_tvs :: [TyVar], -- Existentially bound type variables
159 pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries*
160 -- One reason for putting coercion variable here, I think,
161 -- is to ensure their kinds are zonked
162
163 pat_binds :: TcEvBinds, -- Bindings involving those dictionaries
164 pat_args :: HsConPatDetails id,
165 pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher
166 -- Only relevant for pattern-synonyms;
167 -- ignored for data cons
168 }
169
170 ------------ View patterns ---------------
171 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
172
173 -- For details on above see note [Api annotations] in ApiAnnotation
174 | ViewPat (LHsExpr id)
175 (LPat id)
176 (PostTc id Type) -- The overall type of the pattern
177 -- (= the argument type of the view function)
178 -- for hsPatType.
179
180 ------------ Pattern splices ---------------
181 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
182 -- 'ApiAnnotation.AnnClose' @')'@
183
184 -- For details on above see note [Api annotations] in ApiAnnotation
185 | SplicePat (HsSplice id) -- Includes quasi-quotes
186
187 ------------ Literal and n+k patterns ---------------
188 | LitPat HsLit -- Used for *non-overloaded* literal patterns:
189 -- Int#, Char#, Int, Char, String, etc.
190
191 | NPat -- Used for all overloaded literals,
192 -- including overloaded strings with -XOverloadedStrings
193 (Located (HsOverLit id)) -- ALWAYS positive
194 (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative
195 -- patterns, Nothing otherwise
196 (SyntaxExpr id) -- Equality checker, of type t->t->Bool
197
198 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
199
200 -- For details on above see note [Api annotations] in ApiAnnotation
201 | NPlusKPat (Located id) -- n+k pattern
202 (Located (HsOverLit id)) -- It'll always be an HsIntegral
203 (SyntaxExpr id) -- (>=) function, of type t->t->Bool
204 (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName)
205
206 ------------ Pattern type signatures ---------------
207 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
208
209 -- For details on above see note [Api annotations] in ApiAnnotation
210 | SigPatIn (LPat id) -- Pattern with a type signature
211 (LHsSigWcType id) -- Signature can bind both
212 -- kind and type vars
213
214 | SigPatOut (LPat id) -- Pattern with a type signature
215 Type
216
217 ------------ Pattern coercions (translation only) ---------------
218 | CoPat HsWrapper -- If co :: t1 ~ t2, p :: t2,
219 -- then (CoPat co p) :: t1
220 (Pat id) -- Why not LPat? Ans: existing locn will do
221 Type -- Type of whole pattern, t1
222 -- During desugaring a (CoPat co pat) turns into a cast with 'co' on
223 -- the scrutinee, followed by a match on 'pat'
224 deriving (Typeable)
225 deriving instance (DataId id) => Data (Pat id)
226
227 -- HsConDetails is use for patterns/expressions *and* for data type declarations
228
229 data HsConDetails arg rec
230 = PrefixCon [arg] -- C p1 p2 p3
231 | RecCon rec -- C { x = p1, y = p2 }
232 | InfixCon arg arg -- p1 `C` p2
233 deriving (Data, Typeable)
234
235 type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))
236
237 hsConPatArgs :: HsConPatDetails id -> [LPat id]
238 hsConPatArgs (PrefixCon ps) = ps
239 hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs)
240 hsConPatArgs (InfixCon p1 p2) = [p1,p2]
241
242 instance (Outputable arg, Outputable rec)
243 => Outputable (HsConDetails arg rec) where
244 ppr (PrefixCon args) = text "PrefixCon" <+> ppr args
245 ppr (RecCon rec) = text "RecCon:" <+> ppr rec
246 ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
247
248 {-
249 However HsRecFields is used only for patterns and expressions
250 (not data type declarations)
251 -}
252
253 data HsRecFields id arg -- A bunch of record fields
254 -- { x = 3, y = True }
255 -- Used for both expressions and patterns
256 = HsRecFields { rec_flds :: [LHsRecField id arg],
257 rec_dotdot :: Maybe Int } -- Note [DotDot fields]
258 deriving (Typeable)
259 deriving instance (DataId id, Data arg) => Data (HsRecFields id arg)
260
261 -- Note [DotDot fields]
262 -- ~~~~~~~~~~~~~~~~~~~~
263 -- The rec_dotdot field means this:
264 -- Nothing => the normal case
265 -- Just n => the group uses ".." notation,
266 --
267 -- In the latter case:
268 --
269 -- *before* renamer: rec_flds are exactly the n user-written fields
270 --
271 -- *after* renamer: rec_flds includes *all* fields, with
272 -- the first 'n' being the user-written ones
273 -- and the remainder being 'filled in' implicitly
274
275 type LHsRecField' id arg = Located (HsRecField' id arg)
276 type LHsRecField id arg = Located (HsRecField id arg)
277 type LHsRecUpdField id = Located (HsRecUpdField id)
278
279 type HsRecField id arg = HsRecField' (FieldOcc id) arg
280 type HsRecUpdField id = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id)
281
282 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
283 --
284 -- For details on above see note [Api annotations] in ApiAnnotation
285 data HsRecField' id arg = HsRecField {
286 hsRecFieldLbl :: Located id,
287 hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning
288 hsRecPun :: Bool -- ^ Note [Punning]
289 } deriving (Data, Typeable)
290
291
292 -- Note [Punning]
293 -- ~~~~~~~~~~~~~~
294 -- If you write T { x, y = v+1 }, the HsRecFields will be
295 -- HsRecField x x True ...
296 -- HsRecField y (v+1) False ...
297 -- That is, for "punned" field x is expanded (in the renamer)
298 -- to x=x; but with a punning flag so we can detect it later
299 -- (e.g. when pretty printing)
300 --
301 -- If the original field was qualified, we un-qualify it, thus
302 -- T { A.x } means T { A.x = x }
303
304
305 -- Note [HsRecField and HsRecUpdField]
306 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
307
308 -- A HsRecField (used for record construction and pattern matching)
309 -- contains an unambiguous occurrence of a field (i.e. a FieldOcc).
310 -- We can't just store the Name, because thanks to
311 -- DuplicateRecordFields this may not correspond to the label the user
312 -- wrote.
313 --
314 -- A HsRecUpdField (used for record update) contains a potentially
315 -- ambiguous occurrence of a field (an AmbiguousFieldOcc). The
316 -- renamer will fill in the selector function if it can, but if the
317 -- selector is ambiguous the renamer will defer to the typechecker.
318 -- After the typechecker, a unique selector will have been determined.
319 --
320 -- The renamer produces an Unambiguous result if it can, rather than
321 -- just doing the lookup in the typechecker, so that completely
322 -- unambiguous updates can be represented by 'DsMeta.repUpdFields'.
323 --
324 -- For example, suppose we have:
325 --
326 -- data S = MkS { x :: Int }
327 -- data T = MkT { x :: Int }
328 --
329 -- f z = (z { x = 3 }) :: S
330 --
331 -- The parsed HsRecUpdField corresponding to the record update will have:
332 --
333 -- hsRecFieldLbl = Unambiguous "x" PlaceHolder :: AmbiguousFieldOcc RdrName
334 --
335 -- After the renamer, this will become:
336 --
337 -- hsRecFieldLbl = Ambiguous "x" PlaceHolder :: AmbiguousFieldOcc Name
338 --
339 -- (note that the Unambiguous constructor is not type-correct here).
340 -- The typechecker will determine the particular selector:
341 --
342 -- hsRecFieldLbl = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id
343 --
344 -- See also Note [Disambiguating record fields] in TcExpr.
345
346 hsRecFields :: HsRecFields id arg -> [PostRn id id]
347 hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)
348
349 -- Probably won't typecheck at once, things have changed :/
350 hsRecFieldsArgs :: HsRecFields id arg -> [arg]
351 hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)
352
353 hsRecFieldSel :: HsRecField name arg -> Located (PostRn name name)
354 hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl
355
356 hsRecFieldId :: HsRecField Id arg -> Located Id
357 hsRecFieldId = hsRecFieldSel
358
359 hsRecUpdFieldRdr :: HsRecUpdField id -> Located RdrName
360 hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl
361
362 hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc Id) arg -> Located Id
363 hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc
364
365 hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc Id) arg -> LFieldOcc Id
366 hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
367
368
369 {-
370 ************************************************************************
371 * *
372 * Printing patterns
373 * *
374 ************************************************************************
375 -}
376
377 instance (OutputableBndr name) => Outputable (Pat name) where
378 ppr = pprPat
379
380 pprPatBndr :: OutputableBndr name => name -> SDoc
381 pprPatBndr var -- Print with type info if -dppr-debug is on
382 = getPprStyle $ \ sty ->
383 if debugStyle sty then
384 parens (pprBndr LambdaBind var) -- Could pass the site to pprPat
385 -- but is it worth it?
386 else
387 pprPrefixOcc var
388
389 pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
390 pprParendLPat (L _ p) = pprParendPat p
391
392 pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
393 pprParendPat p = getPprStyle $ \ sty ->
394 if need_parens sty p
395 then parens (pprPat p)
396 else pprPat p
397 where
398 need_parens sty p
399 | CoPat {} <- p -- In debug style we print the cast
400 , debugStyle sty = True -- (see pprHsWrapper) so parens are needed
401 | otherwise = hsPatNeedsParens p
402 -- But otherwise the CoPat is discarded, so it
403 -- is the pattern inside that matters. Sigh.
404
405 pprPat :: (OutputableBndr name) => Pat name -> SDoc
406 pprPat (VarPat (L _ var)) = pprPatBndr var
407 pprPat (WildPat _) = char '_'
408 pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
409 pprPat (BangPat pat) = char '!' <> pprParendLPat pat
410 pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
411 pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
412 pprPat (ParPat pat) = parens (ppr pat)
413 pprPat (LitPat s) = ppr s
414 pprPat (NPat l Nothing _) = ppr l
415 pprPat (NPat l (Just _) _) = char '-' <> ppr l
416 pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
417 pprPat (SplicePat splice) = pprSplice splice
418 pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
419 pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
420 pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
421 pprPat (ListPat pats _ _) = brackets (interpp'SP pats)
422 pprPat (PArrPat pats _) = paBrackets (interpp'SP pats)
423 pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
424 pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
425 pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
426 pat_binds = binds, pat_args = details })
427 = getPprStyle $ \ sty -> -- Tiresome; in TcBinds.tcRhs we print out a
428 if debugStyle sty then -- typechecked Pat in an error message,
429 -- and we want to make sure it prints nicely
430 ppr con
431 <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
432 , ppr binds])
433 <+> pprConArgs details
434 else pprUserCon (unLoc con) details
435
436
437 pprUserCon :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
438 pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
439 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
440
441 pprConArgs :: OutputableBndr id => HsConPatDetails id -> SDoc
442 pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
443 pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
444 pprConArgs (RecCon rpats) = ppr rpats
445
446 instance (Outputable arg)
447 => Outputable (HsRecFields id arg) where
448 ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
449 = braces (fsep (punctuate comma (map ppr flds)))
450 ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
451 = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
452 where
453 dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds))
454
455 instance (Outputable id, Outputable arg)
456 => Outputable (HsRecField' id arg) where
457 ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
458 hsRecPun = pun })
459 = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
460
461
462 {-
463 ************************************************************************
464 * *
465 * Building patterns
466 * *
467 ************************************************************************
468 -}
469
470 mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id
471 -- Make a vanilla Prefix constructor pattern
472 mkPrefixConPat dc pats tys
473 = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
474 pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
475 pat_arg_tys = tys, pat_wrap = idHsWrapper }
476
477 mkNilPat :: Type -> OutPat id
478 mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
479
480 mkCharLitPat :: String -> Char -> OutPat id
481 mkCharLitPat src c = mkPrefixConPat charDataCon
482 [noLoc $ LitPat (HsCharPrim src c)] []
483
484 {-
485 ************************************************************************
486 * *
487 * Predicates for checking things about pattern-lists in EquationInfo *
488 * *
489 ************************************************************************
490
491 \subsection[Pat-list-predicates]{Look for interesting things in patterns}
492
493 Unlike in the Wadler chapter, where patterns are either ``variables''
494 or ``constructors,'' here we distinguish between:
495 \begin{description}
496 \item[unfailable:]
497 Patterns that cannot fail to match: variables, wildcards, and lazy
498 patterns.
499
500 These are the irrefutable patterns; the two other categories
501 are refutable patterns.
502
503 \item[constructor:]
504 A non-literal constructor pattern (see next category).
505
506 \item[literal patterns:]
507 At least the numeric ones may be overloaded.
508 \end{description}
509
510 A pattern is in {\em exactly one} of the above three categories; `as'
511 patterns are treated specially, of course.
512
513 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
514 -}
515
516 isUnliftedLPat :: LPat id -> Bool
517 isUnliftedLPat (L _ (ParPat p)) = isUnliftedLPat p
518 isUnliftedLPat (L _ (TuplePat _ Unboxed _)) = True
519 isUnliftedLPat _ = False
520
521 isUnliftedHsBind :: HsBind id -> Bool
522 -- A pattern binding with an outermost bang or unboxed tuple must be matched strictly
523 -- Defined in this module because HsPat is above HsBinds in the import graph
524 isUnliftedHsBind (PatBind { pat_lhs = p }) = isUnliftedLPat p
525 isUnliftedHsBind _ = False
526
527 isBangedPatBind :: HsBind id -> Bool
528 isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat
529 isBangedPatBind _ = False
530
531 isBangedLPat :: LPat id -> Bool
532 isBangedLPat (L _ (ParPat p)) = isBangedLPat p
533 isBangedLPat (L _ (BangPat {})) = True
534 isBangedLPat _ = False
535
536 looksLazyPatBind :: HsBind id -> Bool
537 -- Returns True of anything *except*
538 -- a StrictHsBind (as above) or
539 -- a VarPat
540 -- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
541 looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p
542 looksLazyPatBind _ = False
543
544 looksLazyLPat :: LPat id -> Bool
545 looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p
546 looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p
547 looksLazyLPat (L _ (BangPat {})) = False
548 looksLazyLPat (L _ (TuplePat _ Unboxed _)) = False
549 looksLazyLPat (L _ (VarPat {})) = False
550 looksLazyLPat (L _ (WildPat {})) = False
551 looksLazyLPat _ = True
552
553 isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
554 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
555 -- in the sense of falling through to the next pattern.
556 -- (NB: this is not quite the same as the (silly) defn
557 -- in 3.17.2 of the Haskell 98 report.)
558 --
559 -- WARNING: isIrrefutableHsPat returns False if it's in doubt.
560 -- Specifically on a ConPatIn, which is what it sees for a
561 -- (LPat Name) in the renamer, it doesn't know the size of the
562 -- constructor family, so it returns False. Result: only
563 -- tuple patterns are considered irrefuable at the renamer stage.
564 --
565 -- But if it returns True, the pattern is definitely irrefutable
566 isIrrefutableHsPat pat
567 = go pat
568 where
569 go (L _ pat) = go1 pat
570
571 go1 (WildPat {}) = True
572 go1 (VarPat {}) = True
573 go1 (LazyPat {}) = True
574 go1 (BangPat pat) = go pat
575 go1 (CoPat _ pat _) = go1 pat
576 go1 (ParPat pat) = go pat
577 go1 (AsPat _ pat) = go pat
578 go1 (ViewPat _ pat _) = go pat
579 go1 (SigPatIn pat _) = go pat
580 go1 (SigPatOut pat _) = go pat
581 go1 (TuplePat pats _ _) = all go pats
582 go1 (ListPat {}) = False
583 go1 (PArrPat {}) = False -- ?
584
585 go1 (ConPatIn {}) = False -- Conservative
586 go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
587 = isJust (tyConSingleDataCon_maybe (dataConTyCon con))
588 -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because
589 -- the latter is false of existentials. See Trac #4439
590 && all go (hsConPatArgs details)
591 go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
592 = False -- Conservative
593
594 go1 (LitPat {}) = False
595 go1 (NPat {}) = False
596 go1 (NPlusKPat {}) = False
597
598 -- Both should be gotten rid of by renamer before
599 -- isIrrefutablePat is called
600 go1 (SplicePat {}) = urk pat
601
602 urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
603
604 hsPatNeedsParens :: Pat a -> Bool
605 hsPatNeedsParens (NPlusKPat {}) = True
606 hsPatNeedsParens (SplicePat {}) = False
607 hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds
608 hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p)
609 hsPatNeedsParens (SigPatIn {}) = True
610 hsPatNeedsParens (SigPatOut {}) = True
611 hsPatNeedsParens (ViewPat {}) = True
612 hsPatNeedsParens (CoPat _ p _) = hsPatNeedsParens p
613 hsPatNeedsParens (WildPat {}) = False
614 hsPatNeedsParens (VarPat {}) = False
615 hsPatNeedsParens (LazyPat {}) = False
616 hsPatNeedsParens (BangPat {}) = False
617 hsPatNeedsParens (ParPat {}) = False
618 hsPatNeedsParens (AsPat {}) = False
619 hsPatNeedsParens (TuplePat {}) = False
620 hsPatNeedsParens (ListPat {}) = False
621 hsPatNeedsParens (PArrPat {}) = False
622 hsPatNeedsParens (LitPat {}) = False
623 hsPatNeedsParens (NPat {}) = False
624
625 conPatNeedsParens :: HsConDetails a b -> Bool
626 conPatNeedsParens (PrefixCon args) = not (null args)
627 conPatNeedsParens (InfixCon {}) = True
628 conPatNeedsParens (RecCon {}) = True
629
630 {-
631 % Collect all EvVars from all constructor patterns
632 -}
633
634 -- May need to add more cases
635 collectEvVarsPats :: [Pat id] -> Bag EvVar
636 collectEvVarsPats = unionManyBags . map collectEvVarsPat
637
638 collectEvVarsLPat :: LPat id -> Bag EvVar
639 collectEvVarsLPat (L _ pat) = collectEvVarsPat pat
640
641 collectEvVarsPat :: Pat id -> Bag EvVar
642 collectEvVarsPat pat =
643 case pat of
644 LazyPat p -> collectEvVarsLPat p
645 AsPat _ p -> collectEvVarsLPat p
646 ParPat p -> collectEvVarsLPat p
647 BangPat p -> collectEvVarsLPat p
648 ListPat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
649 TuplePat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
650 PArrPat ps _ -> unionManyBags $ map collectEvVarsLPat ps
651 ConPatOut {pat_dicts = dicts, pat_args = args}
652 -> unionBags (listToBag dicts)
653 $ unionManyBags
654 $ map collectEvVarsLPat
655 $ hsConPatArgs args
656 SigPatOut p _ -> collectEvVarsLPat p
657 CoPat _ p _ -> collectEvVarsPat p
658 ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn"
659 SigPatIn _ _ -> panic "foldMapPatBag: SigPatIn"
660 _other_pat -> emptyBag
661
662 hasFreeVarsLPat :: LPat id -> Bool
663 hasFreeVarsLPat (L _ pat) = hasFreeVarsPat pat
664
665 -- | Checks whether a pattern contains any unbound variables from
666 -- `VarPat`s or `AsPat`s.
667 hasFreeVarsPat :: Pat id -> Bool
668 hasFreeVarsPat pat =
669 case pat of
670 VarPat {} -> True
671 AsPat {} -> True
672 NPlusKPat {} -> True
673 NPat {} -> False
674 LitPat {} -> False
675 WildPat {} -> False
676 ViewPat _ p _ -> hasFreeVarsLPat p
677 LazyPat p -> hasFreeVarsLPat p
678 ParPat p -> hasFreeVarsLPat p
679 BangPat p -> hasFreeVarsLPat p
680 ListPat ps _ _ -> any hasFreeVarsLPat ps
681 TuplePat ps _ _ -> any hasFreeVarsLPat ps
682 PArrPat ps _ -> any hasFreeVarsLPat ps
683 ConPatOut {pat_args = ps}
684 -> any hasFreeVarsLPat (hsConPatArgs ps)
685 SigPatOut p _ -> hasFreeVarsLPat p
686 CoPat _ p _ -> hasFreeVarsPat p
687 ConPatIn _ p -> any hasFreeVarsLPat (hsConPatArgs p)
688 SigPatIn p _ -> hasFreeVarsLPat p
689
690 SplicePat {} -> panic "hasFreVarsPat: SplicePat"