compiler/hsSyn/HsUtils.lhs

   1
   2 %
   3 % (c) The University of Glasgow, 1992-2006
   4 %
   5
   6 Here we collect a variety of helper functions that construct or
   7 analyse HsSyn.  All these functions deal with generic HsSyn; functions
   8 which deal with the intantiated versions are located elsewhere:
   9
  10    Parameterised by     Module
  11    ----------------     -------------
  12    RdrName              parser/RdrHsSyn
  13    Name                 rename/RnHsSyn
  14    Id                   typecheck/TcHsSyn
  15
  16 \begin{code}
  17 module HsUtils(
  18   -- Terms
  19   mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
  20   mkSimpleMatch, unguardedGRHSs, unguardedRHS,
  21   mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
  22   mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
  23   coiToHsWrapper, mkHsDictLet,
  24   mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
  25
  26   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
  27   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
  28   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
  29
  30   -- Bindigns
  31   mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind,
  32
  33   -- Literals
  34   mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
  35
  36   -- Patterns
  37   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat,
  38   nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat,
  39
  40   -- Types
  41   mkHsAppTy, userHsTyVarBndrs,
  42   nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
  43
  44   -- Stmts
  45   mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt,
  46   mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
  47   emptyRecStmt, mkRecStmt,
  48
  49   -- Template Haskell
  50   unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote,
  51
  52   -- Flags
  53   noRebindableInfo,
  54
  55   -- Collecting binders
  56   collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
  57   collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
  58   collectPatBinders, collectPatsBinders,
  59   collectLStmtsBinders, collectStmtsBinders,
  60   collectLStmtBinders, collectStmtBinders,
  61   collectSigTysFromPats, collectSigTysFromPat,
  62
  63   hsTyClDeclBinders, hsTyClDeclsBinders, hsConDeclsBinders,
  64   hsForeignDeclsBinders, hsGroupBinders
  65   ) where
  66
  67 import HsDecls
  68 import HsBinds
  69 import HsExpr
  70 import HsPat
  71 import HsTypes
  72 import HsLit
  73
  74 import RdrName
  75 import Var
  76 import Coercion
  77 import Type
  78 import DataCon
  79 import Name
  80 import NameSet
  81 import BasicTypes
  82 import SrcLoc
  83 import FastString
  84 import Util
  85 import Bag
  86 \end{code}
  87
  88
  89 %************************************************************************
  90 %*                                                                      *
  91         Some useful helpers for constructing syntax
  92 %*                                                                      *
  93 %************************************************************************
  94
  95 These functions attempt to construct a not-completely-useless SrcSpan
  96 from their components, compared with the nl* functions below which
  97 just attach noSrcSpan to everything.
  98
  99 \begin{code}
 100 mkHsPar :: LHsExpr id -> LHsExpr id
 101 mkHsPar e = L (getLoc e) (HsPar e)
 102
 103 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
 104 mkSimpleMatch pats rhs
 105   = L loc $
 106     Match pats Nothing (unguardedGRHSs rhs)
 107   where
 108     loc = case pats of
 109                 []      -> getLoc rhs
 110                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
 111
 112 unguardedGRHSs :: LHsExpr id -> GRHSs id
 113 unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
 114
 115 unguardedRHS :: LHsExpr id -> [LGRHS id]
 116 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
 117
 118 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
 119 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
 120
 121 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
 122 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
 123
 124 nlHsTyApp :: name -> [Type] -> LHsExpr name
 125 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
 126
 127 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
 128 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 129
 130 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 131 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
 132                  | otherwise           = HsWrap co_fn e
 133
 134 mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
 135 mkHsWrapCoI (IdCo _) e = e
 136 mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
 137
 138 mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id
 139 mkLHsWrapCoI (IdCo _) e         = e
 140 mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e)
 141
 142 coiToHsWrapper :: CoercionI -> HsWrapper
 143 coiToHsWrapper (IdCo _) = idHsWrapper
 144 coiToHsWrapper (ACo co) = WpCast co
 145
 146 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
 147 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
 148                        | otherwise           = CoPat co_fn p ty
 149
 150 mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id
 151 mkHsWrapPatCoI (IdCo _) pat _  = pat
 152 mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty
 153
 154 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 155 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 156         where
 157           matches = mkMatchGroup [mkSimpleMatch pats body]
 158
 159 mkMatchGroup :: [LMatch id] -> MatchGroup id
 160 mkMatchGroup matches = MatchGroup matches placeHolderType
 161
 162 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
 163 mkHsDictLet ev_binds expr = mkLHsWrap (WpLet ev_binds) expr
 164
 165 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 166 -- Used for constructing dictionary terms etc, so no locations
 167 mkHsConApp data_con tys args
 168   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
 169   where
 170     mk_app f a = noLoc (HsApp f (noLoc a))
 171
 172 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
 173 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
 174 mkSimpleHsAlt pat expr
 175   = mkSimpleMatch [pat] expr
 176
 177 -------------------------------
 178 -- These are the bits of syntax that contain rebindable names
 179 -- See RnEnv.lookupSyntaxName
 180
 181 mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id
 182 mkHsFractional :: Rational -> PostTcType -> HsOverLit id
 183 mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
 184 mkHsDo         :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
 185
 186 mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
 187 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
 188
 189 mkTransformStmt   :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
 190 mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 191
 192 mkExprStmt :: LHsExpr idR -> StmtLR idL idR
 193 mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
 194
 195 emptyRecStmt :: StmtLR idL idR
 196 mkRecStmt    :: [LStmtLR idL idR] -> StmtLR idL idR
 197
 198
 199 mkHsIntegral   i       = OverLit (HsIntegral   i)  noRebindableInfo noSyntaxExpr
 200 mkHsFractional f       = OverLit (HsFractional f)  noRebindableInfo noSyntaxExpr
 201 mkHsIsString   s       = OverLit (HsIsString   s)  noRebindableInfo noSyntaxExpr
 202
 203 noRebindableInfo :: Bool
 204 noRebindableInfo = error "noRebindableInfo"     -- Just another placeholder;
 205
 206 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 207
 208 mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
 209 mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
 210
 211 mkNPat lit neg     = NPat lit neg noSyntaxExpr
 212 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 213
 214 mkTransformStmt   stmts usingExpr        = TransformStmt stmts [] usingExpr Nothing
 215 mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr)
 216
 217 mkGroupUsingStmt   :: [LStmt idL]                -> LHsExpr idR -> StmtLR idL idR
 218 mkGroupByStmt      :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
 219 mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 220
 221 mkGroupUsingStmt   stmts usingExpr        = GroupStmt stmts [] Nothing       (Left usingExpr)
 222 mkGroupByStmt      stmts byExpr           = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr)
 223 mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr)
 224
 225 mkExprStmt expr     = ExprStmt expr noSyntaxExpr placeHolderType
 226 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 227
 228 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
 229                        , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
 230                        , recS_bind_fn = noSyntaxExpr
 231                        , recS_rec_rets = [], recS_dicts = emptyTcEvBinds }
 232
 233 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
 234
 235 -------------------------------
 236 --- A useful function for building @OpApps@.  The operator is always a
 237 -- variable, and we don't know the fixity yet.
 238 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
 239 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 240
 241 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
 242 mkHsSplice e = HsSplice unqualSplice e
 243
 244 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
 245 mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
 246
 247 unqualSplice :: RdrName
 248 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
 249                 -- A name (uniquified later) to
 250                 -- identify the splice
 251
 252 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
 253 mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
 254
 255 unqualQuasiQuote :: RdrName
 256 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
 257                 -- A name (uniquified later) to
 258                 -- identify the quasi-quote
 259
 260 mkHsString :: String -> HsLit
 261 mkHsString s = HsString (mkFastString s)
 262
 263 -------------
 264 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
 265 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
 266 \end{code}
 267
 268
 269 %************************************************************************
 270 %*                                                                      *
 271         Constructing syntax with no location info
 272 %*                                                                      *
 273 %************************************************************************
 274
 275 \begin{code}
 276 nlHsVar :: id -> LHsExpr id
 277 nlHsVar n = noLoc (HsVar n)
 278
 279 nlHsLit :: HsLit -> LHsExpr id
 280 nlHsLit n = noLoc (HsLit n)
 281
 282 nlVarPat :: id -> LPat id
 283 nlVarPat n = noLoc (VarPat n)
 284
 285 nlLitPat :: HsLit -> LPat id
 286 nlLitPat l = noLoc (LitPat l)
 287
 288 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 289 nlHsApp f x = noLoc (HsApp f x)
 290
 291 nlHsIntLit :: Integer -> LHsExpr id
 292 nlHsIntLit n = noLoc (HsLit (HsInt n))
 293
 294 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 295 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 296
 297 nlHsVarApps :: id -> [id] -> LHsExpr id
 298 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 299                  where
 300                    mk f a = HsApp (noLoc f) (noLoc a)
 301
 302 nlConVarPat :: id -> [id] -> LPat id
 303 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 304
 305 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 306 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 307
 308 nlConPat :: id -> [LPat id] -> LPat id
 309 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 310
 311 nlNullaryConPat :: id -> LPat id
 312 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 313
 314 nlWildConPat :: DataCon -> LPat RdrName
 315 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 316                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 317
 318 nlWildPat :: LPat id
 319 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
 320
 321 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
 322 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
 323
 324 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
 325 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 326
 327 nlHsLam  :: LMatch id -> LHsExpr id
 328 nlHsPar  :: LHsExpr id -> LHsExpr id
 329 nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
 330 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
 331 nlList   :: [LHsExpr id] -> LHsExpr id
 332
 333 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
 334 nlHsPar e               = noLoc (HsPar e)
 335 nlHsIf cond true false  = noLoc (mkHsIf cond true false)
 336 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
 337 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 338
 339 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
 340 nlHsTyVar :: name                         -> LHsType name
 341 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
 342
 343 nlHsAppTy f t           = noLoc (HsAppTy f t)
 344 nlHsTyVar x             = noLoc (HsTyVar x)
 345 nlHsFunTy a b           = noLoc (HsFunTy a b)
 346
 347 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
 348 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 349 \end{code}
 350
 351 Tuples.  All these functions are *pre-typechecker* because they lack
 352 types on the tuple.
 353
 354 \begin{code}
 355 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
 356 -- Makes a pre-typechecker boxed tuple, deals with 1 case
 357 mkLHsTupleExpr [e] = e
 358 mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map Present es) Boxed
 359
 360 mkLHsVarTuple :: [a] -> LHsExpr a
 361 mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
 362
 363 nlTuplePat :: [LPat id] -> Boxity -> LPat id
 364 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
 365
 366 missingTupArg :: HsTupArg a
 367 missingTupArg = Missing placeHolderType
 368 \end{code}
 369
 370 %************************************************************************
 371 %*                                                                      *
 372                 Bindings; with a location at the top
 373 %*                                                                      *
 374 %************************************************************************
 375
 376 \begin{code}
 377 mkFunBind :: Located id -> [LMatch id] -> HsBind id
 378 -- Not infix, with place holders for coercion and free vars
 379 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
 380                             fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
 381                             fun_tick = Nothing }
 382
 383
 384 mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
 385 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 386
 387 mkVarBind :: id -> LHsExpr id -> LHsBind id
 388 mkVarBind var rhs = L (getLoc rhs) $
 389                     VarBind { var_id = var, var_rhs = rhs, var_inline = False }
 390
 391 ------------
 392 mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
 393                 -> LHsExpr id -> LHsBind id
 394
 395 mk_easy_FunBind loc fun pats expr
 396   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 397
 398 ------------
 399 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 400 mkMatch pats expr binds
 401   = noLoc (Match (map paren pats) Nothing
 402                  (GRHSs (unguardedRHS expr) binds))
 403   where
 404     paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
 405                      | otherwise          = lp
 406 \end{code}
 407
 408
 409 %************************************************************************
 410 %*                                                                      *
 411         Collecting binders
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
 416
 417 ...
 418 where
 419   (x, y) = ...
 420   f i j  = ...
 421   [a, b] = ...
 422
 423 it should return [x, y, f, a, b] (remember, order important).
 424
 425 Note [Collect binders only after renaming]
 426 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 427 These functions should only be used on HsSyn *after* the renamer,
 428 to return a [Name] or [Id].  Before renaming the record punning
 429 and wild-card mechanism makes it hard to know what is bound.
 430 So these functions should not be applied to (HsSyn RdrName)
 431
 432 \begin{code}
 433 ----------------- Bindings --------------------------
 434 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
 435 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 436 collectLocalBinders (HsIPBinds _)   = []
 437 collectLocalBinders EmptyLocalBinds = []
 438
 439 collectHsValBinders :: HsValBindsLR idL idR -> [idL]
 440 collectHsValBinders (ValBindsIn  binds _) = collectHsBindsBinders binds
 441 collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
 442   where
 443    collect_one (_,binds) acc = collect_binds binds acc
 444
 445 collectHsBindBinders :: HsBindLR idL idR -> [idL]
 446 collectHsBindBinders b = collect_bind b []
 447
 448 collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
 449 collect_bind (PatBind { pat_lhs = p })    acc = collect_lpat p acc
 450 collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
 451 collect_bind (VarBind { var_id = f })     acc = f : acc
 452 collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
 453   = [dp | (_,dp,_,_) <- dbinds] ++ acc
 454         -- ++ foldr collect_bind acc binds
 455         -- I don't think we want the binders from the nested binds
 456         -- The only time we collect binders from a typechecked
 457         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 458
 459 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
 460 collectHsBindsBinders binds = collect_binds binds []
 461
 462 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
 463 collectHsBindListBinders = foldr (collect_bind . unLoc) []
 464
 465 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
 466 collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
 467
 468 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
 469 -- Used exclusively for the bindings of an instance decl which are all FunBinds
 470 collectMethodBinders binds = foldrBag get [] binds
 471   where
 472     get (L _ (FunBind { fun_id = f })) fs = f : fs
 473     get _                              fs = fs
 474        -- Someone else complains about non-FunBinds
 475
 476 ----------------- Statements --------------------------
 477 collectLStmtsBinders :: [LStmtLR idL idR] -> [idL]
 478 collectLStmtsBinders = concatMap collectLStmtBinders
 479
 480 collectStmtsBinders :: [StmtLR idL idR] -> [idL]
 481 collectStmtsBinders = concatMap collectStmtBinders
 482
 483 collectLStmtBinders :: LStmtLR idL idR -> [idL]
 484 collectLStmtBinders = collectStmtBinders . unLoc
 485
 486 collectStmtBinders :: StmtLR idL idR -> [idL]
 487   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 488 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
 489 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 490 collectStmtBinders (ExprStmt _ _ _)     = []
 491 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
 492                                         $ concatMap fst xs
 493 collectStmtBinders (TransformStmt stmts _ _ _)   = collectLStmtsBinders stmts
 494 collectStmtBinders (GroupStmt     stmts _ _ _)   = collectLStmtsBinders stmts
 495 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
 496
 497
 498 ----------------- Patterns --------------------------
 499 collectPatBinders :: LPat a -> [a]
 500 collectPatBinders pat = collect_lpat pat []
 501
 502 collectPatsBinders :: [LPat a] -> [a]
 503 collectPatsBinders pats = foldr collect_lpat [] pats
 504
 505 -------------
 506 collect_lpat :: LPat name -> [name] -> [name]
 507 collect_lpat (L _ pat) bndrs
 508   = go pat
 509   where
 510     go (VarPat var)               = var : bndrs
 511     go (WildPat _)                = bndrs
 512     go (LazyPat pat)              = collect_lpat pat bndrs
 513     go (BangPat pat)              = collect_lpat pat bndrs
 514     go (AsPat (L _ a) pat)        = a : collect_lpat pat bndrs
 515     go (ViewPat _ pat _)          = collect_lpat pat bndrs
 516     go (ParPat  pat)              = collect_lpat pat bndrs
 517
 518     go (ListPat pats _)           = foldr collect_lpat bndrs pats
 519     go (PArrPat pats _)           = foldr collect_lpat bndrs pats
 520     go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats
 521
 522     go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
 523     go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
 524         -- See Note [Dictionary binders in ConPatOut]
 525     go (LitPat _)                 = bndrs
 526     go (NPat _ _ _)               = bndrs
 527     go (NPlusKPat (L _ n) _ _ _)  = n : bndrs
 528
 529     go (SigPatIn pat _)           = collect_lpat pat bndrs
 530     go (SigPatOut pat _)          = collect_lpat pat bndrs
 531     go (QuasiQuotePat _)          = bndrs
 532     go (TypePat _)                = bndrs
 533     go (CoPat _ pat _)            = go pat
 534 \end{code}
 535
 536 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
 537 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 538 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
 539 of a ConPatOut pattern.  For most calls it doesn't matter, because
 540 it's pre-typechecker and there are no ConPatOuts.  But it does matter
 541 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
 542 collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
 543 we want to generate bindings for x,y but not for dictionaries bound by
 544 C.  (The type checker ensures they would not be used.)
 545
 546 Desugaring of arrow case expressions needs these bindings (see DsArrows
 547 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
 548 own pat-binder-collector:
 549
 550 Here's the problem.  Consider
 551
 552 data T a where
 553    C :: Num a => a -> Int -> T a
 554
 555 f ~(C (n+1) m) = (n,m)
 556
 557 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
 558 and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
 559 variables bound by the lazy pattern are n,m, *not* the dictionary d.
 560 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
 561
 562 \begin{code}
 563 hsGroupBinders :: HsGroup Name -> [Name]
 564 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
 565                           hs_instds = inst_decls, hs_fords = foreign_decls })
 566 -- Collect the binders of a Group
 567   =  collectHsValBinders val_decls
 568   ++ hsTyClDeclsBinders tycl_decls inst_decls
 569   ++ hsForeignDeclsBinders foreign_decls
 570
 571 hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
 572 hsForeignDeclsBinders foreign_decls
 573   = [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
 574
 575 hsTyClDeclsBinders :: [Located (TyClDecl Name)] -> [Located (InstDecl Name)] -> [Name]
 576 hsTyClDeclsBinders tycl_decls inst_decls
 577   = [n | d <- instDeclATs inst_decls ++ tycl_decls, L _ n <- hsTyClDeclBinders d]
 578
 579 hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
 580 -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
 581 -- The first one is guaranteed to be the name of the decl. For record fields
 582 -- mentioned in multiple constructors, the SrcLoc will be from the first
 583 -- occurence.  We use the equality to filter out duplicate field names
 584
 585 hsTyClDeclBinders (L _ (TyFamily    {tcdLName = name})) = [name]
 586 hsTyClDeclBinders (L _ (TySynonym   {tcdLName = name})) = [name]
 587 hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name]
 588
 589 hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}))
 590   = cls_name :
 591     concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig n _) <- sigs]
 592
 593 hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons}))
 594   = tc_name : hsConDeclsBinders cons
 595
 596 hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
 597   -- See hsTyClDeclBinders for what this does
 598   -- The function is boringly complicated because of the records
 599   -- And since we only have equality, we have to be a little careful
 600 hsConDeclsBinders cons
 601   = snd (foldl do_one ([], []) cons)
 602   where
 603     do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
 604         = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
 605         where
 606           new_flds = filterOut (\f -> unLoc f `elem` flds_seen)
 607                                (map cd_fld_name flds)
 608
 609     do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
 610         = (flds_seen, lname:acc)
 611 \end{code}
 612
 613
 614 %************************************************************************
 615 %*                                                                      *
 616         Collecting type signatures from patterns
 617 %*                                                                      *
 618 %************************************************************************
 619
 620 \begin{code}
 621 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 622 collectSigTysFromPats pats = foldr collect_sig_lpat [] pats
 623
 624 collectSigTysFromPat :: InPat name -> [LHsType name]
 625 collectSigTysFromPat pat = collect_sig_lpat pat []
 626
 627 collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name]
 628 collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
 629
 630 collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
 631 collect_sig_pat (SigPatIn pat ty)       acc = collect_sig_lpat pat (ty:acc)
 632 collect_sig_pat (TypePat ty)            acc = ty:acc
 633
 634 collect_sig_pat (LazyPat pat)       acc = collect_sig_lpat pat acc
 635 collect_sig_pat (BangPat pat)       acc = collect_sig_lpat pat acc
 636 collect_sig_pat (AsPat _ pat)       acc = collect_sig_lpat pat acc
 637 collect_sig_pat (ParPat  pat)       acc = collect_sig_lpat pat acc
 638 collect_sig_pat (ListPat pats _)    acc = foldr collect_sig_lpat acc pats
 639 collect_sig_pat (PArrPat pats _)    acc = foldr collect_sig_lpat acc pats
 640 collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats
 641 collect_sig_pat (ConPatIn _ ps)     acc = foldr collect_sig_lpat acc (hsConPatArgs ps)
 642 collect_sig_pat _                   acc = acc       -- Literals, vars, wildcard
 643 \end{code}