HsUtils.hs 43.4 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2
{-
(c) The University of Glasgow, 1992-2006
3

4

5 6
Here we collect a variety of helper functions that construct or
analyse HsSyn.  All these functions deal with generic HsSyn; functions
7
which deal with the instantiated versions are located elsewhere:
8

9
   Parameterised by     Module
10
   ----------------     -------------
11 12 13
   RdrName              parser/RdrHsSyn
   Name                 rename/RnHsSyn
   Id                   typecheck/TcHsSyn
Austin Seipp's avatar
Austin Seipp committed
14
-}
15

16
{-# LANGUAGE CPP #-}
17 18
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
Ian Lynagh's avatar
Ian Lynagh committed
19

20 21 22
module HsUtils(
  -- Terms
  mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
23 24
  mkSimpleMatch, unguardedGRHSs, unguardedRHS,
  mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
25
  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
26
  mkHsDictLet, mkHsLams,
27
  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
28
  mkLHsPar, mkHsCmdCast,
29

30
  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
31
  nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
32
  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
33
  toLHsSigWcType,
34

Simon Marlow's avatar
Simon Marlow committed
35 36 37 38
  -- * Constructing general big tuples
  -- $big_tuples
  mkChunkified, chunkify,

39
  -- Bindings
Simon Marlow's avatar
Simon Marlow committed
40 41
  mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
  mkPatSynBind,
42
  isInfixFunBind,
43 44

  -- Literals
45
  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
46 47

  -- Patterns
48
  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
49 50
  nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
  nlWildPatName, nlWildPatId, nlTuplePat, mkParPat,
Simon Marlow's avatar
Simon Marlow committed
51
  mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
52 53 54

  -- Types
  mkHsAppTy, userHsTyVarBndrs,
55
  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs,
56
  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
57 58

  -- Stmts
59
  mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt,
60 61
  emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
  emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
62 63

  -- Template Haskell
64
  mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice,
65
  mkHsQuasiQuote, unqualQuasiQuote,
66 67

  -- Flags
68
  noRebindableInfo,
69 70

  -- Collecting binders
71
  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
72
  collectHsIdBinders,
73 74 75 76
  collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
  collectPatBinders, collectPatsBinders,
  collectLStmtsBinders, collectStmtsBinders,
  collectLStmtBinders, collectStmtBinders,
77

78
  hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders,
79
  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
80

81 82
  -- Collecting implicit binders
  lStmtsImplicits, hsValBindsImplicits, lPatImplicits
83
  ) where
84

85 86
#include "HsVersions.h"

87
import HsDecls
88 89 90
import HsBinds
import HsExpr
import HsPat
91
import HsTypes
92
import HsLit
93
import PlaceHolder
94

95
import TcType( tcSplitForAllTys, tcSplitPhiTy )
96
import TcEvidence
97 98
import RdrName
import Var
99 100
import Type( isPredTy )
import Kind( isKind )
101
import TypeRep
102 103
import DataCon
import Name
104
import NameSet
105
import BasicTypes
106
import SrcLoc
107 108
import FastString
import Util
109
import Bag
110
import Outputable
Simon Marlow's avatar
Simon Marlow committed
111
import Constants
112

113
import Data.Either
114 115
import Data.Function
import Data.List
116

117 118 119 120 121
#if __GLASGOW_HASKELL__ < 709
import Data.Foldable ( foldMap )
import Data.Monoid ( mempty, mappend )
#endif

Austin Seipp's avatar
Austin Seipp committed
122 123 124
{-
************************************************************************
*                                                                      *
125
        Some useful helpers for constructing syntax
Austin Seipp's avatar
Austin Seipp committed
126 127
*                                                                      *
************************************************************************
128

129 130 131
These functions attempt to construct a not-completely-useless SrcSpan
from their components, compared with the nl* functions below which
just attach noSrcSpan to everything.
Austin Seipp's avatar
Austin Seipp committed
132
-}
133 134 135 136

mkHsPar :: LHsExpr id -> LHsExpr id
mkHsPar e = L (getLoc e) (HsPar e)

137
mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
138
mkSimpleMatch pats rhs
139
  = L loc $
140
    Match NonFunBindMatch pats Nothing (unguardedGRHSs rhs)
141 142
  where
    loc = case pats of
143 144
                []      -> getLoc rhs
                (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
145

146
unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
147 148
unguardedGRHSs rhs@(L loc _)
  = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
149

Alan Zimmerman's avatar
Alan Zimmerman committed
150 151
unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))]
unguardedRHS loc rhs = [L loc (GRHS [] rhs)]
152

153 154
mkMatchGroup :: Origin -> [LMatch RdrName (Located (body RdrName))]
             -> MatchGroup RdrName (Located (body RdrName))
155 156
mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches
                                 , mg_arg_tys = []
157 158 159
                                 , mg_res_ty = placeHolderType
                                 , mg_origin = origin }

160 161 162 163
mkLocatedList ::  [Located a] -> Located [Located a]
mkLocatedList [] = noLoc []
mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms

164 165
mkMatchGroupName :: Origin -> [LMatch Name (Located (body Name))]
             -> MatchGroup Name (Located (body Name))
166 167
mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches
                                     , mg_arg_tys = []
168 169
                                     , mg_res_ty = placeHolderType
                                     , mg_origin = origin }
170

171 172 173 174 175 176
mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)

mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)

177
mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
178
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
179
        where
180
          matches = mkMatchGroup Generated [mkSimpleMatch pats body]
181 182

mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
183 184
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
                                       <.> mkWpLams dicts) expr
185 186

mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
187 188
-- Used for constructing dictionary terms etc, so no locations
mkHsConApp data_con tys args
189 190 191 192
  = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
  where
    mk_app f a = noLoc (HsApp f (noLoc a))

193
mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
194
-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
195
mkSimpleHsAlt pat expr
196 197
  = mkSimpleMatch [pat] expr

198
nlHsTyApp :: name -> [Type] -> LHsExpr name
199
nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
200

201 202 203
nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name
nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs

204 205 206 207 208 209 210 211 212 213 214
--------- Adding parens ---------
mkLHsPar :: LHsExpr name -> LHsExpr name
-- Wrap in parens if hsExprNeedsParens says it needs them
-- So   'f x'  becomes '(f x)', but '3' stays as '3'
mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
                      | otherwise           = le

mkParPat :: LPat name -> LPat name
mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
                      | otherwise          = lp

215

216
-------------------------------
217 218 219
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName

220
mkHsIntegral   :: String -> Integer -> PostTc RdrName Type -> HsOverLit RdrName
221
mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName
222
mkHsIsString :: String -> FastString -> PostTc RdrName Type -> HsOverLit RdrName
223 224 225
mkHsDo         :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
mkHsComp       :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
               -> HsExpr RdrName
twanvl's avatar
twanvl committed
226

Alan Zimmerman's avatar
Alan Zimmerman committed
227 228
mkNPat      :: Located (HsOverLit id) -> Maybe (SyntaxExpr id) -> Pat id
mkNPlusKPat :: Located id -> Located (HsOverLit id) -> Pat id
twanvl's avatar
twanvl committed
229

230
mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
231 232
mkBodyStmt :: Located (bodyR RdrName)
           -> StmtLR idL RdrName (Located (bodyR RdrName))
233
mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
234

235 236 237 238
emptyRecStmt     :: StmtLR idL  RdrName bodyR
emptyRecStmtName :: StmtLR Name Name    bodyR
emptyRecStmtId   :: StmtLR Id   Id      bodyR
mkRecStmt    :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR
twanvl's avatar
twanvl committed
239 240


241 242 243
mkHsIntegral src i  = OverLit (HsIntegral   src i) noRebindableInfo noSyntaxExpr
mkHsFractional   f  = OverLit (HsFractional     f) noRebindableInfo noSyntaxExpr
mkHsIsString src s  = OverLit (HsIsString   src s) noRebindableInfo noSyntaxExpr
244

245 246
noRebindableInfo :: PlaceHolder
noRebindableInfo = PlaceHolder -- Just another placeholder;
247

248
mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType
249 250 251
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
  where
    last_stmt = L (getLoc expr) $ mkLastStmt expr
252

253 254 255
mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b

256
mkNPat lit neg     = NPat lit neg noSyntaxExpr
257
mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
258

259 260 261 262 263 264 265 266
mkTransformStmt    :: [ExprLStmt idL] -> LHsExpr idR
                   -> StmtLR idL idR (LHsExpr idL)
mkTransformByStmt  :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
                   -> StmtLR idL idR (LHsExpr idL)
mkGroupUsingStmt   :: [ExprLStmt idL]                -> LHsExpr idR
                   -> StmtLR idL idR (LHsExpr idL)
mkGroupByUsingStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
                   -> StmtLR idL idR (LHsExpr idL)
267

268
emptyTransStmt :: StmtLR idL idR (LHsExpr idR)
269
emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
270
                           , trS_stmts = [], trS_bndrs = []
271 272 273
                           , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
                           , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
                           , trS_fmap = noSyntaxExpr }
274 275 276 277
mkTransformStmt    ss u   = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }
mkTransformByStmt  ss u b = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }
mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
278

Simon Marlow's avatar
Simon Marlow committed
279
mkLastStmt body     = LastStmt body False noSyntaxExpr
280 281
mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr
282 283


284 285 286 287 288 289 290 291 292 293 294 295 296 297 298
emptyRecStmt' :: forall idL idR body.
                       PostTc idR Type -> StmtLR idL idR body
emptyRecStmt' tyVal =
   RecStmt
     { recS_stmts = [], recS_later_ids = []
     , recS_rec_ids = []
     , recS_ret_fn = noSyntaxExpr
     , recS_mfix_fn = noSyntaxExpr
     , recS_bind_fn = noSyntaxExpr, recS_later_rets = []
     , recS_rec_rets = [], recS_ret_ty = tyVal }

emptyRecStmt     = emptyRecStmt' placeHolderType
emptyRecStmtName = emptyRecStmt' placeHolderType
emptyRecStmtId   = emptyRecStmt' placeHolderTypeTc
mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }
299 300

-------------------------------
301 302
--- A useful function for building @OpApps@.  The operator is always a
-- variable, and we don't know the fixity yet.
twanvl's avatar
twanvl committed
303
mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
304 305
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
                           (error "mkOpApp:fixity") e2
306

307 308 309
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))

310 311 312
mkUntypedSplice :: LHsExpr RdrName -> HsSplice RdrName
mkUntypedSplice e = HsUntypedSplice unqualSplice e

313
mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
314
mkHsSpliceE e = HsSpliceE (mkUntypedSplice e)
315 316

mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
317
mkHsSpliceTE e = HsSpliceE (HsTypedSplice unqualSplice e)
318

319
mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
320
mkHsSpliceTy e = HsSpliceTy (HsUntypedSplice unqualSplice e) placeHolderKind
321

322 323
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName
mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
324

twanvl's avatar
twanvl committed
325
unqualQuasiQuote :: RdrName
Ian Lynagh's avatar
Ian Lynagh committed
326
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
327 328
                -- A name (uniquified later) to
                -- identify the quasi-quote
329

twanvl's avatar
twanvl committed
330
mkHsString :: String -> HsLit
331
mkHsString s = HsString s (mkFastString s)
332

333 334 335 336
mkHsStringPrimLit :: FastString -> HsLit
mkHsStringPrimLit fs
  = HsStringPrim (unpackFS fs) (fastStringToByteString fs)

337
-------------
338
userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
339
-- Caller sets location
340
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
341

Austin Seipp's avatar
Austin Seipp committed
342 343 344
{-
************************************************************************
*                                                                      *
345
        Constructing syntax with no location info
Austin Seipp's avatar
Austin Seipp committed
346 347 348
*                                                                      *
************************************************************************
-}
349 350

nlHsVar :: id -> LHsExpr id
351
nlHsVar n = noLoc (HsVar (noLoc n))
352 353 354 355 356

nlHsLit :: HsLit -> LHsExpr id
nlHsLit n = noLoc (HsLit n)

nlVarPat :: id -> LPat id
357
nlVarPat n = noLoc (VarPat (noLoc n))
358 359 360 361 362 363 364

nlLitPat :: HsLit -> LPat id
nlLitPat l = noLoc (LitPat l)

nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsApp f x = noLoc (HsApp f x)

twanvl's avatar
twanvl committed
365
nlHsIntLit :: Integer -> LHsExpr id
366
nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
367 368 369

nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
370

371
nlHsVarApps :: id -> [id] -> LHsExpr id
372
nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
373 374
                 where
                   mk f a = HsApp (noLoc f) (noLoc a)
375

376
nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
377 378
nlConVarPat con vars = nlConPat con (map nlVarPat vars)

379 380 381
nlConVarPatName :: Name -> [Name] -> LPat Name
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)

382 383 384
nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))

385
nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName
386 387
nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

388 389 390
nlConPatName :: Name -> [LPat Name] -> LPat Name
nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

391 392 393 394 395
nlNullaryConPat :: id -> LPat id
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))

nlWildConPat :: DataCon -> LPat RdrName
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
396 397
                         (PrefixCon (nOfThem (dataConSourceArity con)
                                             nlWildPat)))
398

399 400
nlWildPat :: LPat RdrName
nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
401

402 403 404 405 406 407 408 409
nlWildPatName :: LPat Name
nlWildPatName  = noLoc (WildPat placeHolderType )  -- Pre-typechecking

nlWildPatId :: LPat Id
nlWildPatId  = noLoc (WildPat placeHolderTypeTc )  -- Post-typechecking

nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)]
       -> LHsExpr RdrName
410
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
411

twanvl's avatar
twanvl committed
412
nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
413 414
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)

415
nlHsLam  :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName
twanvl's avatar
twanvl committed
416 417
nlHsPar  :: LHsExpr id -> LHsExpr id
nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
418 419 420
nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]
         -> LHsExpr RdrName
nlList   :: [LHsExpr RdrName] -> LHsExpr RdrName
twanvl's avatar
twanvl committed
421

422
nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))
423 424 425 426
nlHsPar e              = noLoc (HsPar e)
nlHsIf cond true false = noLoc (mkHsIf cond true false)
nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup Generated matches))
nlList exprs           = noLoc (ExplicitList placeHolderType Nothing exprs)
427

twanvl's avatar
twanvl committed
428 429 430 431
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
nlHsTyVar :: name                         -> LHsType name
nlHsFunTy :: LHsType name -> LHsType name -> LHsType name

432
nlHsAppTy f t           = noLoc (HsAppTy f t)
433
nlHsTyVar x             = noLoc (HsTyVar (noLoc x))
434
nlHsFunTy a b           = noLoc (HsFunTy a b)
435

twanvl's avatar
twanvl committed
436
nlHsTyConApp :: name -> [LHsType name] -> LHsType name
437
nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
438

Austin Seipp's avatar
Austin Seipp committed
439
{-
440 441
Tuples.  All these functions are *pre-typechecker* because they lack
types on the tuple.
Austin Seipp's avatar
Austin Seipp committed
442
-}
443 444 445 446

mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
447
mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
448 449 450

mkLHsVarTuple :: [a] -> LHsExpr a
mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
451

452
nlTuplePat :: [LPat id] -> Boxity -> LPat id
453
nlTuplePat pats box = noLoc (TuplePat pats box [])
454

455
missingTupArg :: HsTupArg RdrName
456
missingTupArg = Missing placeHolderType
457

Simon Marlow's avatar
Simon Marlow committed
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
mkLHsPatTup :: [LPat id] -> LPat id
mkLHsPatTup []     = noLoc $ TuplePat [] Boxed []
mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats  = L (getLoc (head lpats)) $ TuplePat lpats Boxed []

-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [id] -> LHsExpr id
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)

mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
mkBigLHsTup = mkChunkified mkLHsTupleExpr

-- The Big equivalents for the source tuple patterns
mkBigLHsVarPatTup :: [id] -> LPat id
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)

mkBigLHsPatTup :: [LPat id] -> LPat id
mkBigLHsPatTup = mkChunkified mkLHsPatTup

-- $big_tuples
-- #big_tuples#
--
-- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
-- we might concievably want to build such a massive tuple as part of the
-- output of a desugaring stage (notably that for list comprehensions).
--
-- We call tuples above this size \"big tuples\", and emulate them by
-- creating and pattern matching on >nested< tuples that are expressible
-- by GHC.
--
-- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
-- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
-- construction to be big.
--
-- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
-- and 'mkTupleCase' functions to do all your work with tuples you should be
-- fine, and not have to worry about the arity limitation at all.

-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon
mkChunkified :: ([a] -> a)      -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
             -> [a]             -- ^ Possible \"big\" list of things to construct from
             -> a               -- ^ Constructed thing made possible by recursive decomposition
mkChunkified small_tuple as = mk_big_tuple (chunkify as)
  where
        -- Each sub-list is short enough to fit in a tuple
    mk_big_tuple [as] = small_tuple as
    mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))

chunkify :: [a] -> [[a]]
-- ^ Split a list into lists that are small enough to have a corresponding
-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
chunkify xs
  | n_xs <= mAX_TUPLE_SIZE = [xs]
  | otherwise              = split xs
  where
    n_xs     = length xs
    split [] = []
    split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)

Austin Seipp's avatar
Austin Seipp committed
518 519 520
{-
************************************************************************
*                                                                      *
521
        LHsSigType and LHsSigWcType
Austin Seipp's avatar
Austin Seipp committed
522
*                                                                      *
523
********************************************************************* -}
524

525 526
mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName
mkLHsSigType ty = mkHsImplicitBndrs ty
527

528 529
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty)
530

531 532 533 534 535 536
mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName]
-- Convert TypeSig to ClassOpSig
-- The former is what is parsed, but the latter is
-- what we need in class/instance declarations
mkClassOpSigs sigs
  = map fiddle sigs
537
  where
538 539
    fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
    fiddle sig                      = sig
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
toLHsSigWcType :: Type -> LHsSigWcType RdrName
-- ^ Converting a Type to an HsType RdrName
-- This is needed to implement GeneralizedNewtypeDeriving.
--
-- Note that we use 'getRdrName' extensively, which
-- generates Exact RdrNames rather than strings.
toLHsSigWcType ty
  = mkLHsSigWcType (go ty)
  where
    go :: Type -> LHsType RdrName
    go ty@(ForAllTy {})
      | (tvs, tau) <- tcSplitForAllTys ty
      = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
                          , hst_body = go tau })
    go ty@(FunTy arg _)
      | isPredTy arg
      , (theta, tau) <- tcSplitPhiTy ty
      = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
                        , hst_body = go tau })
    go (FunTy arg res)      = nlHsFunTy (go arg) (go res)
    go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)
    go (AppTy t1 t2)        = nlHsAppTy (go t1) (go t2)
    go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
    go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
    go (TyConApp tc args)   = nlHsTyConApp (getRdrName tc) (map go args')
566
       where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
567 568 569
         args' = filterOut isKind args
         -- Source-language types have _implicit_ kind arguments,
         -- so we must remove them here (Trac #8563)
570

571 572 573
    go_tv :: TyVar -> LHsTyVarBndr RdrName
    go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
                                   (go (tyVarKind tv))
574 575


576 577 578 579 580 581
{- *********************************************************************
*                                                                      *
    --------- HsWrappers: type args, dict args, casts ---------
*                                                                      *
********************************************************************* -}

582 583 584 585 586
mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)

mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
587
                 | otherwise           = HsWrap co_fn e
588

589
mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
590
           -> HsExpr id -> HsExpr id
591
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
592

593
mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
594
            -> HsExpr id -> HsExpr id
595
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
596

597
mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
Joachim Breitner's avatar
Joachim Breitner committed
598
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
599

600 601 602 603
mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id
mkHsCmdCast co cmd | isTcReflCo co = cmd
                   | otherwise     = HsCmdCast co cmd

604 605
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
606
                       | otherwise           = CoPat co_fn p ty
607

608
mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
609
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
610
                        | otherwise     = CoPat (mkWpCastN co) pat ty
611 612 613

mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
Austin Seipp's avatar
Austin Seipp committed
614 615

{-
616
l
Austin Seipp's avatar
Austin Seipp committed
617 618
************************************************************************
*                                                                      *
619
                Bindings; with a location at the top
Austin Seipp's avatar
Austin Seipp committed
620 621 622
*                                                                      *
************************************************************************
-}
623

624 625
mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
          -> HsBind RdrName
626
-- Not infix, with place holders for coercion and free vars
627
mkFunBind fn ms = FunBind { fun_id = fn
628 629
                          , fun_matches = mkMatchGroup Generated ms
                          , fun_co_fn = idHsWrapper
630
                          , bind_fvs = placeHolderNames
631
                          , fun_tick = [] }
632

633 634
mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
             -> HsBind Name
635
-- In Name-land, with empty bind_fvs
636
mkTopFunBind origin fn ms = FunBind { fun_id = fn
637
                                    , fun_matches = mkMatchGroupName origin ms
638
                                    , fun_co_fn = idHsWrapper
639 640
                                    , bind_fvs = emptyNameSet -- NB: closed
                                                              --     binding
641
                                    , fun_tick = [] }
642

643
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
644 645 646 647
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs

mkVarBind :: id -> LHsExpr id -> LHsBind id
mkVarBind var rhs = L (getLoc rhs) $
648
                    VarBind { var_id = var, var_rhs = rhs, var_inline = False }
649

650 651
mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
             -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
652 653 654 655 656 657 658
mkPatSynBind name details lpat dir = PatSynBind psb
  where
    psb = PSB{ psb_id = name
             , psb_args = details
             , psb_def = lpat
             , psb_dir = dir
             , psb_fvs = placeHolderNames }
cactus's avatar
cactus committed
659

660 661 662 663
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
isInfixFunBind :: HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
664
  = any (isInfixMatch . unLoc) (unLoc matches)
665 666 667
isInfixFunBind _ = False


668
------------
669
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
670
                -> LHsExpr RdrName -> LHsBind RdrName
671
mk_easy_FunBind loc fun pats expr
672
  = L loc $ mkFunBind (L loc fun) [mkMatch pats expr (noLoc emptyLocalBinds)]
673

674
------------
675 676 677
mkMatch :: [LPat id] -> LHsExpr id -> Located (HsLocalBinds id)
        -> LMatch id (LHsExpr id)
mkMatch pats expr lbinds
678
  = noLoc (Match NonFunBindMatch (map paren pats) Nothing
679
                 (GRHSs (unguardedRHS noSrcSpan expr) lbinds))
680
  where
681 682
    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
                     | otherwise          = lp
683

Austin Seipp's avatar
Austin Seipp committed
684 685 686
{-
************************************************************************
*                                                                      *
687
        Collecting binders
Austin Seipp's avatar
Austin Seipp committed
688 689
*                                                                      *
************************************************************************
690 691 692 693 694 695 696 697 698 699 700

Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.

...
where
  (x, y) = ...
  f i j  = ...
  [a, b] = ...

it should return [x, y, f, a, b] (remember, order important).

701 702 703
Note [Collect binders only after renaming]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
These functions should only be used on HsSyn *after* the renamer,
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
704
to return a [Name] or [Id].  Before renaming the record punning
705 706
and wild-card mechanism makes it hard to know what is bound.
So these functions should not be applied to (HsSyn RdrName)
Austin Seipp's avatar
Austin Seipp committed
707
-}
708 709 710

----------------- Bindings --------------------------
collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
711 712 713 714
collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
                                         -- No pattern synonyms here
collectLocalBinders (HsIPBinds _)      = []
collectLocalBinders EmptyLocalBinds    = []
715

716 717 718 719
collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL]
-- Collect Id binders only, or Ids + pattern synonmys, respectively
collectHsIdBinders  = collect_hs_val_binders True
collectHsValBinders = collect_hs_val_binders False
720 721

collectHsBindBinders :: HsBindLR idL idR -> [idL]
722 723
-- Collect both Ids and pattern-synonym binders
collectHsBindBinders b = collect_bind False b []
724

725
collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
726
collectHsBindsBinders binds = collect_binds False binds []
727

728
collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752
-- Same as collectHsBindsBinders, but works over a list of bindings
collectHsBindListBinders = foldr (collect_bind False . unLoc) []

collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL]
collect_hs_val_binders ps (ValBindsIn  binds _) = collect_binds     ps binds []
collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds

collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id]
collect_out_binds ps = foldr (collect_binds ps . snd) []

collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL]
-- Collect Ids, or Ids + patter synonyms, depending on boolean flag
collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds

collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL]
collect_bind _ (PatBind { pat_lhs = p })           acc = collect_lpat p acc
collect_bind _ (FunBind { fun_id = L _ f })        acc = f : acc
collect_bind _ (VarBind { var_id = f })            acc = f : acc
collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
        -- I don't think we want the binders from the abe_binds
        -- The only time we collect binders from a typechecked
        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
    if omitPatSyn then acc else ps : acc
753

754 755
collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
-- Used exclusively for the bindings of an instance decl which are all FunBinds
756
collectMethodBinders binds = foldrBag (get . unLoc) [] binds
757
  where
cactus's avatar
cactus committed
758
    get (FunBind { fun_id = f }) fs = f : fs
759
    get _                        fs = fs
760
       -- Someone else complains about non-FunBinds
761

762
----------------- Statements --------------------------
763
collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]
764
collectLStmtsBinders = concatMap collectLStmtBinders
765

766
collectStmtsBinders :: [StmtLR idL idR body] -> [idL]
767 768
collectStmtsBinders = concatMap collectStmtBinders

769
collectLStmtBinders :: LStmtLR idL idR body -> [idL]
770 771
collectLStmtBinders = collectStmtBinders . unLoc

772
collectStmtBinders :: StmtLR idL idR body -> [idL]
773
  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
774 775 776 777 778 779
collectStmtBinders (BindStmt pat _ _ _)  = collectPatBinders pat
collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
collectStmtBinders (BodyStmt {})         = []
collectStmtBinders (LastStmt {})         = []
collectStmtBinders (ParStmt xs _ _)   = collectLStmtsBinders
                                      $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
780 781
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
Simon Marlow's avatar
Simon Marlow committed
782
collectStmtBinders ApplicativeStmt{} = []
783 784


785
----------------- Patterns --------------------------
786
collectPatBinders :: LPat a -> [a]
787
collectPatBinders pat = collect_lpat pat []
788 789

collectPatsBinders :: [LPat a] -> [a]
790
collectPatsBinders pats = foldr collect_lpat [] pats
791

792 793 794
-------------
collect_lpat :: LPat name -> [name] -> [name]
collect_lpat (L _ pat) bndrs
795 796
  = go pat
  where
797
    go (VarPat (L _ var))         = var : bndrs
798 799 800 801
    go (WildPat _)                = bndrs
    go (LazyPat pat)              = collect_lpat pat bndrs
    go (BangPat pat)              = collect_lpat pat bndrs
    go (AsPat (L _ a) pat)        = a : collect_lpat pat bndrs
802
    go (ViewPat _ pat _)          = collect_lpat pat bndrs
803 804
    go (ParPat  pat)              = collect_lpat pat bndrs

805
    go (ListPat pats _ _)         = foldr collect_lpat bndrs pats
806 807 808
    go (PArrPat pats _)           = foldr collect_lpat bndrs pats
    go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats

809 810
    go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
    go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
811 812 813
        -- See Note [Dictionary binders in ConPatOut]
    go (LitPat _)                 = bndrs
    go (NPat _ _ _)               = bndrs
814
    go (NPlusKPat (L _ n) _ _ _)  = n : bndrs
815 816 817

    go (SigPatIn pat _)           = collect_lpat pat bndrs
    go (SigPatOut pat _)          = collect_lpat pat bndrs
gmainland's avatar
gmainland committed
818
    go (SplicePat _)              = bndrs
819
    go (CoPat _ pat _)            = go pat
820

Austin Seipp's avatar
Austin Seipp committed
821
{-
822
Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
823 824 825 826 827 828 829 830 831
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do *not* gather (a) dictionary and (b) dictionary bindings as binders
of a ConPatOut pattern.  For most calls it doesn't matter, because
it's pre-typechecker and there are no ConPatOuts.  But it does matter
more in the desugarer; for example, DsUtils.mkSelectorBinds uses
collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
we want to generate bindings for x,y but not for dictionaries bound by
C.  (The type checker ensures they would not be used.)

Ross Paterson's avatar
Ross Paterson committed
832 833 834 835 836 837 838 839 840 841 842 843 844 845 846
Desugaring of arrow case expressions needs these bindings (see DsArrows
and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
own pat-binder-collector:

Here's the problem.  Consider

data T a where
   C :: Num a => a -> Int -> T a

f ~(C (n+1) m) = (n,m)

Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
variables bound by the lazy pattern are n,m, *not* the dictionary d.
So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
Austin Seipp's avatar
Austin Seipp committed
847
-}
Ross Paterson's avatar
Ross Paterson committed
848

849 850 851 852
hsGroupBinders :: HsGroup Name -> [Name]
hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
                          hs_instds = inst_decls, hs_fords = foreign_decls })
  =  collectHsValBinders val_decls
853
  ++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
854

855 856
hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
                     -> [LForeignDecl Name] -> [Name]
857
-- We need to look at instance declarations too,
858
-- because their associated types may bind data constructors
859
hsTyClForeignBinders tycl_decls inst_decls foreign_decls
860 861 862 863 864 865
  = map unLoc (hsForeignDeclsBinders foreign_decls)
    ++ getSelectorNames (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
                        `mappend` foldMap hsLInstDeclBinders inst_decls)
  where
    getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name]
    getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
866

867
-------------------
868 869 870 871 872 873
hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name])
-- ^ Returns all the /binding/ names of the decl.  The first one is
-- guaranteed to be the name of the decl. The first component
-- represents all binding names except record fields; the second
-- represents field occurrences. For record fields mentioned in
-- multiple constructors, the SrcLoc will be from the first occurrence.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
874
--
875 876
-- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
-- See Note [SrcSpan for binders]
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
877 878

hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
879 880
  = ([L loc name], [])
hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = ([L loc name], [])
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
881 882
hsLTyClDeclBinders (L loc (ClassDecl   { tcdLName = L _ cls_name
                                       , tcdSigs = sigs, tcdATs = ats }))
883
  = (L loc cls_name :
884 885
     [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
     [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ]
886
    , [])
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
887
hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
888
  = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
889 890

-------------------
891 892 893 894
hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
-- See Note [SrcSpan for binders]
hsForeignDeclsBinders foreign_decls
  = [ L decl_loc n
895
    | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]
896

Matthew Pickering's avatar
Matthew Pickering committed
897 898


899
-------------------
Matthew Pickering's avatar
Matthew Pickering committed
900 901
hsPatSynBinders :: HsValBinds RdrName
                -> ([Located RdrName], [Located RdrName])
902 903
-- Collect pattern-synonym binders only, not Ids
-- See Note [SrcSpan for binders]
Matthew Pickering's avatar
Matthew Pickering committed
904
hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr ([],[]) binds
905
hsPatSynBinders _ = panic "hsPatSynBinders"
906

Matthew Pickering's avatar
Matthew Pickering committed
907 908
addPatSynBndr :: LHsBindLR id id -> ([Located id], [Located id])
                -> ([Located id], [Located id]) -- (selectors, other)
909
-- See Note [SrcSpan for binders]
Matthew Pickering's avatar
Matthew Pickering committed
910 911 912 913 914 915
addPatSynBndr bind (sels, pss)
  | L bind_loc (PatSynBind (PSB { psb_id = L _ n
                                , psb_args = RecordPatSyn as })) <- bind
  = (map recordPatSynSelectorId as ++ sels, L bind_loc n : pss)
  | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
  = (sels, L bind_loc n : pss)
916
  | otherwise
Matthew Pickering's avatar
Matthew Pickering committed
917
  = (sels, pss)
918 919

-------------------
920
hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
921
hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
922
  = foldMap (hsDataFamInstBinders . unLoc) dfis
923 924
hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
  = hsDataFamInstBinders fi
925
hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
926 927

-------------------
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
928
-- the SrcLoc returned are for the whole declarations, not just the names
929
hsDataFamInstBinders :: DataFamInstDecl name -> ([Located name], [LFieldOcc name])
930 931 932
hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
  = hsDataDefnBinders defn
  -- There can't be repeated symbols because only data instances have binders
933 934

-------------------
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
935
-- the SrcLoc returned are for the whole declarations, not just the names
936
hsDataDefnBinders :: HsDataDefn name -> ([Located name], [LFieldOcc name])
937 938
hsDataDefnBinders (HsDataDefn { dd_cons = cons })
  = hsConDeclsBinders cons
939
  -- See Note [Binders in family instances]
940

941
-------------------
942
hsConDeclsBinders :: [LConDecl name] -> ([Located name], [LFieldOcc name])