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