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