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,
  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 mkNPat lit neg     = NPat lit neg noSyntaxExpr
 209 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 210
 211 mkTransformStmt   stmts usingExpr        = TransformStmt stmts [] usingExpr Nothing
 212 mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr)
 213
 214 mkGroupUsingStmt   :: [LStmt idL]                -> LHsExpr idR -> StmtLR idL idR
 215 mkGroupByStmt      :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
 216 mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 217
 218 mkGroupUsingStmt   stmts usingExpr        = GroupStmt stmts [] Nothing       (Left usingExpr)
 219 mkGroupByStmt      stmts byExpr           = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr)
 220 mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr)
 221
 222 mkExprStmt expr     = ExprStmt expr noSyntaxExpr placeHolderType
 223 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 224
 225 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
 226                        , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
 227                        , recS_bind_fn = noSyntaxExpr
 228                        , recS_rec_rets = [], recS_dicts = emptyTcEvBinds }
 229
 230 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
 231
 232 -------------------------------
 233 --- A useful function for building @OpApps@.  The operator is always a
 234 -- variable, and we don't know the fixity yet.
 235 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
 236 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 237
 238 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
 239 mkHsSplice e = HsSplice unqualSplice e
 240
 241 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
 242 mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
 243
 244 unqualSplice :: RdrName
 245 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
 246                 -- A name (uniquified later) to
 247                 -- identify the splice
 248
 249 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
 250 mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
 251
 252 unqualQuasiQuote :: RdrName
 253 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
 254                 -- A name (uniquified later) to
 255                 -- identify the quasi-quote
 256
 257 mkHsString :: String -> HsLit
 258 mkHsString s = HsString (mkFastString s)
 259
 260 -------------
 261 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
 262 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
 263 \end{code}
 264
 265
 266 %************************************************************************
 267 %*                                                                      *
 268         Constructing syntax with no location info
 269 %*                                                                      *
 270 %************************************************************************
 271
 272 \begin{code}
 273 nlHsVar :: id -> LHsExpr id
 274 nlHsVar n = noLoc (HsVar n)
 275
 276 nlHsLit :: HsLit -> LHsExpr id
 277 nlHsLit n = noLoc (HsLit n)
 278
 279 nlVarPat :: id -> LPat id
 280 nlVarPat n = noLoc (VarPat n)
 281
 282 nlLitPat :: HsLit -> LPat id
 283 nlLitPat l = noLoc (LitPat l)
 284
 285 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 286 nlHsApp f x = noLoc (HsApp f x)
 287
 288 nlHsIntLit :: Integer -> LHsExpr id
 289 nlHsIntLit n = noLoc (HsLit (HsInt n))
 290
 291 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 292 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 293
 294 nlHsVarApps :: id -> [id] -> LHsExpr id
 295 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 296                  where
 297                    mk f a = HsApp (noLoc f) (noLoc a)
 298
 299 nlConVarPat :: id -> [id] -> LPat id
 300 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 301
 302 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 303 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 304
 305 nlConPat :: id -> [LPat id] -> LPat id
 306 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 307
 308 nlNullaryConPat :: id -> LPat id
 309 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 310
 311 nlWildConPat :: DataCon -> LPat RdrName
 312 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 313                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 314
 315 nlWildPat :: LPat id
 316 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
 317
 318 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
 319 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
 320
 321 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
 322 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 323
 324 nlHsLam  :: LMatch id -> LHsExpr id
 325 nlHsPar  :: LHsExpr id -> LHsExpr id
 326 nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
 327 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
 328 nlList   :: [LHsExpr id] -> LHsExpr id
 329
 330 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
 331 nlHsPar e               = noLoc (HsPar e)
 332 nlHsIf cond true false  = noLoc (HsIf cond true false)
 333 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
 334 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 335
 336 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
 337 nlHsTyVar :: name                         -> LHsType name
 338 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
 339
 340 nlHsAppTy f t           = noLoc (HsAppTy f t)
 341 nlHsTyVar x             = noLoc (HsTyVar x)
 342 nlHsFunTy a b           = noLoc (HsFunTy a b)
 343
 344 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
 345 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 346 \end{code}
 347
 348 Tuples.  All these functions are *pre-typechecker* because they lack
 349 types on the tuple.
 350
 351 \begin{code}
 352 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
 353 -- Makes a pre-typechecker boxed tuple, deals with 1 case
 354 mkLHsTupleExpr [e] = e
 355 mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map Present es) Boxed
 356
 357 mkLHsVarTuple :: [a] -> LHsExpr a
 358 mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
 359
 360 nlTuplePat :: [LPat id] -> Boxity -> LPat id
 361 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
 362
 363 missingTupArg :: HsTupArg a
 364 missingTupArg = Missing placeHolderType
 365 \end{code}
 366
 367 %************************************************************************
 368 %*                                                                      *
 369                 Bindings; with a location at the top
 370 %*                                                                      *
 371 %************************************************************************
 372
 373 \begin{code}
 374 mkFunBind :: Located id -> [LMatch id] -> HsBind id
 375 -- Not infix, with place holders for coercion and free vars
 376 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
 377                             fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
 378                             fun_tick = Nothing }
 379
 380
 381 mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
 382 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 383
 384 mkVarBind :: id -> LHsExpr id -> LHsBind id
 385 mkVarBind var rhs = L (getLoc rhs) $
 386                     VarBind { var_id = var, var_rhs = rhs, var_inline = False }
 387
 388 ------------
 389 mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
 390                 -> LHsExpr id -> LHsBind id
 391
 392 mk_easy_FunBind loc fun pats expr
 393   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 394
 395 ------------
 396 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 397 mkMatch pats expr binds
 398   = noLoc (Match (map paren pats) Nothing
 399                  (GRHSs (unguardedRHS expr) binds))
 400   where
 401     paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
 402                      | otherwise          = lp
 403 \end{code}
 404
 405
 406 %************************************************************************
 407 %*                                                                      *
 408         Collecting binders
 409 %*                                                                      *
 410 %************************************************************************
 411
 412 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
 413
 414 ...
 415 where
 416   (x, y) = ...
 417   f i j  = ...
 418   [a, b] = ...
 419
 420 it should return [x, y, f, a, b] (remember, order important).
 421
 422 Note [Collect binders only after renaming]
 423 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 424 These functions should only be used on HsSyn *after* the renamer,
 425 to return a [Name] or [Id].  Before renaming the record punning
 426 and wild-card mechanism makes it hard to know what is bound.
 427 So these functions should not be applied to (HsSyn RdrName)
 428
 429 \begin{code}
 430 ----------------- Bindings --------------------------
 431 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
 432 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 433 collectLocalBinders (HsIPBinds _)   = []
 434 collectLocalBinders EmptyLocalBinds = []
 435
 436 collectHsValBinders :: HsValBindsLR idL idR -> [idL]
 437 collectHsValBinders (ValBindsIn  binds _) = collectHsBindsBinders binds
 438 collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
 439   where
 440    collect_one (_,binds) acc = collect_binds binds acc
 441
 442 collectHsBindBinders :: HsBindLR idL idR -> [idL]
 443 collectHsBindBinders b = collect_bind b []
 444
 445 collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
 446 collect_bind (PatBind { pat_lhs = p })    acc = collect_lpat p acc
 447 collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
 448 collect_bind (VarBind { var_id = f })     acc = f : acc
 449 collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
 450   = [dp | (_,dp,_,_) <- dbinds] ++ acc
 451         -- ++ foldr collect_bind acc binds
 452         -- I don't think we want the binders from the nested binds
 453         -- The only time we collect binders from a typechecked
 454         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 455
 456 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
 457 collectHsBindsBinders binds = collect_binds binds []
 458
 459 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
 460 collectHsBindListBinders = foldr (collect_bind . unLoc) []
 461
 462 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
 463 collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
 464
 465 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
 466 -- Used exclusively for the bindings of an instance decl which are all FunBinds
 467 collectMethodBinders binds = foldrBag get [] binds
 468   where
 469     get (L _ (FunBind { fun_id = f })) fs = f : fs
 470     get _                              fs = fs
 471        -- Someone else complains about non-FunBinds
 472
 473 ----------------- Statements --------------------------
 474 collectLStmtsBinders :: [LStmtLR idL idR] -> [idL]
 475 collectLStmtsBinders = concatMap collectLStmtBinders
 476
 477 collectStmtsBinders :: [StmtLR idL idR] -> [idL]
 478 collectStmtsBinders = concatMap collectStmtBinders
 479
 480 collectLStmtBinders :: LStmtLR idL idR -> [idL]
 481 collectLStmtBinders = collectStmtBinders . unLoc
 482
 483 collectStmtBinders :: StmtLR idL idR -> [idL]
 484   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 485 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
 486 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 487 collectStmtBinders (ExprStmt _ _ _)     = []
 488 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
 489                                         $ concatMap fst xs
 490 collectStmtBinders (TransformStmt stmts _ _ _)   = collectLStmtsBinders stmts
 491 collectStmtBinders (GroupStmt     stmts _ _ _)   = collectLStmtsBinders stmts
 492 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
 493
 494
 495 ----------------- Patterns --------------------------
 496 collectPatBinders :: LPat a -> [a]
 497 collectPatBinders pat = collect_lpat pat []
 498
 499 collectPatsBinders :: [LPat a] -> [a]
 500 collectPatsBinders pats = foldr collect_lpat [] pats
 501
 502 -------------
 503 collect_lpat :: LPat name -> [name] -> [name]
 504 collect_lpat (L _ pat) bndrs
 505   = go pat
 506   where
 507     go (VarPat var)               = var : bndrs
 508     go (VarPatOut var _)          = var : bndrs
 509         -- See Note [Dictionary binders in ConPatOut]
 510     go (WildPat _)                = bndrs
 511     go (LazyPat pat)              = collect_lpat pat bndrs
 512     go (BangPat pat)              = collect_lpat pat bndrs
 513     go (AsPat (L _ a) pat)        = a : collect_lpat pat bndrs
 514     go (ViewPat _ pat _)          = collect_lpat pat bndrs
 515     go (ParPat  pat)              = collect_lpat pat bndrs
 516
 517     go (ListPat pats _)           = foldr collect_lpat bndrs pats
 518     go (PArrPat pats _)           = foldr collect_lpat bndrs pats
 519     go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats
 520
 521     go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
 522     go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
 523         -- See Note [Dictionary binders in ConPatOut]
 524     go (LitPat _)                 = bndrs
 525     go (NPat _ _ _)               = bndrs
 526     go (NPlusKPat (L _ n) _ _ _)  = n : bndrs
 527
 528     go (SigPatIn pat _)           = collect_lpat pat bndrs
 529     go (SigPatOut pat _)          = collect_lpat pat bndrs
 530     go (QuasiQuotePat _)          = bndrs
 531     go (TypePat _)                = bndrs
 532     go (CoPat _ pat _)            = go pat
 533 \end{code}
 534
 535 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
 536 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 537 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
 538 of a ConPatOut pattern.  For most calls it doesn't matter, because
 539 it's pre-typechecker and there are no ConPatOuts.  But it does matter
 540 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
 541 collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
 542 we want to generate bindings for x,y but not for dictionaries bound by
 543 C.  (The type checker ensures they would not be used.)
 544
 545 Desugaring of arrow case expressions needs these bindings (see DsArrows
 546 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
 547 own pat-binder-collector:
 548
 549 Here's the problem.  Consider
 550
 551 data T a where
 552    C :: Num a => a -> Int -> T a
 553
 554 f ~(C (n+1) m) = (n,m)
 555
 556 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
 557 and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
 558 variables bound by the lazy pattern are n,m, *not* the dictionary d.
 559 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
 560
 561 \begin{code}
 562 hsGroupBinders :: HsGroup Name -> [Name]
 563 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
 564                           hs_instds = inst_decls, hs_fords = foreign_decls })
 565 -- Collect the binders of a Group
 566   =  collectHsValBinders val_decls
 567   ++ hsTyClDeclsBinders tycl_decls inst_decls
 568   ++ hsForeignDeclsBinders foreign_decls
 569
 570 hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
 571 hsForeignDeclsBinders foreign_decls
 572   = [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
 573
 574 hsTyClDeclsBinders :: [Located (TyClDecl Name)] -> [Located (InstDecl Name)] -> [Name]
 575 hsTyClDeclsBinders tycl_decls inst_decls
 576   = [n | d <- instDeclATs inst_decls ++ tycl_decls, L _ n <- hsTyClDeclBinders d]
 577
 578 hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
 579 -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
 580 -- The first one is guaranteed to be the name of the decl. For record fields
 581 -- mentioned in multiple constructors, the SrcLoc will be from the first
 582 -- occurence.  We use the equality to filter out duplicate field names
 583
 584 hsTyClDeclBinders (L _ (TyFamily    {tcdLName = name})) = [name]
 585 hsTyClDeclBinders (L _ (TySynonym   {tcdLName = name})) = [name]
 586 hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name]
 587
 588 hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}))
 589   = cls_name :
 590     concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig n _) <- sigs]
 591
 592 hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons}))
 593   = tc_name : hsConDeclsBinders cons
 594
 595 hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
 596   -- See hsTyClDeclBinders for what this does
 597   -- The function is boringly complicated because of the records
 598   -- And since we only have equality, we have to be a little careful
 599 hsConDeclsBinders cons
 600   = snd (foldl do_one ([], []) cons)
 601   where
 602     do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
 603         = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
 604         where
 605           new_flds = filterOut (\f -> unLoc f `elem` flds_seen)
 606                                (map cd_fld_name flds)
 607
 608     do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
 609         = (flds_seen, lname:acc)
 610 \end{code}
 611
 612
 613 %************************************************************************
 614 %*                                                                      *
 615         Collecting type signatures from patterns
 616 %*                                                                      *
 617 %************************************************************************
 618
 619 \begin{code}
 620 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 621 collectSigTysFromPats pats = foldr collect_sig_lpat [] pats
 622
 623 collectSigTysFromPat :: InPat name -> [LHsType name]
 624 collectSigTysFromPat pat = collect_sig_lpat pat []
 625
 626 collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name]
 627 collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
 628
 629 collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
 630 collect_sig_pat (SigPatIn pat ty)       acc = collect_sig_lpat pat (ty:acc)
 631 collect_sig_pat (TypePat ty)            acc = ty:acc
 632
 633 collect_sig_pat (LazyPat pat)       acc = collect_sig_lpat pat acc
 634 collect_sig_pat (BangPat pat)       acc = collect_sig_lpat pat acc
 635 collect_sig_pat (AsPat _ pat)       acc = collect_sig_lpat pat acc
 636 collect_sig_pat (ParPat  pat)       acc = collect_sig_lpat pat acc
 637 collect_sig_pat (ListPat pats _)    acc = foldr collect_sig_lpat acc pats
 638 collect_sig_pat (PArrPat pats _)    acc = foldr collect_sig_lpat acc pats
 639 collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats
 640 collect_sig_pat (ConPatIn _ ps)     acc = foldr collect_sig_lpat acc (hsConPatArgs ps)
 641 collect_sig_pat _                   acc = acc       -- Literals, vars, wildcard
 642 \end{code}