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   ) where
  62
  63 import HsBinds
  64 import HsExpr
  65 import HsPat
  66 import HsTypes
  67 import HsLit
  68
  69 import RdrName
  70 import Var
  71 import Coercion
  72 import Type
  73 import DataCon
  74 import Name
  75 import NameSet
  76 import BasicTypes
  77 import SrcLoc
  78 import FastString
  79 import Outputable
  80 import Util
  81 import Bag
  82 \end{code}
  83
  84
  85 %************************************************************************
  86 %*                                                                      *
  87         Some useful helpers for constructing syntax
  88 %*                                                                      *
  89 %************************************************************************
  90
  91 These functions attempt to construct a not-completely-useless SrcSpan
  92 from their components, compared with the nl* functions below which
  93 just attach noSrcSpan to everything.
  94
  95 \begin{code}
  96 mkHsPar :: LHsExpr id -> LHsExpr id
  97 mkHsPar e = L (getLoc e) (HsPar e)
  98
  99 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
 100 mkSimpleMatch pats rhs
 101   = L loc $
 102     Match pats Nothing (unguardedGRHSs rhs)
 103   where
 104     loc = case pats of
 105                 []      -> getLoc rhs
 106                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
 107
 108 unguardedGRHSs :: LHsExpr id -> GRHSs id
 109 unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
 110
 111 unguardedRHS :: LHsExpr id -> [LGRHS id]
 112 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
 113
 114 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
 115 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
 116
 117 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
 118 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
 119
 120 nlHsTyApp :: name -> [Type] -> LHsExpr name
 121 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
 122
 123 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
 124 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 125
 126 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 127 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
 128                  | otherwise           = HsWrap co_fn e
 129
 130 mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
 131 mkHsWrapCoI IdCo     e = e
 132 mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
 133
 134 coiToHsWrapper :: CoercionI -> HsWrapper
 135 coiToHsWrapper IdCo     = idHsWrapper
 136 coiToHsWrapper (ACo co) = WpCast co
 137
 138 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 139 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 140         where
 141           matches = mkMatchGroup [mkSimpleMatch pats body]
 142
 143 mkMatchGroup :: [LMatch id] -> MatchGroup id
 144 mkMatchGroup matches = MatchGroup matches placeHolderType
 145
 146 mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
 147 -- Used for the dictionary bindings gotten from TcSimplify
 148 -- We make them recursive to be on the safe side
 149 mkHsDictLet binds expr
 150   | isEmptyLHsBinds binds = expr
 151   | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
 152                           where
 153                             val_binds = ValBindsOut [(Recursive, binds)] []
 154
 155 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 156 -- Used for constructing dictionary terms etc, so no locations
 157 mkHsConApp data_con tys args
 158   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
 159   where
 160     mk_app f a = noLoc (HsApp f (noLoc a))
 161
 162 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
 163 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
 164 mkSimpleHsAlt pat expr
 165   = mkSimpleMatch [pat] expr
 166
 167 -------------------------------
 168 -- These are the bits of syntax that contain rebindable names
 169 -- See RnEnv.lookupSyntaxName
 170
 171 mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id
 172 mkHsFractional :: Rational -> PostTcType -> HsOverLit id
 173 mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
 174 mkHsDo         :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
 175
 176 mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
 177 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
 178
 179 mkTransformStmt   :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
 180 mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 181
 182 mkExprStmt :: LHsExpr idR -> StmtLR idL idR
 183 mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
 184
 185 emptyRecStmt :: StmtLR idL idR
 186 mkRecStmt    :: [LStmtLR idL idR] -> StmtLR idL idR
 187
 188
 189 mkHsIntegral   i       = OverLit (HsIntegral   i)  noRebindableInfo noSyntaxExpr
 190 mkHsFractional f       = OverLit (HsFractional f)  noRebindableInfo noSyntaxExpr
 191 mkHsIsString   s       = OverLit (HsIsString   s)  noRebindableInfo noSyntaxExpr
 192
 193 noRebindableInfo :: Bool
 194 noRebindableInfo = error "noRebindableInfo"     -- Just another placeholder;
 195
 196 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 197
 198 mkNPat lit neg     = NPat lit neg noSyntaxExpr
 199 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 200
 201 mkTransformStmt   stmts usingExpr        = TransformStmt stmts [] usingExpr Nothing
 202 mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr)
 203
 204 mkGroupUsingStmt   :: [LStmt idL]                -> LHsExpr idR -> StmtLR idL idR
 205 mkGroupByStmt      :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
 206 mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 207
 208 mkGroupUsingStmt   stmts usingExpr        = GroupStmt stmts [] Nothing       (Left usingExpr)
 209 mkGroupByStmt      stmts byExpr           = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr)
 210 mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr)
 211
 212 mkExprStmt expr     = ExprStmt expr noSyntaxExpr placeHolderType
 213 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 214
 215 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
 216                        , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
 217                        , recS_bind_fn = noSyntaxExpr
 218                        , recS_rec_rets = [], recS_dicts = emptyLHsBinds }
 219
 220 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
 221
 222 -------------------------------
 223 --- A useful function for building @OpApps@.  The operator is always a
 224 -- variable, and we don't know the fixity yet.
 225 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
 226 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 227
 228 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
 229 mkHsSplice e = HsSplice unqualSplice e
 230
 231 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
 232 mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
 233
 234 unqualSplice :: RdrName
 235 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
 236                 -- A name (uniquified later) to
 237                 -- identify the splice
 238
 239 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
 240 mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
 241
 242 unqualQuasiQuote :: RdrName
 243 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
 244                 -- A name (uniquified later) to
 245                 -- identify the quasi-quote
 246
 247 mkHsString :: String -> HsLit
 248 mkHsString s = HsString (mkFastString s)
 249
 250 -------------
 251 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
 252 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
 253 \end{code}
 254
 255
 256 %************************************************************************
 257 %*                                                                      *
 258         Constructing syntax with no location info
 259 %*                                                                      *
 260 %************************************************************************
 261
 262 \begin{code}
 263 nlHsVar :: id -> LHsExpr id
 264 nlHsVar n = noLoc (HsVar n)
 265
 266 nlHsLit :: HsLit -> LHsExpr id
 267 nlHsLit n = noLoc (HsLit n)
 268
 269 nlVarPat :: id -> LPat id
 270 nlVarPat n = noLoc (VarPat n)
 271
 272 nlLitPat :: HsLit -> LPat id
 273 nlLitPat l = noLoc (LitPat l)
 274
 275 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 276 nlHsApp f x = noLoc (HsApp f x)
 277
 278 nlHsIntLit :: Integer -> LHsExpr id
 279 nlHsIntLit n = noLoc (HsLit (HsInt n))
 280
 281 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 282 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 283
 284 nlHsVarApps :: id -> [id] -> LHsExpr id
 285 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 286                  where
 287                    mk f a = HsApp (noLoc f) (noLoc a)
 288
 289 nlConVarPat :: id -> [id] -> LPat id
 290 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 291
 292 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 293 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 294
 295 nlConPat :: id -> [LPat id] -> LPat id
 296 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 297
 298 nlNullaryConPat :: id -> LPat id
 299 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 300
 301 nlWildConPat :: DataCon -> LPat RdrName
 302 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 303                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 304
 305 nlWildPat :: LPat id
 306 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
 307
 308 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
 309 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
 310
 311 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
 312 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 313
 314 nlHsLam  :: LMatch id -> LHsExpr id
 315 nlHsPar  :: LHsExpr id -> LHsExpr id
 316 nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
 317 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
 318 nlList   :: [LHsExpr id] -> LHsExpr id
 319
 320 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
 321 nlHsPar e               = noLoc (HsPar e)
 322 nlHsIf cond true false  = noLoc (HsIf cond true false)
 323 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
 324 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 325
 326 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
 327 nlHsTyVar :: name                         -> LHsType name
 328 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
 329
 330 nlHsAppTy f t           = noLoc (HsAppTy f t)
 331 nlHsTyVar x             = noLoc (HsTyVar x)
 332 nlHsFunTy a b           = noLoc (HsFunTy a b)
 333
 334 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
 335 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 336 \end{code}
 337
 338 Tuples.  All these functions are *pre-typechecker* because they lack
 339 types on the tuple.
 340
 341 \begin{code}
 342 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
 343 -- Makes a pre-typechecker boxed tuple, deals with 1 case
 344 mkLHsTupleExpr [e] = e
 345 mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map Present es) Boxed
 346
 347 mkLHsVarTuple :: [a] -> LHsExpr a
 348 mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
 349
 350 nlTuplePat :: [LPat id] -> Boxity -> LPat id
 351 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
 352
 353 missingTupArg :: HsTupArg a
 354 missingTupArg = Missing placeHolderType
 355 \end{code}
 356
 357 %************************************************************************
 358 %*                                                                      *
 359                 Bindings; with a location at the top
 360 %*                                                                      *
 361 %************************************************************************
 362
 363 \begin{code}
 364 mkFunBind :: Located id -> [LMatch id] -> HsBind id
 365 -- Not infix, with place holders for coercion and free vars
 366 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
 367                             fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
 368                             fun_tick = Nothing }
 369
 370
 371 mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
 372 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 373
 374 mkVarBind :: id -> LHsExpr id -> LHsBind id
 375 mkVarBind var rhs = L (getLoc rhs) $
 376                     VarBind { var_id = var, var_rhs = rhs, var_inline = False }
 377
 378 ------------
 379 mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
 380                 -> LHsExpr id -> LHsBind id
 381
 382 mk_easy_FunBind loc fun pats expr
 383   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 384
 385 ------------
 386 mk_FunBind :: SrcSpan -> id
 387            -> [([LPat id], LHsExpr id)]
 388            -> LHsBind id
 389
 390 mk_FunBind _   _   [] = panic "TcGenDeriv:mk_FunBind"
 391 mk_FunBind loc fun pats_and_exprs
 392   = L loc $ mkFunBind (L loc fun) matches
 393   where
 394     matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
 395
 396 ------------
 397 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 398 mkMatch pats expr binds
 399   = noLoc (Match (map paren pats) Nothing
 400                  (GRHSs (unguardedRHS expr) binds))
 401   where
 402     paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
 403                      | otherwise          = lp
 404 \end{code}
 405
 406
 407 %************************************************************************
 408 %*                                                                      *
 409         Collecting binders
 410 %*                                                                      *
 411 %************************************************************************
 412
 413 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
 414
 415 ...
 416 where
 417   (x, y) = ...
 418   f i j  = ...
 419   [a, b] = ...
 420
 421 it should return [x, y, f, a, b] (remember, order important).
 422
 423 Note [Collect binders only after renaming]
 424 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 425 These functions should only be used on HsSyn *after* the renamer,
 426 to reuturn a [Name] or [Id].  Before renaming the record punning
 427 and wild-card mechanism makes it hard to know what is bound.
 428 So these functions should not be applied to (HsSyn RdrName)
 429
 430 \begin{code}
 431 ----------------- Bindings --------------------------
 432 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
 433 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 434 collectLocalBinders (HsIPBinds _)   = []
 435 collectLocalBinders EmptyLocalBinds = []
 436
 437 collectHsValBinders :: HsValBindsLR idL idR -> [idL]
 438 collectHsValBinders (ValBindsIn  binds _) = collectHsBindsBinders binds
 439 collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
 440   where
 441    collect_one (_,binds) acc = collect_binds binds acc
 442
 443 collectHsBindBinders :: HsBindLR idL idR -> [idL]
 444 collectHsBindBinders b = collect_bind b []
 445
 446 collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
 447 collect_bind (PatBind { pat_lhs = p })    acc = collect_lpat p acc
 448 collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
 449 collect_bind (VarBind { var_id = f })     acc = f : acc
 450 collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
 451   = [dp | (_,dp,_,_) <- dbinds] ++ acc
 452         -- ++ foldr collect_bind acc binds
 453         -- I don't think we want the binders from the nested binds
 454         -- The only time we collect binders from a typechecked
 455         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 456
 457 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
 458 collectHsBindsBinders binds = collect_binds binds []
 459
 460 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
 461 collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
 462
 463 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
 464 -- Used exclusively for the bindings of an instance decl which are all FunBinds
 465 collectMethodBinders binds = foldrBag get [] binds
 466   where
 467     get (L _ (FunBind { fun_id = f })) fs = f : fs
 468     get _                              fs = fs
 469        -- Someone else complains about non-FunBinds
 470
 471 ----------------- Statements --------------------------
 472 collectLStmtsBinders :: [LStmtLR idL idR] -> [idL]
 473 collectLStmtsBinders = concatMap collectLStmtBinders
 474
 475 collectStmtsBinders :: [StmtLR idL idR] -> [idL]
 476 collectStmtsBinders = concatMap collectStmtBinders
 477
 478 collectLStmtBinders :: LStmtLR idL idR -> [idL]
 479 collectLStmtBinders = collectStmtBinders . unLoc
 480
 481 collectStmtBinders :: StmtLR idL idR -> [idL]
 482   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 483 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
 484 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 485 collectStmtBinders (ExprStmt _ _ _)     = []
 486 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
 487                                         $ concatMap fst xs
 488 collectStmtBinders (TransformStmt stmts _ _ _)   = collectLStmtsBinders stmts
 489 collectStmtBinders (GroupStmt     stmts _ _ _)   = collectLStmtsBinders stmts
 490 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
 491
 492
 493 ----------------- Patterns --------------------------
 494 collectPatBinders :: LPat a -> [a]
 495 collectPatBinders pat = collect_lpat pat []
 496
 497 collectPatsBinders :: [LPat a] -> [a]
 498 collectPatsBinders pats = foldr collect_lpat [] pats
 499
 500 -------------
 501 collect_lpat :: LPat name -> [name] -> [name]
 502 collect_lpat (L _ pat) bndrs
 503   = go pat
 504   where
 505     go (VarPat var)               = var : bndrs
 506     go (VarPatOut var bs)         = var : collect_binds bs bndrs
 507     go (WildPat _)                = bndrs
 508     go (LazyPat pat)              = collect_lpat pat bndrs
 509     go (BangPat pat)              = collect_lpat pat bndrs
 510     go (AsPat (L _ a) pat)        = a : collect_lpat pat bndrs
 511     go (ViewPat _ pat _)          = collect_lpat pat bndrs
 512     go (ParPat  pat)              = collect_lpat pat bndrs
 513
 514     go (ListPat pats _)           = foldr collect_lpat bndrs pats
 515     go (PArrPat pats _)           = foldr collect_lpat bndrs pats
 516     go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats
 517
 518     go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
 519     go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
 520         -- See Note [Dictionary binders in ConPatOut]
 521     go (LitPat _)                 = bndrs
 522     go (NPat _ _ _)               = bndrs
 523     go (NPlusKPat (L _ n) _ _ _)  = n : bndrs
 524
 525     go (SigPatIn pat _)           = collect_lpat pat bndrs
 526     go (SigPatOut pat _)          = collect_lpat pat bndrs
 527     go (QuasiQuotePat _)          = bndrs
 528     go (TypePat _)                = bndrs
 529     go (CoPat _ pat _)            = go pat
 530 \end{code}
 531
 532 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
 533 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 534 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
 535 of a ConPatOut pattern.  For most calls it doesn't matter, because
 536 it's pre-typechecker and there are no ConPatOuts.  But it does matter
 537 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
 538 collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
 539 we want to generate bindings for x,y but not for dictionaries bound by
 540 C.  (The type checker ensures they would not be used.)
 541
 542 Desugaring of arrow case expressions needs these bindings (see DsArrows
 543 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
 544 own pat-binder-collector:
 545
 546 Here's the problem.  Consider
 547
 548 data T a where
 549    C :: Num a => a -> Int -> T a
 550
 551 f ~(C (n+1) m) = (n,m)
 552
 553 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
 554 and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
 555 variables bound by the lazy pattern are n,m, *not* the dictionary d.
 556 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
 557
 558 %************************************************************************
 559 %*                                                                      *
 560         Collecting type signatures from patterns
 561 %*                                                                      *
 562 %************************************************************************
 563
 564 \begin{code}
 565 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 566 collectSigTysFromPats pats = foldr collect_sig_lpat [] pats
 567
 568 collectSigTysFromPat :: InPat name -> [LHsType name]
 569 collectSigTysFromPat pat = collect_sig_lpat pat []
 570
 571 collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name]
 572 collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
 573
 574 collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
 575 collect_sig_pat (SigPatIn pat ty)       acc = collect_sig_lpat pat (ty:acc)
 576 collect_sig_pat (TypePat ty)            acc = ty:acc
 577
 578 collect_sig_pat (LazyPat pat)       acc = collect_sig_lpat pat acc
 579 collect_sig_pat (BangPat pat)       acc = collect_sig_lpat pat acc
 580 collect_sig_pat (AsPat _ pat)       acc = collect_sig_lpat pat acc
 581 collect_sig_pat (ParPat  pat)       acc = collect_sig_lpat pat acc
 582 collect_sig_pat (ListPat pats _)    acc = foldr collect_sig_lpat acc pats
 583 collect_sig_pat (PArrPat pats _)    acc = foldr collect_sig_lpat acc pats
 584 collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats
 585 collect_sig_pat (ConPatIn _ ps)     acc = foldr collect_sig_lpat acc (hsConPatArgs ps)
 586 collect_sig_pat _                   acc = acc       -- Literals, vars, wildcard
 587 \end{code}