HsPat.lhs 17.9 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6
7
%
\section[PatSyntax]{Abstract Haskell syntax---patterns}

\begin{code}
8
{-# OPTIONS -fno-warn-incomplete-patterns #-}
9
10
11
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
12
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
13
-- for details
14
{-# LANGUAGE DeriveDataTypeable #-}
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
21
22
23
        HsConDetails(..),
        HsConPatDetails, hsConPatArgs,
        HsRecFields(..), HsRecField(..), hsRecFields,

        mkPrefixConPat, mkCharLitPat, mkNilPat,
24

25
26
        isBangHsBind, isLiftedPatBind,
        isBangLPat, hsPatNeedsParens,
27
        isIrrefutableHsPat,
28

Ian Lynagh's avatar
Ian Lynagh committed
29
        pprParendLPat
30
31
    ) where

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

34
-- friends:
35
36
37
38
import HsBinds
import HsLit
import HsTypes
import BasicTypes
39
-- others:
Ian Lynagh's avatar
Ian Lynagh committed
40
import PprCore          ( {- instance OutputableBndr TyVar -} )
41
42
43
44
import TysWiredIn
import Var
import DataCon
import TyCon
Ian Lynagh's avatar
Ian Lynagh committed
45
import Outputable
46
47
import Type
import SrcLoc
48
import FastString
49
50
-- libraries:
import Data.Data hiding (TyCon)
51
import Data.Maybe
52
53
\end{code}

54

55
\begin{code}
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
61

data Pat id
Ian Lynagh's avatar
Ian Lynagh committed
62
63
64
65
  =     ------------ Simple patterns ---------------
    WildPat     PostTcType              -- Wild card
        -- The sole reason for a type on a WildPat is to
        -- support hsPatType :: Pat Id -> Type
66

Ian Lynagh's avatar
Ian Lynagh committed
67
  | VarPat      id                      -- Variable
68
  | LazyPat     (LPat id)               -- Lazy pattern
Ian Lynagh's avatar
Ian Lynagh committed
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
  | AsPat       (Located id) (LPat id)  -- As pattern
  | ParPat      (LPat id)               -- Parenthesised pattern
                                        -- See Note [Parens in HsSyn] in HsExpr
  | BangPat     (LPat id)               -- Bang pattern

        ------------ Lists, tuples, arrays ---------------
  | ListPat     [LPat id]               -- Syntactic list
                PostTcType              -- The type of the elements

  | TuplePat    [LPat id]               -- Tuple
                Boxity                  -- UnitPat is TuplePat []
                PostTcType
        -- You might think that the PostTcType was redundant, 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

  | PArrPat     [LPat id]               -- Syntactic parallel array
                PostTcType              -- The type of the elements

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

100
  | ConPatOut {
Ian Lynagh's avatar
Ian Lynagh committed
101
102
103
104
105
106
107
108
        pat_con   :: Located DataCon,
        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,
        pat_ty    :: Type               -- The type of the pattern
109
    }
110

Ian Lynagh's avatar
Ian Lynagh committed
111
112
        ------------ View patterns ---------------
  | ViewPat       (LHsExpr id)
113
114
115
116
117
                  (LPat id)
                  PostTcType        -- The overall type of the pattern
                                    -- (= the argument type of the view function)
                                    -- for hsPatType.

Ian Lynagh's avatar
Ian Lynagh committed
118
119
        ------------ Quasiquoted patterns ---------------
        -- See Note [Quasi-quote overview] in TcSplice
120
121
  | QuasiQuotePat   (HsQuasiQuote id)

Ian Lynagh's avatar
Ian Lynagh committed
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
        ------------ 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
                    (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

  | NPlusKPat       (Located id)        -- n+k pattern
                    (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 ---------------
  | SigPatIn        (LPat id)           -- Pattern with a type signature
                    (LHsType id)

  | 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'
152
  deriving (Data, Typeable)
153
154
\end{code}

155
HsConDetails is use for patterns/expressions *and* for data type declarations
156
157

\begin{code}
158
159
data HsConDetails arg rec
  = PrefixCon [arg]             -- C p1 p2 p3
Ian Lynagh's avatar
Ian Lynagh committed
160
161
  | RecCon    rec               -- C { x = p1, y = p2 }
  | InfixCon  arg arg           -- p1 `C` p2
162
  deriving (Data, Typeable)
163
164
165
166
167
168
169
170
171
172
173
174
175

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

hsConPatArgs :: HsConPatDetails id -> [LPat id]
hsConPatArgs (PrefixCon ps)   = ps
hsConPatArgs (RecCon fs)      = map hsRecFieldArg (rec_flds fs)
hsConPatArgs (InfixCon p1 p2) = [p1,p2]
\end{code}

However HsRecFields is used only for patterns and expressions
(not data type declarations)

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
176
177
178
data HsRecFields id arg         -- A bunch of record fields
                                --      { x = 3, y = True }
        -- Used for both expressions and patterns
179
  = HsRecFields { rec_flds   :: [HsRecField id arg],
Ian Lynagh's avatar
Ian Lynagh committed
180
                  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
181
  deriving (Data, Typeable)
182
183
184
185
186

-- Note [DotDot fields]
-- ~~~~~~~~~~~~~~~~~~~~
-- The rec_dotdot field means this:
--   Nothing => the normal case
Ian Lynagh's avatar
Ian Lynagh committed
187
--   Just n  => the group uses ".." notation,
188
--
Ian Lynagh's avatar
Ian Lynagh committed
189
-- In the latter case:
190
191
192
--
--   *before* renamer: rec_flds are exactly the n user-written fields
--
Ian Lynagh's avatar
Ian Lynagh committed
193
194
195
--   *after* renamer:  rec_flds includes *all* fields, with
--                     the first 'n' being the user-written ones
--                     and the remainder being 'filled in' implicitly
196
197

data HsRecField id arg = HsRecField {
Ian Lynagh's avatar
Ian Lynagh committed
198
199
200
        hsRecFieldId  :: Located id,
        hsRecFieldArg :: arg,           -- Filled in by renamer
        hsRecPun      :: Bool           -- Note [Punning]
201
  } deriving (Data, Typeable)
202
203
204
205

-- Note [Punning]
-- ~~~~~~~~~~~~~~
-- If you write T { x, y = v+1 }, the HsRecFields will be
Ian Lynagh's avatar
Ian Lynagh committed
206
207
208
--      HsRecField x x True ...
--      HsRecField y (v+1) False ...
-- That is, for "punned" field x is expanded (in the renamer)
209
-- to x=x; but with a punning flag so we can detect it later
210
-- (e.g. when pretty printing)
211
212
213
--
-- If the original field was qualified, we un-qualify it, thus
--    T { A.x } means T { A.x = x }
214
215
216

hsRecFields :: HsRecFields id arg -> [id]
hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds)
217
218
219
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
220
221
222
%*                                                                      *
%*              Printing patterns
%*                                                                      *
223
%************************************************************************
224

225
\begin{code}
226
227
228
instance (OutputableBndr name) => Outputable (Pat name) where
    ppr = pprPat

229
pprPatBndr :: OutputableBndr name => name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
230
pprPatBndr var                  -- Print with type info if -dppr-debug is on
231
232
  = getPprStyle $ \ sty ->
    if debugStyle sty then
Ian Lynagh's avatar
Ian Lynagh committed
233
234
        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat
                                                -- but is it worth it?
235
    else
Ian Lynagh's avatar
Ian Lynagh committed
236
        ppr var
237

238
239
240
241
pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
pprParendLPat (L _ p) = pprParendPat p

pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
242
243
pprParendPat p | hsPatNeedsParens p = parens (pprPat p)
               | otherwise          = pprPat p
244

245
pprPat :: (OutputableBndr name) => Pat name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
246
247
pprPat (VarPat var)       = pprPatBndr var
pprPat (WildPat _)        = char '_'
248
249
250
251
pprPat (LazyPat pat)      = char '~' <> pprParendLPat pat
pprPat (BangPat pat)      = char '!' <> pprParendLPat pat
pprPat (AsPat name pat)   = hcat [ppr name, char '@', pprParendLPat pat]
pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
Ian Lynagh's avatar
Ian Lynagh committed
252
pprPat (ParPat pat)         = parens (ppr pat)
253
254
pprPat (ListPat pats _)     = brackets (interpp'SP pats)
pprPat (PArrPat pats _)     = pabrackets (interpp'SP pats)
batterseapower's avatar
batterseapower committed
255
pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
256

257
pprPat (ConPatIn con details) = pprUserCon con details
Ian Lynagh's avatar
Ian Lynagh committed
258
259
260
261
262
263
264
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])
265
                <+> pprConArgs details
266
    else pprUserCon con details
267

Ian Lynagh's avatar
Ian Lynagh committed
268
pprPat (LitPat s)           = ppr s
269
270
pprPat (NPat l Nothing  _)  = ppr l
pprPat (NPat l (Just _) _)  = char '-' <> ppr l
271
272
pprPat (NPlusKPat n k _ _)  = hcat [ppr n, char '+', ppr k]
pprPat (QuasiQuotePat qq)   = ppr qq
Ian Lynagh's avatar
Ian Lynagh committed
273
pprPat (CoPat co pat _)     = pprHsWrapper (ppr pat) co
274
275
pprPat (SigPatIn pat ty)    = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty)   = ppr pat <+> dcolon <+> ppr ty
276

277
pprUserCon :: (Outputable con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
278
279
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2
pprUserCon c details          = ppr c <+> pprConArgs details
280

281
pprConArgs ::  OutputableBndr id => HsConPatDetails id -> SDoc
282
283
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
284
285
286
287
288
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
289
        = braces (fsep (punctuate comma (map ppr flds)))
290
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
Ian Lynagh's avatar
Ian Lynagh committed
291
292
293
        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
        where
          dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds))
294
295
296

instance (OutputableBndr id, Outputable arg)
      => Outputable (HsRecField id arg) where
Ian Lynagh's avatar
Ian Lynagh committed
297
298
  ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
                    hsRecPun = pun })
299
    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
chak's avatar
chak committed
300
301
302
303

-- add parallel array brackets around a document
--
pabrackets   :: SDoc -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
304
pabrackets p  = ptext (sLit "[:") <> p <> ptext (sLit ":]")
305
306
\end{code}

307

308
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
309
310
311
%*                                                                      *
%*              Building patterns
%*                                                                      *
312
%************************************************************************
313

314
315
316
\begin{code}
mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
-- Make a vanilla Prefix constructor pattern
Ian Lynagh's avatar
Ian Lynagh committed
317
mkPrefixConPat dc pats ty
318
  = noLoc $ ConPatOut { pat_con = noLoc dc, pat_tvs = [], pat_dicts = [],
Ian Lynagh's avatar
Ian Lynagh committed
319
320
                        pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
                        pat_ty = ty }
321

322
323
mkNilPat :: Type -> OutPat id
mkNilPat ty = mkPrefixConPat nilDataCon [] ty
324

325
326
mkCharLitPat :: Char -> OutPat id
mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy
327
328
\end{code}

329

330
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
331
332
333
%*                                                                      *
%* Predicates for checking things about pattern-lists in EquationInfo   *
%*                                                                      *
334
%************************************************************************
335

336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
\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.

358
359
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
\begin{code}
360
361
362
363
isBangLPat :: LPat id -> Bool
isBangLPat (L _ (BangPat {})) = True
isBangLPat (L _ (ParPat p))   = isBangLPat p
isBangLPat _                  = False
364

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
365
isBangHsBind :: HsBind id -> Bool
366
367
-- A pattern binding with an outermost bang
-- Defined in this module because HsPat is above HsBinds in the import graph
368
369
isBangHsBind (PatBind { pat_lhs = p }) = isBangLPat p
isBangHsBind _                         = False
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
370

371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
isLiftedPatBind :: HsBind id -> Bool
-- A pattern binding with a compound pattern, not just a variable
--    (I# x)       yes
--    (# a, b #)   no, even if a::Int#
--    x            no, even if x::Int#
-- We want to warn about a missing bang-pattern on the yes's
isLiftedPatBind (PatBind { pat_lhs = p }) = isLiftedLPat p
isLiftedPatBind _                         = False

isLiftedLPat :: LPat id -> Bool
isLiftedLPat (L _ (ParPat p))   = isLiftedLPat p
isLiftedLPat (L _ (BangPat p))  = isLiftedLPat p
isLiftedLPat (L _ (AsPat _ p))  = isLiftedLPat p
isLiftedLPat (L _ (TuplePat _ Unboxed _)) = False
isLiftedLPat (L _ (VarPat {}))            = False
isLiftedLPat (L _ (WildPat {}))           = False
isLiftedLPat _                            = True

389
isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
390
391
-- (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
392
393
394
--      (NB: this is not quite the same as the (silly) defn
--      in 3.17.2 of the Haskell 98 report.)
--
395
-- isIrrefutableHsPat returns False if it's in doubt; specifically
396
-- on a ConPatIn it doesn't know the size of the constructor family
397
398
399
400
-- But if it returns True, the pattern is definitely irrefutable
isIrrefutableHsPat pat
  = go pat
  where
401
    go (L _ pat) = go1 pat
402

403
404
405
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
406
    go1 (BangPat pat)       = go pat
407
    go1 (CoPat _ pat _)     = go1 pat
408
409
    go1 (ParPat pat)        = go pat
    go1 (AsPat _ pat)       = go pat
410
    go1 (ViewPat _ pat _)   = go pat
411
412
413
    go1 (SigPatIn pat _)    = go pat
    go1 (SigPatOut pat _)   = go pat
    go1 (TuplePat pats _ _) = all go pats
414
    go1 (ListPat {})        = False
Ian Lynagh's avatar
Ian Lynagh committed
415
    go1 (PArrPat {})        = False     -- ?
416

Ian Lynagh's avatar
Ian Lynagh committed
417
418
419
420
421
422
    go1 (ConPatIn {})       = False     -- Conservative
    go1 (ConPatOut{ pat_con = L _ 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)
423

424
425
426
    go1 (LitPat {})    = False
    go1 (NPat {})      = False
    go1 (NPlusKPat {}) = False
427

Ian Lynagh's avatar
Ian Lynagh committed
428
429
    go1 (QuasiQuotePat {}) = urk pat    -- Gotten rid of by renamer, before
                                        -- isIrrefutablePat is called
430
431

    urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
432
433

hsPatNeedsParens :: Pat a -> Bool
434
435
436
437
438
439
440
441
hsPatNeedsParens (NPlusKPat {})      = True
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
442
443
444
445
446
447
448
449
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
450
451
452
hsPatNeedsParens (PArrPat {})        = False
hsPatNeedsParens (LitPat {})         = False
hsPatNeedsParens (NPat {})           = False
453
454
455

conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon args) = not (null args)
456
457
conPatNeedsParens (InfixCon {})    = True
conPatNeedsParens (RecCon {})      = True
458
459
\end{code}