HsUtils.hs 45.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 #-}
19
{-# LANGUAGE TypeFamilies #-}
Ian Lynagh's avatar
Ian Lynagh committed
20

21 22 23
module HsUtils(
  -- Terms
  mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
24 25
  mkSimpleMatch, unguardedGRHSs, unguardedRHS,
  mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
26
  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
27
  mkHsDictLet, mkHsLams,
28
  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
29
  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, isLHsTypeExpr_maybe, isLHsTypeExpr,
30

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

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

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

  -- Literals
47
  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
48 49

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

  -- Types
56
  mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs,
57
  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs,
58
  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
59 60

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

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

  -- Flags
71
  noRebindableInfo,
72 73

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

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

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

88 89
#include "HsVersions.h"

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

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

116
import Data.Either
117 118
import Data.Function
import Data.List
119

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

127 128 129
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
130
-}
131 132 133 134

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

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

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

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

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

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

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

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

172
mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
173
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
174
        where
175
          matches = mkMatchGroup Generated [mkSimpleMatch pats body]
176 177

mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
178 179
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
                                       <.> mkWpLams dicts) expr
180 181

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

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

193
nlHsTyApp :: name -> [Type] -> LHsExpr name
194
nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
195

196 197 198
nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name
nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs

199 200 201 202 203 204 205 206 207 208 209
--------- 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

210

211
-------------------------------
212 213 214
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName

215
mkHsIntegral   :: String -> Integer -> PostTc RdrName Type -> HsOverLit RdrName
216
mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName
217
mkHsIsString :: String -> FastString -> PostTc RdrName Type -> HsOverLit RdrName
218 219 220
mkHsDo         :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
mkHsComp       :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
               -> HsExpr RdrName
twanvl's avatar
twanvl committed
221

222 223
mkNPat      :: Located (HsOverLit RdrName) -> Maybe (SyntaxExpr RdrName) -> Pat RdrName
mkNPlusKPat :: Located RdrName -> Located (HsOverLit RdrName) -> Pat RdrName
twanvl's avatar
twanvl committed
224

225
mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
226 227
mkBodyStmt :: Located (bodyR RdrName)
           -> StmtLR idL RdrName (Located (bodyR RdrName))
228 229 230 231
mkBindStmt :: (PostTc idR Type ~ PlaceHolder)
           => LPat idL -> Located (bodyR idR)
           -> StmtLR idL idR (Located (bodyR idR))
mkTcBindStmt :: LPat Id -> Located (bodyR Id) -> StmtLR Id Id (Located (bodyR Id))
232

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


239 240 241
mkHsIntegral src i  = OverLit (HsIntegral   src i) noRebindableInfo noExpr
mkHsFractional   f  = OverLit (HsFractional     f) noRebindableInfo noExpr
mkHsIsString src s  = OverLit (HsIsString   src s) noRebindableInfo noExpr
242

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

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

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

254 255
mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
256

257 258
mkTransformStmt    :: (PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL] -> LHsExpr idR
259
                   -> StmtLR idL idR (LHsExpr idL)
260 261
mkTransformByStmt  :: (PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
262
                   -> StmtLR idL idR (LHsExpr idL)
263 264
mkGroupUsingStmt   :: (PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL]                -> LHsExpr idR
265
                   -> StmtLR idL idR (LHsExpr idL)
266 267
mkGroupByUsingStmt :: (PostTc idR Type ~ PlaceHolder)
                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
268
                   -> StmtLR idL idR (LHsExpr idL)
269

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

Simon Marlow's avatar
Simon Marlow committed
282
mkLastStmt body     = LastStmt body False noSyntaxExpr
283
mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
284 285 286
mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder
mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy
  -- don't use placeHolderTypeTc above, because that panics during zonking
287

288 289 290 291 292 293 294 295
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
296 297
     , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal
     , recS_later_rets = []
298 299 300 301
     , recS_rec_rets = [], recS_ret_ty = tyVal }

emptyRecStmt     = emptyRecStmt' placeHolderType
emptyRecStmtName = emptyRecStmt' placeHolderType
302
emptyRecStmtId   = emptyRecStmt' unitTy -- a panic might trigger during zonking
303
mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }
304 305

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

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

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

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

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

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

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

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

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

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

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

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

351

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

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

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

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

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

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

375 376 377 378 379 380 381 382 383 384 385 386
nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id
nlHsSyntaxApps (SyntaxExpr { syn_expr      = fun
                           , syn_arg_wraps = arg_wraps
                           , syn_res_wrap  = res_wrap }) args
  | [] <- arg_wraps   -- in the noSyntaxExpr case
  = ASSERT( isIdHsWrapper res_wrap )
    foldl nlHsApp (noLoc fun) args

  | otherwise
  = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
                                                     mkLHsWrap arg_wraps args))

twanvl's avatar
twanvl committed
387
nlHsIntLit :: Integer -> LHsExpr id
388
nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
389 390 391

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

393
nlHsVarApps :: id -> [id] -> LHsExpr id
394
nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
395 396
                 where
                   mk f a = HsApp (noLoc f) (noLoc a)
397

398
nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
399 400
nlConVarPat con vars = nlConPat con (map nlVarPat vars)

401 402 403
nlConVarPatName :: Name -> [Name] -> LPat Name
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)

404 405 406
nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))

407
nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName
408 409
nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

410 411 412
nlConPatName :: Name -> [LPat Name] -> LPat Name
nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

413 414 415 416 417
nlNullaryConPat :: id -> LPat id
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))

nlWildConPat :: DataCon -> LPat RdrName
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
418 419
                         (PrefixCon (nOfThem (dataConSourceArity con)
                                             nlWildPat)))
420

421 422
nlWildPat :: LPat RdrName
nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
423

424 425 426 427 428 429 430 431
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
432
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
433

twanvl's avatar
twanvl committed
434
nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
435 436
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)

437
nlHsLam  :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName
twanvl's avatar
twanvl committed
438 439
nlHsPar  :: LHsExpr id -> LHsExpr id
nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
440 441 442
nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]
         -> LHsExpr RdrName
nlList   :: [LHsExpr RdrName] -> LHsExpr RdrName
twanvl's avatar
twanvl committed
443

444
nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))
445 446 447 448
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)
449

twanvl's avatar
twanvl committed
450 451 452 453
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
nlHsTyVar :: name                         -> LHsType name
nlHsFunTy :: LHsType name -> LHsType name -> LHsType name

454
nlHsAppTy f t           = noLoc (HsAppTy f t)
455
nlHsTyVar x             = noLoc (HsTyVar (noLoc x))
456
nlHsFunTy a b           = noLoc (HsFunTy a b)
457

twanvl's avatar
twanvl committed
458
nlHsTyConApp :: name -> [LHsType name] -> LHsType name
459
nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
460

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
461 462 463 464 465 466 467 468 469 470 471 472 473 474 475
-- | 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
476
{-
477 478
Tuples.  All these functions are *pre-typechecker* because they lack
types on the tuple.
Austin Seipp's avatar
Austin Seipp committed
479
-}
480 481 482 483

mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
484
mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
485 486 487

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

489
nlTuplePat :: [LPat id] -> Boxity -> LPat id
490
nlTuplePat pats box = noLoc (TuplePat pats box [])
491

492
missingTupArg :: HsTupArg RdrName
493
missingTupArg = Missing placeHolderType
494

Simon Marlow's avatar
Simon Marlow committed
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 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554
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
555 556 557
{-
************************************************************************
*                                                                      *
558
        LHsSigType and LHsSigWcType
Austin Seipp's avatar
Austin Seipp committed
559
*                                                                      *
560
********************************************************************* -}
561

562 563
mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName
mkLHsSigType ty = mkHsImplicitBndrs ty
564

565 566
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty)
567

568 569 570 571 572 573
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
574
  where
575 576
    fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
    fiddle sig                      = sig
577

578 579 580 581 582 583 584 585 586 587
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
588
    go ty@(ForAllTy (Anon arg) _)
589 590 591 592
      | isPredTy arg
      , (theta, tau) <- tcSplitPhiTy ty
      = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
                        , hst_body = go tau })
593 594 595 596 597
    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 })
598 599 600 601 602
    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')
603
       where
604 605 606 607 608
         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
609
         -- so we must remove them here (Trac #8563)
610

611 612 613
    go_tv :: TyVar -> LHsTyVarBndr RdrName
    go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
                                   (go (tyVarKind tv))
614 615


616 617 618 619 620 621
{- *********************************************************************
*                                                                      *
    --------- HsWrappers: type args, dict args, casts ---------
*                                                                      *
********************************************************************* -}

622 623 624 625 626
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
627
                 | otherwise           = HsWrap co_fn e
628

629
mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
630
           -> HsExpr id -> HsExpr id
631
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
632

633
mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
634
            -> HsExpr id -> HsExpr id
635
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
636

637
mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
Joachim Breitner's avatar
Joachim Breitner committed
638
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
639

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
640 641 642 643 644 645
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)
646

647 648
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
649
                       | otherwise           = CoPat co_fn p ty
650

651
mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
652
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
653
                        | otherwise     = CoPat (mkWpCastN co) pat ty
654 655 656

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

{-
659
l
Austin Seipp's avatar
Austin Seipp committed
660 661
************************************************************************
*                                                                      *
662
                Bindings; with a location at the top
Austin Seipp's avatar
Austin Seipp committed
663 664 665
*                                                                      *
************************************************************************
-}
666

667 668
mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
          -> HsBind RdrName
669
-- Not infix, with place holders for coercion and free vars
670
mkFunBind fn ms = FunBind { fun_id = fn
671 672
                          , fun_matches = mkMatchGroup Generated ms
                          , fun_co_fn = idHsWrapper
673
                          , bind_fvs = placeHolderNames
674
                          , fun_tick = [] }
675

676 677
mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
             -> HsBind Name
678
-- In Name-land, with empty bind_fvs
679
mkTopFunBind origin fn ms = FunBind { fun_id = fn
680
                                    , fun_matches = mkMatchGroupName origin ms
681
                                    , fun_co_fn = idHsWrapper
682 683
                                    , bind_fvs = emptyNameSet -- NB: closed
                                                              --     binding
684
                                    , fun_tick = [] }
685

686
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
687 688 689 690
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs

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

693 694
mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
             -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
695 696 697 698 699 700 701
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
702

703 704 705 706
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
isInfixFunBind :: HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
707
  = any (isInfixMatch . unLoc) (unLoc matches)
708 709 710
isInfixFunBind _ = False


711
------------
712
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
713
                -> LHsExpr RdrName -> LHsBind RdrName
714
mk_easy_FunBind loc fun pats expr
715
  = L loc $ mkFunBind (L loc fun) [mkMatch pats expr (noLoc emptyLocalBinds)]
716

717
------------
718 719 720
mkMatch :: [LPat id] -> LHsExpr id -> Located (HsLocalBinds id)
        -> LMatch id (LHsExpr id)
mkMatch pats expr lbinds
721
  = noLoc (Match NonFunBindMatch (map paren pats) Nothing
722
                 (GRHSs (unguardedRHS noSrcSpan expr) lbinds))
723
  where
724 725
    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
                     | otherwise          = lp
726

Austin Seipp's avatar
Austin Seipp committed
727 728 729
{-
************************************************************************
*                                                                      *
730
        Collecting binders
Austin Seipp's avatar
Austin Seipp committed
731 732
*                                                                      *
************************************************************************
733 734 735 736 737 738 739 740 741 742 743

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

744 745 746
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
747
to return a [Name] or [Id].  Before renaming the record punning
748 749
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
750
-}
751 752 753

----------------- Bindings --------------------------
collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
754 755 756 757
collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
                                         -- No pattern synonyms here
collectLocalBinders (HsIPBinds _)      = []
collectLocalBinders EmptyLocalBinds    = []
758

759 760 761 762
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
763 764

collectHsBindBinders :: HsBindLR idL idR -> [idL]
765 766
-- Collect both Ids and pattern-synonym binders
collectHsBindBinders b = collect_bind False b []
767

768
collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
769
collectHsBindsBinders binds = collect_binds False binds []
770

771
collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
772 773 774 775 776 777 778 779 780 781 782
-- 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]
783
-- Collect Ids, or Ids + pattern synonyms, depending on boolean flag
784 785 786 787 788 789 790 791 792 793
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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
794
collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
795 796
collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
    if omitPatSyn then acc else ps : acc
797

798 799
collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
-- Used exclusively for the bindings of an instance decl which are all FunBinds
800
collectMethodBinders binds = foldrBag (get . unLoc) [] binds
801
  where
cactus's avatar
cactus committed
802
    get (FunBind { fun_id = f }) fs = f : fs
803
    get _                        fs = fs
804
       -- Someone else complains about non-FunBinds
805

806
----------------- Statements --------------------------
807
collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]
808
collectLStmtsBinders = concatMap collectLStmtBinders
809

810
collectStmtsBinders :: [StmtLR idL idR body] -> [idL]
811 812
collectStmtsBinders = concatMap collectStmtBinders

813
collectLStmtBinders :: LStmtLR idL idR body -> [idL]
814 815
collectLStmtBinders = collectStmtBinders . unLoc

816
collectStmtBinders :: StmtLR idL idR body -> [idL]
817
  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
818
collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat
819 820 821
collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
collectStmtBinders (BodyStmt {})         = []
collectStmtBinders (LastStmt {})         = []
822
collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
823
                                      $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
824 825
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
Simon Marlow's avatar
Simon Marlow committed
826
collectStmtBinders ApplicativeStmt{} = []
827 828


829
----------------- Patterns --------------------------
830
collectPatBinders :: LPat a -> [a]
831
collectPatBinders pat = collect_lpat pat []
832 833

collectPatsBinders :: [LPat a] -> [a]
834
collectPatsBinders pats = foldr collect_lpat [] pats
835

836 837 838
-------------
collect_lpat :: LPat name -> [name] -> [name]
collect_lpat (L _ pat) bndrs
839 840
  = go pat
  where
841
    go (VarPat (L _ var))         = var : bndrs
842 843 844 845
    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
846
    go (ViewPat _ pat _)          = collect_lpat pat bndrs
847 848
    go (ParPat  pat)              = collect_lpat pat bndrs

849
    go (ListPat pats _ _)         = foldr collect_lpat bndrs pats
850 851 852
    go (PArrPat pats _)           = foldr collect_lpat bndrs pats
    go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats

853 854
    go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
    go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
855 856
        -- See Note [Dictionary binders in ConPatOut]
    go (LitPat _)                 = bndrs
857 858
    go (NPat {})                  = bndrs
    go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs
859 860 861

    go (SigPatIn pat _)           = collect_lpat pat bndrs
    go (SigPatOut pat _)          = collect_lpat pat bndrs
gmainland's avatar
gmainland committed
862
    go (SplicePat _)              = bndrs
863
    go (CoPat _ pat _)            = go pat
864

Austin Seipp's avatar
Austin Seipp committed
865
{-
866
Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
867 868 869 870 871 872 873 874 875
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
876 877 878 879 880 881 882 883 884 885 886 887 888 889 890
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
891
-}
Ross Paterson's avatar
Ross Paterson committed
892

893 894 895 896
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
897
  ++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
898

899 900
hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
                     -> [LForeignDecl Name] -> [Name]
901
-- We need to look at instance declarations too,
902
-- because their associated types may bind data constructors
903
hsTyClForeignBinders tycl_decls inst_decls foreign_decls
904 905 906 907 908 909
  = 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
910

911
-------------------
912 913 914 915 916 917
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
918
--
919 920
-- 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
921 922

hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
923 924
  = ([L loc name], [])
hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = ([L loc name], [])
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
925 926
hsLTyClDeclBinders (L loc (ClassDecl   { tcdLName = L _ cls_name
                                       , tcdSigs = sigs, tcdATs = ats }))
927
  = (L loc cls_name :
928 929
     [ 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 ]
930
    , [])
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
931
hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
932
  = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
933 934

-------------------
935 936 937 938
hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
-- See Note [SrcSpan for binders]
hsForeignDeclsBinders foreign_decls
  = [ L decl_loc n
939
    | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]