62aabe34fa8dc8b33a5fbb295c28b99cf9060340
[ghc.git] / compiler / hsSyn / HsUtils.hs
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 instantiated versions are located elsewhere:
8
9 Parameterised by Module
10 ---------------- -------------
11 RdrName parser/RdrHsSyn
12 Name rename/RnHsSyn
13 Id typecheck/TcHsSyn
14 -}
15
16 {-# LANGUAGE CPP #-}
17 {-# LANGUAGE ScopedTypeVariables #-}
18 {-# LANGUAGE FlexibleContexts #-}
19
20 module HsUtils(
21 -- Terms
22 mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
23 mkSimpleMatch, unguardedGRHSs, unguardedRHS,
24 mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
25 mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
26 coToHsWrapper, coToHsWrapperR, mkHsDictLet, mkHsLams,
27 mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
28 mkLHsPar, mkHsCmdCast,
29
30 nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
31 nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
32 mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
33 toHsType, toHsKind,
34
35 -- * Constructing general big tuples
36 -- $big_tuples
37 mkChunkified, chunkify,
38
39 -- Bindings
40 mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
41 mkPatSynBind,
42 isInfixFunBind,
43
44 -- Literals
45 mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
46
47 -- Patterns
48 mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
49 nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
50 nlWildPatName, nlWildPatId, nlTuplePat, mkParPat,
51 mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
52
53 -- Types
54 mkHsAppTy, userHsTyVarBndrs,
55 nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
56
57 -- Stmts
58 mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt,
59 emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
60 emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
61
62 -- Template Haskell
63 mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice,
64 mkHsQuasiQuote, unqualQuasiQuote,
65
66 -- Flags
67 noRebindableInfo,
68
69 -- Collecting binders
70 collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
71 collectHsIdBinders,
72 collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
73 collectPatBinders, collectPatsBinders,
74 collectLStmtsBinders, collectStmtsBinders,
75 collectLStmtBinders, collectStmtBinders,
76
77 hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders,
78 hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
79
80 -- Collecting implicit binders
81 lStmtsImplicits, hsValBindsImplicits, lPatImplicits
82 ) where
83
84 #include "HsVersions.h"
85
86 import HsDecls
87 import HsBinds
88 import HsExpr
89 import HsPat
90 import HsTypes
91 import HsLit
92 import PlaceHolder
93
94 import TcEvidence
95 import RdrName
96 import Var
97 import TypeRep
98 import TcType
99 import Kind
100 import DataCon
101 import Name
102 import NameSet
103 import BasicTypes
104 import SrcLoc
105 import FastString
106 import Util
107 import Bag
108 import Outputable
109 import Constants
110
111 import Data.Either
112 import Data.Function
113 import Data.List
114
115 #if __GLASGOW_HASKELL__ < 709
116 import Data.Foldable ( foldMap )
117 import Data.Monoid ( mempty, mappend )
118 #endif
119
120 {-
121 ************************************************************************
122 * *
123 Some useful helpers for constructing syntax
124 * *
125 ************************************************************************
126
127 These functions attempt to construct a not-completely-useless SrcSpan
128 from their components, compared with the nl* functions below which
129 just attach noSrcSpan to everything.
130 -}
131
132 mkHsPar :: LHsExpr id -> LHsExpr id
133 mkHsPar e = L (getLoc e) (HsPar e)
134
135 mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
136 mkSimpleMatch pats rhs
137 = L loc $
138 Match NonFunBindMatch pats Nothing (unguardedGRHSs rhs)
139 where
140 loc = case pats of
141 [] -> getLoc rhs
142 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
143
144 unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
145 unguardedGRHSs rhs@(L loc _)
146 = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
147
148 unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))]
149 unguardedRHS loc rhs = [L loc (GRHS [] rhs)]
150
151 mkMatchGroup :: Origin -> [LMatch RdrName (Located (body RdrName))]
152 -> MatchGroup RdrName (Located (body RdrName))
153 mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches
154 , mg_arg_tys = []
155 , mg_res_ty = placeHolderType
156 , mg_origin = origin }
157
158 mkLocatedList :: [Located a] -> Located [Located a]
159 mkLocatedList [] = noLoc []
160 mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
161
162 mkMatchGroupName :: Origin -> [LMatch Name (Located (body Name))]
163 -> MatchGroup Name (Located (body Name))
164 mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches
165 , mg_arg_tys = []
166 , mg_res_ty = placeHolderType
167 , mg_origin = origin }
168
169 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
170 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
171
172 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
173 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
174
175 mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
176 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
177 where
178 matches = mkMatchGroup Generated [mkSimpleMatch pats body]
179
180 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
181 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
182 <.> mkWpLams dicts) expr
183
184 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
185 -- Used for constructing dictionary terms etc, so no locations
186 mkHsConApp data_con tys args
187 = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
188 where
189 mk_app f a = noLoc (HsApp f (noLoc a))
190
191 mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
192 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
193 mkSimpleHsAlt pat expr
194 = mkSimpleMatch [pat] expr
195
196 nlHsTyApp :: name -> [Type] -> LHsExpr name
197 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
198
199 nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name
200 nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
201
202 --------- Adding parens ---------
203 mkLHsPar :: LHsExpr name -> LHsExpr name
204 -- Wrap in parens if hsExprNeedsParens says it needs them
205 -- So 'f x' becomes '(f x)', but '3' stays as '3'
206 mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
207 | otherwise = le
208
209 mkParPat :: LPat name -> LPat name
210 mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
211 | otherwise = lp
212
213
214 -------------------------------
215 -- These are the bits of syntax that contain rebindable names
216 -- See RnEnv.lookupSyntaxName
217
218 mkHsIntegral :: String -> Integer -> PostTc RdrName Type -> HsOverLit RdrName
219 mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName
220 mkHsIsString :: String -> FastString -> PostTc RdrName Type -> HsOverLit RdrName
221 mkHsDo :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
222 mkHsComp :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
223 -> HsExpr RdrName
224
225 mkNPat :: Located (HsOverLit id) -> Maybe (SyntaxExpr id) -> Pat id
226 mkNPlusKPat :: Located id -> Located (HsOverLit id) -> Pat id
227
228 mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
229 mkBodyStmt :: Located (bodyR RdrName)
230 -> StmtLR idL RdrName (Located (bodyR RdrName))
231 mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
232
233 emptyRecStmt :: StmtLR idL RdrName bodyR
234 emptyRecStmtName :: StmtLR Name Name bodyR
235 emptyRecStmtId :: StmtLR Id Id bodyR
236 mkRecStmt :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR
237
238
239 mkHsIntegral src i = OverLit (HsIntegral src i) noRebindableInfo noSyntaxExpr
240 mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr
241 mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noSyntaxExpr
242
243 noRebindableInfo :: PlaceHolder
244 noRebindableInfo = PlaceHolder -- Just another placeholder;
245
246 mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType
247 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
248 where
249 last_stmt = L (getLoc expr) $ mkLastStmt expr
250
251 mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
252 mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
253
254 mkNPat lit neg = NPat lit neg noSyntaxExpr
255 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
256
257 mkTransformStmt :: [ExprLStmt idL] -> LHsExpr idR
258 -> StmtLR idL idR (LHsExpr idL)
259 mkTransformByStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
260 -> StmtLR idL idR (LHsExpr idL)
261 mkGroupUsingStmt :: [ExprLStmt idL] -> LHsExpr idR
262 -> StmtLR idL idR (LHsExpr idL)
263 mkGroupByUsingStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
264 -> StmtLR idL idR (LHsExpr idL)
265
266 emptyTransStmt :: StmtLR idL idR (LHsExpr idR)
267 emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
268 , trS_stmts = [], trS_bndrs = []
269 , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
270 , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
271 , trS_fmap = noSyntaxExpr }
272 mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
273 mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
274 mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
275 mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
276
277 mkLastStmt body = LastStmt body False noSyntaxExpr
278 mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
279 mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr
280
281
282 emptyRecStmt' :: forall idL idR body.
283 PostTc idR Type -> StmtLR idL idR body
284 emptyRecStmt' tyVal =
285 RecStmt
286 { recS_stmts = [], recS_later_ids = []
287 , recS_rec_ids = []
288 , recS_ret_fn = noSyntaxExpr
289 , recS_mfix_fn = noSyntaxExpr
290 , recS_bind_fn = noSyntaxExpr, recS_later_rets = []
291 , recS_rec_rets = [], recS_ret_ty = tyVal }
292
293 emptyRecStmt = emptyRecStmt' placeHolderType
294 emptyRecStmtName = emptyRecStmt' placeHolderType
295 emptyRecStmtId = emptyRecStmt' placeHolderTypeTc
296 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
297
298 -------------------------------
299 --- A useful function for building @OpApps@. The operator is always a
300 -- variable, and we don't know the fixity yet.
301 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
302 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
303 (error "mkOpApp:fixity") e2
304
305 unqualSplice :: RdrName
306 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
307
308 mkUntypedSplice :: LHsExpr RdrName -> HsSplice RdrName
309 mkUntypedSplice e = HsUntypedSplice unqualSplice e
310
311 mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
312 mkHsSpliceE e = HsSpliceE (mkUntypedSplice e)
313
314 mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
315 mkHsSpliceTE e = HsSpliceE (HsTypedSplice unqualSplice e)
316
317 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
318 mkHsSpliceTy e = HsSpliceTy (HsUntypedSplice unqualSplice e) placeHolderKind
319
320 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName
321 mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
322
323 unqualQuasiQuote :: RdrName
324 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
325 -- A name (uniquified later) to
326 -- identify the quasi-quote
327
328 mkHsString :: String -> HsLit
329 mkHsString s = HsString s (mkFastString s)
330
331 mkHsStringPrimLit :: FastString -> HsLit
332 mkHsStringPrimLit fs
333 = HsStringPrim (unpackFS fs) (fastStringToByteString fs)
334
335 -------------
336 userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
337 -- Caller sets location
338 userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
339
340 {-
341 ************************************************************************
342 * *
343 Constructing syntax with no location info
344 * *
345 ************************************************************************
346 -}
347
348 nlHsVar :: id -> LHsExpr id
349 nlHsVar n = noLoc (HsVar (noLoc n))
350
351 nlHsLit :: HsLit -> LHsExpr id
352 nlHsLit n = noLoc (HsLit n)
353
354 nlVarPat :: id -> LPat id
355 nlVarPat n = noLoc (VarPat (noLoc n))
356
357 nlLitPat :: HsLit -> LPat id
358 nlLitPat l = noLoc (LitPat l)
359
360 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
361 nlHsApp f x = noLoc (HsApp f x)
362
363 nlHsIntLit :: Integer -> LHsExpr id
364 nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
365
366 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
367 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
368
369 nlHsVarApps :: id -> [id] -> LHsExpr id
370 nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
371 where
372 mk f a = HsApp (noLoc f) (noLoc a)
373
374 nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
375 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
376
377 nlConVarPatName :: Name -> [Name] -> LPat Name
378 nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
379
380 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
381 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
382
383 nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName
384 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
385
386 nlConPatName :: Name -> [LPat Name] -> LPat Name
387 nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
388
389 nlNullaryConPat :: id -> LPat id
390 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
391
392 nlWildConPat :: DataCon -> LPat RdrName
393 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
394 (PrefixCon (nOfThem (dataConSourceArity con)
395 nlWildPat)))
396
397 nlWildPat :: LPat RdrName
398 nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking
399
400 nlWildPatName :: LPat Name
401 nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking
402
403 nlWildPatId :: LPat Id
404 nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking
405
406 nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)]
407 -> LHsExpr RdrName
408 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
409
410 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
411 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
412
413 nlHsLam :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName
414 nlHsPar :: LHsExpr id -> LHsExpr id
415 nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
416 nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]
417 -> LHsExpr RdrName
418 nlList :: [LHsExpr RdrName] -> LHsExpr RdrName
419
420 nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match]))
421 nlHsPar e = noLoc (HsPar e)
422 nlHsIf cond true false = noLoc (mkHsIf cond true false)
423 nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches))
424 nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs)
425
426 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
427 nlHsTyVar :: name -> LHsType name
428 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
429
430 nlHsAppTy f t = noLoc (HsAppTy f t)
431 nlHsTyVar x = noLoc (HsTyVar (noLoc x))
432 nlHsFunTy a b = noLoc (HsFunTy a b)
433
434 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
435 nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
436
437 {-
438 Tuples. All these functions are *pre-typechecker* because they lack
439 types on the tuple.
440 -}
441
442 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
443 -- Makes a pre-typechecker boxed tuple, deals with 1 case
444 mkLHsTupleExpr [e] = e
445 mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
446
447 mkLHsVarTuple :: [a] -> LHsExpr a
448 mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
449
450 nlTuplePat :: [LPat id] -> Boxity -> LPat id
451 nlTuplePat pats box = noLoc (TuplePat pats box [])
452
453 missingTupArg :: HsTupArg RdrName
454 missingTupArg = Missing placeHolderType
455
456 mkLHsPatTup :: [LPat id] -> LPat id
457 mkLHsPatTup [] = noLoc $ TuplePat [] Boxed []
458 mkLHsPatTup [lpat] = lpat
459 mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed []
460
461 -- The Big equivalents for the source tuple expressions
462 mkBigLHsVarTup :: [id] -> LHsExpr id
463 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
464
465 mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
466 mkBigLHsTup = mkChunkified mkLHsTupleExpr
467
468 -- The Big equivalents for the source tuple patterns
469 mkBigLHsVarPatTup :: [id] -> LPat id
470 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
471
472 mkBigLHsPatTup :: [LPat id] -> LPat id
473 mkBigLHsPatTup = mkChunkified mkLHsPatTup
474
475 -- $big_tuples
476 -- #big_tuples#
477 --
478 -- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
479 -- we might concievably want to build such a massive tuple as part of the
480 -- output of a desugaring stage (notably that for list comprehensions).
481 --
482 -- We call tuples above this size \"big tuples\", and emulate them by
483 -- creating and pattern matching on >nested< tuples that are expressible
484 -- by GHC.
485 --
486 -- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
487 -- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
488 -- construction to be big.
489 --
490 -- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
491 -- and 'mkTupleCase' functions to do all your work with tuples you should be
492 -- fine, and not have to worry about the arity limitation at all.
493
494 -- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon
495 mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
496 -> [a] -- ^ Possible \"big\" list of things to construct from
497 -> a -- ^ Constructed thing made possible by recursive decomposition
498 mkChunkified small_tuple as = mk_big_tuple (chunkify as)
499 where
500 -- Each sub-list is short enough to fit in a tuple
501 mk_big_tuple [as] = small_tuple as
502 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
503
504 chunkify :: [a] -> [[a]]
505 -- ^ Split a list into lists that are small enough to have a corresponding
506 -- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
507 -- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
508 chunkify xs
509 | n_xs <= mAX_TUPLE_SIZE = [xs]
510 | otherwise = split xs
511 where
512 n_xs = length xs
513 split [] = []
514 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
515
516 {-
517 ************************************************************************
518 * *
519 Converting a Type to an HsType RdrName
520 * *
521 ************************************************************************
522
523 This is needed to implement GeneralizedNewtypeDeriving.
524 -}
525
526 toHsType :: Type -> LHsType RdrName
527 toHsType ty
528 | [] <- tvs_only
529 , [] <- theta
530 = to_hs_type tau
531 | otherwise
532 = noLoc $
533 mkExplicitHsForAllTy (map mk_hs_tvb tvs_only)
534 (noLoc $ map toHsType theta)
535 (to_hs_type tau)
536
537 where
538 (tvs, theta, tau) = tcSplitSigmaTy ty
539 tvs_only = filter isTypeVar tvs
540
541 to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv)
542 to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2)
543 to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args')
544 where
545 args' = filterOut isKind args
546 -- Source-language types have _implicit_ kind arguments,
547 -- so we must remove them here (Trac #8563)
548 to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) )
549 nlHsFunTy (toHsType arg) (toHsType res)
550 to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t)
551 to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
552 to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
553
554 mk_hs_tvb tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
555 (toHsKind (tyVarKind tv))
556
557 toHsKind :: Kind -> LHsKind RdrName
558 toHsKind = toHsType
559
560 --------- HsWrappers: type args, dict args, casts ---------
561 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
562 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
563
564 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
565 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
566 | otherwise = HsWrap co_fn e
567
568 mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
569 -> HsExpr id -> HsExpr id
570 mkHsWrapCo co e = mkHsWrap (coToHsWrapper co) e
571
572 mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b
573 -> HsExpr id -> HsExpr id
574 mkHsWrapCoR co e = mkHsWrap (coToHsWrapperR co) e
575
576 mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id
577 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
578
579 mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id
580 mkHsCmdCast co cmd | isTcReflCo co = cmd
581 | otherwise = HsCmdCast co cmd
582
583 coToHsWrapper :: TcCoercion -> HsWrapper -- A Nominal coercion
584 coToHsWrapper co | isTcReflCo co = idHsWrapper
585 | otherwise = mkWpCast (mkTcSubCo co)
586
587 coToHsWrapperR :: TcCoercion -> HsWrapper -- A Representational coercion
588 coToHsWrapperR co | isTcReflCo co = idHsWrapper
589 | otherwise = mkWpCast co
590
591 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
592 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
593 | otherwise = CoPat co_fn p ty
594
595 -- input coercion is Nominal
596 mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id
597 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
598 | otherwise = CoPat (mkWpCast (mkTcSubCo co)) pat ty
599
600 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
601 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
602
603 {-
604 l
605 ************************************************************************
606 * *
607 Bindings; with a location at the top
608 * *
609 ************************************************************************
610 -}
611
612 mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
613 -> HsBind RdrName
614 -- Not infix, with place holders for coercion and free vars
615 mkFunBind fn ms = FunBind { fun_id = fn
616 , fun_matches = mkMatchGroup Generated ms
617 , fun_co_fn = idHsWrapper
618 , bind_fvs = placeHolderNames
619 , fun_tick = [] }
620
621 mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
622 -> HsBind Name
623 -- In Name-land, with empty bind_fvs
624 mkTopFunBind origin fn ms = FunBind { fun_id = fn
625 , fun_matches = mkMatchGroupName origin ms
626 , fun_co_fn = idHsWrapper
627 , bind_fvs = emptyNameSet -- NB: closed
628 -- binding
629 , fun_tick = [] }
630
631 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
632 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
633
634 mkVarBind :: id -> LHsExpr id -> LHsBind id
635 mkVarBind var rhs = L (getLoc rhs) $
636 VarBind { var_id = var, var_rhs = rhs, var_inline = False }
637
638 mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
639 -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
640 mkPatSynBind name details lpat dir = PatSynBind psb
641 where
642 psb = PSB{ psb_id = name
643 , psb_args = details
644 , psb_def = lpat
645 , psb_dir = dir
646 , psb_fvs = placeHolderNames }
647
648 -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
649 -- considered infix.
650 isInfixFunBind :: HsBindLR id1 id2 -> Bool
651 isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
652 = any (isInfixMatch . unLoc) (unLoc matches)
653 isInfixFunBind _ = False
654
655
656 ------------
657 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
658 -> LHsExpr RdrName -> LHsBind RdrName
659 mk_easy_FunBind loc fun pats expr
660 = L loc $ mkFunBind (L loc fun) [mkMatch pats expr (noLoc emptyLocalBinds)]
661
662 ------------
663 mkMatch :: [LPat id] -> LHsExpr id -> Located (HsLocalBinds id)
664 -> LMatch id (LHsExpr id)
665 mkMatch pats expr lbinds
666 = noLoc (Match NonFunBindMatch (map paren pats) Nothing
667 (GRHSs (unguardedRHS noSrcSpan expr) lbinds))
668 where
669 paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
670 | otherwise = lp
671
672 {-
673 ************************************************************************
674 * *
675 Collecting binders
676 * *
677 ************************************************************************
678
679 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
680
681 ...
682 where
683 (x, y) = ...
684 f i j = ...
685 [a, b] = ...
686
687 it should return [x, y, f, a, b] (remember, order important).
688
689 Note [Collect binders only after renaming]
690 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
691 These functions should only be used on HsSyn *after* the renamer,
692 to return a [Name] or [Id]. Before renaming the record punning
693 and wild-card mechanism makes it hard to know what is bound.
694 So these functions should not be applied to (HsSyn RdrName)
695 -}
696
697 ----------------- Bindings --------------------------
698 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
699 collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
700 -- No pattern synonyms here
701 collectLocalBinders (HsIPBinds _) = []
702 collectLocalBinders EmptyLocalBinds = []
703
704 collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL]
705 -- Collect Id binders only, or Ids + pattern synonmys, respectively
706 collectHsIdBinders = collect_hs_val_binders True
707 collectHsValBinders = collect_hs_val_binders False
708
709 collectHsBindBinders :: HsBindLR idL idR -> [idL]
710 -- Collect both Ids and pattern-synonym binders
711 collectHsBindBinders b = collect_bind False b []
712
713 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
714 collectHsBindsBinders binds = collect_binds False binds []
715
716 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
717 -- Same as collectHsBindsBinders, but works over a list of bindings
718 collectHsBindListBinders = foldr (collect_bind False . unLoc) []
719
720 collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL]
721 collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds []
722 collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
723
724 collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id]
725 collect_out_binds ps = foldr (collect_binds ps . snd) []
726
727 collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL]
728 -- Collect Ids, or Ids + patter synonyms, depending on boolean flag
729 collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
730
731 collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL]
732 collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
733 collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
734 collect_bind _ (VarBind { var_id = f }) acc = f : acc
735 collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
736 -- I don't think we want the binders from the abe_binds
737 -- The only time we collect binders from a typechecked
738 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
739 collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
740 if omitPatSyn then acc else ps : acc
741
742 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
743 -- Used exclusively for the bindings of an instance decl which are all FunBinds
744 collectMethodBinders binds = foldrBag (get . unLoc) [] binds
745 where
746 get (FunBind { fun_id = f }) fs = f : fs
747 get _ fs = fs
748 -- Someone else complains about non-FunBinds
749
750 ----------------- Statements --------------------------
751 collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]
752 collectLStmtsBinders = concatMap collectLStmtBinders
753
754 collectStmtsBinders :: [StmtLR idL idR body] -> [idL]
755 collectStmtsBinders = concatMap collectStmtBinders
756
757 collectLStmtBinders :: LStmtLR idL idR body -> [idL]
758 collectLStmtBinders = collectStmtBinders . unLoc
759
760 collectStmtBinders :: StmtLR idL idR body -> [idL]
761 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
762 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
763 collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
764 collectStmtBinders (BodyStmt {}) = []
765 collectStmtBinders (LastStmt {}) = []
766 collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders
767 $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
768 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
769 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
770 collectStmtBinders ApplicativeStmt{} = []
771
772
773 ----------------- Patterns --------------------------
774 collectPatBinders :: LPat a -> [a]
775 collectPatBinders pat = collect_lpat pat []
776
777 collectPatsBinders :: [LPat a] -> [a]
778 collectPatsBinders pats = foldr collect_lpat [] pats
779
780 -------------
781 collect_lpat :: LPat name -> [name] -> [name]
782 collect_lpat (L _ pat) bndrs
783 = go pat
784 where
785 go (VarPat (L _ var)) = var : bndrs
786 go (WildPat _) = bndrs
787 go (LazyPat pat) = collect_lpat pat bndrs
788 go (BangPat pat) = collect_lpat pat bndrs
789 go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs
790 go (ViewPat _ pat _) = collect_lpat pat bndrs
791 go (ParPat pat) = collect_lpat pat bndrs
792
793 go (ListPat pats _ _) = foldr collect_lpat bndrs pats
794 go (PArrPat pats _) = foldr collect_lpat bndrs pats
795 go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
796
797 go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
798 go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
799 -- See Note [Dictionary binders in ConPatOut]
800 go (LitPat _) = bndrs
801 go (NPat _ _ _) = bndrs
802 go (NPlusKPat (L _ n) _ _ _) = n : bndrs
803
804 go (SigPatIn pat _) = collect_lpat pat bndrs
805 go (SigPatOut pat _) = collect_lpat pat bndrs
806 go (SplicePat _) = bndrs
807 go (CoPat _ pat _) = go pat
808
809 {-
810 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
811 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
812 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
813 of a ConPatOut pattern. For most calls it doesn't matter, because
814 it's pre-typechecker and there are no ConPatOuts. But it does matter
815 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
816 collectPatBinders. In a lazy pattern, for example f ~(C x y) = ...,
817 we want to generate bindings for x,y but not for dictionaries bound by
818 C. (The type checker ensures they would not be used.)
819
820 Desugaring of arrow case expressions needs these bindings (see DsArrows
821 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
822 own pat-binder-collector:
823
824 Here's the problem. Consider
825
826 data T a where
827 C :: Num a => a -> Int -> T a
828
829 f ~(C (n+1) m) = (n,m)
830
831 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
832 and *also* uses that dictionary to match the (n+1) pattern. Yet, the
833 variables bound by the lazy pattern are n,m, *not* the dictionary d.
834 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
835 -}
836
837 hsGroupBinders :: HsGroup Name -> [Name]
838 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
839 hs_instds = inst_decls, hs_fords = foreign_decls })
840 = collectHsValBinders val_decls
841 ++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
842
843 hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
844 -> [LForeignDecl Name] -> [Name]
845 -- We need to look at instance declarations too,
846 -- because their associated types may bind data constructors
847 hsTyClForeignBinders tycl_decls inst_decls foreign_decls
848 = map unLoc (hsForeignDeclsBinders foreign_decls)
849 ++ getSelectorNames (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
850 `mappend` foldMap hsLInstDeclBinders inst_decls)
851 where
852 getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name]
853 getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
854
855 -------------------
856 hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name])
857 -- ^ Returns all the /binding/ names of the decl. The first one is
858 -- guaranteed to be the name of the decl. The first component
859 -- represents all binding names except record fields; the second
860 -- represents field occurrences. For record fields mentioned in
861 -- multiple constructors, the SrcLoc will be from the first occurrence.
862 --
863 -- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
864 -- See Note [SrcSpan for binders]
865
866 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
867 = ([L loc name], [])
868 hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], [])
869 hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name
870 , tcdSigs = sigs, tcdATs = ats }))
871 = (L loc cls_name :
872 [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
873 [ L mem_loc mem_name | L mem_loc (TypeSig ns _ _) <- sigs, L _ mem_name <- ns ]
874 , [])
875 hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }))
876 = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
877
878 -------------------
879 hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
880 -- See Note [SrcSpan for binders]
881 hsForeignDeclsBinders foreign_decls
882 = [ L decl_loc n
883 | L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls]
884
885
886
887 -------------------
888 hsPatSynBinders :: HsValBinds RdrName
889 -> ([Located RdrName], [Located RdrName])
890 -- Collect pattern-synonym binders only, not Ids
891 -- See Note [SrcSpan for binders]
892 hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr ([],[]) binds
893 hsPatSynBinders _ = panic "hsPatSynBinders"
894
895 addPatSynBndr :: LHsBindLR id id -> ([Located id], [Located id])
896 -> ([Located id], [Located id]) -- (selectors, other)
897 -- See Note [SrcSpan for binders]
898 addPatSynBndr bind (sels, pss)
899 | L bind_loc (PatSynBind (PSB { psb_id = L _ n
900 , psb_args = RecordPatSyn as })) <- bind
901 = (map recordPatSynSelectorId as ++ sels, L bind_loc n : pss)
902 | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
903 = (sels, L bind_loc n : pss)
904 | otherwise
905 = (sels, pss)
906
907 -------------------
908 hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
909 hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
910 = foldMap (hsDataFamInstBinders . unLoc) dfis
911 hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
912 = hsDataFamInstBinders fi
913 hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
914
915 -------------------
916 -- the SrcLoc returned are for the whole declarations, not just the names
917 hsDataFamInstBinders :: DataFamInstDecl name -> ([Located name], [LFieldOcc name])
918 hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
919 = hsDataDefnBinders defn
920 -- There can't be repeated symbols because only data instances have binders
921
922 -------------------
923 -- the SrcLoc returned are for the whole declarations, not just the names
924 hsDataDefnBinders :: HsDataDefn name -> ([Located name], [LFieldOcc name])
925 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
926 = hsConDeclsBinders cons
927 -- See Note [Binders in family instances]
928
929 -------------------
930 hsConDeclsBinders :: [LConDecl name] -> ([Located name], [LFieldOcc name])
931 -- See hsLTyClDeclBinders for what this does
932 -- The function is boringly complicated because of the records
933 -- And since we only have equality, we have to be a little careful
934 hsConDeclsBinders cons = go id cons
935 where go :: ([LFieldOcc name] -> [LFieldOcc name])
936 -> [LConDecl name] -> ([Located name], [LFieldOcc name])
937 go _ [] = ([], [])
938 go remSeen (r:rs) =
939 -- don't re-mangle the location of field names, because we don't
940 -- have a record of the full location of the field declaration anyway
941 case r of
942 -- remove only the first occurrence of any seen field in order to
943 -- avoid circumventing detection of duplicate fields (#9156)
944 L loc (ConDecl { con_names = names, con_details = RecCon flds }) ->
945 (map (L loc . unLoc) names ++ ns, r' ++ fs)
946 where r' = remSeen (concatMap (cd_fld_names . unLoc)
947 (unLoc flds))
948 remSeen' = foldr (.) remSeen [deleteBy ((==) `on` rdrNameFieldOcc . unLoc) v | v <- r']
949 (ns, fs) = go remSeen' rs
950 L loc (ConDecl { con_names = names }) ->
951 (map (L loc . unLoc) names ++ ns, fs)
952 where (ns, fs) = go remSeen rs
953
954 {-
955
956 Note [SrcSpan for binders]
957 ~~~~~~~~~~~~~~~~~~~~~~~~~~
958 When extracting the (Located RdrNme) for a binder, at least for the
959 main name (the TyCon of a type declaration etc), we want to give it
960 the @SrcSpan@ of the whole /declaration/, not just the name itself
961 (which is how it appears in the syntax tree). This SrcSpan (for the
962 entire declaration) is used as the SrcSpan for the Name that is
963 finally produced, and hence for error messages. (See Trac #8607.)
964
965 Note [Binders in family instances]
966 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
967 In a type or data family instance declaration, the type
968 constructor is an *occurrence* not a binding site
969 type instance T Int = Int -> Int -- No binders
970 data instance S Bool = S1 | S2 -- Binders are S1,S2
971
972
973 ************************************************************************
974 * *
975 Collecting binders the user did not write
976 * *
977 ************************************************************************
978
979 The job of this family of functions is to run through binding sites and find the set of all Names
980 that were defined "implicitly", without being explicitly written by the user.
981
982 The main purpose is to find names introduced by record wildcards so that we can avoid
983 warning the user when they don't use those names (#4404)
984 -}
985
986 lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet
987 lStmtsImplicits = hs_lstmts
988 where
989 hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet
990 hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
991
992 hs_stmt :: StmtLR Name idR (Located (body idR)) -> NameSet
993 hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
994 hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args)
995 where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat
996 do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts
997 hs_stmt (LetStmt binds) = hs_local_binds (unLoc binds)
998 hs_stmt (BodyStmt {}) = emptyNameSet
999 hs_stmt (LastStmt {}) = emptyNameSet
1000 hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
1001 hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
1002 hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
1003
1004 hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
1005 hs_local_binds (HsIPBinds _) = emptyNameSet
1006 hs_local_binds EmptyLocalBinds = emptyNameSet
1007
1008 hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
1009 hsValBindsImplicits (ValBindsOut binds _)
1010 = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
1011 hsValBindsImplicits (ValBindsIn binds _)
1012 = lhsBindsImplicits binds
1013
1014 lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
1015 lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet
1016 where
1017 lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
1018 lhs_bind _ = emptyNameSet
1019
1020 lPatImplicits :: LPat Name -> NameSet
1021 lPatImplicits = hs_lpat
1022 where
1023 hs_lpat (L _ pat) = hs_pat pat
1024
1025 hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet
1026
1027 hs_pat (LazyPat pat) = hs_lpat pat
1028 hs_pat (BangPat pat) = hs_lpat pat
1029 hs_pat (AsPat _ pat) = hs_lpat pat
1030 hs_pat (ViewPat _ pat _) = hs_lpat pat
1031 hs_pat (ParPat pat) = hs_lpat pat
1032 hs_pat (ListPat pats _ _) = hs_lpats pats
1033 hs_pat (PArrPat pats _) = hs_lpats pats
1034 hs_pat (TuplePat pats _ _) = hs_lpats pats
1035
1036 hs_pat (SigPatIn pat _) = hs_lpat pat
1037 hs_pat (SigPatOut pat _) = hs_lpat pat
1038 hs_pat (CoPat _ pat _) = hs_pat pat
1039
1040 hs_pat (ConPatIn _ ps) = details ps
1041 hs_pat (ConPatOut {pat_args=ps}) = details ps
1042
1043 hs_pat _ = emptyNameSet
1044
1045 details (PrefixCon ps) = hs_lpats ps
1046 details (RecCon fs) = hs_lpats explicit `unionNameSet` mkNameSet (collectPatsBinders implicit)
1047 where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
1048 | (i, fld) <- [0..] `zip` rec_flds fs
1049 , let pat = hsRecFieldArg
1050 (unLoc fld)
1051 pat_explicit = maybe True (i<) (rec_dotdot fs)]
1052 details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2