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