525e834393d060f61dfdbae6ac61d33b8ce2204e
[ghc.git] / compiler / typecheck / TcEnv.hs
1 -- (c) The University of Glasgow 2006
2 {-# LANGUAGE CPP, FlexibleInstances #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an
5 -- orphan
6 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
7 -- in module PlaceHolder
8
9 module TcEnv(
10 TyThing(..), TcTyThing(..), TcId,
11
12 -- Instance environment, and InstInfo type
13 InstInfo(..), iDFunId, pprInstInfoDetails,
14 simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
15 InstBindings(..),
16
17 -- Global environment
18 tcExtendGlobalEnv, tcExtendTyConEnv,
19 tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
20 tcExtendGlobalValEnv,
21 tcLookupLocatedGlobal, tcLookupGlobal,
22 tcLookupTyCon, tcLookupClass,
23 tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
24 tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
25 tcLookupLocatedClass, tcLookupAxiom,
26 lookupGlobal,
27
28 -- Local environment
29 tcExtendKindEnv2,
30 tcExtendTyVarEnv, tcExtendTyVarEnv2,
31 tcExtendLetEnv, tcExtendLetEnvIds,
32 tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
33 tcExtendIdBndrs, tcExtendLocalTypeEnv,
34 isTypeClosedLetBndr,
35
36 tcLookup, tcLookupLocated, tcLookupLocalIds,
37 tcLookupId, tcLookupTyVar,
38 tcLookupLcl_maybe,
39 getInLocalScope,
40 wrongThingErr, pprBinders,
41
42 tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
43 getPatSynBinds, getTypeSigNames,
44 tcExtendRecEnv, -- For knot-tying
45
46 -- Instances
47 tcLookupInstance, tcGetInstEnvs,
48
49 -- Rules
50 tcExtendRules,
51
52 -- Defaults
53 tcGetDefaultTys,
54
55 -- Global type variables
56 tcGetGlobalTyCoVars,
57
58 -- Template Haskell stuff
59 checkWellStaged, tcMetaTy, thLevel,
60 topIdLvl, isBrackStage,
61
62 -- New Ids
63 newLocalName, newDFunName, newDFunName', newFamInstTyConName,
64 newFamInstAxiomName,
65 mkStableIdFromString, mkStableIdFromName,
66 mkWrapperName
67 ) where
68
69 #include "HsVersions.h"
70
71 import HsSyn
72 import IfaceEnv
73 import TcRnMonad
74 import TcMType
75 import TcType
76 import LoadIface
77 import PrelNames
78 import TysWiredIn
79 import Id
80 import Var
81 import VarSet
82 import RdrName
83 import InstEnv
84 import DataCon ( DataCon )
85 import PatSyn ( PatSyn )
86 import ConLike
87 import TyCon
88 import CoAxiom
89 import Class
90 import Name
91 import NameSet
92 import NameEnv
93 import VarEnv
94 import HscTypes
95 import DynFlags
96 import SrcLoc
97 import BasicTypes hiding( SuccessFlag(..) )
98 import Module
99 import Outputable
100 import Encoding
101 import FastString
102 import Bag
103 import ListSetOps
104 import Util
105 import Maybes( MaybeErr(..) )
106 import qualified GHC.LanguageExtensions as LangExt
107
108 import Data.IORef
109 import Data.List
110
111
112 {- *********************************************************************
113 * *
114 An IO interface to looking up globals
115 * *
116 ********************************************************************* -}
117
118 lookupGlobal :: HscEnv -> Name -> IO TyThing
119 -- An IO version, used outside the typechecker
120 -- It's more complicated than it looks, because it may
121 -- need to suck in an interface file
122 lookupGlobal hsc_env name
123 = initTcForLookup hsc_env (tcLookupGlobal name)
124 -- This initTcForLookup stuff is massive overkill
125 -- but that's how it is right now, and at least
126 -- this function localises it
127
128 {-
129 ************************************************************************
130 * *
131 * tcLookupGlobal *
132 * *
133 ************************************************************************
134
135 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
136 unless you know that the SrcSpan in the monad is already set to the
137 span of the Name.
138 -}
139
140
141 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
142 -- c.f. IfaceEnvEnv.tcIfaceGlobal
143 tcLookupLocatedGlobal name
144 = addLocM tcLookupGlobal name
145
146 tcLookupGlobal :: Name -> TcM TyThing
147 -- The Name is almost always an ExternalName, but not always
148 -- In GHCi, we may make command-line bindings (ghci> let x = True)
149 -- that bind a GlobalId, but with an InternalName
150 tcLookupGlobal name
151 = do { -- Try local envt
152 env <- getGblEnv
153 ; case lookupNameEnv (tcg_type_env env) name of {
154 Just thing -> return thing ;
155 Nothing ->
156
157 -- Should it have been in the local envt?
158 if nameIsLocalOrFrom (tcg_mod env) name
159 then notFound name -- Internal names can happen in GHCi
160 else
161
162 -- Try home package table and external package table
163 do { mb_thing <- tcLookupImported_maybe name
164 ; case mb_thing of
165 Succeeded thing -> return thing
166 Failed msg -> failWithTc msg
167 }}}
168
169 tcLookupDataCon :: Name -> TcM DataCon
170 tcLookupDataCon name = do
171 thing <- tcLookupGlobal name
172 case thing of
173 AConLike (RealDataCon con) -> return con
174 _ -> wrongThingErr "data constructor" (AGlobal thing) name
175
176 tcLookupPatSyn :: Name -> TcM PatSyn
177 tcLookupPatSyn name = do
178 thing <- tcLookupGlobal name
179 case thing of
180 AConLike (PatSynCon ps) -> return ps
181 _ -> wrongThingErr "pattern synonym" (AGlobal thing) name
182
183 tcLookupConLike :: Name -> TcM ConLike
184 tcLookupConLike name = do
185 thing <- tcLookupGlobal name
186 case thing of
187 AConLike cl -> return cl
188 _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name
189
190 tcLookupClass :: Name -> TcM Class
191 tcLookupClass name = do
192 thing <- tcLookupGlobal name
193 case thing of
194 ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
195 _ -> wrongThingErr "class" (AGlobal thing) name
196
197 tcLookupTyCon :: Name -> TcM TyCon
198 tcLookupTyCon name = do
199 thing <- tcLookupGlobal name
200 case thing of
201 ATyCon tc -> return tc
202 _ -> wrongThingErr "type constructor" (AGlobal thing) name
203
204 tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
205 tcLookupAxiom name = do
206 thing <- tcLookupGlobal name
207 case thing of
208 ACoAxiom ax -> return ax
209 _ -> wrongThingErr "axiom" (AGlobal thing) name
210
211 tcLookupLocatedGlobalId :: Located Name -> TcM Id
212 tcLookupLocatedGlobalId = addLocM tcLookupId
213
214 tcLookupLocatedClass :: Located Name -> TcM Class
215 tcLookupLocatedClass = addLocM tcLookupClass
216
217 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
218 tcLookupLocatedTyCon = addLocM tcLookupTyCon
219
220 -- Find the instance that exactly matches a type class application. The class arguments must be precisely
221 -- the same as in the instance declaration (modulo renaming & casts).
222 --
223 tcLookupInstance :: Class -> [Type] -> TcM ClsInst
224 tcLookupInstance cls tys
225 = do { instEnv <- tcGetInstEnvs
226 ; case lookupUniqueInstEnv instEnv cls tys of
227 Left err -> failWithTc $ text "Couldn't match instance:" <+> err
228 Right (inst, tys)
229 | uniqueTyVars tys -> return inst
230 | otherwise -> failWithTc errNotExact
231 }
232 where
233 errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
234
235 uniqueTyVars tys = all isTyVarTy tys
236 && hasNoDups (map (getTyVar "tcLookupInstance") tys)
237
238 tcGetInstEnvs :: TcM InstEnvs
239 -- Gets both the external-package inst-env
240 -- and the home-pkg inst env (includes module being compiled)
241 tcGetInstEnvs = do { eps <- getEps
242 ; env <- getGblEnv
243 ; return (InstEnvs { ie_global = eps_inst_env eps
244 , ie_local = tcg_inst_env env
245 , ie_visible = tcVisibleOrphanMods env }) }
246
247 instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
248 lookupThing = tcLookupGlobal
249
250 {-
251 ************************************************************************
252 * *
253 Extending the global environment
254 * *
255 ************************************************************************
256 -}
257
258 setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
259 -- Use this to update the global type env
260 -- It updates both * the normal tcg_type_env field
261 -- * the tcg_type_env_var field seen by interface files
262 setGlobalTypeEnv tcg_env new_type_env
263 = do { -- Sync the type-envt variable seen by interface files
264 writeMutVar (tcg_type_env_var tcg_env) new_type_env
265 ; return (tcg_env { tcg_type_env = new_type_env }) }
266
267
268 tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
269 -- Just extend the global environment with some TyThings
270 -- Do not extend tcg_tcs etc
271 tcExtendGlobalEnvImplicit things thing_inside
272 = do { tcg_env <- getGblEnv
273 ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things
274 ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
275 ; setGblEnv tcg_env' thing_inside }
276
277 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
278 -- Given a mixture of Ids, TyCons, Classes, all defined in the
279 -- module being compiled, extend the global environment
280 tcExtendGlobalEnv things thing_inside
281 = do { env <- getGblEnv
282 ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
283 tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
284 ; setGblEnv env' $
285 tcExtendGlobalEnvImplicit things thing_inside
286 }
287
288 tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
289 -- Given a mixture of Ids, TyCons, Classes, all defined in the
290 -- module being compiled, extend the global environment
291 tcExtendTyConEnv tycons thing_inside
292 = do { env <- getGblEnv
293 ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }
294 ; setGblEnv env' $
295 tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
296 }
297
298 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
299 -- Same deal as tcExtendGlobalEnv, but for Ids
300 tcExtendGlobalValEnv ids thing_inside
301 = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
302
303 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
304 -- Extend the global environments for the type/class knot tying game
305 -- Just like tcExtendGlobalEnv, except the argument is a list of pairs
306 tcExtendRecEnv gbl_stuff thing_inside
307 = do { tcg_env <- getGblEnv
308 ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
309 ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
310 ; setGblEnv tcg_env' thing_inside }
311
312 {-
313 ************************************************************************
314 * *
315 \subsection{The local environment}
316 * *
317 ************************************************************************
318 -}
319
320 tcLookupLocated :: Located Name -> TcM TcTyThing
321 tcLookupLocated = addLocM tcLookup
322
323 tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
324 tcLookupLcl_maybe name
325 = do { local_env <- getLclTypeEnv
326 ; return (lookupNameEnv local_env name) }
327
328 tcLookup :: Name -> TcM TcTyThing
329 tcLookup name = do
330 local_env <- getLclTypeEnv
331 case lookupNameEnv local_env name of
332 Just thing -> return thing
333 Nothing -> AGlobal <$> tcLookupGlobal name
334
335 tcLookupTyVar :: Name -> TcM TcTyVar
336 tcLookupTyVar name
337 = do { thing <- tcLookup name
338 ; case thing of
339 ATyVar _ tv -> return tv
340 _ -> pprPanic "tcLookupTyVar" (ppr name) }
341
342 tcLookupId :: Name -> TcM Id
343 -- Used when we aren't interested in the binding level, nor refinement.
344 -- The "no refinement" part means that we return the un-refined Id regardless
345 --
346 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
347 tcLookupId name = do
348 thing <- tcLookup name
349 case thing of
350 ATcId { tct_id = id} -> return id
351 AGlobal (AnId id) -> return id
352 _ -> pprPanic "tcLookupId" (ppr name)
353
354 tcLookupLocalIds :: [Name] -> TcM [TcId]
355 -- We expect the variables to all be bound, and all at
356 -- the same level as the lookup. Only used in one place...
357 tcLookupLocalIds ns
358 = do { env <- getLclEnv
359 ; return (map (lookup (tcl_env env)) ns) }
360 where
361 lookup lenv name
362 = case lookupNameEnv lenv name of
363 Just (ATcId { tct_id = id }) -> id
364 _ -> pprPanic "tcLookupLocalIds" (ppr name)
365
366 getInLocalScope :: TcM (Name -> Bool)
367 getInLocalScope = do { lcl_env <- getLclTypeEnv
368 ; return (`elemNameEnv` lcl_env) }
369
370 tcExtendKindEnv2 :: [(Name, TcTyThing)] -> TcM r -> TcM r
371 -- Used only during kind checking, for TcThings that are
372 -- ATcTyCon or APromotionErr
373 -- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
374 tcExtendKindEnv2 things thing_inside
375 = do { traceTc "txExtendKindEnv" (ppr things)
376 ; updLclEnv upd_env thing_inside }
377 where
378 upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
379
380 -----------------------
381 -- Scoped type and kind variables
382 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
383 tcExtendTyVarEnv tvs thing_inside
384 = tcExtendTyVarEnv2 [(tyVarName tv, tv) | tv <- tvs] thing_inside
385
386 tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r
387 tcExtendTyVarEnv2 binds thing_inside
388 -- this should be used only for explicitly mentioned scoped variables.
389 -- thus, no coercion variables
390 = do { tc_extend_local_env NotTopLevel
391 [(name, ATyVar name tv) | (name, tv) <- binds] $
392 do { env <- getLclEnv
393 ; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) }
394 ; setLclEnv env' thing_inside }}
395 where
396 add_tidy_tvs env = foldl add env binds
397
398 -- We initialise the "tidy-env", used for tidying types before printing,
399 -- by building a reverse map from the in-scope type variables to the
400 -- OccName that the programmer originally used for them
401 add :: TidyEnv -> (Name, TcTyVar) -> TidyEnv
402 add (env,subst) (name, tyvar)
403 = ASSERT( isTyVar tyvar )
404 case tidyOccName env (nameOccName name) of
405 (env', occ') -> (env', extendVarEnv subst tyvar tyvar')
406 where
407 tyvar' = setTyVarName tyvar name'
408 name' = tidyNameOcc name occ'
409
410 isTypeClosedLetBndr :: Id -> Bool
411 -- See Note [Bindings with closed types] in TcRnTypes
412 isTypeClosedLetBndr id
413 | isEmptyVarSet (tyCoVarsOfType (idType id)) = True
414 | otherwise = False
415
416 tcExtendLetEnv :: TopLevelFlag -> IsGroupClosed -> [TcId] -> TcM a -> TcM a
417 -- Used for both top-level value bindings and and nested let/where-bindings
418 -- Adds to the TcIdBinderStack too
419 tcExtendLetEnv top_lvl closed_group ids thing_inside
420 = tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] $
421 tcExtendLetEnvIds' top_lvl closed_group
422 [(idName id, id) | id <- ids]
423 thing_inside
424
425 tcExtendLetEnvIds :: TopLevelFlag -> [(Name, TcId)] -> TcM a -> TcM a
426 -- Used for both top-level value bindings and and nested let/where-bindings
427 -- Does not extend the TcIdBinderStack
428 tcExtendLetEnvIds top_lvl
429 = tcExtendLetEnvIds' top_lvl ClosedGroup
430
431 tcExtendLetEnvIds' :: TopLevelFlag -> IsGroupClosed
432 -> [(Name,TcId)] -> TcM a
433 -> TcM a
434 -- Used for both top-level value bindings and and nested let/where-bindings
435 -- Does not extend the TcIdBinderStack
436 tcExtendLetEnvIds' top_lvl closed_group pairs thing_inside
437 = tc_extend_local_env top_lvl
438 [ (name, ATcId { tct_id = let_id
439 , tct_info = case closed_group of
440 ClosedGroup
441 | isTypeClosedLetBndr let_id -> ClosedLet
442 | otherwise -> NonClosedLet emptyNameSet False
443 NonClosedGroup fvs ->
444 NonClosedLet
445 (maybe emptyNameSet id $ lookupNameEnv fvs name)
446 (isTypeClosedLetBndr let_id)
447 })
448 | (name, let_id) <- pairs ] $
449 thing_inside
450
451 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
452 -- For lambda-bound and case-bound Ids
453 -- Extends the the TcIdBinderStack as well
454 tcExtendIdEnv ids thing_inside
455 = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
456
457 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
458 -- Exactly like tcExtendIdEnv2, but for a single (name,id) pair
459 tcExtendIdEnv1 name id thing_inside
460 = tcExtendIdEnv2 [(name,id)] thing_inside
461
462 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
463 tcExtendIdEnv2 names_w_ids thing_inside
464 = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
465 | (_,mono_id) <- names_w_ids ] $
466 do { tc_extend_local_env NotTopLevel
467 [ (name, ATcId { tct_id = id
468 , tct_info = NotLetBound })
469 | (name,id) <- names_w_ids] $
470 thing_inside }
471
472 tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)]
473 -> TcM a -> TcM a
474 tc_extend_local_env top_lvl extra_env thing_inside
475 -- Precondition: the argument list extra_env has TcTyThings
476 -- that ATcId or ATyVar, but nothing else
477 --
478 -- Invariant: the ATcIds are fully zonked. Reasons:
479 -- (a) The kinds of the forall'd type variables are defaulted
480 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
481 -- (b) There are no via-Indirect occurrences of the bound variables
482 -- in the types, because instantiation does not look through such things
483 -- (c) The call to tyCoVarsOfTypes is ok without looking through refs
484
485 -- The second argument of type TyVarSet is a set of type variables
486 -- that are bound together with extra_env and should not be regarded
487 -- as free in the types of extra_env.
488 = do { traceTc "env2" (ppr extra_env)
489 ; env0 <- getLclEnv
490 ; env1 <- tcExtendLocalTypeEnv env0 extra_env
491 ; stage <- getStage
492 ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1
493 ; setLclEnv env2 thing_inside }
494 where
495 extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
496 -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously
497 -- Reason for extending LocalRdrEnv: after running a TH splice we need
498 -- to do renaming.
499 extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env
500 , tcl_th_bndrs = th_bndrs })
501 = env { tcl_rdr = extendLocalRdrEnvList rdr_env
502 [ n | (n, _) <- pairs, isInternalName n ]
503 -- The LocalRdrEnv contains only non-top-level names
504 -- (GlobalRdrEnv handles the top level)
505 , tcl_th_bndrs = extendNameEnvList th_bndrs -- We only track Ids in tcl_th_bndrs
506 [(n, thlvl) | (n, ATcId {}) <- pairs] }
507
508 tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcM TcLclEnv
509 tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
510 | isEmptyVarSet extra_tvs
511 = return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things })
512 | otherwise
513 = do { global_tvs <- readMutVar (tcl_tyvars lcl_env)
514 ; new_g_var <- newMutVar (global_tvs `unionVarSet` extra_tvs)
515 ; return (lcl_env { tcl_tyvars = new_g_var
516 , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) }
517 where
518 extra_tvs = foldr get_tvs emptyVarSet tc_ty_things
519
520 get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs
521 = case closed of
522 ClosedLet ->
523 ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) tvs
524 _ ->
525 tvs `unionVarSet` id_tvs
526 where id_tvs = tyCoVarsOfType (idType id)
527
528 get_tvs (_, ATyVar _ tv) tvs -- See Note [Global TyVars]
529 = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv
530
531 get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc)
532
533 get_tvs (_, AGlobal {}) tvs = tvs
534 get_tvs (_, APromotionErr {}) tvs = tvs
535
536 -- Note [Global TyVars]
537 -- It's important to add the in-scope tyvars to the global tyvar set
538 -- as well. Consider
539 -- f (_::r) = let g y = y::r in ...
540 -- Here, g mustn't be generalised. This is also important during
541 -- class and instance decls, when we mustn't generalise the class tyvars
542 -- when typechecking the methods.
543 --
544 -- Nor must we generalise g over any kind variables free in r's kind
545
546 -------------------------------------------------------------
547 -- Extending the TcIdBinderStack, used only for error messages
548
549 tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a
550 tcExtendIdBndrs bndrs thing_inside
551 = do { traceTc "tcExtendIdBndrs" (ppr bndrs)
552 ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
553 thing_inside }
554
555
556 {- *********************************************************************
557 * *
558 Adding placeholders
559 * *
560 ********************************************************************* -}
561
562 tcAddDataFamConPlaceholders :: [LInstDecl Name] -> TcM a -> TcM a
563 -- See Note [AFamDataCon: not promoting data family constructors]
564 tcAddDataFamConPlaceholders inst_decls thing_inside
565 = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE)
566 | lid <- inst_decls, con <- get_cons lid ]
567 thing_inside
568 -- Note [AFamDataCon: not promoting data family constructors]
569 where
570 -- get_cons extracts the *constructor* bindings of the declaration
571 get_cons :: LInstDecl Name -> [Name]
572 get_cons (L _ (TyFamInstD {})) = []
573 get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
574 get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
575 = concatMap (get_fi_cons . unLoc) fids
576
577 get_fi_cons :: DataFamInstDecl Name -> [Name]
578 get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
579 = map unLoc $ concatMap (getConNames . unLoc) cons
580
581
582 tcAddPatSynPlaceholders :: [PatSynBind Name Name] -> TcM a -> TcM a
583 -- See Note [Don't promote pattern synonyms]
584 tcAddPatSynPlaceholders pat_syns thing_inside
585 = tcExtendKindEnv2 [ (name, APromotionErr PatSynPE)
586 | PSB{ psb_id = L _ name } <- pat_syns ]
587 thing_inside
588
589 getPatSynBinds :: [(RecFlag, LHsBinds Name)] -> [PatSynBind Name Name]
590 getPatSynBinds binds
591 = [ psb | (_, lbinds) <- binds
592 , L _ (PatSynBind psb) <- bagToList lbinds ]
593
594
595 getTypeSigNames :: [LSig Name] -> NameSet
596 -- Get the names that have a user type sig
597 getTypeSigNames sigs
598 = foldr get_type_sig emptyNameSet sigs
599 where
600 get_type_sig :: LSig Name -> NameSet -> NameSet
601 get_type_sig sig ns =
602 case sig of
603 L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
604 L _ (PatSynSig name _) -> extendNameSet ns (unLoc name)
605 _ -> ns
606
607
608 {- Note [AFamDataCon: not promoting data family constructors]
609 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
610 Consider
611 data family T a
612 data instance T Int = MkT
613 data Proxy (a :: k)
614 data S = MkS (Proxy 'MkT)
615
616 Is it ok to use the promoted data family instance constructor 'MkT' in
617 the data declaration for S? No, we don't allow this. It *might* make
618 sense, but at least it would mean that we'd have to interleave
619 typechecking instances and data types, whereas at present we do data
620 types *then* instances.
621
622 So to check for this we put in the TcLclEnv a binding for all the family
623 constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
624 type checking 'S' we'll produce a decent error message.
625
626 Note [Don't promote pattern synonyms]
627 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
628 We never promote pattern synonyms.
629
630 Consider this (Trac #11265):
631 pattern A = True
632 instance Eq A
633 We want a civilised error message from the occurrence of 'A'
634 in the instance, yet 'A' really has not yet been type checked.
635
636 Similarly (Trac #9161)
637 {-# LANGUAGE PatternSynonyms, DataKinds #-}
638 pattern A = ()
639 b :: A
640 b = undefined
641 Here, the type signature for b mentions A. But A is a pattern
642 synonym, which is typechecked as part of a group of bindings (for very
643 good reasons; a view pattern in the RHS may mention a value binding).
644 It is entirely reasonable to reject this, but to do so we need A to be
645 in the kind environment when kind-checking the signature for B.
646
647 Hence tcAddPatSynPlaceholers adds a binding
648 A -> APromotionErr PatSynPE
649 to the environment. Then TcHsType.tcTyVar will find A in the kind
650 environment, and will give a 'wrongThingErr' as a result. But the
651 lookup of A won't fail.
652
653
654 ************************************************************************
655 * *
656 \subsection{Rules}
657 * *
658 ************************************************************************
659 -}
660
661 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
662 -- Just pop the new rules into the EPS and envt resp
663 -- All the rules come from an interface file, not source
664 -- Nevertheless, some may be for this module, if we read
665 -- its interface instead of its source code
666 tcExtendRules lcl_rules thing_inside
667 = do { env <- getGblEnv
668 ; let
669 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
670 ; setGblEnv env' thing_inside }
671
672 {-
673 ************************************************************************
674 * *
675 Meta level
676 * *
677 ************************************************************************
678 -}
679
680 checkWellStaged :: SDoc -- What the stage check is for
681 -> ThLevel -- Binding level (increases inside brackets)
682 -> ThLevel -- Use stage
683 -> TcM () -- Fail if badly staged, adding an error
684 checkWellStaged pp_thing bind_lvl use_lvl
685 | use_lvl >= bind_lvl -- OK! Used later than bound
686 = return () -- E.g. \x -> [| $(f x) |]
687
688 | bind_lvl == outerLevel -- GHC restriction on top level splices
689 = stageRestrictionError pp_thing
690
691 | otherwise -- Badly staged
692 = failWithTc $ -- E.g. \x -> $(f x)
693 text "Stage error:" <+> pp_thing <+>
694 hsep [text "is bound at stage" <+> ppr bind_lvl,
695 text "but used at stage" <+> ppr use_lvl]
696
697 stageRestrictionError :: SDoc -> TcM a
698 stageRestrictionError pp_thing
699 = failWithTc $
700 sep [ text "GHC stage restriction:"
701 , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
702 , text "and must be imported, not defined locally"])]
703
704 topIdLvl :: Id -> ThLevel
705 -- Globals may either be imported, or may be from an earlier "chunk"
706 -- (separated by declaration splices) of this module. The former
707 -- *can* be used inside a top-level splice, but the latter cannot.
708 -- Hence we give the former impLevel, but the latter topLevel
709 -- E.g. this is bad:
710 -- x = [| foo |]
711 -- $( f x )
712 -- By the time we are prcessing the $(f x), the binding for "x"
713 -- will be in the global env, not the local one.
714 topIdLvl id | isLocalId id = outerLevel
715 | otherwise = impLevel
716
717 tcMetaTy :: Name -> TcM Type
718 -- Given the name of a Template Haskell data type,
719 -- return the type
720 -- E.g. given the name "Expr" return the type "Expr"
721 tcMetaTy tc_name = do
722 t <- tcLookupTyCon tc_name
723 return (mkTyConApp t [])
724
725 isBrackStage :: ThStage -> Bool
726 isBrackStage (Brack {}) = True
727 isBrackStage _other = False
728
729 {-
730 ************************************************************************
731 * *
732 getDefaultTys
733 * *
734 ************************************************************************
735 -}
736
737 tcGetDefaultTys :: TcM ([Type], -- Default types
738 (Bool, -- True <=> Use overloaded strings
739 Bool)) -- True <=> Use extended defaulting rules
740 tcGetDefaultTys
741 = do { dflags <- getDynFlags
742 ; let ovl_strings = xopt LangExt.OverloadedStrings dflags
743 extended_defaults = xopt LangExt.ExtendedDefaultRules dflags
744 -- See also Trac #1974
745 flags = (ovl_strings, extended_defaults)
746
747 ; mb_defaults <- getDeclaredDefaultTys
748 ; case mb_defaults of {
749 Just tys -> return (tys, flags) ;
750 -- User-supplied defaults
751 Nothing -> do
752
753 -- No use-supplied default
754 -- Use [Integer, Double], plus modifications
755 { integer_ty <- tcMetaTy integerTyConName
756 ; list_ty <- tcMetaTy listTyConName
757 ; checkWiredInTyCon doubleTyCon
758 ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
759 -- Note [Extended defaults]
760 ++ [integer_ty, doubleTy]
761 ++ opt_deflt ovl_strings [stringTy]
762 ; return (deflt_tys, flags) } } }
763 where
764 opt_deflt True xs = xs
765 opt_deflt False _ = []
766
767 {-
768 Note [Extended defaults]
769 ~~~~~~~~~~~~~~~~~~~~~
770 In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
771 try when defaulting. This has very little real impact, except in the following case.
772 Consider:
773 Text.Printf.printf "hello"
774 This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't
775 want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to
776 default the 'a' to (), rather than to Integer (which is what would otherwise happen;
777 and then GHCi doesn't attempt to print the (). So in interactive mode, we add
778 () to the list of defaulting types. See Trac #1200.
779
780 Additonally, the list type [] is added as a default specialization for
781 Traversable and Foldable. As such the default default list now has types of
782 varying kinds, e.g. ([] :: * -> *) and (Integer :: *).
783
784 ************************************************************************
785 * *
786 \subsection{The InstInfo type}
787 * *
788 ************************************************************************
789
790 The InstInfo type summarises the information in an instance declaration
791
792 instance c => k (t tvs) where b
793
794 It is used just for *local* instance decls (not ones from interface files).
795 But local instance decls includes
796 - derived ones
797 - generic ones
798 as well as explicit user written ones.
799 -}
800
801 data InstInfo a
802 = InstInfo
803 { iSpec :: ClsInst -- Includes the dfun id
804 , iBinds :: InstBindings a
805 }
806
807 iDFunId :: InstInfo a -> DFunId
808 iDFunId info = instanceDFunId (iSpec info)
809
810 data InstBindings a
811 = InstBindings
812 { ib_tyvars :: [Name] -- Names of the tyvars from the instance head
813 -- that are lexically in scope in the bindings
814 -- Must correspond 1-1 with the forall'd tyvars
815 -- of the dfun Id. When typechecking, we are
816 -- going to extend the typechecker's envt with
817 -- ib_tyvars -> dfun_forall_tyvars
818
819 , ib_binds :: LHsBinds a -- Bindings for the instance methods
820
821 , ib_pragmas :: [LSig a] -- User pragmas recorded for generating
822 -- specialised instances
823
824 , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should
825 -- be enabled when type-checking
826 -- this instance; needed for
827 -- GeneralizedNewtypeDeriving
828
829 , ib_derived :: Bool
830 -- True <=> This code was generated by GHC from a deriving clause
831 -- or standalone deriving declaration
832 -- Used only to improve error messages
833 }
834
835 instance (OutputableBndrId a) => Outputable (InstInfo a) where
836 ppr = pprInstInfoDetails
837
838 pprInstInfoDetails :: (OutputableBndrId a) => InstInfo a -> SDoc
839 pprInstInfoDetails info
840 = hang (pprInstanceHdr (iSpec info) <+> text "where")
841 2 (details (iBinds info))
842 where
843 details (InstBindings { ib_binds = b }) = pprLHsBinds b
844
845 simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
846 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
847 (_, cls, [ty]) -> (cls, ty)
848 _ -> panic "simpleInstInfoClsTy"
849
850 simpleInstInfoTy :: InstInfo a -> Type
851 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
852
853 simpleInstInfoTyCon :: InstInfo a -> TyCon
854 -- Gets the type constructor for a simple instance declaration,
855 -- i.e. one of the form instance (...) => C (T a b c) where ...
856 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
857
858 -- | Make a name for the dict fun for an instance decl. It's an *external*
859 -- name, like other top-level names, and hence must be made with
860 -- newGlobalBinder.
861 newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
862 newDFunName clas tys loc
863 = do { is_boot <- tcIsHsBootOrSig
864 ; mod <- getModule
865 ; let info_string = occNameString (getOccName clas) ++
866 concatMap (occNameString.getDFunTyKey) tys
867 ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
868 ; newGlobalBinder mod dfun_occ loc }
869
870 -- | Special case of 'newDFunName' to generate dict fun name for a single TyCon.
871 newDFunName' :: Class -> TyCon -> TcM Name
872 newDFunName' clas tycon -- Just a simple wrapper
873 = do { loc <- getSrcSpanM -- The location of the instance decl,
874 -- not of the tycon
875 ; newDFunName clas [mkTyConApp tycon []] loc }
876 -- The type passed to newDFunName is only used to generate
877 -- a suitable string; hence the empty type arg list
878
879 {-
880 Make a name for the representation tycon of a family instance. It's an
881 *external* name, like other top-level names, and hence must be made with
882 newGlobalBinder.
883 -}
884
885 newFamInstTyConName :: Located Name -> [Type] -> TcM Name
886 newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
887
888 newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name
889 newFamInstAxiomName (L loc name) branches
890 = mk_fam_inst_name mkInstTyCoOcc loc name branches
891
892 mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
893 mk_fam_inst_name adaptOcc loc tc_name tyss
894 = do { mod <- getModule
895 ; let info_string = occNameString (getOccName tc_name) ++
896 intercalate "|" ty_strings
897 ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
898 ; newGlobalBinder mod (adaptOcc occ) loc }
899 where
900 ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
901
902 {-
903 Stable names used for foreign exports and annotations.
904 For stable names, the name must be unique (see #1533). If the
905 same thing has several stable Ids based on it, the
906 top-level bindings generated must not have the same name.
907 Hence we create an External name (doesn't change), and we
908 append a Unique to the string right here.
909 -}
910
911 mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
912 mkStableIdFromString str sig_ty loc occ_wrapper = do
913 uniq <- newUnique
914 mod <- getModule
915 name <- mkWrapperName "stable" str
916 let occ = mkVarOccFS name :: OccName
917 gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
918 id = mkExportedVanillaId gnm sig_ty :: Id
919 return id
920
921 mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
922 mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
923
924 mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
925 => String -> String -> m FastString
926 mkWrapperName what nameBase
927 = do dflags <- getDynFlags
928 thisMod <- getModule
929 let -- Note [Generating fresh names for ccall wrapper]
930 wrapperRef = nextWrapperNum dflags
931 pkg = unitIdString (moduleUnitId thisMod)
932 mod = moduleNameString (moduleName thisMod)
933 wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
934 let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
935 mod_env' = extendModuleEnv mod_env thisMod (num+1)
936 in (mod_env', num)
937 let components = [what, show wrapperNum, pkg, mod, nameBase]
938 return $ mkFastString $ zEncodeString $ intercalate ":" components
939
940 {-
941 Note [Generating fresh names for FFI wrappers]
942
943 We used to use a unique, rather than nextWrapperNum, to distinguish
944 between FFI wrapper functions. However, the wrapper names that we
945 generate are external names. This means that if a call to them ends up
946 in an unfolding, then we can't alpha-rename them, and thus if the
947 unique randomly changes from one compile to another then we get a
948 spurious ABI change (#4012).
949
950 The wrapper counter has to be per-module, not global, so that the number we end
951 up using is not dependent on the modules compiled before the current one.
952 -}
953
954 {-
955 ************************************************************************
956 * *
957 \subsection{Errors}
958 * *
959 ************************************************************************
960 -}
961
962 pprBinders :: [Name] -> SDoc
963 -- Used in error messages
964 -- Use quotes for a single one; they look a bit "busy" for several
965 pprBinders [bndr] = quotes (ppr bndr)
966 pprBinders bndrs = pprWithCommas ppr bndrs
967
968 notFound :: Name -> TcM TyThing
969 notFound name
970 = do { lcl_env <- getLclEnv
971 ; let stage = tcl_th_ctxt lcl_env
972 ; case stage of -- See Note [Out of scope might be a staging error]
973 Splice {}
974 | isUnboundName name -> failM -- If the name really isn't in scope
975 -- don't report it again (Trac #11941)
976 | otherwise -> stageRestrictionError (quotes (ppr name))
977 _ -> failWithTc $
978 vcat[text "GHC internal error:" <+> quotes (ppr name) <+>
979 text "is not in scope during type checking, but it passed the renamer",
980 text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]
981 -- Take care: printing the whole gbl env can
982 -- cause an infinite loop, in the case where we
983 -- are in the middle of a recursive TyCon/Class group;
984 -- so let's just not print it! Getting a loop here is
985 -- very unhelpful, because it hides one compiler bug with another
986 }
987
988 wrongThingErr :: String -> TcTyThing -> Name -> TcM a
989 -- It's important that this only calls pprTcTyThingCategory, which in
990 -- turn does not look at the details of the TcTyThing.
991 -- See Note [Placeholder PatSyn kinds] in TcBinds
992 wrongThingErr expected thing name
993 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
994 text "used as a" <+> text expected)
995
996 {- Note [Out of scope might be a staging error]
997 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
998 Consider
999 x = 3
1000 data T = MkT $(foo x)
1001
1002 where 'foo' is is imported from somewhere.
1003
1004 This is really a staging error, because we can't run code involving 'x'.
1005 But in fact the type checker processes types first, so 'x' won't even be
1006 in the type envt when we look for it in $(foo x). So inside splices we
1007 report something missing from the type env as a staging error.
1008 See Trac #5752 and #5795.
1009 -}