Squash some spelling issues
[ghc.git] / 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 {-# OPTIONS -fno-warn-tabs #-}
17 -- The above warning supression flag is a temporary kludge.
18 -- While working on this module you are encouraged to remove it and
19 -- detab the module (please do the detabbing in a separate patch). See
20 --     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
21 -- for details
22
23 module HsUtils(
24   -- Terms
25   mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
26   mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
27   mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
28   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo,
29   coToHsWrapper, mkHsDictLet, mkHsLams,
30   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
31   mkLHsPar, mkHsCmdCast,
32
33   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
34   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
35   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
36   toHsType, toHsKind,
37
38   -- Bindings
39   mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, mkPatSynBind,
40
41   -- Literals
42   mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, 
43
44   -- Patterns
45   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat,
46   nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat, mkParPat,
47
48   -- Types
49   mkHsAppTy, userHsTyVarBndrs,
50   nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, 
51
52   -- Stmts
53   mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt,
54   emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, 
55   emptyRecStmt, mkRecStmt, 
56
57   -- Template Haskell
58   mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkHsSplice,
59   mkHsQuasiQuote, unqualQuasiQuote,
60
61   -- Flags
62   noRebindableInfo, 
63
64   -- Collecting binders
65   collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
66   collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
67   collectPatBinders, collectPatsBinders,
68   collectLStmtsBinders, collectStmtsBinders,
69   collectLStmtBinders, collectStmtBinders,
70
71   hsLTyClDeclBinders, hsTyClDeclsBinders, 
72   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
73   
74   -- Collecting implicit binders
75   lStmtsImplicits, hsValBindsImplicits, lPatImplicits
76   ) where
77
78 #include "HsVersions.h"
79
80 import HsDecls
81 import HsBinds
82 import HsExpr
83 import HsPat
84 import HsTypes  
85 import HsLit
86
87 import TcEvidence
88 import RdrName
89 import Var
90 import TypeRep
91 import TcType
92 import Kind
93 import DataCon
94 import Name
95 import NameSet
96 import BasicTypes
97 import SrcLoc
98 import FastString
99 import Util
100 import Bag
101 import Outputable
102 import Data.Either
103 \end{code}
104
105
106 %************************************************************************
107 %*                                                                      *
108         Some useful helpers for constructing syntax
109 %*                                                                      *
110 %************************************************************************
111
112 These functions attempt to construct a not-completely-useless SrcSpan
113 from their components, compared with the nl* functions below which
114 just attach noSrcSpan to everything.
115
116 \begin{code}
117 mkHsPar :: LHsExpr id -> LHsExpr id
118 mkHsPar e = L (getLoc e) (HsPar e)
119
120 mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
121 mkSimpleMatch pats rhs 
122   = L loc $
123     Match pats Nothing (unguardedGRHSs rhs)
124   where
125     loc = case pats of
126                 []      -> getLoc rhs
127                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
128
129 unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
130 unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
131
132 unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))]
133 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
134
135 mkMatchGroup :: [LMatch id (Located (body id))] -> MatchGroup id (Located (body id))
136 mkMatchGroup matches = MG { mg_alts = matches, mg_arg_tys = [], mg_res_ty = placeHolderType }
137
138 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
139 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
140
141 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
142 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
143
144 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
145 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
146         where
147           matches = mkMatchGroup [mkSimpleMatch pats body]
148
149 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
150 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr
151
152 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
153 -- Used for constructing dictionary terms etc, so no locations 
154 mkHsConApp data_con tys args 
155   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
156   where
157     mk_app f a = noLoc (HsApp f (noLoc a))
158
159 mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
160 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
161 mkSimpleHsAlt pat expr 
162   = mkSimpleMatch [pat] expr
163
164 nlHsTyApp :: name -> [Type] -> LHsExpr name
165 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
166
167 --------- Adding parens ---------
168 mkLHsPar :: LHsExpr name -> LHsExpr name
169 -- Wrap in parens if hsExprNeedsParens says it needs them
170 -- So   'f x'  becomes '(f x)', but '3' stays as '3'
171 mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
172                       | otherwise           = le
173
174 mkParPat :: LPat name -> LPat name
175 mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
176                       | otherwise          = lp
177
178
179 -------------------------------
180 -- These are the bits of syntax that contain rebindable names
181 -- See RnEnv.lookupSyntaxName
182
183 mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id
184 mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id
185 mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
186 mkHsDo         :: HsStmtContext Name -> [ExprLStmt id] -> HsExpr id
187 mkHsComp       :: HsStmtContext Name -> [ExprLStmt id] -> LHsExpr id -> HsExpr id
188
189 mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
190 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
191
192 mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
193 mkBodyStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
194 mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
195
196 emptyRecStmt :: StmtLR idL idR bodyR
197 mkRecStmt    :: [LStmtLR idL idR bodyR] -> StmtLR idL idR bodyR
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 = HsDo ctxt stmts placeHolderType
208 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
209   where
210     last_stmt = L (getLoc expr) $ mkLastStmt expr
211
212 mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
213 mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
214
215 mkNPat lit neg     = NPat lit neg noSyntaxExpr
216 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
217
218 mkTransformStmt    :: [ExprLStmt idL] -> LHsExpr idR
219                    -> StmtLR idL idR (LHsExpr idL)
220 mkTransformByStmt  :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
221                    -> StmtLR idL idR (LHsExpr idL)
222 mkGroupUsingStmt   :: [ExprLStmt idL]                -> LHsExpr idR
223                    -> StmtLR idL idR (LHsExpr idL)
224 mkGroupByUsingStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
225                    -> StmtLR idL idR (LHsExpr idL)
226
227 emptyTransStmt :: StmtLR idL idR (LHsExpr idR)
228 emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
229                            , trS_stmts = [], trS_bndrs = [] 
230                            , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
231                            , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
232                            , trS_fmap = noSyntaxExpr }
233 mkTransformStmt    ss u   = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }
234 mkTransformByStmt  ss u b = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }
235 mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
236 mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
237
238 mkLastStmt body     = LastStmt body noSyntaxExpr
239 mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
240 mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr
241
242 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
243                        , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
244                        , recS_bind_fn = noSyntaxExpr, recS_later_rets = []
245                        , recS_rec_rets = [], recS_ret_ty = placeHolderType }
246
247 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
248
249 -------------------------------
250 --- A useful function for building @OpApps@.  The operator is always a
251 -- variable, and we don't know the fixity yet.
252 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
253 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
254
255 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
256 mkHsSplice e = HsSplice unqualSplice e
257
258 mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
259 mkHsSpliceE e = HsSpliceE False (mkHsSplice e)
260
261 mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
262 mkHsSpliceTE e = HsSpliceE True (mkHsSplice e)
263
264 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
265 mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) placeHolderKind
266
267 unqualSplice :: RdrName
268 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
269                 -- A name (uniquified later) to
270                 -- identify the splice
271
272 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
273 mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
274
275 unqualQuasiQuote :: RdrName
276 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
277                 -- A name (uniquified later) to
278                 -- identify the quasi-quote
279
280 mkHsString :: String -> HsLit
281 mkHsString s = HsString (mkFastString s)
282
283 -------------
284 userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
285 -- Caller sets location
286 userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
287 \end{code}
288
289
290 %************************************************************************
291 %*                                                                      *
292         Constructing syntax with no location info
293 %*                                                                      *
294 %************************************************************************
295
296 \begin{code}
297 nlHsVar :: id -> LHsExpr id
298 nlHsVar n = noLoc (HsVar n)
299
300 nlHsLit :: HsLit -> LHsExpr id
301 nlHsLit n = noLoc (HsLit n)
302
303 nlVarPat :: id -> LPat id
304 nlVarPat n = noLoc (VarPat n)
305
306 nlLitPat :: HsLit -> LPat id
307 nlLitPat l = noLoc (LitPat l)
308
309 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
310 nlHsApp f x = noLoc (HsApp f x)
311
312 nlHsIntLit :: Integer -> LHsExpr id
313 nlHsIntLit n = noLoc (HsLit (HsInt n))
314
315 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
316 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
317              
318 nlHsVarApps :: id -> [id] -> LHsExpr id
319 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
320                  where
321                    mk f a = HsApp (noLoc f) (noLoc a)
322
323 nlConVarPat :: id -> [id] -> LPat id
324 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
325
326 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
327 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
328
329 nlConPat :: id -> [LPat id] -> LPat id
330 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
331
332 nlNullaryConPat :: id -> LPat id
333 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
334
335 nlWildConPat :: DataCon -> LPat RdrName
336 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
337                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
338
339 nlWildPat :: LPat id
340 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
341
342 nlHsDo :: HsStmtContext Name -> [LStmt id (LHsExpr id)] -> LHsExpr id
343 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
344
345 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
346 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
347
348 nlHsLam  :: LMatch id (LHsExpr id) -> LHsExpr id
349 nlHsPar  :: LHsExpr id -> LHsExpr id
350 nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
351 nlHsCase :: LHsExpr id -> [LMatch id (LHsExpr id)] -> LHsExpr id
352 nlList   :: [LHsExpr id] -> LHsExpr id
353
354 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
355 nlHsPar e               = noLoc (HsPar e)
356 nlHsIf cond true false  = noLoc (mkHsIf cond true false)
357 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
358 nlList exprs            = noLoc (ExplicitList placeHolderType Nothing exprs)
359
360 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
361 nlHsTyVar :: name                         -> LHsType name
362 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
363
364 nlHsAppTy f t           = noLoc (HsAppTy f t)
365 nlHsTyVar x             = noLoc (HsTyVar x)
366 nlHsFunTy a b           = noLoc (HsFunTy a b)
367
368 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
369 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
370 \end{code}
371
372 Tuples.  All these functions are *pre-typechecker* because they lack
373 types on the tuple.
374
375 \begin{code}
376 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
377 -- Makes a pre-typechecker boxed tuple, deals with 1 case
378 mkLHsTupleExpr [e] = e
379 mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map Present es) Boxed
380
381 mkLHsVarTuple :: [a] -> LHsExpr a
382 mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
383
384 nlTuplePat :: [LPat id] -> Boxity -> LPat id
385 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
386
387 missingTupArg :: HsTupArg a
388 missingTupArg = Missing placeHolderType
389 \end{code}
390
391
392 %************************************************************************
393 %*                                                                      *
394         Converting a Type to an HsType RdrName
395 %*                                                                      *
396 %************************************************************************
397
398 This is needed to implement GeneralizedNewtypeDeriving.
399
400 \begin{code}
401 toHsType :: Type -> LHsType RdrName
402 toHsType ty
403   | [] <- tvs_only
404   , [] <- theta
405   = to_hs_type tau
406   | otherwise
407   = noLoc $
408     mkExplicitHsForAllTy (map mk_hs_tvb tvs_only)
409                          (noLoc $ map toHsType theta)
410                          (to_hs_type tau)
411
412   where
413     (tvs, theta, tau) = tcSplitSigmaTy ty
414     tvs_only = filter isTypeVar tvs
415
416     to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv)
417     to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2)
418     to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args')
419        where 
420          args' = filterOut isKind args
421          -- Source-language types have _implicit_ kind arguments,
422          -- so we must remove them here (Trac #8563)
423     to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) )
424                                  nlHsFunTy (toHsType arg) (toHsType res)
425     to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t)
426     to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy n)
427     to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy s)
428
429     mk_hs_tvb tv = noLoc $ KindedTyVar (getRdrName tv) (toHsKind (tyVarKind tv))
430
431 toHsKind :: Kind -> LHsKind RdrName
432 toHsKind = toHsType
433
434 \end{code}
435
436 \begin{code}
437 --------- HsWrappers: type args, dict args, casts ---------
438 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
439 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
440
441 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
442 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
443                  | otherwise           = HsWrap co_fn e
444
445 mkHsWrapCo :: TcCoercion -> HsExpr id -> HsExpr id
446 mkHsWrapCo co e = mkHsWrap (coToHsWrapper co) e
447
448 mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id
449 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
450
451 mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id
452 mkHsCmdCast co cmd | isTcReflCo co = cmd
453                    | otherwise     = HsCmdCast co cmd
454
455 coToHsWrapper :: TcCoercion -> HsWrapper
456 coToHsWrapper co | isTcReflCo co = idHsWrapper
457                  | otherwise     = mkWpCast (mkTcSubCo co)
458
459 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
460 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
461                        | otherwise           = CoPat co_fn p ty
462
463 mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id
464 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
465                         | otherwise     = CoPat (mkWpCast co) pat ty
466
467 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
468 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
469 \end{code}
470 l
471 %************************************************************************
472 %*                                                                      *
473                 Bindings; with a location at the top
474 %*                                                                      *
475 %************************************************************************
476
477 \begin{code}
478 mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName
479 -- Not infix, with place holders for coercion and free vars
480 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
481                           , fun_matches = mkMatchGroup ms
482                           , fun_co_fn = idHsWrapper
483                           , bind_fvs = placeHolderNames
484                           , fun_tick = Nothing }
485
486 mkTopFunBind :: Located Name -> [LMatch Name (LHsExpr Name)] -> HsBind Name
487 -- In Name-land, with empty bind_fvs
488 mkTopFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
489                              , fun_matches = mkMatchGroup ms
490                              , fun_co_fn = idHsWrapper
491                              , bind_fvs = emptyNameSet  -- NB: closed binding
492                              , fun_tick = Nothing }
493
494 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> (Origin, LHsBind RdrName)
495 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
496
497 mkVarBind :: id -> LHsExpr id -> LHsBind id
498 mkVarBind var rhs = L (getLoc rhs) $
499                     VarBind { var_id = var, var_rhs = rhs, var_inline = False }
500
501 mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
502 mkPatSynBind name details lpat dir = PatSynBind{ patsyn_id = name
503                                                , patsyn_args = details
504                                                , patsyn_def = lpat
505                                                , patsyn_dir = dir
506                                                , bind_fvs = placeHolderNames }
507
508 ------------
509 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
510                 -> LHsExpr RdrName -> (Origin, LHsBind RdrName)
511 mk_easy_FunBind loc fun pats expr
512   = (Generated, L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds])
513
514 ------------
515 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
516 mkMatch pats expr binds
517   = noLoc (Match (map paren pats) Nothing 
518                  (GRHSs (unguardedRHS expr) binds))
519   where
520     paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) 
521                      | otherwise          = lp
522 \end{code}
523
524
525 %************************************************************************
526 %*                                                                      *
527         Collecting binders
528 %*                                                                      *
529 %************************************************************************
530
531 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
532
533 ...
534 where
535   (x, y) = ...
536   f i j  = ...
537   [a, b] = ...
538
539 it should return [x, y, f, a, b] (remember, order important).
540
541 Note [Collect binders only after renaming]
542 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
543 These functions should only be used on HsSyn *after* the renamer,
544 to return a [Name] or [Id].  Before renaming the record punning
545 and wild-card mechanism makes it hard to know what is bound.
546 So these functions should not be applied to (HsSyn RdrName)
547
548 \begin{code}
549 ----------------- Bindings --------------------------
550 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
551 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
552 collectLocalBinders (HsIPBinds _)   = []
553 collectLocalBinders EmptyLocalBinds = []
554
555 collectHsValBinders :: HsValBindsLR idL idR -> [idL]
556 collectHsValBinders (ValBindsIn  binds _) = collectHsBindsBinders binds
557 collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
558   where
559    collect_one (_,binds) acc = collect_binds binds acc
560
561 collectHsBindBinders :: HsBindLR idL idR -> [idL]
562 collectHsBindBinders b = collect_bind b []
563
564 collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
565 collect_bind (PatBind { pat_lhs = p })    acc = collect_lpat p acc
566 collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
567 collect_bind (VarBind { var_id = f })     acc = f : acc
568 collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
569   = map abe_poly dbinds ++ acc 
570         -- ++ foldr collect_bind acc binds
571         -- I don't think we want the binders from the nested binds
572         -- The only time we collect binders from a typechecked 
573         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
574 collect_bind (PatSynBind { patsyn_id = L _ ps }) acc = ps : acc
575
576 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
577 collectHsBindsBinders binds = collect_binds binds []
578
579 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
580 collectHsBindListBinders = foldr (collect_bind . unLoc) []
581
582 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
583 collect_binds binds acc = foldrBag (collect_bind . unLoc . snd) acc binds
584
585 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
586 -- Used exclusively for the bindings of an instance decl which are all FunBinds
587 collectMethodBinders binds = foldrBag (get . unLoc . snd) [] binds
588   where
589     get (FunBind { fun_id = f }) fs = f : fs
590     get _                        fs = fs        
591        -- Someone else complains about non-FunBinds
592
593 ----------------- Statements --------------------------
594 collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]
595 collectLStmtsBinders = concatMap collectLStmtBinders
596
597 collectStmtsBinders :: [StmtLR idL idR body] -> [idL]
598 collectStmtsBinders = concatMap collectStmtBinders
599
600 collectLStmtBinders :: LStmtLR idL idR body -> [idL]
601 collectLStmtBinders = collectStmtBinders . unLoc
602
603 collectStmtBinders :: StmtLR idL idR body -> [idL]
604   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
605 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
606 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
607 collectStmtBinders (BodyStmt {})        = []
608 collectStmtBinders (LastStmt {})        = []
609 collectStmtBinders (ParStmt xs _ _)     = collectLStmtsBinders
610                                         $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
611 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
612 collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
613
614
615 ----------------- Patterns --------------------------
616 collectPatBinders :: LPat a -> [a]
617 collectPatBinders pat = collect_lpat pat []
618
619 collectPatsBinders :: [LPat a] -> [a]
620 collectPatsBinders pats = foldr collect_lpat [] pats
621
622 -------------
623 collect_lpat :: LPat name -> [name] -> [name]
624 collect_lpat (L _ pat) bndrs
625   = go pat
626   where
627     go (VarPat var)               = var : bndrs
628     go (WildPat _)                = bndrs
629     go (LazyPat pat)              = collect_lpat pat bndrs
630     go (BangPat pat)              = collect_lpat pat bndrs
631     go (AsPat (L _ a) pat)        = a : collect_lpat pat bndrs
632     go (ViewPat _ pat _)          = collect_lpat pat bndrs
633     go (ParPat  pat)              = collect_lpat pat bndrs
634                                   
635     go (ListPat pats _ _)         = foldr collect_lpat bndrs pats
636     go (PArrPat pats _)           = foldr collect_lpat bndrs pats
637     go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats
638                                   
639     go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
640     go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
641         -- See Note [Dictionary binders in ConPatOut]
642     go (LitPat _)                 = bndrs
643     go (NPat _ _ _)               = bndrs
644     go (NPlusKPat (L _ n) _ _ _)  = n : bndrs
645                                   
646     go (SigPatIn pat _)           = collect_lpat pat bndrs
647     go (SigPatOut pat _)          = collect_lpat pat bndrs
648     go (SplicePat _)              = bndrs
649     go (QuasiQuotePat _)          = bndrs
650     go (CoPat _ pat _)            = go pat
651 \end{code}
652
653 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
654 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
655 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
656 of a ConPatOut pattern.  For most calls it doesn't matter, because
657 it's pre-typechecker and there are no ConPatOuts.  But it does matter
658 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
659 collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
660 we want to generate bindings for x,y but not for dictionaries bound by
661 C.  (The type checker ensures they would not be used.)
662
663 Desugaring of arrow case expressions needs these bindings (see DsArrows
664 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
665 own pat-binder-collector:
666
667 Here's the problem.  Consider
668
669 data T a where
670    C :: Num a => a -> Int -> T a
671
672 f ~(C (n+1) m) = (n,m)
673
674 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
675 and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
676 variables bound by the lazy pattern are n,m, *not* the dictionary d.
677 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
678
679 \begin{code}
680 hsGroupBinders :: HsGroup Name -> [Name]
681 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
682                           hs_instds = inst_decls, hs_fords = foreign_decls })
683 -- Collect the binders of a Group
684   =  collectHsValBinders val_decls
685   ++ hsTyClDeclsBinders tycl_decls inst_decls
686   ++ hsForeignDeclsBinders foreign_decls
687
688 hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
689 hsForeignDeclsBinders foreign_decls
690   = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
691
692 hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> [Name]
693 -- We need to look at instance declarations too, 
694 -- because their associated types may bind data constructors
695 hsTyClDeclsBinders tycl_decls inst_decls
696   = map unLoc (concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
697                concatMap (hsInstDeclBinders . unLoc) inst_decls)
698
699 -------------------
700 hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
701 -- ^ Returns all the /binding/ names of the decl.
702 -- The first one is guaranteed to be the name of the decl. For record fields
703 -- mentioned in multiple constructors, the SrcLoc will be from the first
704 -- occurrence.  We use the equality to filter out duplicate field names.
705 --
706 -- Each returned (Located name) is wrapped in a @SrcSpan@ of the whole
707 -- /declaration/, not just the name itself (which is how it appears in
708 -- the syntax tree).  This SrcSpan (for the entire declaration) is used
709 -- as the SrcSpan for the Name that is finally produced, and hence for
710 -- error messages.  (See Trac #8607.)
711
712 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
713   = [L loc name]
714 hsLTyClDeclBinders (L loc (ForeignType { tcdLName = L _ name })) = [L loc name]
715 hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = [L loc name]
716 hsLTyClDeclBinders (L loc (ClassDecl   { tcdLName = L _ cls_name
717                                        , tcdSigs = sigs, tcdATs = ats }))
718   = L loc cls_name :
719     [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
720     [ L mem_loc mem_name | L mem_loc (TypeSig ns _) <- sigs, L _ mem_name <- ns ]
721 hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
722   = L loc name : hsDataDefnBinders defn
723
724 -------------------
725 hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
726 hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })
727   = concatMap (hsDataFamInstBinders . unLoc) dfis
728 hsInstDeclBinders (DataFamInstD { dfid_inst = fi }) = hsDataFamInstBinders fi
729 hsInstDeclBinders (TyFamInstD {}) = []
730
731 -------------------
732 -- the SrcLoc returned are for the whole declarations, not just the names
733 hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name]
734 hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
735   = hsDataDefnBinders defn
736   -- There can't be repeated symbols because only data instances have binders
737
738 -------------------
739 -- the SrcLoc returned are for the whole declarations, not just the names
740 hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name]
741 hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons
742   -- See Note [Binders in family instances]
743
744 -------------------
745 hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
746   -- See hsLTyClDeclBinders for what this does
747   -- The function is boringly complicated because of the records
748   -- And since we only have equality, we have to be a little careful
749 hsConDeclsBinders cons
750   = snd (foldl do_one ([], []) cons)
751   where
752     do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name
753                                             , con_details = RecCon flds }))
754         = (map unLoc new_flds ++ flds_seen, L loc name : new_flds ++ acc)
755         where
756           -- don't re-mangle the location of field names, because we don't
757           -- have a record of the full location of the field declaration anyway
758           new_flds = filterOut (\f -> unLoc f `elem` flds_seen) 
759                                (map cd_fld_name flds)
760
761     do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name }))
762         = (flds_seen, L loc name : acc)
763 \end{code}
764
765 Note [Binders in family instances]
766 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
767 In a type or data family instance declaration, the type 
768 constructor is an *occurrence* not a binding site
769     type instance T Int = Int -> Int   -- No binders
770     data instance S Bool = S1 | S2     -- Binders are S1,S2
771
772
773 %************************************************************************
774 %*                                                                      *
775         Collecting binders the user did not write
776 %*                                                                      *
777 %************************************************************************
778
779 The job of this family of functions is to run through binding sites and find the set of all Names
780 that were defined "implicitly", without being explicitly written by the user.
781
782 The main purpose is to find names introduced by record wildcards so that we can avoid
783 warning the user when they don't use those names (#4404)
784
785 \begin{code}
786 lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet
787 lStmtsImplicits = hs_lstmts
788   where
789     hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet
790     hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet
791     
792     hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
793     hs_stmt (LetStmt binds)      = hs_local_binds binds
794     hs_stmt (BodyStmt {})        = emptyNameSet
795     hs_stmt (LastStmt {})        = emptyNameSet
796     hs_stmt (ParStmt xs _ _)     = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
797     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
798     hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss
799     
800     hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
801     hs_local_binds (HsIPBinds _)         = emptyNameSet
802     hs_local_binds EmptyLocalBinds       = emptyNameSet
803
804 hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
805 hsValBindsImplicits (ValBindsOut binds _)
806   = foldr (unionNameSets . lhsBindsImplicits . snd) emptyNameSet binds
807 hsValBindsImplicits (ValBindsIn binds _) 
808   = lhsBindsImplicits binds
809
810 lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
811 lhsBindsImplicits = foldBag unionNameSets (lhs_bind . unLoc . snd) emptyNameSet
812   where
813     lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
814     lhs_bind _ = emptyNameSet
815
816 lPatImplicits :: LPat Name -> NameSet
817 lPatImplicits = hs_lpat
818   where
819     hs_lpat (L _ pat) = hs_pat pat
820     
821     hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet
822     
823     hs_pat (LazyPat pat)       = hs_lpat pat
824     hs_pat (BangPat pat)       = hs_lpat pat
825     hs_pat (AsPat _ pat)       = hs_lpat pat
826     hs_pat (ViewPat _ pat _)   = hs_lpat pat
827     hs_pat (ParPat  pat)       = hs_lpat pat
828     hs_pat (ListPat pats _ _)  = hs_lpats pats
829     hs_pat (PArrPat pats _)    = hs_lpats pats
830     hs_pat (TuplePat pats _ _) = hs_lpats pats
831
832     hs_pat (SigPatIn pat _)  = hs_lpat pat
833     hs_pat (SigPatOut pat _) = hs_lpat pat
834     hs_pat (CoPat _ pat _)   = hs_pat pat
835     
836     hs_pat (ConPatIn _ ps)           = details ps
837     hs_pat (ConPatOut {pat_args=ps}) = details ps
838     
839     hs_pat _ = emptyNameSet
840     
841     details (PrefixCon ps)   = hs_lpats ps
842     details (RecCon fs)      = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit)
843       where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
844                                                     | (i, fld) <- [0..] `zip` rec_flds fs
845                                                     , let pat = hsRecFieldArg fld
846                                                           pat_explicit = maybe True (i<) (rec_dotdot fs)]
847     details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2
848 \end{code}