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, coiToHsWrapper, mkHsDictLet,
  23   mkHsOpApp, mkHsDo,
  24
  25   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
  26   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
  27   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
  28
  29   -- Bindigns
  30   mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mk_FunBind,
  31
  32   -- Literals
  33   mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
  34
  35   -- Patterns
  36   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat,
  37   nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat,
  38
  39   -- Types
  40   mkHsAppTy, userHsTyVarBndrs,
  41   nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
  42
  43   -- Stmts
  44   mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt,
  45   mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
  46   emptyRecStmt, mkRecStmt,
  47
  48   -- Template Haskell
  49   unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote,
  50
  51   -- Flags
  52   noRebindableInfo,
  53
  54   -- Collecting binders
  55   collectLocalBinders, collectHsValBinders,
  56   collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
  57   collectPatBinders, collectPatsBinders,
  58   collectLStmtsBinders, collectStmtsBinders,
  59   collectLStmtBinders, collectStmtBinders,
  60   collectSigTysFromPats, collectSigTysFromPat,
  61
  62   hsTyClDeclBinders, hsTyClDeclsBinders, hsConDeclsBinders,
  63   hsForeignDeclsBinders, hsGroupBinders
  64   ) where
  65
  66 import HsDecls
  67 import HsBinds
  68 import HsExpr
  69 import HsPat
  70 import HsTypes
  71 import HsLit
  72
  73 import RdrName
  74 import Var
  75 import Coercion
  76 import Type
  77 import DataCon
  78 import Name
  79 import NameSet
  80 import BasicTypes
  81 import SrcLoc
  82 import FastString
  83 import Outputable
  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 coiToHsWrapper :: CoercionI -> HsWrapper
 139 coiToHsWrapper IdCo     = idHsWrapper
 140 coiToHsWrapper (ACo co) = WpCast co
 141
 142 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 143 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 144         where
 145           matches = mkMatchGroup [mkSimpleMatch pats body]
 146
 147 mkMatchGroup :: [LMatch id] -> MatchGroup id
 148 mkMatchGroup matches = MatchGroup matches placeHolderType
 149
 150 mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
 151 -- Used for the dictionary bindings gotten from TcSimplify
 152 -- We make them recursive to be on the safe side
 153 mkHsDictLet binds expr
 154   | isEmptyLHsBinds binds = expr
 155   | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
 156                           where
 157                             val_binds = ValBindsOut [(Recursive, binds)] []
 158
 159 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 160 -- Used for constructing dictionary terms etc, so no locations
 161 mkHsConApp data_con tys args
 162   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
 163   where
 164     mk_app f a = noLoc (HsApp f (noLoc a))
 165
 166 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
 167 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
 168 mkSimpleHsAlt pat expr
 169   = mkSimpleMatch [pat] expr
 170
 171 -------------------------------
 172 -- These are the bits of syntax that contain rebindable names
 173 -- See RnEnv.lookupSyntaxName
 174
 175 mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id
 176 mkHsFractional :: Rational -> PostTcType -> HsOverLit id
 177 mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
 178 mkHsDo         :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
 179
 180 mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
 181 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
 182
 183 mkTransformStmt   :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
 184 mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 185
 186 mkExprStmt :: LHsExpr idR -> StmtLR idL idR
 187 mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
 188
 189 emptyRecStmt :: StmtLR idL idR
 190 mkRecStmt    :: [LStmtLR idL idR] -> StmtLR idL idR
 191
 192
 193 mkHsIntegral   i       = OverLit (HsIntegral   i)  noRebindableInfo noSyntaxExpr
 194 mkHsFractional f       = OverLit (HsFractional f)  noRebindableInfo noSyntaxExpr
 195 mkHsIsString   s       = OverLit (HsIsString   s)  noRebindableInfo noSyntaxExpr
 196
 197 noRebindableInfo :: Bool
 198 noRebindableInfo = error "noRebindableInfo"     -- Just another placeholder;
 199
 200 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 201
 202 mkNPat lit neg     = NPat lit neg noSyntaxExpr
 203 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 204
 205 mkTransformStmt   stmts usingExpr        = TransformStmt stmts [] usingExpr Nothing
 206 mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr)
 207
 208 mkGroupUsingStmt   :: [LStmt idL]                -> LHsExpr idR -> StmtLR idL idR
 209 mkGroupByStmt      :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
 210 mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 211
 212 mkGroupUsingStmt   stmts usingExpr        = GroupStmt stmts [] Nothing       (Left usingExpr)
 213 mkGroupByStmt      stmts byExpr           = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr)
 214 mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr)
 215
 216 mkExprStmt expr     = ExprStmt expr noSyntaxExpr placeHolderType
 217 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 218
 219 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
 220                        , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
 221                        , recS_bind_fn = noSyntaxExpr
 222                        , recS_rec_rets = [], recS_dicts = emptyLHsBinds }
 223
 224 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
 225
 226 -------------------------------
 227 --- A useful function for building @OpApps@.  The operator is always a
 228 -- variable, and we don't know the fixity yet.
 229 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
 230 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 231
 232 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
 233 mkHsSplice e = HsSplice unqualSplice e
 234
 235 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
 236 mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
 237
 238 unqualSplice :: RdrName
 239 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
 240                 -- A name (uniquified later) to
 241                 -- identify the splice
 242
 243 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
 244 mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
 245
 246 unqualQuasiQuote :: RdrName
 247 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
 248                 -- A name (uniquified later) to
 249                 -- identify the quasi-quote
 250
 251 mkHsString :: String -> HsLit
 252 mkHsString s = HsString (mkFastString s)
 253
 254 -------------
 255 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
 256 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
 257 \end{code}
 258
 259
 260 %************************************************************************
 261 %*                                                                      *
 262         Constructing syntax with no location info
 263 %*                                                                      *
 264 %************************************************************************
 265
 266 \begin{code}
 267 nlHsVar :: id -> LHsExpr id
 268 nlHsVar n = noLoc (HsVar n)
 269
 270 nlHsLit :: HsLit -> LHsExpr id
 271 nlHsLit n = noLoc (HsLit n)
 272
 273 nlVarPat :: id -> LPat id
 274 nlVarPat n = noLoc (VarPat n)
 275
 276 nlLitPat :: HsLit -> LPat id
 277 nlLitPat l = noLoc (LitPat l)
 278
 279 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 280 nlHsApp f x = noLoc (HsApp f x)
 281
 282 nlHsIntLit :: Integer -> LHsExpr id
 283 nlHsIntLit n = noLoc (HsLit (HsInt n))
 284
 285 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 286 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 287
 288 nlHsVarApps :: id -> [id] -> LHsExpr id
 289 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 290                  where
 291                    mk f a = HsApp (noLoc f) (noLoc a)
 292
 293 nlConVarPat :: id -> [id] -> LPat id
 294 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 295
 296 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 297 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 298
 299 nlConPat :: id -> [LPat id] -> LPat id
 300 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 301
 302 nlNullaryConPat :: id -> LPat id
 303 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 304
 305 nlWildConPat :: DataCon -> LPat RdrName
 306 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 307                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 308
 309 nlWildPat :: LPat id
 310 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
 311
 312 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
 313 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
 314
 315 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
 316 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 317
 318 nlHsLam  :: LMatch id -> LHsExpr id
 319 nlHsPar  :: LHsExpr id -> LHsExpr id
 320 nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
 321 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
 322 nlList   :: [LHsExpr id] -> LHsExpr id
 323
 324 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
 325 nlHsPar e               = noLoc (HsPar e)
 326 nlHsIf cond true false  = noLoc (HsIf cond true false)
 327 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
 328 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 329
 330 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
 331 nlHsTyVar :: name                         -> LHsType name
 332 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
 333
 334 nlHsAppTy f t           = noLoc (HsAppTy f t)
 335 nlHsTyVar x             = noLoc (HsTyVar x)
 336 nlHsFunTy a b           = noLoc (HsFunTy a b)
 337
 338 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
 339 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 340 \end{code}
 341
 342 Tuples.  All these functions are *pre-typechecker* because they lack
 343 types on the tuple.
 344
 345 \begin{code}
 346 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
 347 -- Makes a pre-typechecker boxed tuple, deals with 1 case
 348 mkLHsTupleExpr [e] = e
 349 mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map Present es) Boxed
 350
 351 mkLHsVarTuple :: [a] -> LHsExpr a
 352 mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
 353
 354 nlTuplePat :: [LPat id] -> Boxity -> LPat id
 355 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
 356
 357 missingTupArg :: HsTupArg a
 358 missingTupArg = Missing placeHolderType
 359 \end{code}
 360
 361 %************************************************************************
 362 %*                                                                      *
 363                 Bindings; with a location at the top
 364 %*                                                                      *
 365 %************************************************************************
 366
 367 \begin{code}
 368 mkFunBind :: Located id -> [LMatch id] -> HsBind id
 369 -- Not infix, with place holders for coercion and free vars
 370 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
 371                             fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
 372                             fun_tick = Nothing }
 373
 374
 375 mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
 376 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 377
 378 mkVarBind :: id -> LHsExpr id -> LHsBind id
 379 mkVarBind var rhs = L (getLoc rhs) $
 380                     VarBind { var_id = var, var_rhs = rhs, var_inline = False }
 381
 382 ------------
 383 mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
 384                 -> LHsExpr id -> LHsBind id
 385
 386 mk_easy_FunBind loc fun pats expr
 387   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 388
 389 ------------
 390 mk_FunBind :: SrcSpan -> id
 391            -> [([LPat id], LHsExpr id)]
 392            -> LHsBind id
 393
 394 mk_FunBind _   _   [] = panic "TcGenDeriv:mk_FunBind"
 395 mk_FunBind loc fun pats_and_exprs
 396   = L loc $ mkFunBind (L loc fun) matches
 397   where
 398     matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
 399
 400 ------------
 401 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 402 mkMatch pats expr binds
 403   = noLoc (Match (map paren pats) Nothing
 404                  (GRHSs (unguardedRHS expr) binds))
 405   where
 406     paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
 407                      | otherwise          = lp
 408 \end{code}
 409
 410
 411 %************************************************************************
 412 %*                                                                      *
 413         Collecting binders
 414 %*                                                                      *
 415 %************************************************************************
 416
 417 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
 418
 419 ...
 420 where
 421   (x, y) = ...
 422   f i j  = ...
 423   [a, b] = ...
 424
 425 it should return [x, y, f, a, b] (remember, order important).
 426
 427 Note [Collect binders only after renaming]
 428 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 429 These functions should only be used on HsSyn *after* the renamer,
 430 to reuturn a [Name] or [Id].  Before renaming the record punning
 431 and wild-card mechanism makes it hard to know what is bound.
 432 So these functions should not be applied to (HsSyn RdrName)
 433
 434 \begin{code}
 435 ----------------- Bindings --------------------------
 436 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
 437 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 438 collectLocalBinders (HsIPBinds _)   = []
 439 collectLocalBinders EmptyLocalBinds = []
 440
 441 collectHsValBinders :: HsValBindsLR idL idR -> [idL]
 442 collectHsValBinders (ValBindsIn  binds _) = collectHsBindsBinders binds
 443 collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
 444   where
 445    collect_one (_,binds) acc = collect_binds binds acc
 446
 447 collectHsBindBinders :: HsBindLR idL idR -> [idL]
 448 collectHsBindBinders b = collect_bind b []
 449
 450 collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
 451 collect_bind (PatBind { pat_lhs = p })    acc = collect_lpat p acc
 452 collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
 453 collect_bind (VarBind { var_id = f })     acc = f : acc
 454 collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
 455   = [dp | (_,dp,_,_) <- dbinds] ++ acc
 456         -- ++ foldr collect_bind acc binds
 457         -- I don't think we want the binders from the nested binds
 458         -- The only time we collect binders from a typechecked
 459         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 460
 461 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
 462 collectHsBindsBinders binds = collect_binds binds []
 463
 464 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
 465 collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
 466
 467 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
 468 -- Used exclusively for the bindings of an instance decl which are all FunBinds
 469 collectMethodBinders binds = foldrBag get [] binds
 470   where
 471     get (L _ (FunBind { fun_id = f })) fs = f : fs
 472     get _                              fs = fs
 473        -- Someone else complains about non-FunBinds
 474
 475 ----------------- Statements --------------------------
 476 collectLStmtsBinders :: [LStmtLR idL idR] -> [idL]
 477 collectLStmtsBinders = concatMap collectLStmtBinders
 478
 479 collectStmtsBinders :: [StmtLR idL idR] -> [idL]
 480 collectStmtsBinders = concatMap collectStmtBinders
 481
 482 collectLStmtBinders :: LStmtLR idL idR -> [idL]
 483 collectLStmtBinders = collectStmtBinders . unLoc
 484
 485 collectStmtBinders :: StmtLR idL idR -> [idL]
 486   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 487 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
 488 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 489 collectStmtBinders (ExprStmt _ _ _)     = []
 490 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
 491                                         $ concatMap fst xs
 492 collectStmtBinders (TransformStmt stmts _ _ _)   = collectLStmtsBinders stmts
 493 collectStmtBinders (GroupStmt     stmts _ _ _)   = collectLStmtsBinders stmts
 494 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
 495
 496
 497 ----------------- Patterns --------------------------
 498 collectPatBinders :: LPat a -> [a]
 499 collectPatBinders pat = collect_lpat pat []
 500
 501 collectPatsBinders :: [LPat a] -> [a]
 502 collectPatsBinders pats = foldr collect_lpat [] pats
 503
 504 -------------
 505 collect_lpat :: LPat name -> [name] -> [name]
 506 collect_lpat (L _ pat) bndrs
 507   = go pat
 508   where
 509     go (VarPat var)               = var : bndrs
 510     go (VarPatOut var bs)         = var : collect_binds bs 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}