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