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