HsPat.hs 24.5 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
        isStrictHsBind, looksLazyPatBind,
        isStrictLPat, hsPatNeedsParens,
32
        isIrrefutableHsPat,
33

34
        pprParendLPat, pprConArgs
35 36
    ) where

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

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

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

type LPat id = Located (Pat id)
66

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

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

Ian Lynagh's avatar
Ian Lynagh committed
76
  | VarPat      id                      -- Variable
77
  | LazyPat     (LPat id)               -- Lazy pattern
Alan Zimmerman's avatar
Alan Zimmerman committed
78 79
    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'

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

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

85 86
    -- For details on above see note [Api annotations] in ApiAnnotation

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

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

96 97
    -- For details on above see note [Api annotations] in ApiAnnotation

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

108 109
    -- For details on above see note [Api annotations] in ApiAnnotation

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
151 152 153 154 155 156
        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
157
        pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
158
    }
159

Ian Lynagh's avatar
Ian Lynagh committed
160
        ------------ View patterns ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
161
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
162 163

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

gmainland's avatar
gmainland committed
170
        ------------ Pattern splices ---------------
Alan Zimmerman's avatar
Alan Zimmerman committed
171 172
  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
  --        'ApiAnnotation.AnnClose' @')'@
173 174

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

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

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

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

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

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

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

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

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

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

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

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

Adam Gundry's avatar
Adam Gundry committed
259 260 261 262 263 264
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)
265

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

Adam Gundry's avatar
Adam Gundry committed
275

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

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

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

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

348

Austin Seipp's avatar
Austin Seipp committed
349 350 351 352 353 354 355
{-
************************************************************************
*                                                                      *
*              Printing patterns
*                                                                      *
************************************************************************
-}
356

357 358 359
instance (OutputableBndr name) => Outputable (Pat name) where
    ppr = pprPat

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

369 370 371 372
pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
pprParendLPat (L _ p) = pprParendPat p

pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
373 374 375 376 377 378 379 380 381 382 383
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.
384

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


417 418 419
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
420

421
pprConArgs ::  OutputableBndr id => HsConPatDetails id -> SDoc
422 423
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
424 425
pprConArgs (RecCon rpats)   = ppr rpats

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

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

Adam Gundry's avatar
Adam Gundry committed
441

Austin Seipp's avatar
Austin Seipp committed
442 443 444 445 446 447 448
{-
************************************************************************
*                                                                      *
*              Building patterns
*                                                                      *
************************************************************************
-}
449

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

457
mkNilPat :: Type -> OutPat id
458
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
459

460 461 462
mkCharLitPat :: String -> Char -> OutPat id
mkCharLitPat src c = mkPrefixConPat charDataCon
                                    [noLoc $ LitPat (HsCharPrim src c)] []
463

Austin Seipp's avatar
Austin Seipp committed
464 465 466 467 468 469
{-
************************************************************************
*                                                                      *
* Predicates for checking things about pattern-lists in EquationInfo   *
*                                                                      *
************************************************************************
470

471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492
\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.

493
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
Austin Seipp's avatar
Austin Seipp committed
494 495
-}

496 497 498 499 500 501 502 503
isStrictLPat :: LPat id -> Bool
isStrictLPat (L _ (ParPat p))             = isStrictLPat p
isStrictLPat (L _ (BangPat {}))           = True
isStrictLPat (L _ (TuplePat _ Unboxed _)) = True
isStrictLPat _                            = False

isStrictHsBind :: HsBind id -> Bool
-- A pattern binding with an outermost bang or unboxed tuple must be matched strictly
504
-- Defined in this module because HsPat is above HsBinds in the import graph
505 506 507 508 509
isStrictHsBind (PatBind { pat_lhs = p }) = isStrictLPat p
isStrictHsBind _                         = False

looksLazyPatBind :: HsBind id -> Bool
-- Returns True of anything *except*
Austin Seipp's avatar
Austin Seipp committed
510
--     a StrictHsBind (as above) or
511 512 513 514 515 516 517 518 519 520 521 522 523
--     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
524

525
isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
526 527
-- (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
528 529 530
--      (NB: this is not quite the same as the (silly) defn
--      in 3.17.2 of the Haskell 98 report.)
--
531
-- isIrrefutableHsPat returns False if it's in doubt; specifically
532
-- on a ConPatIn it doesn't know the size of the constructor family
533 534 535 536
-- But if it returns True, the pattern is definitely irrefutable
isIrrefutableHsPat pat
  = go pat
  where
537
    go (L _ pat) = go1 pat
538

539 540 541
    go1 (WildPat {})        = True
    go1 (VarPat {})         = True
    go1 (LazyPat {})        = True
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
542
    go1 (BangPat pat)       = go pat
543
    go1 (CoPat _ pat _)     = go1 pat
544 545
    go1 (ParPat pat)        = go pat
    go1 (AsPat _ pat)       = go pat
546
    go1 (ViewPat _ pat _)   = go pat
547 548 549
    go1 (SigPatIn pat _)    = go pat
    go1 (SigPatOut pat _)   = go pat
    go1 (TuplePat pats _ _) = all go pats
550
    go1 (ListPat {}) = False
Ian Lynagh's avatar
Ian Lynagh committed
551
    go1 (PArrPat {})        = False     -- ?
552

Ian Lynagh's avatar
Ian Lynagh committed
553
    go1 (ConPatIn {})       = False     -- Conservative
Gergő Érdi's avatar
Gergő Érdi committed
554
    go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
Ian Lynagh's avatar
Ian Lynagh committed
555 556 557 558
        =  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
559 560
    go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
        = False -- Conservative
561

562 563 564
    go1 (LitPat {})    = False
    go1 (NPat {})      = False
    go1 (NPlusKPat {}) = False
565

gmainland's avatar
gmainland committed
566 567
    -- Both should be gotten rid of by renamer before
    -- isIrrefutablePat is called
Austin Seipp's avatar
Austin Seipp committed
568
    go1 (SplicePat {})     = urk pat
569 570

    urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
571 572

hsPatNeedsParens :: Pat a -> Bool
573
hsPatNeedsParens (NPlusKPat {})      = True
gmainland's avatar
gmainland committed
574
hsPatNeedsParens (SplicePat {})      = False
575 576 577 578 579
hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
hsPatNeedsParens (SigPatIn {})       = True
hsPatNeedsParens (SigPatOut {})      = True
hsPatNeedsParens (ViewPat {})        = True
580
hsPatNeedsParens (CoPat _ p _)       = hsPatNeedsParens p
581 582 583 584 585 586 587 588
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
589 590 591
hsPatNeedsParens (PArrPat {})        = False
hsPatNeedsParens (LitPat {})         = False
hsPatNeedsParens (NPat {})           = False
592 593 594

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