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