HsPat.hs 25.1 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 #-}
Adam Gundry's avatar
Adam Gundry committed
15
{-# LANGUAGE TypeFamilies #-}
16

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

Ian Lynagh's avatar
Ian Lynagh committed
20 21
        HsConDetails(..),
        HsConPatDetails, hsConPatArgs,
Adam Gundry's avatar
Adam Gundry committed
22 23 24 25 26
        HsRecFields(..), HsRecField'(..), LHsRecField',
        HsRecField, LHsRecField,
        HsRecUpdField, LHsRecUpdField,
        hsRecFields, hsRecFieldSel, hsRecFieldId,
        hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
Ian Lynagh's avatar
Ian Lynagh committed
27 28

        mkPrefixConPat, mkCharLitPat, mkNilPat,
29

30 31 32
        isUnliftedHsBind, looksLazyPatBind,
        isUnliftedLPat, isBangedLPat, isBangedPatBind,
        hsPatNeedsParens,
33
        isIrrefutableHsPat,
34

35
        pprParendLPat, pprConArgs
36 37
    ) where

38
import {-# SOURCE #-} HsExpr            (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice)
sof's avatar
sof committed
39

40
-- friends:
41 42
import HsBinds
import HsLit
Adam Gundry's avatar
Adam Gundry committed
43
import PlaceHolder -- ( PostRn,PostTc,DataId )
44
import HsTypes
45
import TcEvidence
46
import BasicTypes
47
-- others:
Ian Lynagh's avatar
Ian Lynagh committed
48
import PprCore          ( {- instance OutputableBndr TyVar -} )
49 50
import TysWiredIn
import Var
Adam Gundry's avatar
Adam Gundry committed
51
import RdrName ( RdrName )
Gergő Érdi's avatar
Gergő Érdi committed
52
import ConLike
53 54
import DataCon
import TyCon
Ian Lynagh's avatar
Ian Lynagh committed
55
import Outputable
56 57
import Type
import SrcLoc
58
import FastString
Adam Gundry's avatar
Adam Gundry committed
59
import Maybes
60
-- libraries:
61
import Data.Data hiding (TyCon,Fixity)
62

Ian Lynagh's avatar
Ian Lynagh committed
63 64
type InPat id  = LPat id        -- No 'Out' constructors
type OutPat id = LPat id        -- No 'In' constructors
65 66

type LPat id = Located (Pat id)
67

Alan Zimmerman's avatar
Alan Zimmerman committed
68
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
69 70

-- For details on above see note [Api annotations] in ApiAnnotation
71
data Pat id
Ian Lynagh's avatar
Ian Lynagh committed
72
  =     ------------ Simple patterns ---------------
73
    WildPat     (PostTc id Type)        -- Wild card
Ian Lynagh's avatar
Ian Lynagh committed
74 75
        -- The sole reason for a type on a WildPat is to
        -- support hsPatType :: Pat Id -> Type
76

77 78
  | VarPat      (Located id) -- Variable
                             -- See Note [Located RdrNames] in HsExpr
79
  | LazyPat     (LPat id)               -- Lazy pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
80 81
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'

82 83
    -- For details on above see note [Api annotations] in ApiAnnotation

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

87 88
    -- For details on above see note [Api annotations] in ApiAnnotation

Ian Lynagh's avatar
Ian Lynagh committed
89 90
  | ParPat      (LPat id)               -- Parenthesised pattern
                                        -- See Note [Parens in HsSyn] in HsExpr
Alan Zimmerman's avatar
Alan Zimmerman committed
91 92
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
    --                                    'ApiAnnotation.AnnClose' @')'@
93 94

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

98 99
    -- For details on above see note [Api annotations] in ApiAnnotation

Ian Lynagh's avatar
Ian Lynagh committed
100
        ------------ Lists, tuples, arrays ---------------
101
  | ListPat     [LPat id]                            -- Syntactic list
102 103
                (PostTc id Type)                     -- The type of the elements
                (Maybe (PostTc id Type, SyntaxExpr id)) -- For rebindable syntax
104 105 106
                   -- 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
107 108
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
    --                                    'ApiAnnotation.AnnClose' @']'@
Ian Lynagh's avatar
Ian Lynagh committed
109

110 111
    -- For details on above see note [Api annotations] in ApiAnnotation

112 113 114 115 116
  | 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
117 118
        -- get the pattern type by getting the types of the sub-patterns.
        -- But it's essential
Ian Lynagh's avatar
Ian Lynagh committed
119 120 121 122 123 124 125 126 127 128
        --      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
129 130
        -- (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
131 132 133
    -- ^ - 'ApiAnnotation.AnnKeywordId' :
    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
Ian Lynagh's avatar
Ian Lynagh committed
134

135
    -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
136
  | PArrPat     [LPat id]               -- Syntactic parallel array
137
                (PostTc id Type)        -- The type of the elements
Alan Zimmerman's avatar
Alan Zimmerman committed
138 139
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
    --                                    'ApiAnnotation.AnnClose' @':]'@
Ian Lynagh's avatar
Ian Lynagh committed
140

141
    -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
142 143 144
        ------------ Constructor patterns ---------------
  | ConPatIn    (Located id)
                (HsConPatDetails id)
145

146
  | ConPatOut {
147
        pat_con     :: Located ConLike,
Gabor Greif's avatar
Gabor Greif committed
148
        pat_arg_tys :: [Type],          -- The universal arg types, 1-1 with the universal
149
                                        -- tyvars of the constructor/pattern synonym
Austin Seipp's avatar
Austin Seipp committed
150
                                        --   Use (conLikeResTy pat_con pat_arg_tys) to get
151 152
                                        --   the type of the pattern

Ian Lynagh's avatar
Ian Lynagh committed
153 154 155 156 157 158
        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
159
        pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
160 161
                                        -- Only relevant for pattern-synonyms;
                                        --   ignored for data cons
162
    }
163

Ian Lynagh's avatar
Ian Lynagh committed
164
        ------------ View patterns ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
165
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
166 167

  -- For details on above see note [Api annotations] in ApiAnnotation
Ian Lynagh's avatar
Ian Lynagh committed
168
  | ViewPat       (LHsExpr id)
169
                  (LPat id)
170
                  (PostTc id Type)  -- The overall type of the pattern
171 172 173
                                    -- (= the argument type of the view function)
                                    -- for hsPatType.

gmainland's avatar
gmainland committed
174
        ------------ Pattern splices ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
175 176
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
  --        'ApiAnnotation.AnnClose' @')'@
177 178

  -- For details on above see note [Api annotations] in ApiAnnotation
179
  | SplicePat       (HsSplice id)   -- Includes quasi-quotes
180

Ian Lynagh's avatar
Ian Lynagh committed
181 182 183 184 185 186
        ------------ 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
187
                    (Located (HsOverLit id))    -- ALWAYS positive
Ian Lynagh's avatar
Ian Lynagh committed
188 189 190 191
                    (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
192
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
193 194

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

  -- For details on above see note [Api annotations] in ApiAnnotation
204 205 206
  | SigPatIn        (LPat id)                 -- Pattern with a type signature
                    (LHsSigWcType id)         -- Signature can bind both
                                              -- kind and type vars
Ian Lynagh's avatar
Ian Lynagh committed
207 208 209 210 211 212 213 214 215 216 217

  | 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'
218 219
  deriving (Typeable)
deriving instance (DataId id) => Data (Pat id)
220

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

223 224
data HsConDetails arg rec
  = PrefixCon [arg]             -- C p1 p2 p3
Ian Lynagh's avatar
Ian Lynagh committed
225 226
  | RecCon    rec               -- C { x = p1, y = p2 }
  | InfixCon  arg arg           -- p1 `C` p2
227
  deriving (Data, Typeable)
228 229 230 231 232

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

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

Austin Seipp's avatar
Austin Seipp committed
236
{-
237 238
However HsRecFields is used only for patterns and expressions
(not data type declarations)
Austin Seipp's avatar
Austin Seipp committed
239
-}
240

Ian Lynagh's avatar
Ian Lynagh committed
241 242 243
data HsRecFields id arg         -- A bunch of record fields
                                --      { x = 3, y = True }
        -- Used for both expressions and patterns
244
  = HsRecFields { rec_flds   :: [LHsRecField id arg],
Ian Lynagh's avatar
Ian Lynagh committed
245
                  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
Adam Gundry's avatar
Adam Gundry committed
246 247
  deriving (Typeable)
deriving instance (DataId id, Data arg) => Data (HsRecFields id arg)
248 249 250 251 252

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

Adam Gundry's avatar
Adam Gundry committed
263 264 265 266 267 268
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)
269

Adam Gundry's avatar
Adam Gundry committed
270 271
-- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
--
272
-- For details on above see note [Api annotations] in ApiAnnotation
Adam Gundry's avatar
Adam Gundry committed
273 274 275 276
data HsRecField' id arg = HsRecField {
        hsRecFieldLbl :: Located id,
        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning
        hsRecPun      :: Bool           -- ^ Note [Punning]
277
  } deriving (Data, Typeable)
278

Adam Gundry's avatar
Adam Gundry committed
279

280 281 282
-- Note [Punning]
-- ~~~~~~~~~~~~~~
-- If you write T { x, y = v+1 }, the HsRecFields will be
Ian Lynagh's avatar
Ian Lynagh committed
283 284 285
--      HsRecField x x True ...
--      HsRecField y (v+1) False ...
-- That is, for "punned" field x is expanded (in the renamer)
286
-- to x=x; but with a punning flag so we can detect it later
287
-- (e.g. when pretty printing)
288 289 290
--
-- If the original field was qualified, we un-qualify it, thus
--    T { A.x } means T { A.x = x }
291

Adam Gundry's avatar
Adam Gundry committed
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

-- 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
331 332
--
-- See also Note [Disambiguating record fields] in TcExpr.
Adam Gundry's avatar
Adam Gundry committed
333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351

hsRecFields :: HsRecFields id arg -> [PostRn id id]
hsRecFields rbinds = map (unLoc . hsRecFieldSel . 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

352

Austin Seipp's avatar
Austin Seipp committed
353 354 355 356 357 358 359
{-
************************************************************************
*                                                                      *
*              Printing patterns
*                                                                      *
************************************************************************
-}
360

361 362 363
instance (OutputableBndr name) => Outputable (Pat name) where
    ppr = pprPat

364
pprPatBndr :: OutputableBndr name => name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
365
pprPatBndr var                  -- Print with type info if -dppr-debug is on
366 367
  = getPprStyle $ \ sty ->
    if debugStyle sty then
Ian Lynagh's avatar
Ian Lynagh committed
368 369
        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat
                                                -- but is it worth it?
370
    else
371
        pprPrefixOcc var
372

373 374 375 376
pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
pprParendLPat (L _ p) = pprParendPat p

pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
377 378 379 380 381 382 383 384 385 386 387
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.
388

389
pprPat :: (OutputableBndr name) => Pat name -> SDoc
390
pprPat (VarPat (L _ var))     = pprPatBndr var
391 392 393 394 395 396 397 398 399 400 401 402 403 404
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
405
pprPat (ListPat pats _ _)     = brackets (interpp'SP pats)
406 407
pprPat (PArrPat pats _)       = paBrackets (interpp'SP pats)
pprPat (TuplePat pats bx _)   = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
408
pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
Ian Lynagh's avatar
Ian Lynagh committed
409 410 411 412 413
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
414 415 416 417
        ppr con
          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                         , ppr binds])
          <+> pprConArgs details
418
    else pprUserCon (unLoc con) details
419 420


421 422 423
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
424

425
pprConArgs ::  OutputableBndr id => HsConPatDetails id -> SDoc
426 427
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
428 429
pprConArgs (RecCon rpats)   = ppr rpats

Adam Gundry's avatar
Adam Gundry committed
430
instance (Outputable arg)
431 432
      => Outputable (HsRecFields id arg) where
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
Ian Lynagh's avatar
Ian Lynagh committed
433
        = braces (fsep (punctuate comma (map ppr flds)))
434
  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
Ian Lynagh's avatar
Ian Lynagh committed
435 436 437
        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
        where
          dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds))
438

Adam Gundry's avatar
Adam Gundry committed
439 440 441
instance (Outputable id, Outputable arg)
      => Outputable (HsRecField' id arg) where
  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
Ian Lynagh's avatar
Ian Lynagh committed
442
                    hsRecPun = pun })
443
    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
444

Adam Gundry's avatar
Adam Gundry committed
445

Austin Seipp's avatar
Austin Seipp committed
446 447 448 449 450 451 452
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
453

454
mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id
455
-- Make a vanilla Prefix constructor pattern
456
mkPrefixConPat dc pats tys
Gergő Érdi's avatar
Gergő Érdi committed
457
  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
Ian Lynagh's avatar
Ian Lynagh committed
458
                        pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
459
                        pat_arg_tys = tys, pat_wrap = idHsWrapper }
460

461
mkNilPat :: Type -> OutPat id
462
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
463

464 465 466
mkCharLitPat :: String -> Char -> OutPat id
mkCharLitPat src c = mkPrefixConPat charDataCon
                                    [noLoc $ LitPat (HsCharPrim src c)] []
467

Austin Seipp's avatar
Austin Seipp committed
468 469 470 471 472 473
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
474

475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496
\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.

497
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
498 499
-}

500 501 502 503
isUnliftedLPat :: LPat id -> Bool
isUnliftedLPat (L _ (ParPat p))             = isUnliftedLPat p
isUnliftedLPat (L _ (TuplePat _ Unboxed _)) = True
isUnliftedLPat _                            = False
504

505
isUnliftedHsBind :: HsBind id -> Bool
506
-- A pattern binding with an outermost bang or unboxed tuple must be matched strictly
507
-- Defined in this module because HsPat is above HsBinds in the import graph
508 509 510 511 512 513 514 515 516 517 518
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
519 520 521

looksLazyPatBind :: HsBind id -> Bool
-- Returns True of anything *except*
Austin Seipp's avatar
Austin Seipp committed
522
--     a StrictHsBind (as above) or
523 524 525 526 527 528 529 530 531 532 533 534 535
--     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
536

537
isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
538 539
-- (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
540 541 542
--      (NB: this is not quite the same as the (silly) defn
--      in 3.17.2 of the Haskell 98 report.)
--
543 544 545 546 547 548
-- 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.
--
549 550 551 552
-- But if it returns True, the pattern is definitely irrefutable
isIrrefutableHsPat pat
  = go pat
  where
553
    go (L _ pat) = go1 pat
554

555 556 557
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
558
    go1 (BangPat pat)       = go pat
559
    go1 (CoPat _ pat _)     = go1 pat
560 561
    go1 (ParPat pat)        = go pat
    go1 (AsPat _ pat)       = go pat
562
    go1 (ViewPat _ pat _)   = go pat
563 564 565
    go1 (SigPatIn pat _)    = go pat
    go1 (SigPatOut pat _)   = go pat
    go1 (TuplePat pats _ _) = all go pats
566
    go1 (ListPat {}) = False
Ian Lynagh's avatar
Ian Lynagh committed
567
    go1 (PArrPat {})        = False     -- ?
568

Ian Lynagh's avatar
Ian Lynagh committed
569
    go1 (ConPatIn {})       = False     -- Conservative
Gergő Érdi's avatar
Gergő Érdi committed
570
    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
Ian Lynagh's avatar
Ian Lynagh committed
571 572 573 574
        =  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
575 576
    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
        = False -- Conservative
577

578 579 580
    go1 (LitPat {})    = False
    go1 (NPat {})      = False
    go1 (NPlusKPat {}) = False
581

gmainland's avatar
gmainland committed
582 583
    -- Both should be gotten rid of by renamer before
    -- isIrrefutablePat is called
Austin Seipp's avatar
Austin Seipp committed
584
    go1 (SplicePat {})     = urk pat
585 586

    urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
587 588

hsPatNeedsParens :: Pat a -> Bool
589
hsPatNeedsParens (NPlusKPat {})      = True
gmainland's avatar
gmainland committed
590
hsPatNeedsParens (SplicePat {})      = False
591 592 593 594 595
hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
hsPatNeedsParens (SigPatIn {})       = True
hsPatNeedsParens (SigPatOut {})      = True
hsPatNeedsParens (ViewPat {})        = True
596
hsPatNeedsParens (CoPat _ p _)       = hsPatNeedsParens p
597 598 599 600 601 602 603 604
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
605 606 607
hsPatNeedsParens (PArrPat {})        = False
hsPatNeedsParens (LitPat {})         = False
hsPatNeedsParens (NPat {})           = False
608 609 610

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