compiler/hsSyn/HsUtils.lhs

   1 %
   2 % (c) The University of Glasgow, 1992-2006
   3 %
   4
   5 Here we collect a variety of helper functions that construct or
   6 analyse HsSyn.  All these functions deal with generic HsSyn; functions
   7 which deal with the intantiated versions are located elsewhere:
   8
   9    Parameterised by     Module
  10    ----------------     -------------
  11    RdrName              parser/RdrHsSyn
  12    Name                 rename/RnHsSyn
  13    Id                   typecheck/TcHsSyn
  14
  15 \begin{code}
  16 module HsUtils where
  17
  18 #include "HsVersions.h"
  19
  20 import HsBinds
  21 import HsExpr
  22 import HsPat
  23 import HsTypes
  24 import HsLit
  25
  26 import RdrName
  27 import Var
  28 import Coercion
  29 import Type
  30 import DataCon
  31 import Name
  32 import BasicTypes
  33 import SrcLoc
  34 import FastString
  35 import Outputable
  36 import Util
  37 import Bag
  38 \end{code}
  39
  40
  41 %************************************************************************
  42 %*                                                                      *
  43         Some useful helpers for constructing syntax
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 These functions attempt to construct a not-completely-useless SrcSpan
  48 from their components, compared with the nl* functions below which
  49 just attach noSrcSpan to everything.
  50
  51 \begin{code}
  52 mkHsPar :: LHsExpr id -> LHsExpr id
  53 mkHsPar e = L (getLoc e) (HsPar e)
  54
  55 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
  56 mkSimpleMatch pats rhs
  57   = L loc $
  58     Match pats Nothing (unguardedGRHSs rhs)
  59   where
  60     loc = case pats of
  61                 []      -> getLoc rhs
  62                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
  63
  64 unguardedGRHSs :: LHsExpr id -> GRHSs id
  65 unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
  66
  67 unguardedRHS :: LHsExpr id -> [LGRHS id]
  68 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
  69
  70 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
  71 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
  72
  73 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
  74 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
  75
  76 nlHsTyApp :: name -> [Type] -> LHsExpr name
  77 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
  78
  79 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
  80 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
  81
  82 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
  83 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
  84                  | otherwise           = HsWrap co_fn e
  85
  86 mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
  87 mkHsWrapCoI IdCo     e = e
  88 mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
  89
  90 coiToHsWrapper :: CoercionI -> HsWrapper
  91 coiToHsWrapper IdCo     = idHsWrapper
  92 coiToHsWrapper (ACo co) = WpCast co
  93
  94 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
  95 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
  96         where
  97           matches = mkMatchGroup [mkSimpleMatch pats body]
  98
  99 mkMatchGroup :: [LMatch id] -> MatchGroup id
 100 mkMatchGroup matches = MatchGroup matches placeHolderType
 101
 102 mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
 103 -- Used for the dictionary bindings gotten from TcSimplify
 104 -- We make them recursive to be on the safe side
 105 mkHsDictLet binds expr
 106   | isEmptyLHsBinds binds = expr
 107   | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
 108                           where
 109                             val_binds = ValBindsOut [(Recursive, binds)] []
 110
 111 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 112 -- Used for constructing dictionary terms etc, so no locations
 113 mkHsConApp data_con tys args
 114   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
 115   where
 116     mk_app f a = noLoc (HsApp f (noLoc a))
 117
 118 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
 119 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
 120 mkSimpleHsAlt pat expr
 121   = mkSimpleMatch [pat] expr
 122
 123 -------------------------------
 124 -- These are the bits of syntax that contain rebindable names
 125 -- See RnEnv.lookupSyntaxName
 126
 127 mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id
 128 mkHsFractional :: Rational -> PostTcType -> HsOverLit id
 129 mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
 130 mkHsDo         :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
 131
 132 mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
 133 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
 134
 135 mkTransformStmt   :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
 136 mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 137
 138 mkGroupUsingStmt   :: [LStmt idL]                -> LHsExpr idR -> StmtLR idL idR
 139 mkGroupByStmt      :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
 140 mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 141
 142 mkExprStmt :: LHsExpr idR -> StmtLR idL idR
 143 mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
 144 mkRecStmt  :: [LStmtLR idL idR] -> StmtLR idL idR
 145
 146
 147 mkHsIntegral   i       = HsIntegral   i  noSyntaxExpr
 148 mkHsFractional f       = HsFractional f  noSyntaxExpr
 149 mkHsIsString   s       = HsIsString   s  noSyntaxExpr
 150 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 151
 152 mkNPat lit neg     = NPat lit neg noSyntaxExpr
 153 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 154
 155 mkTransformStmt   stmts usingExpr        = TransformStmt (stmts, []) usingExpr Nothing
 156 mkTransformByStmt stmts usingExpr byExpr = TransformStmt (stmts, []) usingExpr (Just byExpr)
 157
 158 mkGroupUsingStmt   stmts usingExpr        = GroupStmt (stmts, []) (GroupByNothing usingExpr)
 159 mkGroupByStmt      stmts byExpr           = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr)
 160 mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr)
 161
 162 mkExprStmt expr     = ExprStmt expr noSyntaxExpr placeHolderType
 163 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 164 mkRecStmt stmts     = RecStmt stmts [] [] [] emptyLHsBinds
 165
 166 -------------------------------
 167 --- A useful function for building @OpApps@.  The operator is always a
 168 -- variable, and we don't know the fixity yet.
 169 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
 170 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 171
 172 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
 173 mkHsSplice e = HsSplice unqualSplice e
 174
 175 unqualSplice :: RdrName
 176 unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
 177                 -- A name (uniquified later) to
 178                 -- identify the splice
 179
 180 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
 181 mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualQuasiQuote quoter span quote
 182
 183 unqualQuasiQuote :: RdrName
 184 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS FSLIT("quasiquote"))
 185                 -- A name (uniquified later) to
 186                 -- identify the quasi-quote
 187
 188 mkHsString :: String -> HsLit
 189 mkHsString s = HsString (mkFastString s)
 190
 191 -------------
 192 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
 193 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
 194 \end{code}
 195
 196
 197 %************************************************************************
 198 %*                                                                      *
 199         Constructing syntax with no location info
 200 %*                                                                      *
 201 %************************************************************************
 202
 203 \begin{code}
 204 nlHsVar :: id -> LHsExpr id
 205 nlHsVar n = noLoc (HsVar n)
 206
 207 nlHsLit :: HsLit -> LHsExpr id
 208 nlHsLit n = noLoc (HsLit n)
 209
 210 nlVarPat :: id -> LPat id
 211 nlVarPat n = noLoc (VarPat n)
 212
 213 nlLitPat :: HsLit -> LPat id
 214 nlLitPat l = noLoc (LitPat l)
 215
 216 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 217 nlHsApp f x = noLoc (HsApp f x)
 218
 219 nlHsIntLit :: Integer -> LHsExpr id
 220 nlHsIntLit n = noLoc (HsLit (HsInt n))
 221
 222 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 223 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 224
 225 nlHsVarApps :: id -> [id] -> LHsExpr id
 226 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
 227                  where
 228                    mk f a = HsApp (noLoc f) (noLoc a)
 229
 230 nlConVarPat :: id -> [id] -> LPat id
 231 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 232
 233 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
 234 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
 235
 236 nlConPat :: id -> [LPat id] -> LPat id
 237 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
 238
 239 nlNullaryConPat :: id -> LPat id
 240 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 241
 242 nlWildConPat :: DataCon -> LPat RdrName
 243 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 244                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 245
 246 nlTuplePat :: [LPat id] -> Boxity -> LPat id
 247 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
 248
 249 nlWildPat :: LPat id
 250 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
 251
 252 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
 253 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
 254
 255 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
 256 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 257
 258 nlHsLam  :: LMatch id -> LHsExpr id
 259 nlHsPar  :: LHsExpr id -> LHsExpr id
 260 nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
 261 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
 262 nlTuple  :: [LHsExpr id] -> Boxity -> LHsExpr id
 263 nlList   :: [LHsExpr id] -> LHsExpr id
 264
 265 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
 266 nlHsPar e               = noLoc (HsPar e)
 267 nlHsIf cond true false  = noLoc (HsIf cond true false)
 268 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
 269 nlTuple exprs box       = noLoc (ExplicitTuple exprs box)
 270 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
 271
 272 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
 273 nlHsTyVar :: name                         -> LHsType name
 274 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
 275
 276 nlHsAppTy f t           = noLoc (HsAppTy f t)
 277 nlHsTyVar x             = noLoc (HsTyVar x)
 278 nlHsFunTy a b           = noLoc (HsFunTy a b)
 279
 280 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
 281 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 282 \end{code}
 283
 284
 285
 286 %************************************************************************
 287 %*                                                                      *
 288                 Bindings; with a location at the top
 289 %*                                                                      *
 290 %************************************************************************
 291
 292 \begin{code}
 293 mkFunBind :: Located id -> [LMatch id] -> HsBind id
 294 -- Not infix, with place holders for coercion and free vars
 295 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
 296                             fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
 297                             fun_tick = Nothing }
 298
 299
 300 mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
 301 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 302
 303 ------------
 304 mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
 305                 -> LHsExpr id -> LHsBind id
 306
 307 mk_easy_FunBind loc fun pats expr
 308   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 309
 310 ------------
 311 mk_FunBind :: SrcSpan -> id
 312            -> [([LPat id], LHsExpr id)]
 313            -> LHsBind id
 314
 315 mk_FunBind _   _   [] = panic "TcGenDeriv:mk_FunBind"
 316 mk_FunBind loc fun pats_and_exprs
 317   = L loc $ mkFunBind (L loc fun) matches
 318   where
 319     matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
 320
 321 ------------
 322 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 323 mkMatch pats expr binds
 324   = noLoc (Match (map paren pats) Nothing
 325                  (GRHSs (unguardedRHS expr) binds))
 326   where
 327     paren p = case p of
 328                 L _ (VarPat _) -> p
 329                 L l _          -> L l (ParPat p)
 330 \end{code}
 331
 332
 333 %************************************************************************
 334 %*                                                                      *
 335         Collecting binders from HsBindGroups and HsBinds
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
 340
 341 ...
 342 where
 343   (x, y) = ...
 344   f i j  = ...
 345   [a, b] = ...
 346
 347 it should return [x, y, f, a, b] (remember, order important).
 348
 349 \begin{code}
 350 collectLocalBinders :: HsLocalBindsLR idL idR -> [Located idL]
 351 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 352 collectLocalBinders (HsIPBinds _)   = []
 353 collectLocalBinders EmptyLocalBinds = []
 354
 355 collectHsValBinders :: HsValBindsLR idL idR -> [Located idL]
 356 collectHsValBinders (ValBindsIn  binds _) = collectHsBindLocatedBinders binds
 357 collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
 358   where
 359    collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
 360
 361 collectAcc :: HsBindLR idL idR -> [Located idL] -> [Located idL]
 362 collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
 363 collectAcc (FunBind { fun_id = f })  acc    = f : acc
 364 collectAcc (VarBind { var_id = f })  acc    = noLoc f : acc
 365 collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
 366   = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
 367         -- ++ foldr collectAcc acc binds
 368         -- I don't think we want the binders from the nested binds
 369         -- The only time we collect binders from a typechecked
 370         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 371
 372 collectHsBindBinders :: LHsBindsLR idL idR -> [idL]
 373 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 374
 375 collectHsBindLocatedBinders :: LHsBindsLR idL idR -> [Located idL]
 376 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 377 \end{code}
 378
 379
 380 %************************************************************************
 381 %*                                                                      *
 382         Getting binders from statements
 383 %*                                                                      *
 384 %************************************************************************
 385
 386 \begin{code}
 387 collectLStmtsBinders :: [LStmtLR idL idR] -> [Located idL]
 388 collectLStmtsBinders = concatMap collectLStmtBinders
 389
 390 collectStmtsBinders :: [StmtLR idL idR] -> [Located idL]
 391 collectStmtsBinders = concatMap collectStmtBinders
 392
 393 collectLStmtBinders :: LStmtLR idL idR -> [Located idL]
 394 collectLStmtBinders = collectStmtBinders . unLoc
 395
 396 collectStmtBinders :: StmtLR idL idR -> [Located idL]
 397   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 398 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 399 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 400 collectStmtBinders (ExprStmt _ _ _)     = []
 401 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
 402                                         $ concatMap fst xs
 403 collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts
 404 collectStmtBinders (GroupStmt (stmts, _) _)     = collectLStmtsBinders stmts
 405 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
 406 \end{code}
 407
 408
 409 %************************************************************************
 410 %*                                                                      *
 411 %*      Gathering stuff out of patterns
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 This function @collectPatBinders@ works with the ``collectBinders''
 416 functions for @HsBinds@, etc.  The order in which the binders are
 417 collected is important; see @HsBinds.lhs@.
 418
 419 It collects the bounds *value* variables in renamed patterns; type variables
 420 are *not* collected.
 421
 422 \begin{code}
 423 collectPatBinders :: LPat a -> [a]
 424 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
 425
 426 collectLocatedPatBinders :: LPat a -> [Located a]
 427 collectLocatedPatBinders pat = collectl pat []
 428
 429 collectPatsBinders :: [LPat a] -> [a]
 430 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
 431
 432 collectLocatedPatsBinders :: [LPat a] -> [Located a]
 433 collectLocatedPatsBinders pats = foldr collectl [] pats
 434
 435 ---------------------
 436 collectl :: LPat name -> [Located name] -> [Located name]
 437 collectl (L l pat) bndrs
 438   = go pat
 439   where
 440     go (VarPat var)               = L l var : bndrs
 441     go (VarPatOut var bs)         = L l var : collectHsBindLocatedBinders bs
 442                                     ++ bndrs
 443     go (WildPat _)                = bndrs
 444     go (LazyPat pat)              = collectl pat bndrs
 445     go (BangPat pat)              = collectl pat bndrs
 446     go (AsPat a pat)              = a : collectl pat bndrs
 447     go (ViewPat _ pat _)          = collectl pat bndrs
 448     go (ParPat  pat)              = collectl pat bndrs
 449
 450     go (ListPat pats _)           = foldr collectl bndrs pats
 451     go (PArrPat pats _)           = foldr collectl bndrs pats
 452     go (TuplePat pats _ _)        = foldr collectl bndrs pats
 453
 454     go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)
 455     go (ConPatOut {pat_args=ps})  = foldr collectl bndrs (hsConPatArgs ps)
 456         -- See Note [Dictionary binders in ConPatOut]
 457     go (LitPat _)                 = bndrs
 458     go (NPat _ _ _)               = bndrs
 459     go (NPlusKPat n _ _ _)        = n : bndrs
 460
 461     go (SigPatIn pat _)           = collectl pat bndrs
 462     go (SigPatOut pat _)          = collectl pat bndrs
 463     go (QuasiQuotePat _)          = bndrs
 464     go (TypePat _)                = bndrs
 465     go (CoPat _ pat _)            = collectl (noLoc pat) bndrs
 466 \end{code}
 467
 468 Note [Dictionary binders in ConPatOut]
 469 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 470 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
 471 of a ConPatOut pattern.  For most calls it doesn't matter, because
 472 it's pre-typechecker and there are no ConPatOuts.  But it does matter
 473 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
 474 collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
 475 we want to generate bindings for x,y but not for dictionaries bound by
 476 C.  (The type checker ensures they would not be used.)
 477
 478 Desugaring of arrow case expressions needs these bindings (see DsArrows
 479 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
 480 own pat-binder-collector:
 481
 482 Here's the problem.  Consider
 483
 484 data T a where
 485    C :: Num a => a -> Int -> T a
 486
 487 f ~(C (n+1) m) = (n,m)
 488
 489 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
 490 and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
 491 variables bound by the lazy pattern are n,m, *not* the dictionary d.
 492 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
 493
 494 \begin{code}
 495 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 496 collectSigTysFromPats pats = foldr collect_lpat [] pats
 497
 498 collectSigTysFromPat :: InPat name -> [LHsType name]
 499 collectSigTysFromPat pat = collect_lpat pat []
 500
 501 collect_lpat :: InPat name -> [LHsType name] -> [LHsType name]
 502 collect_lpat pat acc = collect_pat (unLoc pat) acc
 503
 504 collect_pat :: Pat name -> [LHsType name] -> [LHsType name]
 505 collect_pat (SigPatIn pat ty)   acc = collect_lpat pat (ty:acc)
 506 collect_pat (TypePat ty)        acc = ty:acc
 507
 508 collect_pat (LazyPat pat)       acc = collect_lpat pat acc
 509 collect_pat (BangPat pat)       acc = collect_lpat pat acc
 510 collect_pat (AsPat _ pat)       acc = collect_lpat pat acc
 511 collect_pat (ParPat  pat)       acc = collect_lpat pat acc
 512 collect_pat (ListPat pats _)    acc = foldr collect_lpat acc pats
 513 collect_pat (PArrPat pats _)    acc = foldr collect_lpat acc pats
 514 collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
 515 collect_pat (ConPatIn _ ps)     acc = foldr collect_lpat acc (hsConPatArgs ps)
 516 collect_pat _                   acc = acc       -- Literals, vars, wildcard
 517 \end{code}