HsUtils.lhs 18.5 KB
Newer Older
1
%
2
% (c) The University of Glasgow, 1992-2006
3 4
%

5 6 7 8 9 10 11 12 13
Here we collect a variety of helper functions that construct or
analyse HsSyn.  All these functions deal with generic HsSyn; functions
which deal with the intantiated versions are located elsewhere:

   Parameterised by	Module
   ----------------     -------------
   RdrName		parser/RdrHsSyn
   Name			rename/RnHsSyn
   Id			typecheck/TcHsSyn	
14 15 16 17 18 19 20 21 22 23

\begin{code}
module HsUtils where

import HsBinds
import HsExpr
import HsPat
import HsTypes	
import HsLit

24 25
import RdrName
import Var
26
import Coercion
27 28 29 30
import Type
import DataCon
import Name
import BasicTypes
31
import SrcLoc
32
import FastString
33
import Outputable
34
import Util
35 36 37 38 39 40
import Bag
\end{code}


%************************************************************************
%*									*
41
	Some useful helpers for constructing syntax
42 43 44
%*									*
%************************************************************************

45 46 47
These functions attempt to construct a not-completely-useless SrcSpan
from their components, compared with the nl* functions below which
just attach noSrcSpan to everything.
48 49 50 51 52

\begin{code}
mkHsPar :: LHsExpr id -> LHsExpr id
mkHsPar e = L (getLoc e) (HsPar e)

53 54
mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
mkSimpleMatch pats rhs 
55
  = L loc $
56
    Match pats Nothing (unguardedGRHSs rhs)
57 58 59 60
  where
    loc = case pats of
		[]      -> getLoc rhs
		(pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
61

62 63 64
unguardedGRHSs :: LHsExpr id -> GRHSs id
unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds

65
unguardedRHS :: LHsExpr id -> [LGRHS id]
66
unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
67 68 69 70 71 72 73

mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)

mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)

74
nlHsTyApp :: name -> [Type] -> LHsExpr name
75
nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
76

77 78
mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
79

80 81
mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
82
		 | otherwise	       = HsWrap co_fn e
83

84 85
mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
mkHsWrapCoI IdCo     e = e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
86
mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
87

88 89
coiToHsWrapper :: CoercionI -> HsWrapper
coiToHsWrapper IdCo     = idHsWrapper
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
90
coiToHsWrapper (ACo co) = WpCast co
91

92
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
93
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
94
	where
95 96 97 98
	  matches = mkMatchGroup [mkSimpleMatch pats body]

mkMatchGroup :: [LMatch id] -> MatchGroup id
mkMatchGroup matches = MatchGroup matches placeHolderType
99

100 101 102 103
mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
-- Used for the dictionary bindings gotten from TcSimplify
-- We make them recursive to be on the safe side
mkHsDictLet binds expr 
104
  | isEmptyLHsBinds binds = expr
105 106
  | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
			  where
107
			    val_binds = ValBindsOut [(Recursive, binds)] []
108 109

mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
110
-- Used for constructing dictionary terms etc, so no locations 
111
mkHsConApp data_con tys args 
112
  = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
113 114 115 116 117 118
  where
    mk_app f a = noLoc (HsApp f (noLoc a))

mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
mkSimpleHsAlt pat expr 
119
  = mkSimpleMatch [pat] expr
120

121
-------------------------------
122 123 124
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName

twanvl's avatar
twanvl committed
125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id
mkHsFractional :: Rational -> PostTcType -> HsOverLit id
mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
mkHsDo         :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id

mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
mkNPlusKPat :: Located id -> HsOverLit id -> Pat id

mkTransformStmt   :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR

mkGroupUsingStmt   :: [LStmt idL]                -> LHsExpr idR -> StmtLR idL idR
mkGroupByStmt      :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR

mkExprStmt :: LHsExpr idR -> StmtLR idL idR
mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
mkRecStmt  :: [LStmtLR idL idR] -> StmtLR idL idR


145 146 147 148 149 150 151
mkHsIntegral   i       = OverLit (HsIntegral   i)  noRebindableInfo noSyntaxExpr
mkHsFractional f       = OverLit (HsFractional f)  noRebindableInfo noSyntaxExpr
mkHsIsString   s       = OverLit (HsIsString   s)  noRebindableInfo noSyntaxExpr

noRebindableInfo :: Bool
noRebindableInfo = error "noRebindableInfo" 	-- Just another placeholder; 

152 153
mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType

154
mkNPat lit neg     = NPat lit neg noSyntaxExpr
155
mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
156

157 158 159 160 161 162 163
mkTransformStmt   stmts usingExpr        = TransformStmt (stmts, []) usingExpr Nothing
mkTransformByStmt stmts usingExpr byExpr = TransformStmt (stmts, []) usingExpr (Just byExpr)

mkGroupUsingStmt   stmts usingExpr        = GroupStmt (stmts, []) (GroupByNothing usingExpr)
mkGroupByStmt      stmts byExpr           = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr)
mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr)

164 165 166 167 168
mkExprStmt expr	    = ExprStmt expr noSyntaxExpr placeHolderType
mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
mkRecStmt stmts	    = RecStmt stmts [] [] [] emptyLHsBinds

-------------------------------
169 170
--- A useful function for building @OpApps@.  The operator is always a
-- variable, and we don't know the fixity yet.
twanvl's avatar
twanvl committed
171
mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
172 173
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2

twanvl's avatar
twanvl committed
174
mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
175 176
mkHsSplice e = HsSplice unqualSplice e

twanvl's avatar
twanvl committed
177
unqualSplice :: RdrName
Ian Lynagh's avatar
Ian Lynagh committed
178
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
179 180 181
		-- A name (uniquified later) to
		-- identify the splice

twanvl's avatar
twanvl committed
182
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
183 184
mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualQuasiQuote quoter span quote

twanvl's avatar
twanvl committed
185
unqualQuasiQuote :: RdrName
Ian Lynagh's avatar
Ian Lynagh committed
186
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
187 188 189
		-- A name (uniquified later) to
		-- identify the quasi-quote

twanvl's avatar
twanvl committed
190
mkHsString :: String -> HsLit
191
mkHsString s = HsString (mkFastString s)
192 193 194 195

-------------
userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
196 197 198 199 200
\end{code}


%************************************************************************
%*									*
201
	Constructing syntax with no location info
202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220
%*									*
%************************************************************************

\begin{code}
nlHsVar :: id -> LHsExpr id
nlHsVar n = noLoc (HsVar n)

nlHsLit :: HsLit -> LHsExpr id
nlHsLit n = noLoc (HsLit n)

nlVarPat :: id -> LPat id
nlVarPat n = noLoc (VarPat n)

nlLitPat :: HsLit -> LPat id
nlLitPat l = noLoc (LitPat l)

nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsApp f x = noLoc (HsApp f x)

twanvl's avatar
twanvl committed
221
nlHsIntLit :: Integer -> LHsExpr id
222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245
nlHsIntLit n = noLoc (HsLit (HsInt n))

nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
	     
nlHsVarApps :: id -> [id] -> LHsExpr id
nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
		 where
		   mk f a = HsApp (noLoc f) (noLoc a)

nlConVarPat :: id -> [id] -> LPat id
nlConVarPat con vars = nlConPat con (map nlVarPat vars)

nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))

nlConPat :: id -> [LPat id] -> LPat id
nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))

nlNullaryConPat :: id -> LPat id
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))

nlWildConPat :: DataCon -> LPat RdrName
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
246
				   (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
247

twanvl's avatar
twanvl committed
248
nlWildPat :: LPat id
249
nlWildPat  = noLoc (WildPat placeHolderType)	-- Pre-typechecking
250

251 252
nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
253

twanvl's avatar
twanvl committed
254
nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
255 256
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)

twanvl's avatar
twanvl committed
257 258 259 260 261 262
nlHsLam  :: LMatch id -> LHsExpr id
nlHsPar  :: LHsExpr id -> LHsExpr id
nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
nlList   :: [LHsExpr id] -> LHsExpr id

263
nlHsLam	match		= noLoc (HsLam (mkMatchGroup [match]))
264 265
nlHsPar e		= noLoc (HsPar e)
nlHsIf cond true false	= noLoc (HsIf cond true false)
266
nlHsCase expr matches	= noLoc (HsCase expr (mkMatchGroup matches))
267 268
nlList exprs		= noLoc (ExplicitList placeHolderType exprs)

twanvl's avatar
twanvl committed
269 270 271 272
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
nlHsTyVar :: name                         -> LHsType name
nlHsFunTy :: LHsType name -> LHsType name -> LHsType name

273 274 275
nlHsAppTy f t		= noLoc (HsAppTy f t)
nlHsTyVar x		= noLoc (HsTyVar x)
nlHsFunTy a b		= noLoc (HsFunTy a b)
276

twanvl's avatar
twanvl committed
277
nlHsTyConApp :: name -> [LHsType name] -> LHsType name
278
nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
279 280
\end{code}

281 282 283 284 285 286 287 288 289 290 291
Tuples.  All these functions are *pre-typechecker* because they lack
types on the tuple.

\begin{code}
mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map Present es) Boxed

mkLHsVarTuple :: [a] -> LHsExpr a
mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
292

293 294 295 296 297 298
nlTuplePat :: [LPat id] -> Boxity -> LPat id
nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)

missingTupArg :: HsTupArg a
missingTupArg = Missing placeHolderType
\end{code}
299 300 301 302 303 304 305 306

%************************************************************************
%*									*
		Bindings; with a location at the top
%*									*
%************************************************************************

\begin{code}
307 308 309
mkFunBind :: Located id -> [LMatch id] -> HsBind id
-- Not infix, with place holders for coercion and free vars
mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
andy@galois.com's avatar
andy@galois.com committed
310 311
			    fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
			    fun_tick = Nothing }
312 313


Simon Marlow's avatar
Simon Marlow committed
314 315
mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
316

317
------------
318 319
mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
		-> LHsExpr id -> LHsBind id
320

321
mk_easy_FunBind loc fun pats expr
322
  = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
323

324
------------
325 326 327
mk_FunBind :: SrcSpan -> id
	   -> [([LPat id], LHsExpr id)]
	   -> LHsBind id
328

twanvl's avatar
twanvl committed
329
mk_FunBind _   _   [] = panic "TcGenDeriv:mk_FunBind"
330
mk_FunBind loc fun pats_and_exprs
331
  = L loc $ mkFunBind (L loc fun) matches
332
  where
333
    matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
334 335 336

------------
mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
337 338
mkMatch pats expr binds
  = noLoc (Match (map paren pats) Nothing 
339
		 (GRHSs (unguardedRHS expr) binds))
340 341 342 343 344 345
  where
    paren p = case p of
		L _ (VarPat _) -> p
		L l _	       -> L l (ParPat p)
\end{code}

346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363

%************************************************************************
%*									*
	Collecting binders from HsBindGroups and HsBinds
%*									*
%************************************************************************

Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.

...
where
  (x, y) = ...
  f i j  = ...
  [a, b] = ...

it should return [x, y, f, a, b] (remember, order important).

\begin{code}
364
collectLocalBinders :: HsLocalBindsLR idL idR -> [Located idL]
365 366 367
collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
collectLocalBinders (HsIPBinds _)   = []
collectLocalBinders EmptyLocalBinds = []
368

369
collectHsValBinders :: HsValBindsLR idL idR -> [Located idL]
twanvl's avatar
twanvl committed
370 371
collectHsValBinders (ValBindsIn  binds _) = collectHsBindLocatedBinders binds
collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
372 373
  where
   collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
374

375
collectAcc :: HsBindLR idL idR -> [Located idL] -> [Located idL]
376 377 378
collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
collectAcc (FunBind { fun_id = f })  acc    = f : acc
collectAcc (VarBind { var_id = f })  acc    = noLoc f : acc
twanvl's avatar
twanvl committed
379
collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
380
  = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
381 382 383 384 385
	-- ++ foldr collectAcc acc binds
	-- I don't think we want the binders from the nested binds
	-- The only time we collect binders from a typechecked 
	-- binding (hence see AbsBinds) is in zonking in TcHsSyn

386
collectHsBindBinders :: LHsBindsLR idL idR -> [idL]
387 388
collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)

389
collectHsBindLocatedBinders :: LHsBindsLR idL idR -> [Located idL]
390 391 392 393 394 395 396 397 398 399 400
collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
\end{code}


%************************************************************************
%*									*
	Getting binders from statements
%*									*
%************************************************************************

\begin{code}
401
collectLStmtsBinders :: [LStmtLR idL idR] -> [Located idL]
402
collectLStmtsBinders = concatMap collectLStmtBinders
403

404
collectStmtsBinders :: [StmtLR idL idR] -> [Located idL]
405 406
collectStmtsBinders = concatMap collectStmtBinders

407
collectLStmtBinders :: LStmtLR idL idR -> [Located idL]
408 409
collectLStmtBinders = collectStmtBinders . unLoc

410
collectStmtBinders :: StmtLR idL idR -> [Located idL]
411
  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
412
collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
413
collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
414 415 416
collectStmtBinders (ExprStmt _ _ _)     = []
collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
                                        $ concatMap fst xs
417 418
collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts
collectStmtBinders (GroupStmt (stmts, _) _)     = collectLStmtsBinders stmts
419
collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
420
\end{code}
421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449


%************************************************************************
%*									*
%* 	Gathering stuff out of patterns
%*									*
%************************************************************************

This function @collectPatBinders@ works with the ``collectBinders''
functions for @HsBinds@, etc.  The order in which the binders are
collected is important; see @HsBinds.lhs@.

It collects the bounds *value* variables in renamed patterns; type variables
are *not* collected.

\begin{code}
collectPatBinders :: LPat a -> [a]
collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)

collectLocatedPatBinders :: LPat a -> [Located a]
collectLocatedPatBinders pat = collectl pat []

collectPatsBinders :: [LPat a] -> [a]
collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)

collectLocatedPatsBinders :: [LPat a] -> [Located a]
collectLocatedPatsBinders pats = foldr collectl [] pats

---------------------
twanvl's avatar
twanvl committed
450
collectl :: LPat name -> [Located name] -> [Located name]
451 452 453 454 455 456 457 458
collectl (L l pat) bndrs
  = go pat
  where
    go (VarPat var) 	   	  = L l var : bndrs
    go (VarPatOut var bs) 	  = L l var : collectHsBindLocatedBinders bs 
				    ++ bndrs
    go (WildPat _)	      	  = bndrs
    go (LazyPat pat)     	  = collectl pat bndrs
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
459
    go (BangPat pat)     	  = collectl pat bndrs
460
    go (AsPat a pat)     	  = a : collectl pat bndrs
twanvl's avatar
twanvl committed
461
    go (ViewPat _ pat _)          = collectl pat bndrs
462 463 464 465
    go (ParPat  pat)     	  = collectl pat bndrs
				  
    go (ListPat pats _)    	  = foldr collectl bndrs pats
    go (PArrPat pats _)    	  = foldr collectl bndrs pats
466
    go (TuplePat pats _ _)  	  = foldr collectl bndrs pats
467
				  
twanvl's avatar
twanvl committed
468
    go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)
469
    go (ConPatOut {pat_args=ps})  = foldr collectl bndrs (hsConPatArgs ps)
470
	-- See Note [Dictionary binders in ConPatOut]
471
    go (LitPat _)	      	  = bndrs
472
    go (NPat _ _ _)		  = bndrs
473
    go (NPlusKPat n _ _ _)        = n : bndrs
474
 				  
475 476
    go (SigPatIn pat _)	 	  = collectl pat bndrs
    go (SigPatOut pat _)	  = collectl pat bndrs
477
    go (QuasiQuotePat _)          = bndrs
twanvl's avatar
twanvl committed
478 479
    go (TypePat _)                = bndrs
    go (CoPat _ pat _)            = collectl (noLoc pat) bndrs
480 481
\end{code}

482 483 484 485 486 487 488 489 490 491
Note [Dictionary binders in ConPatOut]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do *not* gather (a) dictionary and (b) dictionary bindings as binders
of a ConPatOut pattern.  For most calls it doesn't matter, because
it's pre-typechecker and there are no ConPatOuts.  But it does matter
more in the desugarer; for example, DsUtils.mkSelectorBinds uses
collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
we want to generate bindings for x,y but not for dictionaries bound by
C.  (The type checker ensures they would not be used.)

Ross Paterson's avatar
Ross Paterson committed
492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507
Desugaring of arrow case expressions needs these bindings (see DsArrows
and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
own pat-binder-collector:

Here's the problem.  Consider

data T a where
   C :: Num a => a -> Int -> T a

f ~(C (n+1) m) = (n,m)

Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
variables bound by the lazy pattern are n,m, *not* the dictionary d.
So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.

508 509 510 511 512 513 514
\begin{code}
collectSigTysFromPats :: [InPat name] -> [LHsType name]
collectSigTysFromPats pats = foldr collect_lpat [] pats

collectSigTysFromPat :: InPat name -> [LHsType name]
collectSigTysFromPat pat = collect_lpat pat []

twanvl's avatar
twanvl committed
515
collect_lpat :: InPat name -> [LHsType name] -> [LHsType name]
516 517
collect_lpat pat acc = collect_pat (unLoc pat) acc

twanvl's avatar
twanvl committed
518
collect_pat :: Pat name -> [LHsType name] -> [LHsType name]
519 520 521 522
collect_pat (SigPatIn pat ty)  	acc = collect_lpat pat (ty:acc)
collect_pat (TypePat ty)       	acc = ty:acc

collect_pat (LazyPat pat)      	acc = collect_lpat pat acc
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
523
collect_pat (BangPat pat)      	acc = collect_lpat pat acc
twanvl's avatar
twanvl committed
524
collect_pat (AsPat _ pat)      	acc = collect_lpat pat acc
525 526 527 528
collect_pat (ParPat  pat)      	acc = collect_lpat pat acc
collect_pat (ListPat pats _)   	acc = foldr collect_lpat acc pats
collect_pat (PArrPat pats _)   	acc = foldr collect_lpat acc pats
collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
twanvl's avatar
twanvl committed
529 530
collect_pat (ConPatIn _ ps)     acc = foldr collect_lpat acc (hsConPatArgs ps)
collect_pat _                   acc = acc       -- Literals, vars, wildcard
531
\end{code}