HsUtils.hs 47.5 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,
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
28
  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, isLHsTypeExpr_maybe, isLHsTypeExpr,
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

  -- Types
54
  mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs,
55
  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs,
56
  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
57 58
  getAppsTyHead_maybe, hsTyGetAppHead_maybe, splitHsAppsTy,
  getLHsInstDeclClass_maybe,
59 60

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

  -- Template Haskell
66
  mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice,
67
  mkHsQuasiQuote, unqualQuasiQuote,
68 69

  -- Flags
70
  noRebindableInfo,
71 72

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

80
  hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders,
81
  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
82

83 84
  -- Collecting implicit binders
  lStmtsImplicits, hsValBindsImplicits, lPatImplicits
85
  ) where
86

87 88
#include "HsVersions.h"

89
import HsDecls
90 91 92
import HsBinds
import HsExpr
import HsPat
93
import HsTypes
94
import HsLit
95
import PlaceHolder
96

97
import TcEvidence
98 99
import RdrName
import Var
100 101 102
import TyCoRep
import Type   ( filterOutInvisibleTypes )
import TcType
103 104
import DataCon
import Name
105
import NameSet
106
import BasicTypes
107
import SrcLoc
108 109
import FastString
import Util
110
import Bag
111
import Outputable
Simon Marlow's avatar
Simon Marlow committed
112
import Constants
113

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

Austin Seipp's avatar
Austin Seipp committed
118 119 120
{-
************************************************************************
*                                                                      *
121
        Some useful helpers for constructing syntax
Austin Seipp's avatar
Austin Seipp committed
122 123
*                                                                      *
************************************************************************
124

125 126 127
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
128
-}
129 130 131 132

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

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

142
unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
143 144
unguardedGRHSs rhs@(L loc _)
  = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
145

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

149 150
mkMatchGroup :: Origin -> [LMatch RdrName (Located (body RdrName))]
             -> MatchGroup RdrName (Located (body RdrName))
151 152
mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches
                                 , mg_arg_tys = []
153 154 155
                                 , mg_res_ty = placeHolderType
                                 , mg_origin = origin }

156 157 158 159
mkLocatedList ::  [Located a] -> Located [Located a]
mkLocatedList [] = noLoc []
mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms

160 161
mkMatchGroupName :: Origin -> [LMatch Name (Located (body Name))]
             -> MatchGroup Name (Located (body Name))
162 163
mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches
                                     , mg_arg_tys = []
164 165
                                     , mg_res_ty = placeHolderType
                                     , mg_origin = origin }
166

167 168 169
mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)

170 171 172
mkHsAppTys :: LHsType name -> [LHsType name] -> LHsType name
mkHsAppTys = foldl mkHsAppTy

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

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

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

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

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

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

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

203 204 205 206 207 208 209 210 211 212 213
--------- 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

214

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

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

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

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

234 235 236 237
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
238 239


240 241 242
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
243

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

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

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

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

258 259 260 261 262 263 264 265
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)
266

267
emptyTransStmt :: StmtLR idL idR (LHsExpr idR)
268
emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
269
                           , trS_stmts = [], trS_bndrs = []
270 271 272
                           , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
                           , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
                           , trS_fmap = noSyntaxExpr }
273 274 275 276
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 }
277

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


283 284 285 286 287 288 289 290 291 292 293 294 295 296 297
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 }
298 299

-------------------------------
300 301
--- 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
302
mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
303 304
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
                           (error "mkOpApp:fixity") e2
305

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

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

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

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

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

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

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

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

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

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

userHsTyVarBndrs :: SrcSpan -> [name] -> [LHsTyVarBndr name]
342
-- Caller sets location
343
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
344

345

Austin Seipp's avatar
Austin Seipp committed
346 347 348
{-
************************************************************************
*                                                                      *
349
        Constructing syntax with no location info
Austin Seipp's avatar
Austin Seipp committed
350 351 352
*                                                                      *
************************************************************************
-}
353 354

nlHsVar :: id -> LHsExpr id
355
nlHsVar n = noLoc (HsVar (noLoc n))
356 357 358 359 360

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

nlVarPat :: id -> LPat id
361
nlVarPat n = noLoc (VarPat (noLoc n))
362 363 364 365 366 367 368

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
369
nlHsIntLit :: Integer -> LHsExpr id
370
nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
371 372 373

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

375
nlHsVarApps :: id -> [id] -> LHsExpr id
376
nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
377 378
                 where
                   mk f a = HsApp (noLoc f) (noLoc a)
379

380
nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
381 382
nlConVarPat con vars = nlConPat con (map nlVarPat vars)

383 384 385
nlConVarPatName :: Name -> [Name] -> LPat Name
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)

386 387 388
nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))

389
nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName
390 391
nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

392 393 394
nlConPatName :: Name -> [LPat Name] -> LPat Name
nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

395 396 397 398 399
nlNullaryConPat :: id -> LPat id
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))

nlWildConPat :: DataCon -> LPat RdrName
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
400 401
                         (PrefixCon (nOfThem (dataConSourceArity con)
                                             nlWildPat)))
402

403 404
nlWildPat :: LPat RdrName
nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
405

406 407 408 409 410 411 412 413
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
414
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
415

twanvl's avatar
twanvl committed
416
nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
417 418
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)

419
nlHsLam  :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName
twanvl's avatar
twanvl committed
420 421
nlHsPar  :: LHsExpr id -> LHsExpr id
nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
422 423 424
nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]
         -> LHsExpr RdrName
nlList   :: [LHsExpr RdrName] -> LHsExpr RdrName
twanvl's avatar
twanvl committed
425

426
nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))
427 428 429 430
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)
431

twanvl's avatar
twanvl committed
432 433 434 435
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
nlHsTyVar :: name                         -> LHsType name
nlHsFunTy :: LHsType name -> LHsType name -> LHsType name

436
nlHsAppTy f t           = noLoc (HsAppTy f t)
437
nlHsTyVar x             = noLoc (HsTyVar (noLoc x))
438
nlHsFunTy a b           = noLoc (HsFunTy a b)
439

twanvl's avatar
twanvl committed
440
nlHsTyConApp :: name -> [LHsType name] -> LHsType name
441
nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
442

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
443 444 445 446 447 448 449 450 451 452 453 454 455 456 457
-- | Extract a type argument from an HsExpr, with the list of wildcards in
-- the type
isLHsTypeExpr_maybe :: LHsExpr name -> Maybe (LHsWcType name)
isLHsTypeExpr_maybe (L _ (HsPar e))       = isLHsTypeExpr_maybe e
isLHsTypeExpr_maybe (L _ (HsType ty))     = Just ty
  -- the HsTypeOut case is ill-typed. We never need it here anyway.
isLHsTypeExpr_maybe _                     = Nothing

-- | Is an expression a visible type application?
isLHsTypeExpr :: LHsExpr name -> Bool
isLHsTypeExpr (L _ (HsPar e))     = isLHsTypeExpr e
isLHsTypeExpr (L _ (HsType _))    = True
isLHsTypeExpr (L _ (HsTypeOut _)) = True
isLHsTypeExpr _                   = False

Austin Seipp's avatar
Austin Seipp committed
458
{-
459 460
Tuples.  All these functions are *pre-typechecker* because they lack
types on the tuple.
Austin Seipp's avatar
Austin Seipp committed
461
-}
462 463 464 465

mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
466
mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
467 468 469

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

471
nlTuplePat :: [LPat id] -> Boxity -> LPat id
472
nlTuplePat pats box = noLoc (TuplePat pats box [])
473

474
missingTupArg :: HsTupArg RdrName
475
missingTupArg = Missing placeHolderType
476

Simon Marlow's avatar
Simon Marlow committed
477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536
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
537 538 539
{-
************************************************************************
*                                                                      *
540
        LHsSigType and LHsSigWcType
Austin Seipp's avatar
Austin Seipp committed
541
*                                                                      *
542
********************************************************************* -}
543

544 545
mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName
mkLHsSigType ty = mkHsImplicitBndrs ty
546

547 548
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty)
549

550 551 552 553 554 555
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
556
  where
557 558
    fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
    fiddle sig                      = sig
559

560 561 562 563 564 565 566 567 568 569
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
570
    go ty@(ForAllTy (Anon arg) _)
571 572 573 574
      | isPredTy arg
      , (theta, tau) <- tcSplitPhiTy ty
      = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
                        , hst_body = go tau })
575 576 577 578 579
    go (ForAllTy (Anon arg) res) = nlHsFunTy (go arg) (go res)
    go ty@(ForAllTy {})
      | (tvs, tau) <- tcSplitForAllTys ty
      = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
                          , hst_body = go tau })
580 581 582 583 584
    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')
585
       where
586 587 588 589 590
         args' = filterOutInvisibleTypes tc args
    go (CastTy ty _)        = go ty
    go (CoercionTy co)      = pprPanic "toLHsSigWcType" (ppr co)

         -- Source-language types have _invisible_ kind arguments,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
591
         -- so we must remove them here (Trac #8563)
592

593 594 595
    go_tv :: TyVar -> LHsTyVarBndr RdrName
    go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
                                   (go (tyVarKind tv))
596 597


598 599 600 601 602 603
{- *********************************************************************
*                                                                      *
    --------- HsWrappers: type args, dict args, casts ---------
*                                                                      *
********************************************************************* -}

604 605 606 607 608
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
609
                 | otherwise           = HsWrap co_fn e
610

611
mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
612
           -> HsExpr id -> HsExpr id
613
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
614

615
mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
616
            -> HsExpr id -> HsExpr id
617
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
618

619
mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
Joachim Breitner's avatar
Joachim Breitner committed
620
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
621

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
622 623 624 625 626 627
mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id
mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
                  | otherwise       = HsCmdWrap w cmd

mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
628

629 630
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
631
                       | otherwise           = CoPat co_fn p ty
632

633
mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
634
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
635
                        | otherwise     = CoPat (mkWpCastN co) pat ty
636 637 638

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

{-
641
l
Austin Seipp's avatar
Austin Seipp committed
642 643
************************************************************************
*                                                                      *
644
                Bindings; with a location at the top
Austin Seipp's avatar
Austin Seipp committed
645 646 647
*                                                                      *
************************************************************************
-}
648

649 650
mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
          -> HsBind RdrName
651
-- Not infix, with place holders for coercion and free vars
652
mkFunBind fn ms = FunBind { fun_id = fn
653 654
                          , fun_matches = mkMatchGroup Generated ms
                          , fun_co_fn = idHsWrapper
655
                          , bind_fvs = placeHolderNames
656
                          , fun_tick = [] }
657

658 659
mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
             -> HsBind Name
660
-- In Name-land, with empty bind_fvs
661
mkTopFunBind origin fn ms = FunBind { fun_id = fn
662
                                    , fun_matches = mkMatchGroupName origin ms
663
                                    , fun_co_fn = idHsWrapper
664 665
                                    , bind_fvs = emptyNameSet -- NB: closed
                                                              --     binding
666
                                    , fun_tick = [] }
667

668
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
669 670 671 672
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs

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

675 676
mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
             -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
677 678 679 680 681 682 683
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
684

685 686 687 688
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
isInfixFunBind :: HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
689
  = any (isInfixMatch . unLoc) (unLoc matches)
690 691 692
isInfixFunBind _ = False


693
------------
694
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
695
                -> LHsExpr RdrName -> LHsBind RdrName
696
mk_easy_FunBind loc fun pats expr
697
  = L loc $ mkFunBind (L loc fun) [mkMatch pats expr (noLoc emptyLocalBinds)]
698

699
------------
700 701 702
mkMatch :: [LPat id] -> LHsExpr id -> Located (HsLocalBinds id)
        -> LMatch id (LHsExpr id)
mkMatch pats expr lbinds
703
  = noLoc (Match NonFunBindMatch (map paren pats) Nothing
704
                 (GRHSs (unguardedRHS noSrcSpan expr) lbinds))
705
  where
706 707
    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
                     | otherwise          = lp
708

Austin Seipp's avatar
Austin Seipp committed
709 710 711
{-
************************************************************************
*                                                                      *
712
        Collecting binders
Austin Seipp's avatar
Austin Seipp committed
713 714
*                                                                      *
************************************************************************
715 716 717 718 719 720 721 722 723 724 725

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).

726 727 728
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
729
to return a [Name] or [Id].  Before renaming the record punning
730 731
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
732
-}
733 734 735

----------------- Bindings --------------------------
collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
736 737 738 739
collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
                                         -- No pattern synonyms here
collectLocalBinders (HsIPBinds _)      = []
collectLocalBinders EmptyLocalBinds    = []
740

741 742 743 744
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
745 746

collectHsBindBinders :: HsBindLR idL idR -> [idL]
747 748
-- Collect both Ids and pattern-synonym binders
collectHsBindBinders b = collect_bind False b []
749

750
collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
751
collectHsBindsBinders binds = collect_binds False binds []
752

753
collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
754 755 756 757 758 759 760 761 762 763 764
-- 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]
765
-- Collect Ids, or Ids + pattern synonyms, depending on boolean flag
766 767 768 769 770 771 772 773 774 775 776 777
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
778

779 780
collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
-- Used exclusively for the bindings of an instance decl which are all FunBinds
781
collectMethodBinders binds = foldrBag (get . unLoc) [] binds
782
  where
cactus's avatar
cactus committed
783
    get (FunBind { fun_id = f }) fs = f : fs
784
    get _                        fs = fs
785
       -- Someone else complains about non-FunBinds
786

787
----------------- Statements --------------------------
788
collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]
789
collectLStmtsBinders = concatMap collectLStmtBinders
790

791
collectStmtsBinders :: [StmtLR idL idR body] -> [idL]
792 793
collectStmtsBinders = concatMap collectStmtBinders

794
collectLStmtBinders :: LStmtLR idL idR body -> [idL]
795 796
collectLStmtBinders = collectStmtBinders . unLoc

797
collectStmtBinders :: StmtLR idL idR body -> [idL]
798
  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
799 800 801 802 803 804
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]
805 806
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
Simon Marlow's avatar
Simon Marlow committed
807
collectStmtBinders ApplicativeStmt{} = []
808 809


810
----------------- Patterns --------------------------
811
collectPatBinders :: LPat a -> [a]
812
collectPatBinders pat = collect_lpat pat []
813 814

collectPatsBinders :: [LPat a] -> [a]
815
collectPatsBinders pats = foldr collect_lpat [] pats
816

817 818 819
-------------
collect_lpat :: LPat name -> [name] -> [name]
collect_lpat (L _ pat) bndrs
820 821
  = go pat
  where
822
    go (VarPat (L _ var))         = var : bndrs
823 824 825 826
    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
827
    go (ViewPat _ pat _)          = collect_lpat pat bndrs
828 829
    go (ParPat  pat)              = collect_lpat pat bndrs

830
    go (ListPat pats _ _)         = foldr collect_lpat bndrs pats
831 832 833
    go (PArrPat pats _)           = foldr collect_lpat bndrs pats
    go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats

834 835
    go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
    go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
836 837 838
        -- See Note [Dictionary binders in ConPatOut]
    go (LitPat _)                 = bndrs
    go (NPat _ _ _)               = bndrs
839
    go (NPlusKPat (L _ n) _ _ _)  = n : bndrs
840 841 842

    go (SigPatIn pat _)           = collect_lpat pat bndrs
    go (SigPatOut pat _)          = collect_lpat pat bndrs
gmainland's avatar
gmainland committed
843
    go (SplicePat _)              = bndrs
844
    go (CoPat _ pat _)            = go pat
845

Austin Seipp's avatar
Austin Seipp committed
846
{-
847
Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
848 849 850 851 852 853 854 855 856
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
857 858 859 860 861 862 863 864 865 866 867 868 869 870 871
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
872
-}
Ross Paterson's avatar
Ross Paterson committed
873

874 875 876 877
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
878
  ++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
879

880 881
hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
                     -> [LForeignDecl Name] -> [Name]
882
-- We need to look at instance declarations too,
883
-- because their associated types may bind data constructors
884
hsTyClForeignBinders tycl_decls inst_decls foreign_decls
885 886 887 888 889 890
  = 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
891

892
-------------------
893 894 895 896 897 898
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
899
--
900 901
-- 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
902 903

hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
904 905
  = ([L loc name], [])
hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = ([L loc name], [])
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
906 907
hsLTyClDeclBinders (L loc (ClassDecl   { tcdLName = L _ cls_name
                                       , tcdSigs = sigs, tcdATs = ats }))
908
  = (L loc cls_name :
909 910
     [ 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 ]
911
    , [])
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
912
hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
913
  = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
914 915

-------------------
916 917 918 919
hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
-- See Note [SrcSpan for binders]
hsForeignDeclsBinders foreign_decls
  = [ L decl_loc n
920
    | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]
921

Matthew Pickering's avatar
Matthew Pickering committed
922 923


924
-------------------
Matthew Pickering's avatar
Matthew Pickering committed
925 926
hsPatSynBinders :: HsValBinds RdrName
                -> ([Located RdrName], [Located RdrName])
927 928
-- Collect pattern-synonym binders only, not Ids
-- See Note [SrcSpan for binders]
Matthew Pickering's avatar
Matthew Pickering committed
929
hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr ([],[]) binds
930
hsPatSynBinders _ = panic "hsPatSynBinders"
931

Matthew Pickering's avatar
Matthew Pickering committed
932 933
addPatSynBndr :: LHsBindLR id id -> ([Located id], [Located id])
                -> ([Located id], [Located id]) -- (selectors, other)
934
-- See Note [SrcSpan for binders]
Matthew Pickering's avatar
Matthew Pickering committed
935 936 937 938 939 940
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)
941
  | otherwise
Matthew Pickering's avatar
Matthew Pickering committed
942
  = (sels, pss)
943 944

-------------------
945
hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
946
hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
947
  = foldMap (hsDataFamInstBinders . unLoc) dfis
948 949
hsLInstDeclBinders (L _ (