never executed always true always false
1 -- (c) The University of Glasgow 2006
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an
5 -- orphan
6 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
7 -- in module Language.Haskell.Syntax.Extension
8 {-# LANGUAGE TypeFamilies #-}
9
10 module GHC.Tc.Utils.Env(
11 TyThing(..), TcTyThing(..), TcId,
12
13 -- Instance environment, and InstInfo type
14 InstInfo(..), iDFunId, pprInstInfoDetails,
15 simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
16 InstBindings(..),
17
18 -- Global environment
19 tcExtendGlobalEnv, tcExtendTyConEnv,
20 tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
21 tcExtendGlobalValEnv, tcTyThBinders,
22 tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
23 tcLookupTyCon, tcLookupClass,
24 tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
25 tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
26 tcLookupLocatedClass, tcLookupAxiom,
27 lookupGlobal, ioLookupDataCon,
28 addTypecheckedBinds,
29
30 -- Local environment
31 tcExtendKindEnv, tcExtendKindEnvList,
32 tcExtendTyVarEnv, tcExtendNameTyVarEnv,
33 tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
34 tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
35 tcExtendBinderStack, tcExtendLocalTypeEnv,
36 isTypeClosedLetBndr,
37 tcCheckUsage,
38
39 tcLookup, tcLookupLocated, tcLookupLocalIds,
40 tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
41 tcLookupTcTyCon,
42 tcLookupLcl_maybe,
43 getInLocalScope,
44 wrongThingErr, pprBinders,
45
46 tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
47 getTypeSigNames,
48 tcExtendRecEnv, -- For knot-tying
49
50 -- Tidying
51 tcInitTidyEnv, tcInitOpenTidyEnv,
52
53 -- Instances
54 tcLookupInstance, tcGetInstEnvs,
55
56 -- Rules
57 tcExtendRules,
58
59 -- Defaults
60 tcGetDefaultTys,
61
62 -- Template Haskell stuff
63 checkWellStaged, tcMetaTy, thLevel,
64 topIdLvl, isBrackStage,
65
66 -- New Ids
67 newDFunName,
68 newFamInstTyConName, newFamInstAxiomName,
69 mkStableIdFromString, mkStableIdFromName,
70 mkWrapperName
71 ) where
72
73 import GHC.Prelude
74
75 import GHC.Driver.Env
76 import GHC.Driver.Session
77
78 import GHC.Builtin.Names
79 import GHC.Builtin.Types
80
81 import GHC.Runtime.Context
82
83 import GHC.Hs
84
85 import GHC.Iface.Env
86 import GHC.Iface.Load
87
88 import GHC.Tc.Errors.Types
89 import GHC.Tc.Utils.Monad
90 import GHC.Tc.Utils.TcMType
91 import GHC.Tc.Utils.TcType
92 import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper)
93 import {-# SOURCE #-} GHC.Tc.Utils.Unify ( tcSubMult )
94 import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) )
95
96 import GHC.Core.UsageEnv
97 import GHC.Core.InstEnv
98 import GHC.Core.DataCon ( DataCon, flSelector )
99 import GHC.Core.PatSyn ( PatSyn )
100 import GHC.Core.ConLike
101 import GHC.Core.TyCon
102 import GHC.Core.Type
103 import GHC.Core.Coercion.Axiom
104 import GHC.Core.Class
105
106 import GHC.Unit.Module
107 import GHC.Unit.Home
108 import GHC.Unit.External
109
110 import GHC.Utils.Outputable
111 import GHC.Utils.Panic
112 import GHC.Utils.Encoding
113 import GHC.Utils.Misc ( HasDebugCallStack )
114
115 import GHC.Data.FastString
116 import GHC.Data.Bag
117 import GHC.Data.List.SetOps
118 import GHC.Data.Maybe( MaybeErr(..), orElse )
119
120 import GHC.Types.SrcLoc
121 import GHC.Types.Basic hiding( SuccessFlag(..) )
122 import GHC.Types.TypeEnv
123 import GHC.Types.SourceFile
124 import GHC.Types.Name
125 import GHC.Types.Name.Set
126 import GHC.Types.Name.Env
127 import GHC.Types.Id
128 import GHC.Types.Var
129 import GHC.Types.Var.Env
130 import GHC.Types.Name.Reader
131 import GHC.Types.TyThing
132 import GHC.Types.Error
133 import qualified GHC.LanguageExtensions as LangExt
134
135 import Data.IORef
136 import Data.List (intercalate)
137 import Control.Monad
138 import GHC.Driver.Env.KnotVars
139
140 {- *********************************************************************
141 * *
142 An IO interface to looking up globals
143 * *
144 ********************************************************************* -}
145
146 lookupGlobal :: HscEnv -> Name -> IO TyThing
147 -- A variant of lookupGlobal_maybe for the clients which are not
148 -- interested in recovering from lookup failure and accept panic.
149 lookupGlobal hsc_env name
150 = do {
151 mb_thing <- lookupGlobal_maybe hsc_env name
152 ; case mb_thing of
153 Succeeded thing -> return thing
154 Failed msg -> pprPanic "lookupGlobal" msg
155 }
156
157 lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
158 -- This may look up an Id that one has previously looked up.
159 -- If so, we are going to read its interface file, and add its bindings
160 -- to the ExternalPackageTable.
161 lookupGlobal_maybe hsc_env name
162 = do { -- Try local envt
163 let mod = icInteractiveModule (hsc_IC hsc_env)
164 home_unit = hsc_home_unit hsc_env
165 tcg_semantic_mod = homeModuleInstantiation home_unit mod
166
167 ; if nameIsLocalOrFrom tcg_semantic_mod name
168 then (return
169 (Failed (text "Can't find local name: " <+> ppr name)))
170 -- Internal names can happen in GHCi
171 else
172 -- Try home package table and external package table
173 lookupImported_maybe hsc_env name
174 }
175
176 lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
177 -- Returns (Failed err) if we can't find the interface file for the thing
178 lookupImported_maybe hsc_env name
179 = do { mb_thing <- lookupType hsc_env name
180 ; case mb_thing of
181 Just thing -> return (Succeeded thing)
182 Nothing -> importDecl_maybe hsc_env name
183 }
184
185 importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
186 importDecl_maybe hsc_env name
187 | Just thing <- wiredInNameTyThing_maybe name
188 = do { when (needWiredInHomeIface thing)
189 (initIfaceLoad hsc_env (loadWiredInHomeIface name))
190 -- See Note [Loading instances for wired-in things]
191 ; return (Succeeded thing) }
192 | otherwise
193 = initIfaceLoad hsc_env (importDecl name)
194
195 ioLookupDataCon :: HscEnv -> Name -> IO DataCon
196 ioLookupDataCon hsc_env name = do
197 mb_thing <- ioLookupDataCon_maybe hsc_env name
198 case mb_thing of
199 Succeeded thing -> return thing
200 Failed msg -> pprPanic "lookupDataConIO" msg
201
202 ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon)
203 ioLookupDataCon_maybe hsc_env name = do
204 thing <- lookupGlobal hsc_env name
205 return $ case thing of
206 AConLike (RealDataCon con) -> Succeeded con
207 _ -> Failed $
208 pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
209 text "used as a data constructor"
210
211 addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
212 addTypecheckedBinds tcg_env binds
213 | isHsBootOrSig (tcg_src tcg_env) = tcg_env
214 -- Do not add the code for record-selector bindings
215 -- when compiling hs-boot files
216 | otherwise = tcg_env { tcg_binds = foldr unionBags
217 (tcg_binds tcg_env)
218 binds }
219
220 {-
221 ************************************************************************
222 * *
223 * tcLookupGlobal *
224 * *
225 ************************************************************************
226
227 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
228 unless you know that the SrcSpan in the monad is already set to the
229 span of the Name.
230 -}
231
232
233 tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing
234 -- c.f. GHC.IfaceToCore.tcIfaceGlobal
235 tcLookupLocatedGlobal name
236 = addLocMA tcLookupGlobal name
237
238 tcLookupGlobal :: Name -> TcM TyThing
239 -- The Name is almost always an ExternalName, but not always
240 -- In GHCi, we may make command-line bindings (ghci> let x = True)
241 -- that bind a GlobalId, but with an InternalName
242 tcLookupGlobal name
243 = do { -- Try local envt
244 env <- getGblEnv
245 ; case lookupNameEnv (tcg_type_env env) name of {
246 Just thing -> return thing ;
247 Nothing ->
248
249 -- Should it have been in the local envt?
250 -- (NB: use semantic mod here, since names never use
251 -- identity module, see Note [Identity versus semantic module].)
252 if nameIsLocalOrFrom (tcg_semantic_mod env) name
253 then notFound name -- Internal names can happen in GHCi
254 else
255
256 -- Try home package table and external package table
257 do { mb_thing <- tcLookupImported_maybe name
258 ; case mb_thing of
259 Succeeded thing -> return thing
260 Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)
261 }}}
262
263 -- Look up only in this module's global env't. Don't look in imports, etc.
264 -- Panic if it's not there.
265 tcLookupGlobalOnly :: Name -> TcM TyThing
266 tcLookupGlobalOnly name
267 = do { env <- getGblEnv
268 ; return $ case lookupNameEnv (tcg_type_env env) name of
269 Just thing -> thing
270 Nothing -> pprPanic "tcLookupGlobalOnly" (ppr name) }
271
272 tcLookupDataCon :: Name -> TcM DataCon
273 tcLookupDataCon name = do
274 thing <- tcLookupGlobal name
275 case thing of
276 AConLike (RealDataCon con) -> return con
277 _ -> wrongThingErr "data constructor" (AGlobal thing) name
278
279 tcLookupPatSyn :: Name -> TcM PatSyn
280 tcLookupPatSyn name = do
281 thing <- tcLookupGlobal name
282 case thing of
283 AConLike (PatSynCon ps) -> return ps
284 _ -> wrongThingErr "pattern synonym" (AGlobal thing) name
285
286 tcLookupConLike :: Name -> TcM ConLike
287 tcLookupConLike name = do
288 thing <- tcLookupGlobal name
289 case thing of
290 AConLike cl -> return cl
291 _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name
292
293 tcLookupClass :: Name -> TcM Class
294 tcLookupClass name = do
295 thing <- tcLookupGlobal name
296 case thing of
297 ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
298 _ -> wrongThingErr "class" (AGlobal thing) name
299
300 tcLookupTyCon :: Name -> TcM TyCon
301 tcLookupTyCon name = do
302 thing <- tcLookupGlobal name
303 case thing of
304 ATyCon tc -> return tc
305 _ -> wrongThingErr "type constructor" (AGlobal thing) name
306
307 tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
308 tcLookupAxiom name = do
309 thing <- tcLookupGlobal name
310 case thing of
311 ACoAxiom ax -> return ax
312 _ -> wrongThingErr "axiom" (AGlobal thing) name
313
314 tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
315 tcLookupLocatedGlobalId = addLocMA tcLookupId
316
317 tcLookupLocatedClass :: LocatedA Name -> TcM Class
318 tcLookupLocatedClass = addLocMA tcLookupClass
319
320 tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
321 tcLookupLocatedTyCon = addLocMA tcLookupTyCon
322
323 -- Find the instance that exactly matches a type class application. The class arguments must be precisely
324 -- the same as in the instance declaration (modulo renaming & casts).
325 --
326 tcLookupInstance :: Class -> [Type] -> TcM ClsInst
327 tcLookupInstance cls tys
328 = do { instEnv <- tcGetInstEnvs
329 ; case lookupUniqueInstEnv instEnv cls tys of
330 Left err ->
331 failWithTc $ TcRnUnknownMessage
332 $ mkPlainError noHints (text "Couldn't match instance:" <+> err)
333 Right (inst, tys)
334 | uniqueTyVars tys -> return inst
335 | otherwise -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints errNotExact)
336 }
337 where
338 errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
339
340 uniqueTyVars tys = all isTyVarTy tys
341 && hasNoDups (map (getTyVar "tcLookupInstance") tys)
342
343 tcGetInstEnvs :: TcM InstEnvs
344 -- Gets both the external-package inst-env
345 -- and the home-pkg inst env (includes module being compiled)
346 tcGetInstEnvs = do { eps <- getEps
347 ; env <- getGblEnv
348 ; return (InstEnvs { ie_global = eps_inst_env eps
349 , ie_local = tcg_inst_env env
350 , ie_visible = tcVisibleOrphanMods env }) }
351
352 instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
353 lookupThing = tcLookupGlobal
354
355 {-
356 ************************************************************************
357 * *
358 Extending the global environment
359 * *
360 ************************************************************************
361 -}
362
363 setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
364 -- Use this to update the global type env
365 -- It updates both * the normal tcg_type_env field
366 -- * the tcg_type_env_var field seen by interface files
367 setGlobalTypeEnv tcg_env new_type_env
368 = do { -- Sync the type-envt variable seen by interface files
369 ; case lookupKnotVars (tcg_type_env_var tcg_env) (tcg_mod tcg_env) of
370 Just tcg_env_var -> writeMutVar tcg_env_var new_type_env
371 Nothing -> return ()
372 ; return (tcg_env { tcg_type_env = new_type_env }) }
373
374
375 tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
376 -- Just extend the global environment with some TyThings
377 -- Do not extend tcg_tcs, tcg_patsyns etc
378 tcExtendGlobalEnvImplicit things thing_inside
379 = do { tcg_env <- getGblEnv
380 ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things
381 ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
382 ; setGblEnv tcg_env' thing_inside }
383
384 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
385 -- Given a mixture of Ids, TyCons, Classes, all defined in the
386 -- module being compiled, extend the global environment
387 tcExtendGlobalEnv things thing_inside
388 = do { env <- getGblEnv
389 ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
390 tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
391 ; setGblEnv env' $
392 tcExtendGlobalEnvImplicit things thing_inside
393 }
394
395 tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
396 -- Given a mixture of Ids, TyCons, Classes, all defined in the
397 -- module being compiled, extend the global environment
398 tcExtendTyConEnv tycons thing_inside
399 = do { env <- getGblEnv
400 ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }
401 ; setGblEnv env' $
402 tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
403 }
404
405 -- Given a [TyThing] of "non-value" bindings coming from type decls
406 -- (constructors, field selectors, class methods) return their
407 -- TH binding levels (to be added to a LclEnv).
408 -- See GHC ticket #17820 .
409 tcTyThBinders :: [TyThing] -> TcM ThBindEnv
410 tcTyThBinders implicit_things = do
411 stage <- getStage
412 let th_lvl = thLevel stage
413 th_bndrs = mkNameEnv
414 [ ( n , (TopLevel, th_lvl) ) | n <- names ]
415 return th_bndrs
416 where
417 names = concatMap get_names implicit_things
418 get_names (AConLike acl) =
419 conLikeName acl : map flSelector (conLikeFieldLabels acl)
420 get_names (AnId i) = [idName i]
421 get_names _ = []
422
423 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
424 -- Same deal as tcExtendGlobalEnv, but for Ids
425 tcExtendGlobalValEnv ids thing_inside
426 = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
427
428 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
429 -- Extend the global environments for the type/class knot tying game
430 -- Just like tcExtendGlobalEnv, except the argument is a list of pairs
431 tcExtendRecEnv gbl_stuff thing_inside
432 = do { tcg_env <- getGblEnv
433 ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
434 tcg_env' = tcg_env { tcg_type_env = ge' }
435 -- No need for setGlobalTypeEnv (which side-effects the
436 -- tcg_type_env_var); tcExtendRecEnv is used just
437 -- when kind-check a group of type/class decls. It would
438 -- in any case be wrong for an interface-file decl to end up
439 -- with a TcTyCon in it!
440 ; setGblEnv tcg_env' thing_inside }
441
442 {-
443 ************************************************************************
444 * *
445 \subsection{The local environment}
446 * *
447 ************************************************************************
448 -}
449
450 tcLookupLocated :: LocatedA Name -> TcM TcTyThing
451 tcLookupLocated = addLocMA tcLookup
452
453 tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
454 tcLookupLcl_maybe name
455 = do { local_env <- getLclTypeEnv
456 ; return (lookupNameEnv local_env name) }
457
458 tcLookup :: Name -> TcM TcTyThing
459 tcLookup name = do
460 local_env <- getLclTypeEnv
461 case lookupNameEnv local_env name of
462 Just thing -> return thing
463 Nothing -> (AGlobal <$> tcLookupGlobal name)
464
465 tcLookupTyVar :: Name -> TcM TcTyVar
466 tcLookupTyVar name
467 = do { thing <- tcLookup name
468 ; case thing of
469 ATyVar _ tv -> return tv
470 _ -> pprPanic "tcLookupTyVar" (ppr name) }
471
472 tcLookupId :: Name -> TcM Id
473 -- Used when we aren't interested in the binding level, nor refinement.
474 -- The "no refinement" part means that we return the un-refined Id regardless
475 --
476 -- The Id is never a DataCon. (Why does that matter? see GHC.Tc.Gen.Expr.tcId)
477 tcLookupId name = do
478 thing <- tcLookupIdMaybe name
479 case thing of
480 Just id -> return id
481 _ -> pprPanic "tcLookupId" (ppr name)
482
483 tcLookupIdMaybe :: Name -> TcM (Maybe Id)
484 tcLookupIdMaybe name
485 = do { thing <- tcLookup name
486 ; case thing of
487 ATcId { tct_id = id} -> return $ Just id
488 AGlobal (AnId id) -> return $ Just id
489 _ -> return Nothing }
490
491 tcLookupLocalIds :: [Name] -> TcM [TcId]
492 -- We expect the variables to all be bound, and all at
493 -- the same level as the lookup. Only used in one place...
494 tcLookupLocalIds ns
495 = do { env <- getLclEnv
496 ; return (map (lookup (tcl_env env)) ns) }
497 where
498 lookup lenv name
499 = case lookupNameEnv lenv name of
500 Just (ATcId { tct_id = id }) -> id
501 _ -> pprPanic "tcLookupLocalIds" (ppr name)
502
503 -- inferInitialKind has made a suitably-shaped kind for the type or class
504 -- Look it up in the local environment. This is used only for tycons
505 -- that we're currently type-checking, so we're sure to find a TcTyCon.
506 tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon
507 tcLookupTcTyCon name = do
508 thing <- tcLookup name
509 case thing of
510 ATcTyCon tc -> return tc
511 _ -> pprPanic "tcLookupTcTyCon" (ppr name)
512
513 getInLocalScope :: TcM (Name -> Bool)
514 getInLocalScope = do { lcl_env <- getLclTypeEnv
515 ; return (`elemNameEnv` lcl_env) }
516
517 tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
518 -- Used only during kind checking, for TcThings that are
519 -- ATcTyCon or APromotionErr
520 -- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
521 tcExtendKindEnvList things thing_inside
522 = do { traceTc "tcExtendKindEnvList" (ppr things)
523 ; updLclEnv upd_env thing_inside }
524 where
525 upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
526
527 tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
528 -- A variant of tcExtendKindEvnList
529 tcExtendKindEnv extra_env thing_inside
530 = do { traceTc "tcExtendKindEnv" (ppr extra_env)
531 ; updLclEnv upd_env thing_inside }
532 where
533 upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }
534
535 -----------------------
536 -- Scoped type and kind variables
537 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
538 tcExtendTyVarEnv tvs thing_inside
539 = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside
540
541 tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r
542 tcExtendNameTyVarEnv binds thing_inside
543 -- this should be used only for explicitly mentioned scoped variables.
544 -- thus, no coercion variables
545 = tc_extend_local_env NotTopLevel names $
546 tcExtendBinderStack tv_binds $
547 thing_inside
548 where
549 tv_binds :: [TcBinder]
550 tv_binds = [TcTvBndr name tv | (name,tv) <- binds]
551
552 names = [(name, ATyVar name tv) | (name, tv) <- binds]
553
554 isTypeClosedLetBndr :: Id -> Bool
555 -- See Note [Bindings with closed types] in GHC.Tc.Types
556 isTypeClosedLetBndr = noFreeVarsOfType . idType
557
558 tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
559 -- Used for binding the recursive uses of Ids in a binding
560 -- both top-level value bindings and nested let/where-bindings
561 -- Does not extend the TcBinderStack
562 tcExtendRecIds pairs thing_inside
563 = tc_extend_local_env NotTopLevel
564 [ (name, ATcId { tct_id = let_id
565 , tct_info = NonClosedLet emptyNameSet False })
566 | (name, let_id) <- pairs ] $
567 thing_inside
568
569 tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
570 -- Used for binding the Ids that have a complete user type signature
571 -- Does not extend the TcBinderStack
572 tcExtendSigIds top_lvl sig_ids thing_inside
573 = tc_extend_local_env top_lvl
574 [ (idName id, ATcId { tct_id = id
575 , tct_info = info })
576 | id <- sig_ids
577 , let closed = isTypeClosedLetBndr id
578 info = NonClosedLet emptyNameSet closed ]
579 thing_inside
580
581
582 tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
583 -> [TcId] -> TcM a -> TcM a
584 -- Used for both top-level value bindings and nested let/where-bindings
585 -- Adds to the TcBinderStack too
586 tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
587 ids thing_inside
588 = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $
589 tc_extend_local_env top_lvl
590 [ (idName id, ATcId { tct_id = id
591 , tct_info = mk_tct_info id })
592 | id <- ids ]
593 thing_inside
594 where
595 mk_tct_info id
596 | type_closed && isEmptyNameSet rhs_fvs = ClosedLet
597 | otherwise = NonClosedLet rhs_fvs type_closed
598 where
599 name = idName id
600 rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet
601 type_closed = isTypeClosedLetBndr id &&
602 (fv_type_closed || hasCompleteSig sig_fn name)
603
604 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
605 -- For lambda-bound and case-bound Ids
606 -- Extends the TcBinderStack as well
607 tcExtendIdEnv ids thing_inside
608 = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
609
610 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
611 -- Exactly like tcExtendIdEnv2, but for a single (name,id) pair
612 tcExtendIdEnv1 name id thing_inside
613 = tcExtendIdEnv2 [(name,id)] thing_inside
614
615 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
616 tcExtendIdEnv2 names_w_ids thing_inside
617 = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
618 | (_,mono_id) <- names_w_ids ] $
619 tc_extend_local_env NotTopLevel
620 [ (name, ATcId { tct_id = id
621 , tct_info = NotLetBound })
622 | (name,id) <- names_w_ids]
623 thing_inside
624
625 tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
626 tc_extend_local_env top_lvl extra_env thing_inside
627 -- Precondition: the argument list extra_env has TcTyThings
628 -- that ATcId or ATyVar, but nothing else
629 --
630 -- Invariant: the ATcIds are fully zonked. Reasons:
631 -- (a) The kinds of the forall'd type variables are defaulted
632 -- (see Kind.defaultKind, done in skolemiseQuantifiedTyVar)
633 -- (b) There are no via-Indirect occurrences of the bound variables
634 -- in the types, because instantiation does not look through such things
635 -- (c) The call to tyCoVarsOfTypes is ok without looking through refs
636
637 -- The second argument of type TyVarSet is a set of type variables
638 -- that are bound together with extra_env and should not be regarded
639 -- as free in the types of extra_env.
640 = do { traceTc "tc_extend_local_env" (ppr extra_env)
641 ; stage <- getStage
642 ; env0@(TcLclEnv { tcl_rdr = rdr_env
643 , tcl_th_bndrs = th_bndrs
644 , tcl_env = lcl_type_env }) <- getLclEnv
645
646 ; let thlvl = (top_lvl, thLevel stage)
647
648 env1 = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env
649 [ n | (n, _) <- extra_env, isInternalName n ]
650 -- The LocalRdrEnv contains only non-top-level names
651 -- (GlobalRdrEnv handles the top level)
652
653 , tcl_th_bndrs = extendNameEnvList th_bndrs
654 [(n, thlvl) | (n, ATcId {}) <- extra_env]
655 -- We only track Ids in tcl_th_bndrs
656
657 , tcl_env = extendNameEnvList lcl_type_env extra_env }
658
659 -- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and
660 -- Template Haskell staging env simultaneously. Reason for extending
661 -- LocalRdrEnv: after running a TH splice we need to do renaming.
662
663 ; setLclEnv env1 thing_inside }
664
665 tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv
666 tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
667 = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things }
668
669 -- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the
670 -- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the
671 -- usage environment. See also Note [Wrapper returned from tcSubMult] in
672 -- GHC.Tc.Utils.Unify, which applies to the wrapper returned from this function.
673 tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper)
674 tcCheckUsage name id_mult thing_inside
675 = do { (local_usage, result) <- tcCollectingUsage thing_inside
676 ; wrapper <- check_then_add_usage local_usage
677 ; return (result, wrapper) }
678 where
679 check_then_add_usage :: UsageEnv -> TcM HsWrapper
680 -- Checks that the usage of the newly introduced binder is compatible with
681 -- its multiplicity, and combines the usage of non-new binders to |uenv|
682 check_then_add_usage uenv
683 = do { let actual_u = lookupUE uenv name
684 ; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u)
685 ; wrapper <- case actual_u of
686 Bottom -> return idHsWrapper
687 Zero -> tcSubMult (UsageEnvironmentOf name) Many id_mult
688 MUsage m -> do { m <- promote_mult m
689 ; tcSubMult (UsageEnvironmentOf name) m id_mult }
690 ; tcEmitBindingUsage (deleteUE uenv name)
691 ; return wrapper }
692
693 -- This is gross. The problem is in test case typecheck/should_compile/T18998:
694 -- f :: a %1-> Id n a -> Id n a
695 -- f x (MkId _) = MkId x
696 -- where MkId is a GADT constructor. Multiplicity polymorphism of constructors
697 -- invents a new multiplicity variable p[2] for the application MkId x. This
698 -- variable is at level 2, bumped because of the GADT pattern-match (MkId _).
699 -- We eventually unify the variable with One, due to the call to tcSubMult in
700 -- tcCheckUsage. But by then, we're at TcLevel 1, and so the level-check
701 -- fails.
702 --
703 -- What to do? If we did inference "for real", the sub-multiplicity constraint
704 -- would end up in the implication of the GADT pattern-match, and all would
705 -- be well. But we don't have a real sub-multiplicity constraint to put in
706 -- the implication. (Multiplicity inference works outside the usual generate-
707 -- constraints-and-solve scheme.) Here, where the multiplicity arrives, we
708 -- must promote all multiplicity variables to reflect this outer TcLevel.
709 -- It's reminiscent of floating a constraint, really, so promotion is
710 -- appropriate. The promoteTcType function works only on types of kind TYPE rr,
711 -- so we can't use it here. Thus, this dirtiness.
712 --
713 -- It works nicely in practice.
714 --
715 -- We use a set to avoid calling promoteMetaTyVarTo twice on the same
716 -- metavariable. This happened in #19400.
717 promote_mult m = do { fvs <- zonkTyCoVarsAndFV (tyCoVarsOfType m)
718 ; any_promoted <- promoteTyVarSet fvs
719 ; if any_promoted then zonkTcType m else return m
720 }
721
722 {- *********************************************************************
723 * *
724 The TcBinderStack
725 * *
726 ********************************************************************* -}
727
728 tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
729 tcExtendBinderStack bndrs thing_inside
730 = do { traceTc "tcExtendBinderStack" (ppr bndrs)
731 ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
732 thing_inside }
733
734 tcInitTidyEnv :: TcM TidyEnv
735 -- We initialise the "tidy-env", used for tidying types before printing,
736 -- by building a reverse map from the in-scope type variables to the
737 -- OccName that the programmer originally used for them
738 tcInitTidyEnv
739 = do { lcl_env <- getLclEnv
740 ; go emptyTidyEnv (tcl_bndrs lcl_env) }
741 where
742 go (env, subst) []
743 = return (env, subst)
744 go (env, subst) (b : bs)
745 | TcTvBndr name tyvar <- b
746 = do { let (env', occ') = tidyOccName env (nameOccName name)
747 name' = tidyNameOcc name occ'
748 tyvar1 = setTyVarName tyvar name'
749 ; tyvar2 <- zonkTcTyVarToTyVar tyvar1
750 -- Be sure to zonk here! Tidying applies to zonked
751 -- types, so if we don't zonk we may create an
752 -- ill-kinded type (#14175)
753 ; go (env', extendVarEnv subst tyvar tyvar2) bs }
754 | otherwise
755 = go (env, subst) bs
756
757 -- | Get a 'TidyEnv' that includes mappings for all vars free in the given
758 -- type. Useful when tidying open types.
759 tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
760 tcInitOpenTidyEnv tvs
761 = do { env1 <- tcInitTidyEnv
762 ; let env2 = tidyFreeTyCoVars env1 tvs
763 ; return env2 }
764
765
766
767 {- *********************************************************************
768 * *
769 Adding placeholders
770 * *
771 ********************************************************************* -}
772
773 tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
774 -- See Note [AFamDataCon: not promoting data family constructors]
775 tcAddDataFamConPlaceholders inst_decls thing_inside
776 = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)
777 | lid <- inst_decls, con <- get_cons lid ]
778 thing_inside
779 -- Note [AFamDataCon: not promoting data family constructors]
780 where
781 -- get_cons extracts the *constructor* bindings of the declaration
782 get_cons :: LInstDecl GhcRn -> [Name]
783 get_cons (L _ (TyFamInstD {})) = []
784 get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
785 get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
786 = concatMap (get_fi_cons . unLoc) fids
787
788 get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
789 get_fi_cons (DataFamInstDecl { dfid_eqn =
790 FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }})
791 = map unLoc $ concatMap (getConNames . unLoc) cons
792
793
794 tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
795 -- See Note [Don't promote pattern synonyms]
796 tcAddPatSynPlaceholders pat_syns thing_inside
797 = tcExtendKindEnvList [ (name, APromotionErr PatSynPE)
798 | PSB{ psb_id = L _ name } <- pat_syns ]
799 thing_inside
800
801 getTypeSigNames :: [LSig GhcRn] -> NameSet
802 -- Get the names that have a user type sig
803 getTypeSigNames sigs
804 = foldr get_type_sig emptyNameSet sigs
805 where
806 get_type_sig :: LSig GhcRn -> NameSet -> NameSet
807 get_type_sig sig ns =
808 case sig of
809 L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names)
810 L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names)
811 _ -> ns
812
813
814 {- Note [AFamDataCon: not promoting data family constructors]
815 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
816 Consider
817 data family T a
818 data instance T Int = MkT
819 data Proxy (a :: k)
820 data S = MkS (Proxy 'MkT)
821
822 Is it ok to use the promoted data family instance constructor 'MkT' in
823 the data declaration for S (where both declarations live in the same module)?
824 No, we don't allow this. It *might* make sense, but at least it would mean that
825 we'd have to interleave typechecking instances and data types, whereas at
826 present we do data types *then* instances.
827
828 So to check for this we put in the TcLclEnv a binding for all the family
829 constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
830 type checking 'S' we'll produce a decent error message.
831
832 #12088 describes this limitation. Of course, when MkT and S live in
833 different modules then all is well.
834
835 Note [Don't promote pattern synonyms]
836 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
837 We never promote pattern synonyms.
838
839 Consider this (#11265):
840 pattern A = True
841 instance Eq A
842 We want a civilised error message from the occurrence of 'A'
843 in the instance, yet 'A' really has not yet been type checked.
844
845 Similarly (#9161)
846 {-# LANGUAGE PatternSynonyms, DataKinds #-}
847 pattern A = ()
848 b :: A
849 b = undefined
850 Here, the type signature for b mentions A. But A is a pattern
851 synonym, which is typechecked as part of a group of bindings (for very
852 good reasons; a view pattern in the RHS may mention a value binding).
853 It is entirely reasonable to reject this, but to do so we need A to be
854 in the kind environment when kind-checking the signature for B.
855
856 Hence tcAddPatSynPlaceholers adds a binding
857 A -> APromotionErr PatSynPE
858 to the environment. Then GHC.Tc.Gen.HsType.tcTyVar will find A in the kind
859 environment, and will give a 'wrongThingErr' as a result. But the
860 lookup of A won't fail.
861
862
863 ************************************************************************
864 * *
865 \subsection{Rules}
866 * *
867 ************************************************************************
868 -}
869
870 tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a
871 -- Just pop the new rules into the EPS and envt resp
872 -- All the rules come from an interface file, not source
873 -- Nevertheless, some may be for this module, if we read
874 -- its interface instead of its source code
875 tcExtendRules lcl_rules thing_inside
876 = do { env <- getGblEnv
877 ; let
878 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
879 ; setGblEnv env' thing_inside }
880
881 {-
882 ************************************************************************
883 * *
884 Meta level
885 * *
886 ************************************************************************
887 -}
888
889 checkWellStaged :: SDoc -- What the stage check is for
890 -> ThLevel -- Binding level (increases inside brackets)
891 -> ThLevel -- Use stage
892 -> TcM () -- Fail if badly staged, adding an error
893 checkWellStaged pp_thing bind_lvl use_lvl
894 | use_lvl >= bind_lvl -- OK! Used later than bound
895 = return () -- E.g. \x -> [| $(f x) |]
896
897 | bind_lvl == outerLevel -- GHC restriction on top level splices
898 = stageRestrictionError pp_thing
899
900 | otherwise -- Badly staged
901 = failWithTc $ -- E.g. \x -> $(f x)
902 TcRnUnknownMessage $ mkPlainError noHints $
903 text "Stage error:" <+> pp_thing <+>
904 hsep [text "is bound at stage" <+> ppr bind_lvl,
905 text "but used at stage" <+> ppr use_lvl]
906
907 stageRestrictionError :: SDoc -> TcM a
908 stageRestrictionError pp_thing
909 = failWithTc $
910 TcRnUnknownMessage $ mkPlainError noHints $
911 sep [ text "GHC stage restriction:"
912 , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
913 , text "and must be imported, not defined locally"])]
914
915 topIdLvl :: Id -> ThLevel
916 -- Globals may either be imported, or may be from an earlier "chunk"
917 -- (separated by declaration splices) of this module. The former
918 -- *can* be used inside a top-level splice, but the latter cannot.
919 -- Hence we give the former impLevel, but the latter topLevel
920 -- E.g. this is bad:
921 -- x = [| foo |]
922 -- $( f x )
923 -- By the time we are processing the $(f x), the binding for "x"
924 -- will be in the global env, not the local one.
925 topIdLvl id | isLocalId id = outerLevel
926 | otherwise = impLevel
927
928 tcMetaTy :: Name -> TcM Type
929 -- Given the name of a Template Haskell data type,
930 -- return the type
931 -- E.g. given the name "Expr" return the type "Expr"
932 tcMetaTy tc_name = do
933 t <- tcLookupTyCon tc_name
934 return (mkTyConTy t)
935
936 isBrackStage :: ThStage -> Bool
937 isBrackStage (Brack {}) = True
938 isBrackStage _other = False
939
940 {-
941 ************************************************************************
942 * *
943 getDefaultTys
944 * *
945 ************************************************************************
946 -}
947
948 tcGetDefaultTys :: TcM ([Type], -- Default types
949 (Bool, -- True <=> Use overloaded strings
950 Bool)) -- True <=> Use extended defaulting rules
951 tcGetDefaultTys
952 = do { dflags <- getDynFlags
953 ; let ovl_strings = xopt LangExt.OverloadedStrings dflags
954 extended_defaults = xopt LangExt.ExtendedDefaultRules dflags
955 -- See also #1974
956 flags = (ovl_strings, extended_defaults)
957
958 ; mb_defaults <- getDeclaredDefaultTys
959 ; case mb_defaults of {
960 Just tys -> return (tys, flags) ;
961 -- User-supplied defaults
962 Nothing -> do
963
964 -- No use-supplied default
965 -- Use [Integer, Double], plus modifications
966 { integer_ty <- tcMetaTy integerTyConName
967 ; list_ty <- tcMetaTy listTyConName
968 ; checkWiredInTyCon doubleTyCon
969 ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
970 -- Note [Extended defaults]
971 ++ [integer_ty, doubleTy]
972 ++ opt_deflt ovl_strings [stringTy]
973 ; return (deflt_tys, flags) } } }
974 where
975 opt_deflt True xs = xs
976 opt_deflt False _ = []
977
978 {-
979 Note [Extended defaults]
980 ~~~~~~~~~~~~~~~~~~~~~
981 In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we
982 try when defaulting. This has very little real impact, except in the following case.
983 Consider:
984 Text.Printf.printf "hello"
985 This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't
986 want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to
987 default the 'a' to (), rather than to Integer (which is what would otherwise happen;
988 and then GHCi doesn't attempt to print the (). So in interactive mode, we add
989 () to the list of defaulting types. See #1200.
990
991 Additionally, the list type [] is added as a default specialization for
992 Traversable and Foldable. As such the default default list now has types of
993 varying kinds, e.g. ([] :: * -> *) and (Integer :: *).
994
995 ************************************************************************
996 * *
997 \subsection{The InstInfo type}
998 * *
999 ************************************************************************
1000
1001 The InstInfo type summarises the information in an instance declaration
1002
1003 instance c => k (t tvs) where b
1004
1005 It is used just for *local* instance decls (not ones from interface files).
1006 But local instance decls includes
1007 - derived ones
1008 - generic ones
1009 as well as explicit user written ones.
1010 -}
1011
1012 data InstInfo a
1013 = InstInfo
1014 { iSpec :: ClsInst -- Includes the dfun id
1015 , iBinds :: InstBindings a
1016 }
1017
1018 iDFunId :: InstInfo a -> DFunId
1019 iDFunId info = instanceDFunId (iSpec info)
1020
1021 data InstBindings a
1022 = InstBindings
1023 { ib_tyvars :: [Name] -- Names of the tyvars from the instance head
1024 -- that are lexically in scope in the bindings
1025 -- Must correspond 1-1 with the forall'd tyvars
1026 -- of the dfun Id. When typechecking, we are
1027 -- going to extend the typechecker's envt with
1028 -- ib_tyvars -> dfun_forall_tyvars
1029
1030 , ib_binds :: LHsBinds a -- Bindings for the instance methods
1031
1032 , ib_pragmas :: [LSig a] -- User pragmas recorded for generating
1033 -- specialised instances
1034
1035 , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should
1036 -- be enabled when type-checking
1037 -- this instance; needed for
1038 -- GeneralizedNewtypeDeriving
1039
1040 , ib_derived :: Bool
1041 -- True <=> This code was generated by GHC from a deriving clause
1042 -- or standalone deriving declaration
1043 -- Used only to improve error messages
1044 }
1045
1046 instance (OutputableBndrId a)
1047 => Outputable (InstInfo (GhcPass a)) where
1048 ppr = pprInstInfoDetails
1049
1050 pprInstInfoDetails :: (OutputableBndrId a)
1051 => InstInfo (GhcPass a) -> SDoc
1052 pprInstInfoDetails info
1053 = hang (pprInstanceHdr (iSpec info) <+> text "where")
1054 2 (details (iBinds info))
1055 where
1056 details (InstBindings { ib_pragmas = p, ib_binds = b }) =
1057 pprDeclList (pprLHsBindsForUser b p)
1058
1059 simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
1060 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
1061 (_, cls, [ty]) -> (cls, ty)
1062 _ -> panic "simpleInstInfoClsTy"
1063
1064 simpleInstInfoTy :: InstInfo a -> Type
1065 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
1066
1067 simpleInstInfoTyCon :: InstInfo a -> TyCon
1068 -- Gets the type constructor for a simple instance declaration,
1069 -- i.e. one of the form instance (...) => C (T a b c) where ...
1070 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
1071
1072 -- | Make a name for the dict fun for an instance decl. It's an *external*
1073 -- name, like other top-level names, and hence must be made with
1074 -- newGlobalBinder.
1075 newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
1076 newDFunName clas tys loc
1077 = do { is_boot <- tcIsHsBootOrSig
1078 ; mod <- getModule
1079 ; let info_string = occNameString (getOccName clas) ++
1080 concatMap (occNameString.getDFunTyKey) tys
1081 ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
1082 ; newGlobalBinder mod dfun_occ loc }
1083
1084 newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name
1085 newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locA loc) name [tys]
1086
1087 newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name
1088 newFamInstAxiomName (L loc name) branches
1089 = mk_fam_inst_name mkInstTyCoOcc (locA loc) name branches
1090
1091 mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
1092 mk_fam_inst_name adaptOcc loc tc_name tyss
1093 = do { mod <- getModule
1094 ; let info_string = occNameString (getOccName tc_name) ++
1095 intercalate "|" ty_strings
1096 ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
1097 ; newGlobalBinder mod (adaptOcc occ) loc }
1098 where
1099 ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
1100
1101 {-
1102 Stable names used for foreign exports and annotations.
1103 For stable names, the name must be unique (see #1533). If the
1104 same thing has several stable Ids based on it, the
1105 top-level bindings generated must not have the same name.
1106 Hence we create an External name (doesn't change), and we
1107 append a Unique to the string right here.
1108 -}
1109
1110 mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
1111 mkStableIdFromString str sig_ty loc occ_wrapper = do
1112 uniq <- newUnique
1113 mod <- getModule
1114 nextWrapperNum <- tcg_next_wrapper_num <$> getGblEnv
1115 name <- mkWrapperName nextWrapperNum "stable" str
1116 let occ = mkVarOccFS name :: OccName
1117 gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
1118 id = mkExportedVanillaId gnm sig_ty :: Id
1119 return id
1120
1121 mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
1122 mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
1123
1124 mkWrapperName :: (MonadIO m, HasModule m)
1125 => IORef (ModuleEnv Int) -> String -> String -> m FastString
1126 -- ^ @mkWrapperName ref what nameBase@
1127 --
1128 -- See Note [Generating fresh names for ccall wrapper] for @ref@'s purpose.
1129 mkWrapperName wrapperRef what nameBase
1130 = do thisMod <- getModule
1131 let pkg = unitString (moduleUnit thisMod)
1132 mod = moduleNameString (moduleName thisMod)
1133 wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
1134 let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
1135 mod_env' = extendModuleEnv mod_env thisMod (num+1)
1136 in (mod_env', num)
1137 let components = [what, show wrapperNum, pkg, mod, nameBase]
1138 return $ mkFastString $ zEncodeString $ intercalate ":" components
1139
1140 {-
1141 Note [Generating fresh names for FFI wrappers]
1142
1143 We used to use a unique, rather than nextWrapperNum, to distinguish
1144 between FFI wrapper functions. However, the wrapper names that we
1145 generate are external names. This means that if a call to them ends up
1146 in an unfolding, then we can't alpha-rename them, and thus if the
1147 unique randomly changes from one compile to another then we get a
1148 spurious ABI change (#4012).
1149
1150 The wrapper counter has to be per-module, not global, so that the number we end
1151 up using is not dependent on the modules compiled before the current one.
1152 -}
1153
1154 {-
1155 ************************************************************************
1156 * *
1157 \subsection{Errors}
1158 * *
1159 ************************************************************************
1160 -}
1161
1162 pprBinders :: [Name] -> SDoc
1163 -- Used in error messages
1164 -- Use quotes for a single one; they look a bit "busy" for several
1165 pprBinders [bndr] = quotes (ppr bndr)
1166 pprBinders bndrs = pprWithCommas ppr bndrs
1167
1168 notFound :: Name -> TcM TyThing
1169 notFound name
1170 = do { lcl_env <- getLclEnv
1171 ; let stage = tcl_th_ctxt lcl_env
1172 ; case stage of -- See Note [Out of scope might be a staging error]
1173 Splice {}
1174 | isUnboundName name -> failM -- If the name really isn't in scope
1175 -- don't report it again (#11941)
1176 | otherwise -> stageRestrictionError (quotes (ppr name))
1177 _ -> failWithTc $
1178 TcRnUnknownMessage $ mkPlainError noHints $
1179 vcat[text "GHC internal error:" <+> quotes (ppr name) <+>
1180 text "is not in scope during type checking, but it passed the renamer",
1181 text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]
1182 -- Take care: printing the whole gbl env can
1183 -- cause an infinite loop, in the case where we
1184 -- are in the middle of a recursive TyCon/Class group;
1185 -- so let's just not print it! Getting a loop here is
1186 -- very unhelpful, because it hides one compiler bug with another
1187 }
1188
1189 wrongThingErr :: String -> TcTyThing -> Name -> TcM a
1190 -- It's important that this only calls pprTcTyThingCategory, which in
1191 -- turn does not look at the details of the TcTyThing.
1192 -- See Note [Placeholder PatSyn kinds] in GHC.Tc.Gen.Bind
1193 wrongThingErr expected thing name
1194 = let msg = TcRnUnknownMessage $ mkPlainError noHints $
1195 (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
1196 text "used as a" <+> text expected)
1197 in failWithTc msg
1198
1199 {- Note [Out of scope might be a staging error]
1200 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1201 Consider
1202 x = 3
1203 data T = MkT $(foo x)
1204
1205 where 'foo' is imported from somewhere.
1206
1207 This is really a staging error, because we can't run code involving 'x'.
1208 But in fact the type checker processes types first, so 'x' won't even be
1209 in the type envt when we look for it in $(foo x). So inside splices we
1210 report something missing from the type env as a staging error.
1211 See #5752 and #5795.
1212 -}