HsUtils.hs 46.8 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

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

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

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

130 131 132
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
133
-}
134 135 136 137

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

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

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

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

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

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

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

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

175 176 177
mkHsAppTys :: LHsType name -> [LHsType name] -> LHsType name
mkHsAppTys = foldl mkHsAppTy

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

181
mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
182
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
183
        where
184
          matches = mkMatchGroup Generated [mkSimpleMatch pats body]
185 186

mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
187 188
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
                                       <.> mkWpLams dicts) expr
189 190

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

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

202
nlHsTyApp :: name -> [Type] -> LHsExpr name
203
nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
204

205 206 207
nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name
nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs

208 209 210 211 212 213 214 215 216 217 218
--------- 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

219

220
-------------------------------
221 222 223
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName

224
mkHsIntegral   :: String -> Integer -> PostTc RdrName Type -> HsOverLit RdrName
225
mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName
226
mkHsIsString :: String -> FastString -> PostTc RdrName Type -> HsOverLit RdrName
227 228 229
mkHsDo         :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
mkHsComp       :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
               -> HsExpr RdrName
twanvl's avatar
twanvl committed
230

Alan Zimmerman's avatar
Alan Zimmerman committed
231 232
mkNPat      :: Located (HsOverLit id) -> Maybe (SyntaxExpr id) -> Pat id
mkNPlusKPat :: Located id -> Located (HsOverLit id) -> Pat id
twanvl's avatar
twanvl committed
233

234
mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
235 236
mkBodyStmt :: Located (bodyR RdrName)
           -> StmtLR idL RdrName (Located (bodyR RdrName))
237
mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
238

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


245 246 247
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
248

249 250
noRebindableInfo :: PlaceHolder
noRebindableInfo = PlaceHolder -- Just another placeholder;
251

252
mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType
253 254 255
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
  where
    last_stmt = L (getLoc expr) $ mkLastStmt expr
256

257 258 259
mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b

260
mkNPat lit neg     = NPat lit neg noSyntaxExpr
261
mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
262

263 264 265 266 267 268 269 270
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)
271

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

Simon Marlow's avatar
Simon Marlow committed
283
mkLastStmt body     = LastStmt body False noSyntaxExpr
284 285
mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr
286 287


288 289 290 291 292 293 294 295 296 297 298 299 300 301 302
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 }
303 304

-------------------------------
305 306
--- 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
307
mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
308 309
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
                           (error "mkOpApp:fixity") e2
310

311 312 313
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))

314 315 316
mkUntypedSplice :: LHsExpr RdrName -> HsSplice RdrName
mkUntypedSplice e = HsUntypedSplice unqualSplice e

317
mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
318
mkHsSpliceE e = HsSpliceE (mkUntypedSplice e)
319 320

mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
321
mkHsSpliceTE e = HsSpliceE (HsTypedSplice unqualSplice e)
322

323
mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
324
mkHsSpliceTy e = HsSpliceTy (HsUntypedSplice unqualSplice e) placeHolderKind
325

326 327
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName
mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
328

twanvl's avatar
twanvl committed
329
unqualQuasiQuote :: RdrName
Ian Lynagh's avatar
Ian Lynagh committed
330
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
331 332
                -- A name (uniquified later) to
                -- identify the quasi-quote
333

twanvl's avatar
twanvl committed
334
mkHsString :: String -> HsLit
335
mkHsString s = HsString s (mkFastString s)
336

337 338 339 340
mkHsStringPrimLit :: FastString -> HsLit
mkHsStringPrimLit fs
  = HsStringPrim (unpackFS fs) (fastStringToByteString fs)

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

userHsTyVarBndrs :: SrcSpan -> [name] -> [LHsTyVarBndr name]
347
-- Caller sets location
348
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
349

350

Austin Seipp's avatar
Austin Seipp committed
351 352 353
{-
************************************************************************
*                                                                      *
354
        Constructing syntax with no location info
Austin Seipp's avatar
Austin Seipp committed
355 356 357
*                                                                      *
************************************************************************
-}
358 359

nlHsVar :: id -> LHsExpr id
360
nlHsVar n = noLoc (HsVar (noLoc n))
361 362 363 364 365

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

nlVarPat :: id -> LPat id
366
nlVarPat n = noLoc (VarPat (noLoc n))
367 368 369 370 371 372 373

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
374
nlHsIntLit :: Integer -> LHsExpr id
375
nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
376 377 378

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

380
nlHsVarApps :: id -> [id] -> LHsExpr id
381
nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
382 383
                 where
                   mk f a = HsApp (noLoc f) (noLoc a)
384

385
nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
386 387
nlConVarPat con vars = nlConPat con (map nlVarPat vars)

388 389 390
nlConVarPatName :: Name -> [Name] -> LPat Name
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)

391 392 393
nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))

394
nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName
395 396
nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

397 398 399
nlConPatName :: Name -> [LPat Name] -> LPat Name
nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

400 401 402 403 404
nlNullaryConPat :: id -> LPat id
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))

nlWildConPat :: DataCon -> LPat RdrName
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
405 406
                         (PrefixCon (nOfThem (dataConSourceArity con)
                                             nlWildPat)))
407

408 409
nlWildPat :: LPat RdrName
nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
410

411 412 413 414 415 416 417 418
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
419
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
420

twanvl's avatar
twanvl committed
421
nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
422 423
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)

424
nlHsLam  :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName
twanvl's avatar
twanvl committed
425 426
nlHsPar  :: LHsExpr id -> LHsExpr id
nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
427 428 429
nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]
         -> LHsExpr RdrName
nlList   :: [LHsExpr RdrName] -> LHsExpr RdrName
twanvl's avatar
twanvl committed
430

431
nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))
432 433 434 435
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)
436

twanvl's avatar
twanvl committed
437 438 439 440
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
nlHsTyVar :: name                         -> LHsType name
nlHsFunTy :: LHsType name -> LHsType name -> LHsType name

441
nlHsAppTy f t           = noLoc (HsAppTy f t)
442
nlHsTyVar x             = noLoc (HsTyVar (noLoc x))
443
nlHsFunTy a b           = noLoc (HsFunTy a b)
444

twanvl's avatar
twanvl committed
445
nlHsTyConApp :: name -> [LHsType name] -> LHsType name
446
nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
447

Austin Seipp's avatar
Austin Seipp committed
448
{-
449 450
Tuples.  All these functions are *pre-typechecker* because they lack
types on the tuple.
Austin Seipp's avatar
Austin Seipp committed
451
-}
452 453 454 455

mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
456
mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
457 458 459

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

461
nlTuplePat :: [LPat id] -> Boxity -> LPat id
462
nlTuplePat pats box = noLoc (TuplePat pats box [])
463

464
missingTupArg :: HsTupArg RdrName
465
missingTupArg = Missing placeHolderType
466

Simon Marlow's avatar
Simon Marlow committed
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 518 519 520 521 522 523 524 525 526
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
527 528 529
{-
************************************************************************
*                                                                      *
530
        LHsSigType and LHsSigWcType
Austin Seipp's avatar
Austin Seipp committed
531
*                                                                      *
532
********************************************************************* -}
533

534 535
mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName
mkLHsSigType ty = mkHsImplicitBndrs ty
536

537 538
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty)
539

540 541 542 543 544 545
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
546
  where
547 548
    fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
    fiddle sig                      = sig
549

550 551 552 553 554 555 556 557 558 559
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
560
    go ty@(ForAllTy (Anon arg) _)
561 562 563 564
      | isPredTy arg
      , (theta, tau) <- tcSplitPhiTy ty
      = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
                        , hst_body = go tau })
565 566 567 568 569
    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 })
570 571 572 573 574
    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')
575
       where
576 577 578 579 580
         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
581
         -- so we must remove them here (Trac #8563)
582

583 584 585
    go_tv :: TyVar -> LHsTyVarBndr RdrName
    go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
                                   (go (tyVarKind tv))
586 587


588 589 590 591 592 593
{- *********************************************************************
*                                                                      *
    --------- HsWrappers: type args, dict args, casts ---------
*                                                                      *
********************************************************************* -}

594 595 596 597 598
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
599
                 | otherwise           = HsWrap co_fn e
600

601
mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
602
           -> HsExpr id -> HsExpr id
603
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
604

605
mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
606
            -> HsExpr id -> HsExpr id
607
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
608

609
mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
Joachim Breitner's avatar
Joachim Breitner committed
610
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
611

612 613 614 615
mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id
mkHsCmdCast co cmd | isTcReflCo co = cmd
                   | otherwise     = HsCmdCast co cmd

616 617
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
618
                       | otherwise           = CoPat co_fn p ty
619

620
mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
621
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
622
                        | otherwise     = CoPat (mkWpCastN co) pat ty
623 624 625

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

{-
628
l
Austin Seipp's avatar
Austin Seipp committed
629 630
************************************************************************
*                                                                      *
631
                Bindings; with a location at the top
Austin Seipp's avatar
Austin Seipp committed
632 633 634
*                                                                      *
************************************************************************
-}
635

636 637
mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
          -> HsBind RdrName
638
-- Not infix, with place holders for coercion and free vars
639
mkFunBind fn ms = FunBind { fun_id = fn
640 641
                          , fun_matches = mkMatchGroup Generated ms
                          , fun_co_fn = idHsWrapper
642
                          , bind_fvs = placeHolderNames
643
                          , fun_tick = [] }
644

645 646
mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
             -> HsBind Name
647
-- In Name-land, with empty bind_fvs
648
mkTopFunBind origin fn ms = FunBind { fun_id = fn
649
                                    , fun_matches = mkMatchGroupName origin ms
650
                                    , fun_co_fn = idHsWrapper
651 652
                                    , bind_fvs = emptyNameSet -- NB: closed
                                                              --     binding
653
                                    , fun_tick = [] }
654

655
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
656 657 658 659
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs

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

662 663
mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
             -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
664 665 666 667 668 669 670
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
671

672 673 674 675
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
isInfixFunBind :: HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
676
  = any (isInfixMatch . unLoc) (unLoc matches)
677 678 679
isInfixFunBind _ = False


680
------------
681
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
682
                -> LHsExpr RdrName -> LHsBind RdrName
683
mk_easy_FunBind loc fun pats expr
684
  = L loc $ mkFunBind (L loc fun) [mkMatch pats expr (noLoc emptyLocalBinds)]
685

686
------------
687 688 689
mkMatch :: [LPat id] -> LHsExpr id -> Located (HsLocalBinds id)
        -> LMatch id (LHsExpr id)
mkMatch pats expr lbinds
690
  = noLoc (Match NonFunBindMatch (map paren pats) Nothing
691
                 (GRHSs (unguardedRHS noSrcSpan expr) lbinds))
692
  where
693 694
    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
                     | otherwise          = lp
695

Austin Seipp's avatar
Austin Seipp committed
696 697 698
{-
************************************************************************
*                                                                      *
699
        Collecting binders
Austin Seipp's avatar
Austin Seipp committed
700 701
*                                                                      *
************************************************************************
702 703 704 705 706 707 708 709 710 711 712

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

713 714 715
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
716
to return a [Name] or [Id].  Before renaming the record punning
717 718
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
719
-}
720 721 722

----------------- Bindings --------------------------
collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
723 724 725 726
collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
                                         -- No pattern synonyms here
collectLocalBinders (HsIPBinds _)      = []
collectLocalBinders EmptyLocalBinds    = []
727

728 729 730 731
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
732 733

collectHsBindBinders :: HsBindLR idL idR -> [idL]
734 735
-- Collect both Ids and pattern-synonym binders
collectHsBindBinders b = collect_bind False b []
736

737
collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
738
collectHsBindsBinders binds = collect_binds False binds []
739

740
collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
741 742 743 744 745 746 747 748 749 750 751
-- 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]
752
-- Collect Ids, or Ids + pattern synonyms, depending on boolean flag
753 754 755 756 757 758 759 760 761 762 763 764
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
765

766 767
collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
-- Used exclusively for the bindings of an instance decl which are all FunBinds
768
collectMethodBinders binds = foldrBag (get . unLoc) [] binds
769
  where
cactus's avatar
cactus committed
770
    get (FunBind { fun_id = f }) fs = f : fs
771
    get _                        fs = fs
772
       -- Someone else complains about non-FunBinds
773

774
----------------- Statements --------------------------
775
collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]
776
collectLStmtsBinders = concatMap collectLStmtBinders
777

778
collectStmtsBinders :: [StmtLR idL idR body] -> [idL]
779 780
collectStmtsBinders = concatMap collectStmtBinders

781
collectLStmtBinders :: LStmtLR idL idR body -> [idL]
782 783
collectLStmtBinders = collectStmtBinders . unLoc

784
collectStmtBinders :: StmtLR idL idR body -> [idL]
785
  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
786 787 788 789 790 791
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]
792 793
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
Simon Marlow's avatar
Simon Marlow committed
794
collectStmtBinders ApplicativeStmt{} = []
795 796


797
----------------- Patterns --------------------------
798
collectPatBinders :: LPat a -> [a]
799
collectPatBinders pat = collect_lpat pat []
800 801

collectPatsBinders :: [LPat a] -> [a]
802
collectPatsBinders pats = foldr collect_lpat [] pats
803

804 805 806
-------------
collect_lpat :: LPat name -> [name] -> [name]
collect_lpat (L _ pat) bndrs
807 808
  = go pat
  where
809
    go (VarPat (L _ var))         = var : bndrs
810 811 812 813
    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
814
    go (ViewPat _ pat _)          = collect_lpat pat bndrs
815 816
    go (ParPat  pat)              = collect_lpat pat bndrs

817
    go (ListPat pats _ _)         = foldr collect_lpat bndrs pats
818 819 820
    go (PArrPat pats _)           = foldr collect_lpat bndrs pats
    go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats

821 822
    go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
    go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
823 824 825
        -- See Note [Dictionary binders in ConPatOut]
    go (LitPat _)                 = bndrs
    go (NPat _ _ _)               = bndrs
826
    go (NPlusKPat (L _ n) _ _ _)  = n : bndrs
827 828 829

    go (SigPatIn pat _)           = collect_lpat pat bndrs
    go (SigPatOut pat _)          = collect_lpat pat bndrs
gmainland's avatar
gmainland committed
830
    go (SplicePat _)              = bndrs
831
    go (CoPat _ pat _)            = go pat
832

Austin Seipp's avatar
Austin Seipp committed
833
{-
834
Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
835 836 837 838 839 840 841 842 843
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
844 845 846 847 848 849 850 851 852 853 854 855 856 857 858
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
859
-}
Ross Paterson's avatar
Ross Paterson committed
860

861 862 863 864
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
865
  ++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
866

867 868
hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
                     -> [LForeignDecl Name] -> [Name]
869
-- We need to look at instance declarations too,
870
-- because their associated types may bind data constructors
871
hsTyClForeignBinders tycl_decls inst_decls foreign_decls
872 873 874 875 876 877
  = 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
878

879
-------------------
880 881 882 883 884 885
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
886
--
887 888
-- 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
889 890

hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
891 892
  = ([L loc name], [])
hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = ([L loc name], [])
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
893 894
hsLTyClDeclBinders (L loc (ClassDecl   { tcdLName = L _ cls_name
                                       , tcdSigs = sigs, tcdATs = ats }))
895
  = (L loc cls_name :
896 897
     [ 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 ]
898
    , [])
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
899
hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
900
  = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
901 902

-------------------
903 904 905 906
hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
-- See Note [SrcSpan for binders]
hsForeignDeclsBinders foreign_decls
  = [ L decl_loc n
907
    | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]
908

Matthew Pickering's avatar
Matthew Pickering committed
909 910


911
-------------------
Matthew Pickering's avatar
Matthew Pickering committed
912 913
hsPatSynBinders :: HsValBinds RdrName
                -> ([Located RdrName], [Located RdrName])
914 915
-- Collect pattern-synonym binders only, not Ids
-- See Note [SrcSpan for binders]
Matthew Pickering's avatar
Matthew Pickering committed
916
hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr ([],[]) binds
917
hsPatSynBinders _ = panic "hsPatSynBinders"
918

Matthew Pickering's avatar
Matthew Pickering committed
919 920
addPatSynBndr :: LHsBindLR id id -> ([Located id], [Located id])
                -> ([Located id], [Located id]) -- (selectors, other)
921
-- See Note [SrcSpan for binders]
Matthew Pickering's avatar
Matthew Pickering committed
922 923 924 925 926 927
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)
928
  | otherwise
Matthew Pickering's avatar
Matthew Pickering committed
929
  = (sels, pss)
930 931

-------------------
932
hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
933
hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
934
  = foldMap (hsDataFamInstBinders . unLoc) dfis
935 936
hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
  = hsDataFamInstBinders fi
937
hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
938 939

-------------------
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
940
-- the SrcLoc returned are for the whole declarations, not just the names