never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE BangPatterns #-}
3 {-# LANGUAGE LambdaCase #-}
4 {-# LANGUAGE NondecreasingIndentation #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# LANGUAGE FlexibleContexts #-}
8 {-# LANGUAGE MultiWayIf #-}
9 {-# LANGUAGE TupleSections #-}
10
11 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
12
13 {-
14 (c) The University of Glasgow 2006
15 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
16
17 -}
18
19 -- | Typechecking a whole module
20 --
21 -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker
22 module GHC.Tc.Module (
23 tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
24 tcRnImportDecls,
25 tcRnLookupRdrName,
26 getModuleInterface,
27 tcRnDeclsi,
28 isGHCiMonad,
29 runTcInteractive, -- Used by GHC API clients (#8878)
30 tcRnLookupName,
31 tcRnGetInfo,
32 tcRnModule, tcRnModuleTcRnM,
33 tcTopSrcDecls,
34 rnTopSrcDecls,
35 checkBootDecl, checkHiBootIface',
36 findExtraSigImports,
37 implicitRequirements,
38 checkUnit,
39 mergeSignatures,
40 tcRnMergeSignatures,
41 instantiateSignature,
42 tcRnInstantiateSignature,
43 loadUnqualIfaces,
44 -- More private...
45 badReexportedBootThing,
46 checkBootDeclM,
47 missingBootThing,
48 getRenamedStuff, RenamedStuff
49 ) where
50
51 import GHC.Prelude
52
53 import GHC.Driver.Env
54 import GHC.Driver.Plugins
55 import GHC.Driver.Session
56 import GHC.Driver.Config.Diagnostic
57
58 import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )
59 import GHC.Tc.Errors.Types
60 import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers )
61 import GHC.Tc.Gen.HsType
62 import GHC.Tc.Validity( checkValidType )
63 import GHC.Tc.Gen.Match
64 import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma )
65 import GHC.Tc.Utils.Zonk
66 import GHC.Tc.Gen.Expr
67 import GHC.Tc.Gen.App( tcInferSigma )
68 import GHC.Tc.Utils.Monad
69 import GHC.Tc.Gen.Export
70 import GHC.Tc.Types.Evidence
71 import GHC.Tc.Types.Constraint
72 import GHC.Tc.Types.Origin
73 import GHC.Tc.Instance.Family
74 import GHC.Tc.Gen.Annotation
75 import GHC.Tc.Gen.Bind
76 import GHC.Tc.Gen.Default
77 import GHC.Tc.Utils.Env
78 import GHC.Tc.Gen.Rule
79 import GHC.Tc.Gen.Foreign
80 import GHC.Tc.TyCl.Class ( ClassScopedTVEnv )
81 import GHC.Tc.TyCl.Instance
82 import GHC.Tc.Utils.TcMType
83 import GHC.Tc.Utils.TcType
84 import GHC.Tc.Utils.Instantiate (tcGetInsts)
85 import GHC.Tc.Solver
86 import GHC.Tc.TyCl
87 import GHC.Tc.Instance.Typeable ( mkTypeableBinds )
88 import GHC.Tc.Utils.Backpack
89
90 import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
91 import GHC.Rename.HsType
92 import GHC.Rename.Expr
93 import GHC.Rename.Utils ( HsDocContext(..) )
94 import GHC.Rename.Fixity ( lookupFixityRn )
95 import GHC.Rename.Names
96 import GHC.Rename.Env
97 import GHC.Rename.Module
98
99 import GHC.Iface.Syntax ( ShowSub(..), showToHeader )
100 import GHC.Iface.Type ( ShowForAllFlag(..) )
101 import GHC.Iface.Env ( externaliseName )
102 import GHC.Iface.Make ( coAxiomToIfaceDecl )
103 import GHC.Iface.Load
104
105 import GHC.Builtin.Types ( unitTy, mkListTy )
106 import GHC.Builtin.Names
107 import GHC.Builtin.Utils
108
109 import GHC.Hs
110 import GHC.Hs.Dump
111
112 import GHC.Core.PatSyn ( pprPatSynType )
113 import GHC.Core.Predicate ( classMethodTy )
114 import GHC.Core.FVs ( orphNamesOfFamInst )
115 import GHC.Core.InstEnv
116 import GHC.Core.TyCon
117 import GHC.Core.ConLike
118 import GHC.Core.DataCon
119 import GHC.Core.Type
120 import GHC.Core.Class
121 import GHC.Core.Coercion.Axiom
122 import GHC.Core.Reduction ( Reduction(..) )
123 import GHC.Core.Unify( RoughMatchTc(..) )
124 import GHC.Core.FamInstEnv
125 ( FamInst, pprFamInst, famInstsRepTyCons
126 , famInstEnvElts, extendFamInstEnvList, normaliseType )
127
128 import GHC.Parser.Header ( mkPrelImports )
129
130 import GHC.IfaceToCore
131
132 import GHC.Runtime.Context
133
134 import GHC.Utils.Error
135 import GHC.Utils.Outputable as Outputable
136 import GHC.Utils.Panic
137 import GHC.Utils.Panic.Plain
138 import GHC.Utils.Misc
139 import GHC.Utils.Logger
140
141 import GHC.Types.Error
142 import GHC.Types.Name.Reader
143 import GHC.Types.Fixity.Env
144 import GHC.Types.Id as Id
145 import GHC.Types.Id.Info( IdDetails(..) )
146 import GHC.Types.Var.Env
147 import GHC.Types.TypeEnv
148 import GHC.Types.Unique.FM
149 import GHC.Types.Name
150 import GHC.Types.Name.Env
151 import GHC.Types.Name.Set
152 import GHC.Types.Avail
153 import GHC.Types.Basic hiding( SuccessFlag(..) )
154 import GHC.Types.Annotations
155 import GHC.Types.SrcLoc
156 import GHC.Types.SourceFile
157 import GHC.Types.TyThing.Ppr ( pprTyThingInContext )
158 import GHC.Types.PkgQual
159 import qualified GHC.LanguageExtensions as LangExt
160
161 import GHC.Unit.External
162 import GHC.Unit.Types
163 import GHC.Unit.State
164 import GHC.Unit.Home
165 import GHC.Unit.Module
166 import GHC.Unit.Module.Warnings
167 import GHC.Unit.Module.ModSummary
168 import GHC.Unit.Module.ModIface
169 import GHC.Unit.Module.ModDetails
170 import GHC.Unit.Module.Deps
171
172 import GHC.Data.FastString
173 import GHC.Data.Maybe
174 import GHC.Data.List.SetOps
175 import GHC.Data.Bag
176 import qualified GHC.Data.BooleanFormula as BF
177
178 import Data.List ( sortBy, sort )
179 import Data.Ord
180 import Data.Data ( Data )
181 import qualified Data.Set as S
182 import Control.DeepSeq
183 import Control.Monad
184
185 {-
186 ************************************************************************
187 * *
188 Typecheck and rename a module
189 * *
190 ************************************************************************
191 -}
192
193 -- | Top level entry point for typechecker and renamer
194 tcRnModule :: HscEnv
195 -> ModSummary
196 -> Bool -- True <=> save renamed syntax
197 -> HsParsedModule
198 -> IO (Messages TcRnMessage, Maybe TcGblEnv)
199
200 tcRnModule hsc_env mod_sum save_rn_syntax
201 parsedModule@HsParsedModule {hpm_module= L loc this_module}
202 | RealSrcSpan real_loc _ <- loc
203 = withTiming logger
204 (text "Renamer/typechecker"<+>brackets (ppr this_mod))
205 (const ()) $
206 initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
207 withTcPlugins hsc_env $
208 withDefaultingPlugins hsc_env $
209 withHoleFitPlugins hsc_env $
210
211 tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
212
213 | otherwise
214 = return (err_msg `addMessage` emptyMessages, Nothing)
215
216 where
217 hsc_src = ms_hsc_src mod_sum
218 logger = hsc_logger hsc_env
219 home_unit = hsc_home_unit hsc_env
220 err_msg = mkPlainErrorMsgEnvelope loc $
221 TcRnModMissingRealSrcSpan this_mod
222
223 pair :: (Module, SrcSpan)
224 pair@(this_mod,_)
225 | Just (L mod_loc mod) <- hsmodName this_module
226 = (mkHomeModule home_unit mod, locA mod_loc)
227
228 | otherwise -- 'module M where' is omitted
229 = (mkHomeModule home_unit mAIN_NAME, srcLocSpan (srcSpanStart loc))
230
231
232
233
234 tcRnModuleTcRnM :: HscEnv
235 -> ModSummary
236 -> HsParsedModule
237 -> (Module, SrcSpan)
238 -> TcRn TcGblEnv
239 -- Factored out separately from tcRnModule so that a Core plugin can
240 -- call the type checker directly
241 tcRnModuleTcRnM hsc_env mod_sum
242 (HsParsedModule {
243 hpm_module =
244 (L loc (HsModule _ _ maybe_mod export_ies
245 import_decls local_decls mod_deprec
246 maybe_doc_hdr)),
247 hpm_src_files = src_files
248 })
249 (this_mod, prel_imp_loc)
250 = setSrcSpan loc $
251 do { let { explicit_mod_hdr = isJust maybe_mod
252 ; hsc_src = ms_hsc_src mod_sum }
253 ; -- Load the hi-boot interface for this module, if any
254 -- We do this now so that the boot_names can be passed
255 -- to tcTyAndClassDecls, because the boot_names are
256 -- automatically considered to be loop breakers
257 tcg_env <- getGblEnv
258 ; boot_info <- tcHiBootIface hsc_src this_mod
259 ; setGblEnv (tcg_env { tcg_self_boot = boot_info })
260 $ do
261 { -- Deal with imports; first add implicit prelude
262 implicit_prelude <- xoptM LangExt.ImplicitPrelude
263 ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
264 implicit_prelude import_decls }
265
266 ; when (notNull prel_imports) $ do
267 let msg = TcRnUnknownMessage $
268 mkPlainDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) noHints (implicitPreludeWarn)
269 addDiagnostic msg
270
271 ; -- TODO This is a little skeevy; maybe handle a bit more directly
272 let { simplifyImport (L _ idecl) =
273 ( renameRawPkgQual (hsc_unit_env hsc_env) (ideclPkgQual idecl)
274 , reLoc $ ideclName idecl)
275 }
276 ; raw_sig_imports <- liftIO
277 $ findExtraSigImports hsc_env hsc_src
278 (moduleName this_mod)
279 ; raw_req_imports <- liftIO
280 $ implicitRequirements hsc_env
281 (map simplifyImport (prel_imports
282 ++ import_decls))
283 ; let { mkImport mod_name = noLocA
284 $ (simpleImportDecl mod_name)
285 { ideclHiding = Just (False, noLocA [])}}
286 ; let { withReason t imps = map (,text t) imps }
287 ; let { all_imports = withReason "is implicitly imported" prel_imports
288 ++ withReason "is directly imported" import_decls
289 ++ withReason "is an extra sig import" (map mkImport raw_sig_imports)
290 ++ withReason "is an implicit req import" (map mkImport raw_req_imports) }
291 ; -- OK now finally rename the imports
292 tcg_env <- {-# SCC "tcRnImports" #-}
293 tcRnImports hsc_env all_imports
294
295 ; -- Don't need to rename the Haddock documentation,
296 -- it's not parsed by GHC anymore.
297 -- Make sure to do this before 'tcRnSrcDecls', because we need the
298 -- module header when we're splicing TH, since it can be accessed via
299 -- 'getDoc'.
300 tcg_env <- return (tcg_env
301 { tcg_doc_hdr = maybe_doc_hdr })
302
303 ; -- If the whole module is warned about or deprecated
304 -- (via mod_deprec) record that in tcg_warns. If we do thereby add
305 -- a WarnAll, it will override any subsequent deprecations added to tcg_warns
306 let { tcg_env1 = case mod_deprec of
307 Just (L _ txt) ->
308 tcg_env {tcg_warns = WarnAll txt}
309 Nothing -> tcg_env
310 }
311 ; setGblEnv tcg_env1
312 $ do { -- Rename and type check the declarations
313 traceRn "rn1a" empty
314 ; tcg_env <- if isHsBootOrSig hsc_src
315 then do {
316 ; tcg_env <- tcRnHsBootDecls hsc_src local_decls
317 ; traceRn "rn4a: before exports" empty
318 ; tcg_env <- setGblEnv tcg_env $
319 rnExports explicit_mod_hdr export_ies
320 ; traceRn "rn4b: after exports" empty
321 ; return tcg_env
322 }
323 else {-# SCC "tcRnSrcDecls" #-}
324 tcRnSrcDecls explicit_mod_hdr export_ies local_decls
325
326 ; whenM (goptM Opt_DoCoreLinting) $
327 lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env
328
329 ; setGblEnv tcg_env
330 $ do { -- Compare hi-boot iface (if any) with the real thing
331 -- Must be done after processing the exports
332 tcg_env <- checkHiBootIface tcg_env boot_info
333 ; -- The new type env is already available to stuff
334 -- slurped from interface files, via
335 -- GHC.Tc.Utils.Env.setGlobalTypeEnv. It's important that this
336 -- includes the stuff in checkHiBootIface,
337 -- because the latter might add new bindings for
338 -- boot_dfuns, which may be mentioned in imported
339 -- unfoldings.
340 -- Report unused names
341 -- Do this /after/ typeinference, so that when reporting
342 -- a function with no type signature we can give the
343 -- inferred type
344 reportUnusedNames tcg_env hsc_src
345 ; -- add extra source files to tcg_dependent_files
346 addDependentFiles src_files
347 -- Ensure plugins run with the same tcg_env that we pass in
348 ; setGblEnv tcg_env
349 $ do { tcg_env <- runTypecheckerPlugin mod_sum tcg_env
350 ; -- Dump output and return
351 tcDump tcg_env
352 ; return tcg_env
353 }
354 }
355 }
356 }
357 }
358
359 implicitPreludeWarn :: SDoc
360 implicitPreludeWarn
361 = text "Module `Prelude' implicitly imported"
362
363 {-
364 ************************************************************************
365 * *
366 Import declarations
367 * *
368 ************************************************************************
369 -}
370
371 tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv
372 tcRnImports hsc_env import_decls
373 = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
374
375 ; this_mod <- getModule
376 ; let { dep_mods :: ModuleNameEnv ModuleNameWithIsBoot
377 ; dep_mods = imp_direct_dep_mods imports
378
379 -- We want instance declarations from all home-package
380 -- modules below this one, including boot modules, except
381 -- ourselves. The 'except ourselves' is so that we don't
382 -- get the instances from this module's hs-boot file. This
383 -- filtering also ensures that we don't see instances from
384 -- modules batch (@--make@) compiled before this one, but
385 -- which are not below this one.
386 ; (home_insts, home_fam_insts) = hptInstancesBelow hsc_env (moduleName this_mod)
387 (S.fromList (nonDetEltsUFM dep_mods))
388 } ;
389
390 -- Record boot-file info in the EPS, so that it's
391 -- visible to loadHiBootInterface in tcRnSrcDecls,
392 -- and any other incrementally-performed imports
393 ; when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {
394 updateEps_ $ \eps -> eps { eps_is_boot = imp_boot_mods imports }
395 }
396
397 -- Update the gbl env
398 ; updGblEnv ( \ gbl ->
399 gbl {
400 tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
401 tcg_imports = tcg_imports gbl `plusImportAvails` imports,
402 tcg_rn_imports = rn_imports,
403 tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
404 tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
405 home_fam_insts,
406 tcg_hpc = hpc_info
407 }) $ do {
408
409 ; traceRn "rn1" (ppr (imp_direct_dep_mods imports))
410 -- Fail if there are any errors so far
411 -- The error printing (if needed) takes advantage
412 -- of the tcg_env we have now set
413 -- ; traceIf (text "rdr_env: " <+> ppr rdr_env)
414 ; failIfErrsM
415
416 -- Load any orphan-module (including orphan family
417 -- instance-module) interfaces, so that their rules and
418 -- instance decls will be found. But filter out a
419 -- self hs-boot: these instances will be checked when
420 -- we define them locally.
421 -- (We don't need to load non-orphan family instance
422 -- modules until we either try to use the instances they
423 -- define, or define our own family instances, at which
424 -- point we need to check them for consistency.)
425 ; loadModuleInterfaces (text "Loading orphan modules")
426 (filter (/= this_mod) (imp_orphs imports))
427
428 -- Check type-family consistency between imports.
429 -- See Note [The type family instance consistency story]
430 ; traceRn "rn1: checking family instance consistency {" empty
431 ; let { dir_imp_mods = moduleEnvKeys
432 . imp_mods
433 $ imports }
434 ; checkFamInstConsistency dir_imp_mods
435 ; traceRn "rn1: } checking family instance consistency" empty
436
437 ; getGblEnv } }
438
439 {-
440 ************************************************************************
441 * *
442 Type-checking the top level of a module
443 * *
444 ************************************************************************
445 -}
446
447 tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all
448 -> Maybe (LocatedL [LIE GhcPs])
449 -> [LHsDecl GhcPs] -- Declarations
450 -> TcM TcGblEnv
451 tcRnSrcDecls explicit_mod_hdr export_ies decls
452 = do { -- Do all the declarations
453 ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls
454
455 ------ Simplify constraints ---------
456 --
457 -- We do this after checkMainType, so that we use the type
458 -- info that checkMainType adds
459 --
460 -- We do it with both global and local env in scope:
461 -- * the global env exposes the instances to simplifyTop,
462 -- and affects how names are rendered in error messages
463 -- * the local env exposes the local Ids to simplifyTop,
464 -- so that we get better error messages (monomorphism restriction)
465 ; new_ev_binds <- {-# SCC "simplifyTop" #-}
466 setEnvs (tcg_env, tcl_env) $
467 do { lie_main <- checkMainType tcg_env
468 ; simplifyTop (lie `andWC` lie_main) }
469
470 -- Emit Typeable bindings
471 ; tcg_env <- setGblEnv tcg_env $
472 mkTypeableBinds
473
474 ; traceTc "Tc9" empty
475
476 -- Zonk the final code. This must be done last.
477 -- Even simplifyTop may do some unification.
478 -- This pass also warns about missing type signatures
479 ; (id_env, ev_binds', binds', fords', imp_specs', rules')
480 <- zonkTcGblEnv new_ev_binds tcg_env
481
482 --------- Run finalizers --------------
483 -- Finalizers must run after constraints are simplified, lest types
484 -- might not be complete when using reify (see #12777).
485 -- and also after we zonk the first time because we run typed splices
486 -- in the zonker which gives rise to the finalisers.
487 ; let -- init_tcg_env:
488 -- * Remove accumulated bindings, rules and so on from
489 -- TcGblEnv. They are now in ev_binds', binds', etc.
490 -- * Add the zonked Ids from the value bindings to tcg_type_env
491 -- Up to now these Ids are only in tcl_env's type-envt
492 init_tcg_env = tcg_env { tcg_binds = emptyBag
493 , tcg_ev_binds = emptyBag
494 , tcg_imp_specs = []
495 , tcg_rules = []
496 , tcg_fords = []
497 , tcg_type_env = tcg_type_env tcg_env
498 `plusTypeEnv` id_env }
499 ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env
500 run_th_modfinalizers
501 ; finishTH
502 ; traceTc "Tc11" empty
503
504 --------- Deal with the exports ----------
505 -- Can't be done earlier, because the export list must "see"
506 -- the declarations created by the finalizers
507 ; tcg_env <- setEnvs (tcg_env, tcl_env) $
508 rnExports explicit_mod_hdr export_ies
509
510 --------- Emit the ':Main.main = runMainIO main' declaration ----------
511 -- Do this /after/ rnExports, so that it can consult
512 -- the tcg_exports created by rnExports
513 ; (tcg_env, main_ev_binds)
514 <- setEnvs (tcg_env, tcl_env) $
515 do { (tcg_env, lie) <- captureTopConstraints $
516 checkMain explicit_mod_hdr export_ies
517 ; ev_binds <- simplifyTop lie
518 ; return (tcg_env, ev_binds) }
519
520 ---------- Final zonking ---------------
521 -- Zonk the new bindings arising from running the finalisers,
522 -- and main. This won't give rise to any more finalisers as you
523 -- can't nest finalisers inside finalisers.
524 ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)
525 <- zonkTcGblEnv main_ev_binds tcg_env
526
527 ; let { !final_type_env = tcg_type_env tcg_env
528 `plusTypeEnv` id_env_mf
529 -- Add the zonked Ids from the value bindings (they were in tcl_env)
530 -- Force !final_type_env, lest we retain an old reference
531 -- to the previous tcg_env
532
533 ; tcg_env' = tcg_env
534 { tcg_binds = binds' `unionBags` binds_mf
535 , tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf
536 , tcg_imp_specs = imp_specs' ++ imp_specs_mf
537 , tcg_rules = rules' ++ rules_mf
538 , tcg_fords = fords' ++ fords_mf } } ;
539
540 ; setGlobalTypeEnv tcg_env' final_type_env
541 }
542
543 zonkTcGblEnv :: Bag EvBind -> TcGblEnv
544 -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
545 [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
546 zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds = binds
547 , tcg_ev_binds = cur_ev_binds
548 , tcg_imp_specs = imp_specs
549 , tcg_rules = rules
550 , tcg_fords = fords })
551 = {-# SCC "zonkTopDecls" #-}
552 setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering
553 -- error messages during zonking (notably levity errors)
554 do { failIfErrsM -- Don't zonk if there have been errors
555 -- It's a waste of time; and we may get debug warnings
556 -- about strangely-typed TyCons!
557 ; let all_ev_binds = cur_ev_binds `unionBags` ev_binds
558 ; zonkTopDecls all_ev_binds binds rules imp_specs fords }
559
560 -- | Runs TH finalizers and renames and typechecks the top-level declarations
561 -- that they could introduce.
562 run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
563 run_th_modfinalizers = do
564 th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
565 th_modfinalizers <- readTcRef th_modfinalizers_var
566 if null th_modfinalizers
567 then getEnvs
568 else do
569 writeTcRef th_modfinalizers_var []
570 let run_finalizer (lcl_env, f) =
571 setLclEnv lcl_env (runRemoteModFinalizers f)
572
573 (_, lie_th) <- captureTopConstraints $
574 mapM_ run_finalizer th_modfinalizers
575
576 -- Finalizers can add top-level declarations with addTopDecls, so
577 -- we have to run tc_rn_src_decls to get them
578 (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []
579
580 setEnvs (tcg_env, tcl_env) $ do
581 -- Subsequent rounds of finalizers run after any new constraints are
582 -- simplified, or some types might not be complete when using reify
583 -- (see #12777).
584 new_ev_binds <- {-# SCC "simplifyTop2" #-}
585 simplifyTop (lie_th `andWC` lie_top_decls)
586 addTopEvBinds new_ev_binds run_th_modfinalizers
587 -- addTopDecls can add declarations which add new finalizers.
588
589 tc_rn_src_decls :: [LHsDecl GhcPs]
590 -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
591 -- Loops around dealing with each top level inter-splice group
592 -- in turn, until it's dealt with the entire module
593 -- Never emits constraints; calls captureTopConstraints internally
594 tc_rn_src_decls ds
595 = {-# SCC "tc_rn_src_decls" #-}
596 do { (first_group, group_tail) <- findSplice ds
597 -- If ds is [] we get ([], Nothing)
598
599 -- Deal with decls up to, but not including, the first splice
600 ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group
601 -- rnTopSrcDecls fails if there are any errors
602
603 -- Get TH-generated top-level declarations and make sure they don't
604 -- contain any splices since we don't handle that at the moment
605 --
606 -- The plumbing here is a bit odd: see #10853
607 ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
608 ; th_ds <- readTcRef th_topdecls_var
609 ; writeTcRef th_topdecls_var []
610
611 ; (tcg_env, rn_decls) <-
612 if null th_ds
613 then return (tcg_env, rn_decls)
614 else do { (th_group, th_group_tail) <- findSplice th_ds
615 ; case th_group_tail of
616 { Nothing -> return ()
617 ; Just (SpliceDecl _ (L loc _) _, _) ->
618 setSrcSpanA loc
619 $ addErr (TcRnUnknownMessage $ mkPlainError noHints $ text
620 ("Declaration splices are not "
621 ++ "permitted inside top-level "
622 ++ "declarations added with addTopDecls"))
623 }
624 -- Rename TH-generated top-level declarations
625 ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env
626 $ rnTopSrcDecls th_group
627
628 -- Dump generated top-level declarations
629 ; let msg = "top-level declarations added with addTopDecls"
630 ; traceSplice
631 $ SpliceInfo { spliceDescription = msg
632 , spliceIsDecl = True
633 , spliceSource = Nothing
634 , spliceGenerated = ppr th_rn_decls }
635 ; return (tcg_env, appendGroups rn_decls th_rn_decls)
636 }
637
638 -- Type check all declarations
639 -- NB: set the env **before** captureTopConstraints so that error messages
640 -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that
641 -- the captureTopConstraints must go here, not in tcRnSrcDecls.
642 ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $
643 captureTopConstraints $
644 tcTopSrcDecls rn_decls
645
646 -- If there is no splice, we're nearly done
647 ; setEnvs (tcg_env, tcl_env) $
648 case group_tail of
649 { Nothing -> return (tcg_env, tcl_env, lie1)
650
651 -- If there's a splice, we must carry on
652 ; Just (SpliceDecl _ (L _ splice) _, rest_ds) ->
653 do {
654 -- We need to simplify any constraints from the previous declaration
655 -- group, or else we might reify metavariables, as in #16980.
656 ; ev_binds1 <- simplifyTop lie1
657
658 -- Rename the splice expression, and get its supporting decls
659 ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice
660
661 -- Glue them on the front of the remaining decls and loop
662 ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
663 addTopEvBinds ev_binds1 $
664 tc_rn_src_decls (spliced_decls ++ rest_ds)
665 }
666 }
667 }
668
669 {-
670 ************************************************************************
671 * *
672 Compiling hs-boot source files, and
673 comparing the hi-boot interface with the real thing
674 * *
675 ************************************************************************
676 -}
677
678 tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
679 tcRnHsBootDecls hsc_src decls
680 = do { (first_group, group_tail) <- findSplice decls
681
682 -- Rename the declarations
683 ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
684 , hs_derivds = deriv_decls
685 , hs_fords = for_decls
686 , hs_defds = def_decls
687 , hs_ruleds = rule_decls
688 , hs_annds = _
689 , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) })
690 <- rnTopSrcDecls first_group
691
692 -- The empty list is for extra dependencies coming from .hs-boot files
693 -- See Note [Extra dependencies from .hs-boot files] in GHC.Rename.Module
694
695 ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {
696 -- NB: setGblEnv **before** captureTopConstraints so that
697 -- if the latter reports errors, it knows what's in scope
698
699 -- Check for illegal declarations
700 ; case group_tail of
701 Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d
702 Nothing -> return ()
703 ; mapM_ (badBootDecl hsc_src "foreign") for_decls
704 ; mapM_ (badBootDecl hsc_src "default") def_decls
705 ; mapM_ (badBootDecl hsc_src "rule") rule_decls
706
707 -- Typecheck type/class/instance decls
708 ; traceTc "Tc2 (boot)" empty
709 ; (tcg_env, inst_infos, _deriv_binds, _class_scoped_tv_env, _th_bndrs)
710 <- tcTyClsInstDecls tycl_decls deriv_decls val_binds
711 ; setGblEnv tcg_env $ do {
712
713 -- Emit Typeable bindings
714 ; tcg_env <- mkTypeableBinds
715 ; setGblEnv tcg_env $ do {
716
717 -- Typecheck value declarations
718 ; traceTc "Tc5" empty
719 ; val_ids <- tcHsBootSigs val_binds val_sigs
720
721 -- Wrap up
722 -- No simplification or zonking to do
723 ; traceTc "Tc7a" empty
724 ; gbl_env <- getGblEnv
725
726 -- Make the final type-env
727 -- Include the dfun_ids so that their type sigs
728 -- are written into the interface file.
729 ; let { type_env0 = tcg_type_env gbl_env
730 ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
731 ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
732 ; dfun_ids = map iDFunId inst_infos
733 }
734
735 ; setGlobalTypeEnv gbl_env type_env2
736 }}}
737 ; traceTc "boot" (ppr lie); return gbl_env }
738
739 badBootDecl :: HscSource -> String -> LocatedA decl -> TcM ()
740 badBootDecl hsc_src what (L loc _)
741 = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $
742 (char 'A' <+> text what
743 <+> text "declaration is not (currently) allowed in a"
744 <+> (case hsc_src of
745 HsBootFile -> text "hs-boot"
746 HsigFile -> text "hsig"
747 _ -> panic "badBootDecl: should be an hsig or hs-boot file")
748 <+> text "file")
749
750 {-
751 Once we've typechecked the body of the module, we want to compare what
752 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
753 -}
754
755 checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
756 -- Compare the hi-boot file for this module (if there is one)
757 -- with the type environment we've just come up with
758 -- In the common case where there is no hi-boot file, the list
759 -- of boot_names is empty.
760
761 checkHiBootIface tcg_env boot_info
762 | NoSelfBoot <- boot_info -- Common case
763 = return tcg_env
764
765 | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file!
766 = return tcg_env
767
768 | SelfBoot { sb_mds = boot_details } <- boot_info
769 , TcGblEnv { tcg_binds = binds
770 , tcg_insts = local_insts
771 , tcg_type_env = local_type_env
772 , tcg_exports = local_exports } <- tcg_env
773 = do { -- This code is tricky, see Note [DFun knot-tying]
774 ; dfun_prs <- checkHiBootIface' local_insts local_type_env
775 local_exports boot_details
776
777 -- Now add the boot-dfun bindings $fxblah = $fblah
778 -- to (a) the type envt, and (b) the top-level bindings
779 ; let boot_dfuns = map fst dfun_prs
780 type_env' = extendTypeEnvWithIds local_type_env boot_dfuns
781 dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
782 | (boot_dfun, dfun) <- dfun_prs ]
783 tcg_env_w_binds
784 = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
785
786 ; type_env' `seq`
787 -- Why the seq? Without, we will put a TypeEnv thunk in
788 -- tcg_type_env_var. That thunk will eventually get
789 -- forced if we are typechecking interfaces, but that
790 -- is no good if we are trying to typecheck the very
791 -- DFun we were going to put in.
792 -- TODO: Maybe setGlobalTypeEnv should be strict.
793 setGlobalTypeEnv tcg_env_w_binds type_env' }
794
795 #if __GLASGOW_HASKELL__ <= 810
796 | otherwise = panic "checkHiBootIface: unreachable code"
797 #endif
798
799 {- Note [DFun impedance matching]
800 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
801 We return a list of "impedance-matching" bindings for the dfuns
802 defined in the hs-boot file, such as
803 $fxEqT = $fEqT
804 We need these because the module and hi-boot file might differ in
805 the name it chose for the dfun: the name of a dfun is not
806 uniquely determined by its type; there might be multiple dfuns
807 which, individually, would map to the same name (in which case
808 we have to disambiguate them.) There's no way for the hi file
809 to know exactly what disambiguation to use... without looking
810 at the hi-boot file itself.
811
812 In fact, the names will always differ because we always pick names
813 prefixed with "$fx" for boot dfuns, and "$f" for real dfuns
814 (so that this impedance matching is always possible).
815
816 Note [DFun knot-tying]
817 ~~~~~~~~~~~~~~~~~~~~~~
818 The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from
819 typechecking the hi-boot file that we are presently implementing.
820 Suppose we are typechecking the module A: when we typecheck the
821 hi-boot file, whenever we see an identifier A.T, we knot-tie this
822 identifier to the *local* type environment (via if_rec_types.) The
823 contract then is that we don't *look* at 'SelfBootInfo' until we've
824 finished typechecking the module and updated the type environment with
825 the new tycons and ids.
826
827 This most works well, but there is one problem: DFuns! We do not want
828 to look at the mb_insts of the ModDetails in SelfBootInfo, because a
829 dfun in one of those ClsInsts is gotten (in GHC.IfaceToCore.tcIfaceInst) by a
830 (lazily evaluated) lookup in the if_rec_types. We could extend the
831 type env, do a setGloblaTypeEnv etc; but that all seems very indirect.
832 It is much more directly simply to extract the DFunIds from the
833 md_types of the SelfBootInfo.
834
835 See #4003, #16038 for why we need to take care here.
836 -}
837
838 checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
839 -> ModDetails -> TcM [(Id, Id)]
840 -- Variant which doesn't require a full TcGblEnv; you could get the
841 -- local components from another ModDetails.
842 checkHiBootIface'
843 local_insts local_type_env local_exports
844 (ModDetails { md_types = boot_type_env
845 , md_fam_insts = boot_fam_insts
846 , md_exports = boot_exports })
847 = do { traceTc "checkHiBootIface" $ vcat
848 [ ppr boot_type_env, ppr boot_exports]
849
850 -- Check the exports of the boot module, one by one
851 ; mapM_ check_export boot_exports
852
853 -- Check for no family instances
854 ; unless (null boot_fam_insts) $
855 panic ("GHC.Tc.Module.checkHiBootIface: Cannot handle family " ++
856 "instances in boot files yet...")
857 -- FIXME: Why? The actual comparison is not hard, but what would
858 -- be the equivalent to the dfun bindings returned for class
859 -- instances? We can't easily equate tycons...
860
861 -- Check instance declarations
862 -- and generate an impedance-matching binding
863 ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns
864
865 ; failIfErrsM
866
867 ; return (catMaybes mb_dfun_prs) }
868
869 where
870 boot_dfun_names = map idName boot_dfuns
871 boot_dfuns = filter isDFunId $ typeEnvIds boot_type_env
872 -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts
873 -- We don't want to look at md_insts!
874 -- Why not? See Note [DFun knot-tying]
875
876 check_export boot_avail -- boot_avail is exported by the boot iface
877 | name `elem` boot_dfun_names = return ()
878
879 -- Check that the actual module exports the same thing
880 | not (null missing_names)
881 = addErrAt (nameSrcSpan (head missing_names))
882 (missingBootThing True (head missing_names) "exported by")
883
884 -- If the boot module does not *define* the thing, we are done
885 -- (it simply re-exports it, and names match, so nothing further to do)
886 | isNothing mb_boot_thing = return ()
887
888 -- Check that the actual module also defines the thing, and
889 -- then compare the definitions
890 | Just real_thing <- lookupTypeEnv local_type_env name,
891 Just boot_thing <- mb_boot_thing
892 = checkBootDeclM True boot_thing real_thing
893
894 | otherwise
895 = addErrTc (missingBootThing True name "defined in")
896 where
897 name = availName boot_avail
898 mb_boot_thing = lookupTypeEnv boot_type_env name
899 missing_names = case lookupNameEnv local_export_env name of
900 Nothing -> [name]
901 Just avail -> availNames boot_avail `minusList` availNames avail
902
903 local_export_env :: NameEnv AvailInfo
904 local_export_env = availsToNameEnv local_exports
905
906 check_cls_inst :: DFunId -> TcM (Maybe (Id, Id))
907 -- Returns a pair of the boot dfun in terms of the equivalent
908 -- real dfun. Delicate (like checkBootDecl) because it depends
909 -- on the types lining up precisely even to the ordering of
910 -- the type variables in the foralls.
911 check_cls_inst boot_dfun
912 | (real_dfun : _) <- find_real_dfun boot_dfun
913 , let local_boot_dfun = Id.mkExportedVanillaId
914 (idName boot_dfun) (idType real_dfun)
915 = return (Just (local_boot_dfun, real_dfun))
916 -- Two tricky points here:
917 --
918 -- * The local_boot_fun should have a Name from the /boot-file/,
919 -- but type from the dfun defined in /this module/.
920 -- That ensures that the TyCon etc inside the type are
921 -- the ones defined in this module, not the ones gotten
922 -- from the hi-boot file, which may have a lot less info
923 -- (#8743, comment:10).
924 --
925 -- * The DFunIds from boot_details are /GlobalIds/, because
926 -- they come from typechecking M.hi-boot.
927 -- But all bindings in this module should be for /LocalIds/,
928 -- otherwise dependency analysis fails (#16038). This
929 -- is another reason for using mkExportedVanillaId, rather
930 -- that modifying boot_dfun, to make local_boot_fun.
931
932 | otherwise
933 = setSrcSpan (nameSrcSpan (getName boot_dfun)) $
934 do { traceTc "check_cls_inst" $ vcat
935 [ text "local_insts" <+>
936 vcat (map (ppr . idType . instanceDFunId) local_insts)
937 , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ]
938
939 ; addErrTc (instMisMatch boot_dfun)
940 ; return Nothing }
941
942 find_real_dfun :: DFunId -> [DFunId]
943 find_real_dfun boot_dfun
944 = [dfun | inst <- local_insts
945 , let dfun = instanceDFunId inst
946 , idType dfun `eqType` boot_dfun_ty ]
947 where
948 boot_dfun_ty = idType boot_dfun
949
950
951 -- In general, to perform these checks we have to
952 -- compare the TyThing from the .hi-boot file to the TyThing
953 -- in the current source file. We must be careful to allow alpha-renaming
954 -- where appropriate, and also the boot declaration is allowed to omit
955 -- constructors and class methods.
956 --
957 -- See rnfail055 for a good test of this stuff.
958
959 -- | Compares two things for equivalence between boot-file and normal code,
960 -- reporting an error if they don't match up.
961 checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig)
962 -> TyThing -> TyThing -> TcM ()
963 checkBootDeclM is_boot boot_thing real_thing
964 = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err ->
965 addErrAt span
966 (bootMisMatch is_boot err real_thing boot_thing)
967 where
968 -- Here we use the span of the boot thing or, if it doesn't have a sensible
969 -- span, that of the real thing,
970 span
971 | let span = nameSrcSpan (getName boot_thing)
972 , isGoodSrcSpan span
973 = span
974 | otherwise
975 = nameSrcSpan (getName real_thing)
976
977 -- | Compares the two things for equivalence between boot-file and normal
978 -- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
979 -- failure. If the difference will be apparent to the user, @Just empty@ is
980 -- perfectly suitable.
981 checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc
982
983 checkBootDecl _ (AnId id1) (AnId id2)
984 = assert (id1 == id2) $
985 check (idType id1 `eqType` idType id2)
986 (text "The two types are different")
987
988 checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2)
989 = checkBootTyCon is_boot tc1 tc2
990
991 checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
992 = pprPanic "checkBootDecl" (ppr dc1)
993
994 checkBootDecl _ _ _ = Just empty -- probably shouldn't happen
995
996 -- | Combines two potential error messages
997 andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
998 Nothing `andThenCheck` msg = msg
999 msg `andThenCheck` Nothing = msg
1000 Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)
1001 infixr 0 `andThenCheck`
1002
1003 -- | If the test in the first parameter is True, succeed with @Nothing@;
1004 -- otherwise, return the provided check
1005 checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
1006 checkUnless True _ = Nothing
1007 checkUnless False k = k
1008
1009 -- | Run the check provided for every pair of elements in the lists.
1010 -- The provided SDoc should name the element type, in the plural.
1011 checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
1012 -> Maybe SDoc
1013 checkListBy check_fun as bs whats = go [] as bs
1014 where
1015 herald = text "The" <+> whats <+> text "do not match"
1016
1017 go [] [] [] = Nothing
1018 go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))
1019 go docs (x:xs) (y:ys) = case check_fun x y of
1020 Just doc -> go (doc:docs) xs ys
1021 Nothing -> go docs xs ys
1022 go _ _ _ = Just (hang (herald <> colon)
1023 2 (text "There are different numbers of" <+> whats))
1024
1025 -- | If the test in the first parameter is True, succeed with @Nothing@;
1026 -- otherwise, fail with the given SDoc.
1027 check :: Bool -> SDoc -> Maybe SDoc
1028 check True _ = Nothing
1029 check False doc = Just doc
1030
1031 -- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.
1032 checkSuccess :: Maybe SDoc
1033 checkSuccess = Nothing
1034
1035 ----------------
1036 checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc
1037 checkBootTyCon is_boot tc1 tc2
1038 | not (eqType (tyConKind tc1) (tyConKind tc2))
1039 = Just $ text "The types have different kinds" -- First off, check the kind
1040
1041 | Just c1 <- tyConClass_maybe tc1
1042 , Just c2 <- tyConClass_maybe tc2
1043 , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
1044 = classExtraBigSig c1
1045 (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
1046 = classExtraBigSig c2
1047 , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
1048 = let
1049 eqSig (id1, def_meth1) (id2, def_meth2)
1050 = check (name1 == name2)
1051 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
1052 text "are different") `andThenCheck`
1053 check (eqTypeX env op_ty1 op_ty2)
1054 (text "The types of" <+> pname1 <+>
1055 text "are different") `andThenCheck`
1056 if is_boot
1057 then check (eqMaybeBy eqDM def_meth1 def_meth2)
1058 (text "The default methods associated with" <+> pname1 <+>
1059 text "are different")
1060 else check (subDM op_ty1 def_meth1 def_meth2)
1061 (text "The default methods associated with" <+> pname1 <+>
1062 text "are not compatible")
1063 where
1064 name1 = idName id1
1065 name2 = idName id2
1066 pname1 = quotes (ppr name1)
1067 pname2 = quotes (ppr name2)
1068 op_ty1 = classMethodTy id1
1069 op_ty2 = classMethodTy id2
1070
1071 eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
1072 = checkBootTyCon is_boot tc1 tc2 `andThenCheck`
1073 check (eqATDef def_ats1 def_ats2)
1074 (text "The associated type defaults differ")
1075
1076 eqDM (_, VanillaDM) (_, VanillaDM) = True
1077 eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2
1078 eqDM _ _ = False
1079
1080 -- NB: first argument is from hsig, second is from real impl.
1081 -- Order of pattern matching matters.
1082 subDM _ Nothing _ = True
1083 subDM _ _ Nothing = False
1084 -- If the hsig wrote:
1085 --
1086 -- f :: a -> a
1087 -- default f :: a -> a
1088 --
1089 -- this should be validly implementable using an old-fashioned
1090 -- vanilla default method.
1091 subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM))
1092 = eqTypeX env t1 t2
1093 -- This case can occur when merging signatures
1094 subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2))
1095 = eqTypeX env t1 t2
1096 subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True
1097 subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2))
1098 = eqTypeX env t1 t2
1099
1100 -- Ignore the location of the defaults
1101 eqATDef Nothing Nothing = True
1102 eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2
1103 eqATDef _ _ = False
1104
1105 eqFD (as1,bs1) (as2,bs2) =
1106 eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
1107 eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
1108 in
1109 checkRoles roles1 roles2 `andThenCheck`
1110 -- Checks kind of class
1111 check (eqListBy eqFD clas_fds1 clas_fds2)
1112 (text "The functional dependencies do not match") `andThenCheck`
1113 checkUnless (isAbstractTyCon tc1) $
1114 check (eqListBy (eqTypeX env) sc_theta1 sc_theta2)
1115 (text "The class constraints do not match") `andThenCheck`
1116 checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
1117 checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck`
1118 check (classMinimalDef c1 `BF.implies` classMinimalDef c2)
1119 (text "The MINIMAL pragmas are not compatible")
1120
1121 | Just syn_rhs1 <- synTyConRhs_maybe tc1
1122 , Just syn_rhs2 <- synTyConRhs_maybe tc2
1123 , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
1124 = assert (tc1 == tc2) $
1125 checkRoles roles1 roles2 `andThenCheck`
1126 check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say
1127 -- This allows abstract 'data T a' to be implemented using 'type T = ...'
1128 -- and abstract 'class K a' to be implement using 'type K = ...'
1129 -- See Note [Synonyms implement abstract data]
1130 | not is_boot -- don't support for hs-boot yet
1131 , isAbstractTyCon tc1
1132 , Just (tvs, ty) <- synTyConDefn_maybe tc2
1133 , Just (tc2', args) <- tcSplitTyConApp_maybe ty
1134 = checkSynAbsData tvs ty tc2' args
1135 -- TODO: When it's a synonym implementing a class, we really
1136 -- should check if the fundeps are satisfied, but
1137 -- there is not an obvious way to do this for a constraint synonym.
1138 -- So for now, let it all through (it won't cause segfaults, anyway).
1139 -- Tracked at #12704.
1140
1141 -- This allows abstract 'data T :: Nat' to be implemented using
1142 -- 'type T = 42' Since the kinds already match (we have checked this
1143 -- upfront) all we need to check is that the implementation 'type T
1144 -- = ...' defined an actual literal. See #15138 for the case this
1145 -- handles.
1146 | not is_boot
1147 , isAbstractTyCon tc1
1148 , Just (_,ty2) <- synTyConDefn_maybe tc2
1149 , isJust (isLitTy ty2)
1150 = Nothing
1151
1152 | Just fam_flav1 <- famTyConFlav_maybe tc1
1153 , Just fam_flav2 <- famTyConFlav_maybe tc2
1154 = assert (tc1 == tc2) $
1155 let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True
1156 eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True
1157 -- This case only happens for hsig merging:
1158 eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True
1159 eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
1160 eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
1161 eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
1162 = eqClosedFamilyAx ax1 ax2
1163 eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2
1164 eqFamFlav _ _ = False
1165 injInfo1 = tyConInjectivityInfo tc1
1166 injInfo2 = tyConInjectivityInfo tc2
1167 in
1168 -- check equality of roles, family flavours and injectivity annotations
1169 -- (NB: Type family roles are always nominal. But the check is
1170 -- harmless enough.)
1171 checkRoles roles1 roles2 `andThenCheck`
1172 check (eqFamFlav fam_flav1 fam_flav2)
1173 (whenPprDebug $
1174 text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+>
1175 text "do not match") `andThenCheck`
1176 check (injInfo1 == injInfo2) (text "Injectivities do not match")
1177
1178 | isAlgTyCon tc1 && isAlgTyCon tc2
1179 , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
1180 = assert (tc1 == tc2) $
1181 checkRoles roles1 roles2 `andThenCheck`
1182 check (eqListBy (eqTypeX env)
1183 (tyConStupidTheta tc1) (tyConStupidTheta tc2))
1184 (text "The datatype contexts do not match") `andThenCheck`
1185 eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)
1186
1187 | otherwise = Just empty -- two very different types -- should be obvious
1188 where
1189 roles1 = tyConRoles tc1 -- the abstract one
1190 roles2 = tyConRoles tc2
1191 roles_msg = text "The roles do not match." $$
1192 (text "Roles on abstract types default to" <+>
1193 quotes (text "representational") <+> text "in boot files.")
1194
1195 roles_subtype_msg = text "The roles are not compatible:" $$
1196 text "Main module:" <+> ppr roles2 $$
1197 text "Hsig file:" <+> ppr roles1
1198
1199 checkRoles r1 r2
1200 | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping]
1201 = check (r1 == r2) roles_msg
1202 | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg
1203
1204 -- Note [Role subtyping]
1205 -- ~~~~~~~~~~~~~~~~~~~~~
1206 -- In the current formulation of roles, role subtyping is only OK if the
1207 -- "abstract" TyCon was not representationally injective. Among the most
1208 -- notable examples of non representationally injective TyCons are abstract
1209 -- data, which can be implemented via newtypes (which are not
1210 -- representationally injective). The key example is
1211 -- in this example from #13140:
1212 --
1213 -- -- In an hsig file
1214 -- data T a -- abstract!
1215 -- type role T nominal
1216 --
1217 -- -- Elsewhere
1218 -- foo :: Coercible (T a) (T b) => a -> b
1219 -- foo x = x
1220 --
1221 -- We must NOT allow foo to typecheck, because if we instantiate
1222 -- T with a concrete data type with a phantom role would cause
1223 -- Coercible (T a) (T b) to be provable. Fortunately, if T is not
1224 -- representationally injective, we cannot make the inference that a ~N b if
1225 -- T a ~R T b.
1226 --
1227 -- Unconditional role subtyping would be possible if we setup
1228 -- an extra set of roles saying when we can project out coercions
1229 -- (we call these proj-roles); then it would NOT be valid to instantiate T
1230 -- with a data type at phantom since the proj-role subtyping check
1231 -- would fail. See #13140 for more details.
1232 --
1233 -- One consequence of this is we get no role subtyping for non-abstract
1234 -- data types in signatures. Suppose you have:
1235 --
1236 -- signature A where
1237 -- type role T nominal
1238 -- data T a = MkT
1239 --
1240 -- If you write this, we'll treat T as injective, and make inferences
1241 -- like T a ~R T b ==> a ~N b (mkNthCo). But if we can
1242 -- subsequently replace T with one at phantom role, we would then be able to
1243 -- infer things like T Int ~R T Bool which is bad news.
1244 --
1245 -- We could allow role subtyping here if we didn't treat *any* data types
1246 -- defined in signatures as injective. But this would be a bit surprising,
1247 -- replacing a data type in a module with one in a signature could cause
1248 -- your code to stop typechecking (whereas if you made the type abstract,
1249 -- it is more understandable that the type checker knows less).
1250 --
1251 -- It would have been best if this was purely a question of defaults
1252 -- (i.e., a user could explicitly ask for one behavior or another) but
1253 -- the current role system isn't expressive enough to do this.
1254 -- Having explicit proj-roles would solve this problem.
1255
1256 rolesSubtypeOf [] [] = True
1257 -- NB: this relation is the OPPOSITE of the subroling relation
1258 rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys
1259 rolesSubtypeOf _ _ = False
1260
1261 -- Note [Synonyms implement abstract data]
1262 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1263 -- An abstract data type or class can be implemented using a type synonym,
1264 -- but ONLY if the type synonym is nullary and has no type family
1265 -- applications. This arises from two properties of skolem abstract data:
1266 --
1267 -- For any T (with some number of paramaters),
1268 --
1269 -- 1. T is a valid type (it is "curryable"), and
1270 --
1271 -- 2. T is valid in an instance head (no type families).
1272 --
1273 -- See also 'HowAbstract' and Note [Skolem abstract data].
1274
1275 -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@,
1276 -- check that this synonym is an acceptable implementation of @tc1@.
1277 -- See Note [Synonyms implement abstract data]
1278 checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc
1279 checkSynAbsData tvs ty tc2' args =
1280 check (null (tcTyFamInsts ty))
1281 (text "Illegal type family application in implementation of abstract data.")
1282 `andThenCheck`
1283 check (null tvs)
1284 (text "Illegal parameterized type synonym in implementation of abstract data." $$
1285 text "(Try eta reducing your type synonym so that it is nullary.)")
1286 `andThenCheck`
1287 -- Don't report roles errors unless the type synonym is nullary
1288 checkUnless (not (null tvs)) $
1289 assert (null roles2) $
1290 -- If we have something like:
1291 --
1292 -- signature H where
1293 -- data T a
1294 -- module H where
1295 -- data K a b = ...
1296 -- type T = K Int
1297 --
1298 -- we need to drop the first role of K when comparing!
1299 checkRoles roles1 (drop (length args) (tyConRoles tc2'))
1300 {-
1301 -- Hypothetically, if we were allow to non-nullary type synonyms, here
1302 -- is how you would check the roles
1303 if length tvs == length roles1
1304 then checkRoles roles1 roles2
1305 else case tcSplitTyConApp_maybe ty of
1306 Just (tc2', args) ->
1307 checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2)
1308 Nothing -> Just roles_msg
1309 -}
1310
1311 eqAlgRhs _ (AbstractTyCon {}) _rhs2
1312 = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon
1313 eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} =
1314 checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
1315 eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} =
1316 eqCon (data_con tc1) (data_con tc2)
1317 eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>
1318 text "definition with a" <+> quotes (text "newtype") <+>
1319 text "definition")
1320
1321 eqCon c1 c2
1322 = check (name1 == name2)
1323 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
1324 text "differ") `andThenCheck`
1325 check (dataConIsInfix c1 == dataConIsInfix c2)
1326 (text "The fixities of" <+> pname1 <+>
1327 text "differ") `andThenCheck`
1328 check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2))
1329 (text "The strictness annotations for" <+> pname1 <+>
1330 text "differ") `andThenCheck`
1331 check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2))
1332 (text "The record label lists for" <+> pname1 <+>
1333 text "differ") `andThenCheck`
1334 check (eqType (dataConWrapperType c1) (dataConWrapperType c2))
1335 (text "The types for" <+> pname1 <+> text "differ")
1336 where
1337 name1 = dataConName c1
1338 name2 = dataConName c2
1339 pname1 = quotes (ppr name1)
1340 pname2 = quotes (ppr name2)
1341
1342 eqClosedFamilyAx Nothing Nothing = True
1343 eqClosedFamilyAx Nothing (Just _) = False
1344 eqClosedFamilyAx (Just _) Nothing = False
1345 eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))
1346 (Just (CoAxiom { co_ax_branches = branches2 }))
1347 = numBranches branches1 == numBranches branches2
1348 && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2)
1349 where
1350 branch_list1 = fromBranches branches1
1351 branch_list2 = fromBranches branches2
1352
1353 eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1
1354 , cab_lhs = lhs1, cab_rhs = rhs1 })
1355 (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2
1356 , cab_lhs = lhs2, cab_rhs = rhs2 })
1357 | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2
1358 , Just env <- eqVarBndrs env1 cvs1 cvs2
1359 = eqListBy (eqTypeX env) lhs1 lhs2 &&
1360 eqTypeX env rhs1 rhs2
1361
1362 | otherwise = False
1363
1364 emptyRnEnv2 :: RnEnv2
1365 emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
1366
1367 ----------------
1368 missingBootThing :: Bool -> Name -> String -> TcRnMessage
1369 missingBootThing is_boot name what
1370 = TcRnUnknownMessage $ mkPlainError noHints $
1371 quotes (ppr name) <+> text "is exported by the"
1372 <+> (if is_boot then text "hs-boot" else text "hsig")
1373 <+> text "file, but not"
1374 <+> text what <+> text "the module"
1375
1376 badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage
1377 badReexportedBootThing is_boot name name'
1378 = TcRnUnknownMessage $ mkPlainError noHints $
1379 withUserStyle alwaysQualify AllTheWay $ vcat
1380 [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig")
1381 <+> text "file (re)exports" <+> quotes (ppr name)
1382 , text "but the implementing module exports a different identifier" <+> quotes (ppr name')
1383 ]
1384
1385 bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage
1386 bootMisMatch is_boot extra_info real_thing boot_thing
1387 = TcRnUnknownMessage $ mkPlainError noHints $
1388 pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc
1389 where
1390 to_doc
1391 = pprTyThingInContext $ showToHeader { ss_forall =
1392 if is_boot
1393 then ShowForAllMust
1394 else ShowForAllWhen }
1395
1396 real_doc = to_doc real_thing
1397 boot_doc = to_doc boot_thing
1398
1399 pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
1400 pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc
1401 = vcat
1402 [ ppr real_thing <+>
1403 text "has conflicting definitions in the module",
1404 text "and its" <+>
1405 (if is_boot
1406 then text "hs-boot file"
1407 else text "hsig file"),
1408 text "Main module:" <+> real_doc,
1409 (if is_boot
1410 then text "Boot file: "
1411 else text "Hsig file: ")
1412 <+> boot_doc,
1413 extra_info
1414 ]
1415
1416 instMisMatch :: DFunId -> TcRnMessage
1417 instMisMatch dfun
1418 = TcRnUnknownMessage $ mkPlainError noHints $
1419 hang (text "instance" <+> ppr (idType dfun))
1420 2 (text "is defined in the hs-boot file, but not in the module itself")
1421
1422 {-
1423 ************************************************************************
1424 * *
1425 Type-checking the top level of a module (continued)
1426 * *
1427 ************************************************************************
1428 -}
1429
1430 rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
1431 -- Fails if there are any errors
1432 rnTopSrcDecls group
1433 = do { -- Rename the source decls
1434 traceRn "rn12" empty ;
1435 (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
1436 traceRn "rn13" empty ;
1437 (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ;
1438 traceRn "rn13-plugin" empty ;
1439
1440 -- save the renamed syntax, if we want it
1441 let { tcg_env'
1442 | Just grp <- tcg_rn_decls tcg_env
1443 = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
1444 | otherwise
1445 = tcg_env };
1446
1447 -- Dump trace of renaming part
1448 rnDump rn_decls ;
1449 return (tcg_env', rn_decls)
1450 }
1451
1452 tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
1453 tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
1454 hs_derivds = deriv_decls,
1455 hs_fords = foreign_decls,
1456 hs_defds = default_decls,
1457 hs_annds = annotation_decls,
1458 hs_ruleds = rule_decls,
1459 hs_valds = hs_val_binds@(XValBindsLR
1460 (NValBinds val_binds val_sigs)) })
1461 = do { -- Type-check the type and class decls, and all imported decls
1462 -- The latter come in via tycl_decls
1463 traceTc "Tc2 (src)" empty ;
1464
1465 -- Source-language instances, including derivings,
1466 -- and import the supporting declarations
1467 traceTc "Tc3" empty ;
1468 (tcg_env, inst_infos, class_scoped_tv_env, th_bndrs,
1469 XValBindsLR (NValBinds deriv_binds deriv_sigs))
1470 <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
1471
1472 updLclEnv (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $
1473 setGblEnv tcg_env $ do {
1474
1475 -- Generate Applicative/Monad proposal (AMP) warnings
1476 traceTc "Tc3b" empty ;
1477
1478 -- Generate Semigroup/Monoid warnings
1479 traceTc "Tc3c" empty ;
1480 tcSemigroupWarnings ;
1481
1482 -- Foreign import declarations next.
1483 traceTc "Tc4" empty ;
1484 (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
1485 tcExtendGlobalValEnv fi_ids $ do {
1486
1487 -- Default declarations
1488 traceTc "Tc4a" empty ;
1489 default_tys <- tcDefaults default_decls ;
1490 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
1491
1492 -- Value declarations next.
1493 -- It is important that we check the top-level value bindings
1494 -- before the GHC-generated derived bindings, since the latter
1495 -- may be defined in terms of the former. (For instance,
1496 -- the bindings produced in a Data instance.)
1497 traceTc "Tc5" empty ;
1498 tc_envs <- tcTopBinds val_binds val_sigs;
1499 setEnvs tc_envs $ do {
1500
1501 -- Now GHC-generated derived bindings, generics, and selectors
1502 -- Do not generate warnings from compiler-generated code;
1503 -- hence the use of discardWarnings
1504 tc_envs@(tcg_env, tcl_env)
1505 <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;
1506 setEnvs tc_envs $ do { -- Environment doesn't change now
1507
1508 -- Second pass over class and instance declarations,
1509 -- now using the kind-checked decls
1510 traceTc "Tc6" empty ;
1511 inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls)
1512 inst_infos class_scoped_tv_env ;
1513
1514 -- Foreign exports
1515 traceTc "Tc7" empty ;
1516 (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
1517
1518 -- Annotations
1519 annotations <- tcAnnotations annotation_decls ;
1520
1521 -- Rules
1522 rules <- tcRules rule_decls ;
1523
1524 -- Wrap up
1525 traceTc "Tc7a" empty ;
1526 let { all_binds = inst_binds `unionBags`
1527 foe_binds
1528
1529 ; fo_gres = fi_gres `unionBags` foe_gres
1530 ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` greMangledName gre)
1531 emptyFVs fo_gres
1532
1533 ; sig_names = mkNameSet (collectHsValBinders CollNoDictBinders hs_val_binds)
1534 `minusNameSet` getTypeSigNames val_sigs
1535
1536 -- Extend the GblEnv with the (as yet un-zonked)
1537 -- bindings, rules, foreign decls
1538 ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
1539 , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names
1540 , tcg_rules = tcg_rules tcg_env
1541 ++ flattenRuleDecls rules
1542 , tcg_anns = tcg_anns tcg_env ++ annotations
1543 , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
1544 , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls
1545 , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
1546 -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
1547
1548 -- See Note [Newtype constructor usage in foreign declarations]
1549 addUsedGREs (bagToList fo_gres) ;
1550
1551 return (tcg_env', tcl_env)
1552 }}}}}}
1553
1554 tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
1555
1556
1557 tcSemigroupWarnings :: TcM ()
1558 tcSemigroupWarnings = do
1559 traceTc "tcSemigroupWarnings" empty
1560 let warnFlag = Opt_WarnSemigroup
1561 tcPreludeClashWarn warnFlag sappendName
1562 tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName
1563
1564
1565 -- | Warn on local definitions of names that would clash with future Prelude
1566 -- elements.
1567 --
1568 -- A name clashes if the following criteria are met:
1569 -- 1. It would is imported (unqualified) from Prelude
1570 -- 2. It is locally defined in the current module
1571 -- 3. It has the same literal name as the reference function
1572 -- 4. It is not identical to the reference function
1573 tcPreludeClashWarn :: WarningFlag
1574 -> Name
1575 -> TcM ()
1576 tcPreludeClashWarn warnFlag name = do
1577 { warn <- woptM warnFlag
1578 ; when warn $ do
1579 { traceTc "tcPreludeClashWarn/wouldBeImported" empty
1580 -- Is the name imported (unqualified) from Prelude? (Point 4 above)
1581 ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv
1582 -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude
1583 -- will not appear in rnImports automatically if it is set.)
1584
1585 -- Continue only the name is imported from Prelude
1586 ; when (importedViaPrelude name rnImports) $ do
1587 -- Handle 2.-4.
1588 { rdrElts <- fmap (concat . nonDetOccEnvElts . tcg_rdr_env) getGblEnv
1589
1590 ; let clashes :: GlobalRdrElt -> Bool
1591 clashes x = isLocalDef && nameClashes && isNotInProperModule
1592 where
1593 isLocalDef = gre_lcl x == True
1594 -- Names are identical ...
1595 nameClashes = nameOccName (greMangledName x) == nameOccName name
1596 -- ... but not the actual definitions, because we don't want to
1597 -- warn about a bad definition of e.g. <> in Data.Semigroup, which
1598 -- is the (only) proper place where this should be defined
1599 isNotInProperModule = greMangledName x /= name
1600
1601 -- List of all offending definitions
1602 clashingElts :: [GlobalRdrElt]
1603 clashingElts = filter clashes rdrElts
1604
1605 ; traceTc "tcPreludeClashWarn/prelude_functions"
1606 (hang (ppr name) 4 (sep [ppr clashingElts]))
1607
1608 ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greMangledName x)) $
1609 TcRnUnknownMessage $
1610 mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep
1611 [ text "Local definition of"
1612 , (quotes . ppr . nameOccName . greMangledName) x
1613 , text "clashes with a future Prelude name." ]
1614 $$
1615 text "This will become an error in a future release." )
1616 ; mapM_ warn_msg clashingElts
1617 }}}
1618
1619 where
1620
1621 -- Is the given name imported via Prelude?
1622 --
1623 -- Possible scenarios:
1624 -- a) Prelude is imported implicitly, issue warnings.
1625 -- b) Prelude is imported explicitly, but without mentioning the name in
1626 -- question. Issue no warnings.
1627 -- c) Prelude is imported hiding the name in question. Issue no warnings.
1628 -- d) Qualified import of Prelude, no warnings.
1629 importedViaPrelude :: Name
1630 -> [ImportDecl GhcRn]
1631 -> Bool
1632 importedViaPrelude name = any importViaPrelude
1633 where
1634 isPrelude :: ImportDecl GhcRn -> Bool
1635 isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME
1636
1637 -- Implicit (Prelude) import?
1638 isImplicit :: ImportDecl GhcRn -> Bool
1639 isImplicit = ideclImplicit
1640
1641 -- Unqualified import?
1642 isUnqualified :: ImportDecl GhcRn -> Bool
1643 isUnqualified = not . isImportDeclQualified . ideclQualified
1644
1645 -- List of explicitly imported (or hidden) Names from a single import.
1646 -- Nothing -> No explicit imports
1647 -- Just (False, <names>) -> Explicit import list of <names>
1648 -- Just (True , <names>) -> Explicit hiding of <names>
1649 importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name])
1650 importListOf = fmap toImportList . ideclHiding
1651 where
1652 toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc))
1653
1654 isExplicit :: ImportDecl GhcRn -> Bool
1655 isExplicit x = case importListOf x of
1656 Nothing -> False
1657 Just (False, explicit)
1658 -> nameOccName name `elem` map nameOccName explicit
1659 Just (True, hidden)
1660 -> nameOccName name `notElem` map nameOccName hidden
1661
1662 -- Check whether the given name would be imported (unqualified) from
1663 -- an import declaration.
1664 importViaPrelude :: ImportDecl GhcRn -> Bool
1665 importViaPrelude x = isPrelude x
1666 && isUnqualified x
1667 && (isImplicit x || isExplicit x)
1668
1669
1670 -- Notation: is* is for classes the type is an instance of, should* for those
1671 -- that it should also be an instance of based on the corresponding
1672 -- is*.
1673 tcMissingParentClassWarn :: WarningFlag
1674 -> Name -- ^ Instances of this ...
1675 -> Name -- ^ should also be instances of this
1676 -> TcM ()
1677 tcMissingParentClassWarn warnFlag isName shouldName
1678 = do { warn <- woptM warnFlag
1679 ; when warn $ do
1680 { traceTc "tcMissingParentClassWarn" empty
1681 ; isClass' <- tcLookupClass_maybe isName
1682 ; shouldClass' <- tcLookupClass_maybe shouldName
1683 ; case (isClass', shouldClass') of
1684 (Just isClass, Just shouldClass) -> do
1685 { localInstances <- tcGetInsts
1686 ; let isInstance m = is_cls m == isClass
1687 isInsts = filter isInstance localInstances
1688 ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts)
1689 ; forM_ isInsts (checkShouldInst isClass shouldClass)
1690 }
1691 (is',should') ->
1692 traceTc "tcMissingParentClassWarn/notIsShould"
1693 (hang (ppr isName <> text "/" <> ppr shouldName) 2 (
1694 (hsep [ quotes (text "Is"), text "lookup for"
1695 , ppr isName
1696 , text "resulted in", ppr is' ])
1697 $$
1698 (hsep [ quotes (text "Should"), text "lookup for"
1699 , ppr shouldName
1700 , text "resulted in", ppr should' ])))
1701 }}
1702 where
1703 -- Check whether the desired superclass exists in a given environment.
1704 checkShouldInst :: Class -- ^ Class of existing instance
1705 -> Class -- ^ Class there should be an instance of
1706 -> ClsInst -- ^ Existing instance
1707 -> TcM ()
1708 checkShouldInst isClass shouldClass isInst
1709 = do { instEnv <- tcGetInstEnvs
1710 ; let (instanceMatches, shouldInsts, _)
1711 = lookupInstEnv False instEnv shouldClass (is_tys isInst)
1712
1713 ; traceTc "tcMissingParentClassWarn/checkShouldInst"
1714 (hang (ppr isInst) 4
1715 (sep [ppr instanceMatches, ppr shouldInsts]))
1716
1717 -- "<location>: Warning: <type> is an instance of <is> but not
1718 -- <should>" e.g. "Foo is an instance of Monad but not Applicative"
1719 ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst
1720 warnMsg (KnownTc name:_) =
1721 addDiagnosticAt instLoc $
1722 TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $
1723 hsep [ (quotes . ppr . nameOccName) name
1724 , text "is an instance of"
1725 , (ppr . nameOccName . className) isClass
1726 , text "but not"
1727 , (ppr . nameOccName . className) shouldClass ]
1728 <> text "."
1729 $$
1730 hsep [ text "This will become an error in"
1731 , text "a future release." ]
1732 warnMsg _ = pure ()
1733 ; when (null shouldInsts && null instanceMatches) $
1734 warnMsg (is_tcs isInst)
1735 }
1736
1737 tcLookupClass_maybe :: Name -> TcM (Maybe Class)
1738 tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case
1739 Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls
1740 _else -> pure Nothing
1741
1742
1743 ---------------------------
1744 tcTyClsInstDecls :: [TyClGroup GhcRn]
1745 -> [LDerivDecl GhcRn]
1746 -> [(RecFlag, LHsBinds GhcRn)]
1747 -> TcM (TcGblEnv, -- The full inst env
1748 [InstInfo GhcRn], -- Source-code instance decls to
1749 -- process; contains all dfuns for
1750 -- this module
1751 ClassScopedTVEnv, -- Class scoped type variables
1752 ThBindEnv, -- TH binding levels
1753 HsValBinds GhcRn) -- Supporting bindings for derived
1754 -- instances
1755
1756 tcTyClsInstDecls tycl_decls deriv_decls binds
1757 = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
1758 tcAddPatSynPlaceholders (getPatSynBinds binds) $
1759 do { (tcg_env, inst_info, deriv_info, class_scoped_tv_env, th_bndrs)
1760 <- tcTyAndClassDecls tycl_decls ;
1761 ; setGblEnv tcg_env $ do {
1762 -- With the @TyClDecl@s and @InstDecl@s checked we're ready to
1763 -- process the deriving clauses, including data family deriving
1764 -- clauses discovered in @tcTyAndClassDecls@.
1765 --
1766 -- Careful to quit now in case there were instance errors, so that
1767 -- the deriving errors don't pile up as well.
1768 ; failIfErrsM
1769 ; (tcg_env', inst_info', val_binds)
1770 <- tcInstDeclsDeriv deriv_info deriv_decls
1771 ; setGblEnv tcg_env' $ do {
1772 failIfErrsM
1773 ; pure ( tcg_env', inst_info' ++ inst_info
1774 , class_scoped_tv_env, th_bndrs, val_binds )
1775 }}}
1776
1777 {- *********************************************************************
1778 * *
1779 Checking for 'main'
1780 * *
1781 ************************************************************************
1782 -}
1783
1784 checkMainType :: TcGblEnv -> TcRn WantedConstraints
1785 -- If this is the Main module, and it defines a function main,
1786 -- check that its type is of form IO tau.
1787 -- If not, do nothing
1788 -- See Note [Dealing with main]
1789 checkMainType tcg_env
1790 = do { hsc_env <- getTopEnv
1791 ; if tcg_mod tcg_env /= mainModIs hsc_env
1792 then return emptyWC else
1793
1794 do { rdr_env <- getGlobalRdrEnv
1795 ; let dflags = hsc_dflags hsc_env
1796 main_occ = getMainOcc dflags
1797 main_gres = lookupGlobalRdrEnv rdr_env main_occ
1798 ; case filter isLocalGRE main_gres of {
1799 [] -> return emptyWC ;
1800 (_:_:_) -> return emptyWC ;
1801 [main_gre] ->
1802
1803 do { let main_name = greMangledName main_gre
1804 ctxt = FunSigCtxt main_name NoRRC
1805 ; main_id <- tcLookupId main_name
1806 ; (io_ty,_) <- getIOType
1807 ; (_, lie) <- captureTopConstraints $
1808 setMainCtxt main_name io_ty $
1809 tcSubTypeSigma ctxt (idType main_id) io_ty
1810 ; return lie } } } }
1811
1812 checkMain :: Bool -- False => no 'module M(..) where' header at all
1813 -> Maybe (LocatedL [LIE GhcPs]) -- Export specs of Main module
1814 -> TcM TcGblEnv
1815 -- If we are in module Main, check that 'main' is exported,
1816 -- and generate the runMainIO binding that calls it
1817 -- See Note [Dealing with main]
1818 checkMain explicit_mod_hdr export_ies
1819 = do { hsc_env <- getTopEnv
1820 ; tcg_env <- getGblEnv
1821
1822 ; let dflags = hsc_dflags hsc_env
1823 main_mod = mainModIs hsc_env
1824 main_occ = getMainOcc dflags
1825
1826 exported_mains :: [Name]
1827 -- Exported things that are called 'main'
1828 exported_mains = [ name | avail <- tcg_exports tcg_env
1829 , name <- availNames avail
1830 , nameOccName name == main_occ ]
1831
1832 ; if | tcg_mod tcg_env /= main_mod
1833 -> -- Not the main module
1834 return tcg_env
1835
1836 | [main_name] <- exported_mains
1837 -> -- The module indeed exports a function called 'main'
1838 generateMainBinding tcg_env main_name
1839
1840 | otherwise
1841 -> assert (null exported_mains) $
1842 -- A fully-checked export list can't contain more
1843 -- than one function with the same OccName
1844 do { complain_no_main dflags main_mod main_occ
1845 ; return tcg_env } }
1846 where
1847 complain_no_main dflags main_mod main_occ
1848 = unless (interactive && not explicit_mod_hdr) $
1849 addErrTc (noMainMsg main_mod main_occ) -- #12906
1850 where
1851 interactive = ghcLink dflags == LinkInMemory
1852 -- Without an explicit module header...
1853 -- in interactive mode, don't worry about the absence of 'main'.
1854 -- in other modes, add error message and go on with typechecking.
1855
1856 noMainMsg main_mod main_occ
1857 = TcRnUnknownMessage $ mkPlainError noHints $
1858 text "The" <+> ppMainFn main_occ
1859 <+> text "is not" <+> text defOrExp <+> text "module"
1860 <+> quotes (ppr main_mod)
1861
1862 defOrExp | explicit_export_list = "exported by"
1863 | otherwise = "defined in"
1864 explicit_export_list = explicit_mod_hdr && isJust export_ies
1865
1866 -- | Get the unqualified name of the function to use as the \"main\" for the main module.
1867 -- Either returns the default name or the one configured on the command line with -main-is
1868 getMainOcc :: DynFlags -> OccName
1869 getMainOcc dflags = case mainFunIs dflags of
1870 Just fn -> mkVarOccFS (mkFastString fn)
1871 Nothing -> mainOcc
1872
1873 ppMainFn :: OccName -> SDoc
1874 ppMainFn main_occ
1875 | main_occ == mainOcc
1876 = text "IO action" <+> quotes (ppr main_occ)
1877 | otherwise
1878 = text "main IO action" <+> quotes (ppr main_occ)
1879
1880 mainOcc :: OccName
1881 mainOcc = mkVarOccFS (fsLit "main")
1882
1883 generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv
1884 -- There is a single exported 'main' function, called 'foo' (say),
1885 -- which may be locally defined or imported
1886 -- Define and typecheck the binding
1887 -- :Main.main :: IO res_ty = runMainIO res_ty foo
1888 -- This wraps the user's main function in the top-level stuff
1889 -- defined in runMainIO (eg catching otherwise un-caught exceptions)
1890 -- See Note [Dealing with main]
1891 generateMainBinding tcg_env main_name = do
1892 { traceTc "checkMain found" (ppr main_name)
1893 ; (io_ty, res_ty) <- getIOType
1894 ; let loc = getSrcSpan main_name
1895 main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpan loc) main_name))
1896 ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $
1897 tcCheckMonoExpr main_expr_rn io_ty
1898
1899 -- See Note [Root-main Id]
1900 -- Construct the binding
1901 -- :Main.main :: IO res_ty = runMainIO res_ty main
1902 ; run_main_id <- tcLookupId runMainIOName
1903 ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
1904 (mkVarOccFS (fsLit "main"))
1905 (getSrcSpan main_name)
1906 ; root_main_id = Id.mkExportedVanillaId root_main_name io_ty
1907 ; co = mkWpTyApps [res_ty]
1908 -- The ev_binds of the `main` function may contain deferred
1909 -- type errors when type of `main` is not `IO a`. The `ev_binds`
1910 -- must be put inside `runMainIO` to ensure the deferred type
1911 -- error can be emitted correctly. See #13838.
1912 ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $
1913 mkHsDictLet ev_binds main_expr
1914 ; main_bind = mkVarBind root_main_id rhs }
1915
1916 ; return (tcg_env { tcg_main = Just main_name
1917 , tcg_binds = tcg_binds tcg_env
1918 `snocBag` main_bind
1919 , tcg_dus = tcg_dus tcg_env
1920 `plusDU` usesOnly (unitFV main_name) })
1921 -- Record the use of 'main', so that we don't
1922 -- complain about it being defined but not used
1923 }
1924
1925 getIOType :: TcM (TcType, TcType)
1926 -- Return (IO alpha, alpha) for fresh alpha
1927 getIOType = do { ioTyCon <- tcLookupTyCon ioTyConName
1928 ; res_ty <- newFlexiTyVarTy liftedTypeKind
1929 ; return (mkTyConApp ioTyCon [res_ty], res_ty) }
1930
1931 setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a)
1932 setMainCtxt main_name io_ty thing_inside
1933 = setSrcSpan (getSrcSpan main_name) $
1934 addErrCtxt main_ctxt $
1935 checkConstraints skol_info [] [] $ -- Builds an implication if necessary
1936 thing_inside -- e.g. with -fdefer-type-errors
1937 where
1938 skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty []
1939 main_ctxt = text "When checking the type of the"
1940 <+> ppMainFn (nameOccName main_name)
1941
1942 {- Note [Dealing with main]
1943 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1944 Dealing with the 'main' declaration is surprisingly tricky. Here are
1945 the moving parts:
1946
1947 * The flag -main-is=M.foo allows you to set the main module to 'M',
1948 and the main function to 'foo'. We access them through
1949 mainModIs :: HscEnv -> Module -- returns M
1950 getMainOcc :: DynFlags -> OccName -- returns foo
1951 Of course usually M = Main, and foo = main.
1952
1953 * checkMainType: when typechecking module M, we add an extra check that
1954 foo :: IO tau, for some type tau.
1955 This avoids getting ambiguous-type errors from the monomorphism restriction
1956 applying to things like
1957 main = return ()
1958 Note that checkMainType does not consult the export list because
1959 we have not yet done rnExports (and can't do it until later).
1960
1961 * rnExports: checks the export list. Very annoyingly, we can only do
1962 this after running any finalisers, which may add new declarations.
1963 That's why checkMainType and checkMain have to be separate.
1964
1965 * checkMain: does two things:
1966 - check that the export list does indeed export something called 'foo'
1967 - generateMainBinding: generate the root-main binding
1968 :Main.main = runMainIO M.foo
1969 See Note [Root-main id]
1970
1971 An annoying consequence of having both checkMainType and checkMain is
1972 that, when (but only when) -fdefer-type-errors is on, we may report an
1973 ill-typed 'main' twice (as warnings): once in checkMainType and once
1974 in checkMain. See test typecheck/should_fail/T13292.
1975
1976 We have the following tests to check this processing:
1977 ----------------+----------------------------------------------------------------------------------+
1978 | Module Header: |
1979 +-------------+-------------+-------------+-------------+-------------+------------+
1980 | module | module Main | <No Header> | module Main |module |module Main |
1981 | Main(main) | | | (module X)| Main () | (Sub.main)|
1982 ----------------+==================================================================================+
1983 `main` function | ERROR: | Main.main | ERROR: | Main.main | ERROR: | Sub.main |
1984 in Main module | Ambiguous | | Ambiguous | | `main` not | |
1985 and in imported | | | | | exported | |
1986 module Sub. | T19397E1 | T16453M0 | T19397E2 | T16453M3 | | T16453M1 |
1987 | | | | X = Main | Remark 2) | |
1988 ----------------+-------------+-------------+-------------+-------------+-------------+------------+
1989 `main`function | Sub.main | ERROR: | Sub.main | Sub.main | ERROR: | Sub.main |
1990 only in imported| | No `main` in| | | `main` not | |
1991 submodule Sub. | | `Main` | | | exported | |
1992 | T19397M0 | T16453E1 | T19397M1 | T16453M4 | | T16453M5 |
1993 | | | | X = Sub | Remark 2) | |
1994 ----------------+-------------+-------------+-------------+-------------+-------------+------------+
1995 `foo` function | Sub.foo | ERROR: | Sub.foo | Sub.foo | ERROR: | Sub.foo |
1996 in submodule | | No `foo` in | | | `foo` not | |
1997 Sub. | | `Main` | | | exported | |
1998 GHC option: | | | | | | |
1999 -main-is foo | T19397M2 | T19397E3 | T19397M3 | T19397M4 | T19397E4 | T16453M6 |
2000 | Remark 1) | | | X = Sub | | Remark 3) |
2001 ----------------+-------------+-------------+-------------+-------------+-------------+------------+
2002
2003 Remarks:
2004 * The first line shows the exported `main` function or the error.
2005 * The second line shows the coresponding test case.
2006 * The module `Sub` contains the following functions:
2007 main :: IO ()
2008 foo :: IO ()
2009 * Remark 1) Here the header is `Main (foo)`.
2010 * Remark 2) Here we have no extra test case. It would exercise the same code path as `T19397E4`.
2011 * Remark 3) Here the header is `Main (Sub.foo)`.
2012
2013
2014 Note [Root-main Id]
2015 ~~~~~~~~~~~~~~~~~~~
2016 The function that the RTS invokes is always :Main.main, which we call
2017 root_main_id. (Because GHC allows the user to have a module not
2018 called Main as the main module, we can't rely on the main function
2019 being called "Main.main". That's why root_main_id has a fixed module
2020 ":Main".)
2021
2022 This is unusual: it's a LocalId whose Name has a Module from another
2023 module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we
2024 get two defns for 'main' in the interface file!
2025
2026
2027 *********************************************************
2028 * *
2029 GHCi stuff
2030 * *
2031 *********************************************************
2032 -}
2033
2034 runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
2035 -- Initialise the tcg_inst_env with instances from all home modules.
2036 -- This mimics the more selective call to hptInstances in tcRnImports
2037 runTcInteractive hsc_env thing_inside
2038 = initTcInteractive hsc_env $ withTcPlugins hsc_env $
2039 withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $
2040 do { traceTc "setInteractiveContext" $
2041 vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
2042 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)
2043 , text "icReaderEnv (LocalDef)" <+>
2044 vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt)
2045 , let local_gres = filter isLocalGRE gres
2046 , not (null local_gres) ]) ]
2047
2048 ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface
2049 : dep_orphs (mi_deps iface))
2050 (loadSrcInterface (text "runTcInteractive") m
2051 NotBoot mb_pkg)
2052
2053 ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
2054 case i of -- force above: see #15111
2055 IIModule n -> getOrphans n NoPkgQual
2056 IIDecl i -> getOrphans (unLoc (ideclName i))
2057 (renameRawPkgQual (hsc_unit_env hsc_env) (ideclPkgQual i))
2058
2059 ; let imports = emptyImportAvails {
2060 imp_orphs = orphs
2061 }
2062
2063 ; (gbl_env, lcl_env) <- getEnvs
2064 ; let gbl_env' = gbl_env {
2065 tcg_rdr_env = icReaderEnv icxt
2066 , tcg_type_env = type_env
2067 , tcg_inst_env = extendInstEnvList
2068 (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)
2069 home_insts
2070 , tcg_fam_inst_env = extendFamInstEnvList
2071 (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
2072 ic_finsts)
2073 home_fam_insts
2074 , tcg_field_env = mkNameEnv con_fields
2075 -- setting tcg_field_env is necessary
2076 -- to make RecordWildCards work (test: ghci049)
2077 , tcg_fix_env = ic_fix_env icxt
2078 , tcg_default = ic_default icxt
2079 -- must calculate imp_orphs of the ImportAvails
2080 -- so that instance visibility is done correctly
2081 , tcg_imports = imports
2082 }
2083
2084 lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids
2085
2086 ; setEnvs (gbl_env', lcl_env') thing_inside }
2087 where
2088 (home_insts, home_fam_insts) = hptAllInstances hsc_env
2089
2090 icxt = hsc_IC hsc_env
2091 (ic_insts, ic_finsts) = ic_instances icxt
2092 (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt)
2093
2094 is_closed :: TyThing -> Either (Name, TcTyThing) TyThing
2095 -- Put Ids with free type variables (always RuntimeUnks)
2096 -- in the *local* type environment
2097 -- See Note [Initialising the type environment for GHCi]
2098 is_closed thing
2099 | AnId id <- thing
2100 , not (isTypeClosedLetBndr id)
2101 = Left (idName id, ATcId { tct_id = id
2102 , tct_info = NotLetBound })
2103 | otherwise
2104 = Right thing
2105
2106 type_env1 = mkTypeEnvWithImplicits top_ty_things
2107 type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)
2108 -- Putting the dfuns in the type_env
2109 -- is just to keep Core Lint happy
2110
2111 con_fields = [ (dataConName c, dataConFieldLabels c)
2112 | ATyCon t <- top_ty_things
2113 , c <- tyConDataCons t ]
2114
2115
2116 {- Note [Initialising the type environment for GHCi]
2117 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2118 Most of the Ids in ic_things, defined by the user in 'let' stmts,
2119 have closed types. E.g.
2120 ghci> let foo x y = x && not y
2121
2122 However the GHCi debugger creates top-level bindings for Ids whose
2123 types have free RuntimeUnk skolem variables, standing for unknown
2124 types. If we don't register these free TyVars as global TyVars then
2125 the typechecker will try to quantify over them and fall over in
2126 skolemiseQuantifiedTyVar. so we must add any free TyVars to the
2127 typechecker's global TyVar set. That is done by using
2128 tcExtendLocalTypeEnv.
2129
2130 We do this by splitting out the Ids with open types, using 'is_closed'
2131 to do the partition. The top-level things go in the global TypeEnv;
2132 the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the
2133 local TypeEnv.
2134
2135 Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope
2136 things are already in the interactive context's GlobalRdrEnv.
2137 Extending the local RdrEnv isn't terrible, but it means there is an
2138 entry for the same Name in both global and local RdrEnvs, and that
2139 lead to duplicate "perhaps you meant..." suggestions (e.g. T5564).
2140
2141 We don't bother with the tcl_th_bndrs environment either.
2142 -}
2143
2144 -- | The returned [Id] is the list of new Ids bound by this statement. It can
2145 -- be used to extend the InteractiveContext via extendInteractiveContext.
2146 --
2147 -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
2148 -- values, coerced to ().
2149 tcRnStmt :: HscEnv -> GhciLStmt GhcPs
2150 -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
2151 tcRnStmt hsc_env rdr_stmt
2152 = runTcInteractive hsc_env $ do {
2153
2154 -- The real work is done here
2155 ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;
2156 zonked_expr <- zonkTopLExpr tc_expr ;
2157 zonked_ids <- zonkTopBndrs bound_ids ;
2158
2159 failIfErrsM ; -- we can't do the next step if there are
2160 -- representation polymorphism errors
2161 -- test case: ghci/scripts/T13202{,a}
2162
2163 -- None of the Ids should be of unboxed type, because we
2164 -- cast them all to HValues in the end!
2165 mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ;
2166
2167 traceTc "tcs 1" empty ;
2168 this_mod <- getModule ;
2169 global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;
2170 -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env
2171
2172 {- ---------------------------------------------
2173 At one stage I removed any shadowed bindings from the type_env;
2174 they are inaccessible but might, I suppose, cause a space leak if we leave them there.
2175 However, with Template Haskell they aren't necessarily inaccessible. Consider this
2176 GHCi session
2177 Prelude> let f n = n * 2 :: Int
2178 Prelude> fName <- runQ [| f |]
2179 Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
2180 14
2181 Prelude> let f n = n * 3 :: Int
2182 Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
2183 In the last line we use 'fName', which resolves to the *first* 'f'
2184 in scope. If we delete it from the type env, GHCi crashes because
2185 it doesn't expect that.
2186
2187 Hence this code is commented out
2188
2189 -------------------------------------------------- -}
2190
2191 traceOptTcRn Opt_D_dump_tc
2192 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
2193 text "Typechecked expr" <+> ppr zonked_expr]) ;
2194
2195 return (global_ids, zonked_expr, fix_env)
2196 }
2197 where
2198 bad_unboxed id = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
2199 (sep [text "GHCi can't bind a variable of unlifted type:",
2200 nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))])
2201
2202 {-
2203 --------------------------------------------------------------------------
2204 Typechecking Stmts in GHCi
2205
2206 Here is the grand plan, implemented in tcUserStmt
2207
2208 What you type The IO [HValue] that hscStmt returns
2209 ------------- ------------------------------------
2210 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
2211 bindings: [x,y,...]
2212
2213 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
2214 bindings: [x,y,...]
2215
2216 expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
2217 [NB: result not printed] bindings: [it]
2218
2219 expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
2220 result showable) bindings: [it]
2221
2222 expr (of non-IO type,
2223 result not showable) ==> error
2224 -}
2225
2226 -- | A plan is an attempt to lift some code into the IO monad.
2227 type PlanResult = ([Id], LHsExpr GhcTc)
2228 type Plan = TcM PlanResult
2229
2230 -- | Try the plans in order. If one fails (by raising an exn), try the next.
2231 -- If one succeeds, take it.
2232 runPlans :: [Plan] -> TcM PlanResult
2233 runPlans [] = panic "runPlans"
2234 runPlans [p] = p
2235 runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p
2236
2237 -- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
2238 -- GHCi 'environment'.
2239 --
2240 -- By 'lift' and 'environment we mean that the code is changed to
2241 -- execute properly in an IO monad. See Note [Interactively-bound Ids
2242 -- in GHCi] in GHC.Driver.Env for more details. We do this lifting by trying
2243 -- different ways ('plans') of lifting the code into the IO monad and
2244 -- type checking each plan until one succeeds.
2245 tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
2246
2247 -- An expression typed at the prompt is treated very specially
2248 tcUserStmt (L loc (BodyStmt _ expr _ _))
2249 = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
2250 -- Don't try to typecheck if the renamer fails!
2251 ; ghciStep <- getGhciStepIO
2252 ; uniq <- newUnique
2253 ; let loc' = noAnnSrcSpan $ locA loc
2254 ; interPrintName <- getInteractivePrintName
2255 ; let fresh_it = itName uniq (locA loc)
2256 matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr
2257 emptyLocalBinds]
2258 -- [it = expr]
2259 the_bind = L loc $ (mkTopFunBind FromSource
2260 (L loc' fresh_it) matches)
2261 { fun_ext = fvs }
2262 -- Care here! In GHCi the expression might have
2263 -- free variables, and they in turn may have free type variables
2264 -- (if we are at a breakpoint, say). We must put those free vars
2265
2266 -- [let it = expr]
2267 let_stmt = L loc $ LetStmt noAnn $ HsValBinds noAnn
2268 $ XValBindsLR
2269 (NValBinds [(NonRecursive,unitBag the_bind)] [])
2270
2271 -- [it <- e]
2272 bind_stmt = L loc $ BindStmt
2273 (XBindStmtRn
2274 { xbsrn_bindOp = mkRnSyntaxExpr bindIOName
2275 , xbsrn_failOp = Nothing
2276 })
2277 (L loc (VarPat noExtField (L loc' fresh_it)))
2278 (nlHsApp ghciStep rn_expr)
2279
2280 -- [; print it]
2281 print_it = L loc $ BodyStmt noExtField
2282 (nlHsApp (nlHsVar interPrintName)
2283 (nlHsVar fresh_it))
2284 (mkRnSyntaxExpr thenIOName)
2285 noSyntaxExpr
2286
2287 -- NewA
2288 no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName
2289 [rn_expr , nlHsVar interPrintName])
2290 (mkRnSyntaxExpr thenIOName)
2291 noSyntaxExpr
2292
2293 no_it_b = L loc $ BodyStmt noExtField (rn_expr)
2294 (mkRnSyntaxExpr thenIOName)
2295 noSyntaxExpr
2296
2297 no_it_c = L loc $ BodyStmt noExtField
2298 (nlHsApp (nlHsVar interPrintName) rn_expr)
2299 (mkRnSyntaxExpr thenIOName)
2300 noSyntaxExpr
2301
2302 -- See Note [GHCi Plans]
2303
2304 it_plans = [
2305 -- Plan A
2306 do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
2307 ; it_ty <- zonkTcType (idType it_id)
2308 ; when (isUnitTy $ it_ty) failM
2309 ; return stuff },
2310
2311 -- Plan B; a naked bind statement
2312 tcGhciStmts [bind_stmt],
2313
2314 -- Plan C; check that the let-binding is typeable all by itself.
2315 -- If not, fail; if so, try to print it.
2316 -- The two-step process avoids getting two errors: one from
2317 -- the expression itself, and one from the 'print it' part
2318 -- This two-step story is very clunky, alas
2319 do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
2320 --- checkNoErrs defeats the error recovery of let-bindings
2321 ; tcGhciStmts [let_stmt, print_it] } ]
2322
2323 -- Plans where we don't bind "it"
2324 no_it_plans = [
2325 tcGhciStmts [no_it_a] ,
2326 tcGhciStmts [no_it_b] ,
2327 tcGhciStmts [no_it_c] ]
2328
2329 ; generate_it <- goptM Opt_NoIt
2330
2331 -- We disable `-fdefer-type-errors` in GHCi for naked expressions.
2332 -- See Note [Deferred type errors in GHCi]
2333
2334 -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes`
2335 -- and `-fdefer-out-of-scope-variables`. However the flag
2336 -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and
2337 -- `-fno-defer-out-of-scope-variables`. Thus the later two flags
2338 -- also need to be unset here.
2339 ; plan <- unsetGOptM Opt_DeferTypeErrors $
2340 unsetGOptM Opt_DeferTypedHoles $
2341 unsetGOptM Opt_DeferOutOfScopeVariables $
2342 runPlans $ if generate_it
2343 then no_it_plans
2344 else it_plans
2345
2346 ; fix_env <- getFixityEnv
2347 ; return (plan, fix_env) }
2348
2349 {- Note [Deferred type errors in GHCi]
2350 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2351 In GHCi, we ensure that type errors don't get deferred when type checking the
2352 naked expressions. Deferring type errors here is unhelpful because the
2353 expression gets evaluated right away anyway. It also would potentially emit
2354 two redundant type-error warnings, one from each plan.
2355
2356 #14963 reveals another bug that when deferred type errors is enabled
2357 in GHCi, any reference of imported/loaded variables (directly or indirectly)
2358 in interactively issued naked expressions will cause ghc panic. See more
2359 detailed discussion in #14963.
2360
2361 The interactively issued declarations, statements, as well as the modules
2362 loaded into GHCi, are not affected. That means, for declaration, you could
2363 have
2364
2365 Prelude> :set -fdefer-type-errors
2366 Prelude> x :: IO (); x = putStrLn True
2367 <interactive>:14:26: warning: [-Wdeferred-type-errors]
2368 ? Couldn't match type ‘Bool’ with ‘[Char]’
2369 Expected type: String
2370 Actual type: Bool
2371 ? In the first argument of ‘putStrLn’, namely ‘True’
2372 In the expression: putStrLn True
2373 In an equation for ‘x’: x = putStrLn True
2374
2375 But for naked expressions, you will have
2376
2377 Prelude> :set -fdefer-type-errors
2378 Prelude> putStrLn True
2379 <interactive>:2:10: error:
2380 ? Couldn't match type ‘Bool’ with ‘[Char]’
2381 Expected type: String
2382 Actual type: Bool
2383 ? In the first argument of ‘putStrLn’, namely ‘True’
2384 In the expression: putStrLn True
2385 In an equation for ‘it’: it = putStrLn True
2386
2387 Prelude> let x = putStrLn True
2388 <interactive>:2:18: warning: [-Wdeferred-type-errors]
2389 ? Couldn't match type ‘Bool’ with ‘[Char]’
2390 Expected type: String
2391 Actual type: Bool
2392 ? In the first argument of ‘putStrLn’, namely ‘True’
2393 In the expression: putStrLn True
2394 In an equation for ‘x’: x = putStrLn True
2395 -}
2396
2397 tcUserStmt rdr_stmt@(L loc _)
2398 = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
2399 rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do
2400 fix_env <- getFixityEnv
2401 return (fix_env, emptyFVs)
2402 -- Don't try to typecheck if the renamer fails!
2403 ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
2404 ; rnDump rn_stmt ;
2405
2406 ; ghciStep <- getGhciStepIO
2407 ; let gi_stmt
2408 | (L loc (BindStmt x pat expr)) <- rn_stmt
2409 = L loc $ BindStmt x pat (nlHsApp ghciStep expr)
2410 | otherwise = rn_stmt
2411
2412 ; opt_pr_flag <- goptM Opt_PrintBindResult
2413 ; let print_result_plan
2414 | opt_pr_flag -- The flag says "print result"
2415 , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt -- One binder
2416 = [mk_print_result_plan gi_stmt v]
2417 | otherwise = []
2418
2419 -- The plans are:
2420 -- [stmt; print v] if one binder and not v::()
2421 -- [stmt] otherwise
2422 ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])
2423 ; return (plan, fix_env) }
2424 where
2425 mk_print_result_plan stmt v
2426 = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
2427 ; v_ty <- zonkTcType (idType v_id)
2428 ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
2429 ; return stuff }
2430 where
2431 print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName)
2432 (nlHsVar v))
2433 (mkRnSyntaxExpr thenIOName) noSyntaxExpr
2434
2435 {-
2436 Note [GHCi Plans]
2437 ~~~~~~~~~~~~~~~~~
2438 When a user types an expression in the repl we try to print it in three different
2439 ways. Also, depending on whether -fno-it is set, we bind a variable called `it`
2440 which can be used to refer to the result of the expression subsequently in the repl.
2441
2442 The normal plans are :
2443 A. [it <- e; print e] but not if it::()
2444 B. [it <- e]
2445 C. [let it = e; print it]
2446
2447 When -fno-it is set, the plans are:
2448 A. [e >>= print]
2449 B. [e]
2450 C. [let it = e in print it]
2451
2452 The reason for -fno-it is explained in #14336. `it` can lead to the repl
2453 leaking memory as it is repeatedly queried.
2454 -}
2455
2456 -- | Typecheck the statements given and then return the results of the
2457 -- statement in the form 'IO [()]'.
2458 tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult
2459 tcGhciStmts stmts
2460 = do { ioTyCon <- tcLookupTyCon ioTyConName
2461 ; ret_id <- tcLookupId returnIOName -- return @ IO
2462 ; let ret_ty = mkListTy unitTy
2463 io_ret_ty = mkTyConApp ioTyCon [ret_ty]
2464 tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts
2465 (mkCheckExpType io_ret_ty)
2466 names = collectLStmtsBinders CollNoDictBinders stmts
2467
2468 -- OK, we're ready to typecheck the stmts
2469 ; traceTc "GHC.Tc.Module.tcGhciStmts: tc stmts" empty
2470 ; ((tc_stmts, ids), lie) <- captureTopConstraints $
2471 tc_io_stmts $ \ _ ->
2472 mapM tcLookupId names
2473 -- Look up the names right in the middle,
2474 -- where they will all be in scope
2475
2476 -- Simplify the context
2477 ; traceTc "GHC.Tc.Module.tcGhciStmts: simplify ctxt" empty
2478 ; const_binds <- checkNoErrs (simplifyInteractive lie)
2479 -- checkNoErrs ensures that the plan fails if context redn fails
2480
2481
2482 ; traceTc "GHC.Tc.Module.tcGhciStmts: done" empty
2483
2484 -- rec_expr is the expression
2485 -- returnIO @ [()] [unsafeCoerce# () x, .., unsafeCorece# () z]
2486 --
2487 -- Despite the inconvenience of building the type applications etc,
2488 -- this *has* to be done in type-annotated post-typecheck form
2489 -- because we are going to return a list of *polymorphic* values
2490 -- coerced to type (). If we built a *source* stmt
2491 -- return [coerce x, ..., coerce z]
2492 -- then the type checker would instantiate x..z, and we wouldn't
2493 -- get their *polymorphic* values. (And we'd get ambiguity errs
2494 -- if they were overloaded, since they aren't applied to anything.)
2495
2496 ; AnId unsafe_coerce_id <- tcLookupGlobal unsafeCoercePrimName
2497 -- We use unsafeCoerce# here because of (U11) in
2498 -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
2499
2500 ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $
2501 noLocA $ ExplicitList unitTy $
2502 map mk_item ids
2503
2504 mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id)
2505 , getRuntimeRep unitTy
2506 , idType id, unitTy]
2507 `nlHsApp` nlHsVar id
2508 stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)]
2509
2510 ; return (ids, mkHsDictLet (EvBinds const_binds) $
2511 noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts)))
2512 }
2513
2514 -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
2515 getGhciStepIO :: TcM (LHsExpr GhcRn)
2516 getGhciStepIO = do
2517 ghciTy <- getGHCiMonad
2518 a_tv <- newName (mkTyVarOccFS (fsLit "a"))
2519 let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
2520 ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
2521
2522 step_ty :: LHsSigType GhcRn
2523 step_ty = noLocA $ HsSig
2524 { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]}
2525 , sig_ext = noExtField
2526 , sig_body = nlHsFunTy ghciM ioM }
2527
2528 stepTy :: LHsSigWcType GhcRn
2529 stepTy = mkEmptyWildCardBndrs step_ty
2530
2531 return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy)
2532
2533 isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name)
2534 isGHCiMonad hsc_env ty
2535 = runTcInteractive hsc_env $ do
2536 rdrEnv <- getGlobalRdrEnv
2537 let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
2538 case occIO of
2539 Just [n] -> do
2540 let name = greMangledName n
2541 ghciClass <- tcLookupClass ghciIoClassName
2542 userTyCon <- tcLookupTyCon name
2543 let userTy = mkTyConApp userTyCon []
2544 _ <- tcLookupInstance ghciClass [userTy]
2545 return name
2546
2547 Just _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!"
2548 Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty)
2549
2550 -- | How should we infer a type? See Note [TcRnExprMode]
2551 data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:type)
2552 | TM_Default -- ^ Instantiate all quantifiers,
2553 -- and do eager defaulting (:type +d)
2554
2555 -- | tcRnExpr just finds the type of an expression
2556 -- for :type
2557 tcRnExpr :: HscEnv
2558 -> TcRnExprMode
2559 -> LHsExpr GhcPs
2560 -> IO (Messages TcRnMessage, Maybe Type)
2561 tcRnExpr hsc_env mode rdr_expr
2562 = runTcInteractive hsc_env $
2563 do {
2564
2565 (rn_expr, _fvs) <- rnLExpr rdr_expr ;
2566 failIfErrsM ;
2567
2568 -- Typecheck the expression
2569 ((tclvl, res_ty), lie)
2570 <- captureTopConstraints $
2571 pushTcLevelM $
2572 tcInferSigma inst rn_expr ;
2573
2574 -- Generalise
2575 uniq <- newUnique ;
2576 let { fresh_it = itName uniq (getLocA rdr_expr) } ;
2577 ((qtvs, dicts, _, _), residual)
2578 <- captureConstraints $
2579 simplifyInfer tclvl infer_mode
2580 [] {- No sig vars -}
2581 [(fresh_it, res_ty)]
2582 lie ;
2583
2584 -- Ignore the dictionary bindings
2585 _ <- perhaps_disable_default_warnings $
2586 simplifyInteractive residual ;
2587
2588 let { all_expr_ty = mkInfForAllTys qtvs $
2589 mkPhiTy (map idType dicts) res_ty } ;
2590 ty <- zonkTcType all_expr_ty ;
2591
2592 -- We normalise type families, so that the type of an expression is the
2593 -- same as of a bound expression (GHC.Tc.Gen.Bind.mkInferredPolyId). See Trac
2594 -- #10321 for further discussion.
2595 fam_envs <- tcGetFamInstEnvs ;
2596 -- normaliseType returns a coercion which we discard, so the Role is
2597 -- irrelevant
2598 return (reductionReducedType (normaliseType fam_envs Nominal ty))
2599 }
2600 where
2601 -- Optionally instantiate the type of the expression
2602 -- See Note [TcRnExprMode]
2603 (inst, infer_mode, perhaps_disable_default_warnings) = case mode of
2604 TM_Inst -> (False, NoRestrictions, id)
2605 TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults)
2606
2607 {- Note [Implementing :type]
2608 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2609 Consider :type const
2610
2611 We want forall a b. a -> b -> a
2612 and not forall {a}{b}. a -> b -> a
2613
2614 The latter is what we'd get if we eagerly instantiated and then
2615 re-generalised with Inferred binders. It makes a difference, because
2616 it tells us we where we can use Visible Type Application (VTA).
2617
2618 And also for :type const @Int
2619 we want forall b. Int -> b -> Int
2620 and not forall {b}. Int -> b -> Int
2621
2622 Solution: use tcInferSigma, which in turn uses tcInferApp, which
2623 has a special case for application chains.
2624 -}
2625
2626 --------------------------
2627 tcRnImportDecls :: HscEnv
2628 -> [LImportDecl GhcPs]
2629 -> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
2630 -- Find the new chunk of GlobalRdrEnv created by this list of import
2631 -- decls. In contract tcRnImports *extends* the TcGblEnv.
2632 tcRnImportDecls hsc_env import_decls
2633 = runTcInteractive hsc_env $
2634 do { gbl_env <- updGblEnv zap_rdr_env $
2635 tcRnImports hsc_env $ map (,text "is directly imported") import_decls
2636 ; return (tcg_rdr_env gbl_env) }
2637 where
2638 zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
2639
2640 -- tcRnType just finds the kind of a type
2641 tcRnType :: HscEnv
2642 -> ZonkFlexi
2643 -> Bool -- Normalise the returned type
2644 -> LHsType GhcPs
2645 -> IO (Messages TcRnMessage, Maybe (Type, Kind))
2646 tcRnType hsc_env flexi normalise rdr_type
2647 = runTcInteractive hsc_env $
2648 setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType]
2649 do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs)
2650 <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type)
2651 -- The type can have wild cards, but no implicit
2652 -- generalisation; e.g. :kind (T _)
2653 ; failIfErrsM
2654
2655 -- We follow Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType here
2656
2657 -- Now kind-check the type
2658 -- It can have any rank or kind
2659 -- First bring into scope any wildcards
2660 ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type])
2661 ; ((ty, kind), wanted)
2662 <- captureTopConstraints $
2663 pushTcLevelM_ $
2664 bindNamedWildCardBinders wcs $ \ wcs' ->
2665 do { mapM_ emitNamedTypeHole wcs'
2666 ; tcInferLHsTypeUnsaturated rn_type }
2667
2668 -- Since all the wanteds are equalities, the returned bindings will be empty
2669 ; empty_binds <- simplifyTop wanted
2670 ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)
2671
2672 -- Do kind generalisation; see Note [Kind-generalise in tcRnType]
2673 ; kvs <- kindGeneralizeAll kind
2674
2675 ; e <- mkEmptyZonkEnv flexi
2676 ; ty <- zonkTcTypeToTypeX e ty
2677
2678 -- Do validity checking on type
2679 ; checkValidType (GhciCtxt True) ty
2680
2681 -- Optionally (:k vs :k!) normalise the type. Does two things:
2682 -- normaliseType: expand type-family applications
2683 -- expandTypeSynonyms: expand type synonyms (#18828)
2684 ; fam_envs <- tcGetFamInstEnvs
2685 ; let ty' | normalise = expandTypeSynonyms $ reductionReducedType $
2686 normaliseType fam_envs Nominal ty
2687 | otherwise = ty
2688
2689 ; return (ty', mkInfForAllTys kvs (tcTypeKind ty')) }
2690
2691
2692 {- Note [TcRnExprMode]
2693 ~~~~~~~~~~~~~~~~~~~~~~
2694 How should we infer a type when a user asks for the type of an expression e
2695 at the GHCi prompt? We offer 2 different possibilities, described below. Each
2696 considers this example, with -fprint-explicit-foralls enabled. See also
2697 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0179-printing-foralls.rst
2698
2699 :type / TM_Inst
2700
2701 In this mode, we report the type obained by instantiating only the
2702 /inferred/ quantifiers of e's type, solving constraints, and
2703 re-generalising, as discussed in #11376.
2704
2705 > :type reverse
2706 reverse :: forall a. [a] -> [a]
2707
2708 -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String
2709 > :type +v foo @Int
2710 forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String
2711
2712 Note that Show Int is still reported, because the solver never got a chance
2713 to see it.
2714
2715 :type +d / TM_Default
2716
2717 This mode is for the benefit of users who wish to see instantiations
2718 of generalized types, and in particular to instantiate Foldable and
2719 Traversable. In this mode, all type variables (inferred or
2720 specified) are instantiated. Because GHCi uses
2721 -XExtendedDefaultRules, this means that Foldable and Traversable are
2722 defaulted.
2723
2724 > :type +d reverse
2725 reverse :: forall {a}. [a] -> [a]
2726
2727 -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String
2728 > :type +d foo @Int
2729 Int -> [Integer] -> String
2730
2731 Note that this mode can sometimes lead to a type error, if a type variable is
2732 used with a defaultable class but cannot actually be defaulted:
2733
2734 bar :: (Num a, Monoid a) => a -> a
2735 > :type +d bar
2736 ** error **
2737
2738 The error arises because GHC tries to default a but cannot find a concrete
2739 type in the defaulting list that is both Num and Monoid. (If this list is
2740 modified to include an element that is both Num and Monoid, the defaulting
2741 would succeed, of course.)
2742
2743 Note that the variables and constraints are reordered here, because this
2744 is possible during regeneralization. Also note that the variables are
2745 reported as Inferred instead of Specified.
2746
2747 Note [Kind-generalise in tcRnType]
2748 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2749 We switch on PolyKinds when kind-checking a user type, so that we will
2750 kind-generalise the type, even when PolyKinds is not otherwise on.
2751 This gives the right default behaviour at the GHCi prompt, where if
2752 you say ":k T", and T has a polymorphic kind, you'd like to see that
2753 polymorphism. Of course. If T isn't kind-polymorphic you won't get
2754 anything unexpected, but the apparent *loss* of polymorphism, for
2755 types that you know are polymorphic, is quite surprising. See Trac
2756 #7688 for a discussion.
2757
2758 Note that the goal is to generalise the *kind of the type*, not
2759 the type itself! Example:
2760 ghci> data SameKind :: k -> k -> Type
2761 ghci> :k SameKind _
2762
2763 We want to get `k -> Type`, not `Any -> Type`, which is what we would
2764 get without kind-generalisation. Note that `:k SameKind` is OK, as
2765 GHC will not instantiate SameKind here, and so we see its full kind
2766 of `forall k. k -> k -> Type`.
2767
2768 ************************************************************************
2769 * *
2770 tcRnDeclsi
2771 * *
2772 ************************************************************************
2773
2774 tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
2775 -}
2776
2777 tcRnDeclsi :: HscEnv
2778 -> [LHsDecl GhcPs]
2779 -> IO (Messages TcRnMessage, Maybe TcGblEnv)
2780 tcRnDeclsi hsc_env local_decls
2781 = runTcInteractive hsc_env $
2782 tcRnSrcDecls False Nothing local_decls
2783
2784 externaliseAndTidyId :: Module -> Id -> TcM Id
2785 externaliseAndTidyId this_mod id
2786 = do { name' <- externaliseName this_mod (idName id)
2787 ; return $ globaliseId id
2788 `setIdName` name'
2789 `setIdType` tidyTopType (idType id) }
2790
2791
2792 {-
2793 ************************************************************************
2794 * *
2795 More GHCi stuff, to do with browsing and getting info
2796 * *
2797 ************************************************************************
2798 -}
2799
2800 -- | ASSUMES that the module is either in the 'HomePackageTable' or is
2801 -- a package module with an interface on disk. If neither of these is
2802 -- true, then the result will be an error indicating the interface
2803 -- could not be found.
2804 getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
2805 getModuleInterface hsc_env mod
2806 = runTcInteractive hsc_env $
2807 loadModuleInterface (text "getModuleInterface") mod
2808
2809 tcRnLookupRdrName :: HscEnv -> LocatedN RdrName
2810 -> IO (Messages TcRnMessage, Maybe [Name])
2811 -- ^ Find all the Names that this RdrName could mean, in GHCi
2812 tcRnLookupRdrName hsc_env (L loc rdr_name)
2813 = runTcInteractive hsc_env $
2814 setSrcSpanA loc $
2815 do { -- If the identifier is a constructor (begins with an
2816 -- upper-case letter), then we need to consider both
2817 -- constructor and type class identifiers.
2818 let rdr_names = dataTcOccs rdr_name
2819 ; names_s <- mapM lookupInfoOccRn rdr_names
2820 ; let names = concat names_s
2821 ; when (null names) (addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $
2822 (text "Not in scope:" <+> quotes (ppr rdr_name)))
2823 ; return names }
2824
2825 tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing)
2826 tcRnLookupName hsc_env name
2827 = runTcInteractive hsc_env $
2828 tcRnLookupName' name
2829
2830 -- To look up a name we have to look in the local environment (tcl_lcl)
2831 -- as well as the global environment, which is what tcLookup does.
2832 -- But we also want a TyThing, so we have to convert:
2833
2834 tcRnLookupName' :: Name -> TcRn TyThing
2835 tcRnLookupName' name = do
2836 tcthing <- tcLookup name
2837 case tcthing of
2838 AGlobal thing -> return thing
2839 ATcId{tct_id=id} -> return (AnId id)
2840 _ -> panic "tcRnLookupName'"
2841
2842 tcRnGetInfo :: HscEnv
2843 -> Name
2844 -> IO ( Messages TcRnMessage
2845 , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
2846
2847 -- Used to implement :info in GHCi
2848 --
2849 -- Look up a RdrName and return all the TyThings it might be
2850 -- A capitalised RdrName is given to us in the DataName namespace,
2851 -- but we want to treat it as *both* a data constructor
2852 -- *and* as a type or class constructor;
2853 -- hence the call to dataTcOccs, and we return up to two results
2854 tcRnGetInfo hsc_env name
2855 = runTcInteractive hsc_env $
2856 do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
2857 -- Load the interface for all unqualified types and classes
2858 -- That way we will find all the instance declarations
2859 -- (Packages have not orphan modules, and we assume that
2860 -- in the home package all relevant modules are loaded.)
2861
2862 ; thing <- tcRnLookupName' name
2863 ; fixity <- lookupFixityRn name
2864 ; (cls_insts, fam_insts) <- lookupInsts thing
2865 ; let info = lookupKnownNameInfo name
2866 ; return (thing, fixity, cls_insts, fam_insts, info) }
2867
2868
2869 -- Lookup all class and family instances for a type constructor.
2870 --
2871 -- This function filters all instances in the type environment, so there
2872 -- is a lot of duplicated work if it is called many times in the same
2873 -- type environment. If this becomes a problem, the NameEnv computed
2874 -- in GHC.getNameToInstancesIndex could be cached in TcM and both functions
2875 -- could be changed to consult that index.
2876 lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
2877 lookupInsts (ATyCon tc)
2878 = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs
2879 ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
2880 -- Load all instances for all classes that are
2881 -- in the type environment (which are all the ones
2882 -- we've seen in any interface file so far)
2883
2884 -- Return only the instances relevant to the given thing, i.e.
2885 -- the instances whose head contains the thing's name.
2886 ; let cls_insts =
2887 [ ispec -- Search all
2888 | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
2889 , instIsVisible vis_mods ispec
2890 , tc_name `elemNameSet` orphNamesOfClsInst ispec ]
2891 ; let fam_insts =
2892 [ fispec
2893 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
2894 , tc_name `elemNameSet` orphNamesOfFamInst fispec ]
2895 ; return (cls_insts, fam_insts) }
2896 where
2897 tc_name = tyConName tc
2898
2899 lookupInsts _ = return ([],[])
2900
2901 loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
2902 -- Load the interface for everything that is in scope unqualified
2903 -- This is so that we can accurately report the instances for
2904 -- something
2905 loadUnqualIfaces hsc_env ictxt
2906 = initIfaceTcRn $
2907 mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
2908 where
2909 home_unit = hsc_home_unit hsc_env
2910
2911 unqual_mods = [ nameModule name
2912 | gre <- globalRdrEnvElts (icReaderEnv ictxt)
2913 , let name = greMangledName gre
2914 , nameIsFromExternalPackage home_unit name
2915 , isTcOcc (nameOccName name) -- Types and classes only
2916 , unQualOK gre ] -- In scope unqualified
2917 doc = text "Need interface for module whose export(s) are in scope unqualified"
2918
2919
2920
2921 {-
2922 ************************************************************************
2923 * *
2924 Debugging output
2925 This is what happens when you do -ddump-types
2926 * *
2927 ************************************************************************
2928 -}
2929
2930 -- | Dump, with a banner, if -ddump-rn
2931 rnDump :: (Outputable a, Data a) => a -> TcRn ()
2932 rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn)
2933
2934 tcDump :: TcGblEnv -> TcRn ()
2935 tcDump env
2936 = do { unit_state <- hsc_units <$> getTopEnv ;
2937 logger <- getLogger ;
2938
2939 -- Dump short output if -ddump-types or -ddump-tc
2940 when (logHasDumpFlag logger Opt_D_dump_types || logHasDumpFlag logger Opt_D_dump_tc)
2941 (dumpTcRn True Opt_D_dump_types
2942 "" FormatText (pprWithUnitState unit_state short_dump)) ;
2943
2944 -- Dump bindings if -ddump-tc
2945 dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump;
2946
2947 -- Dump bindings as an hsSyn AST if -ddump-tc-ast
2948 dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump
2949 }
2950 where
2951 short_dump = pprTcGblEnv env
2952 full_dump = pprLHsBinds (tcg_binds env)
2953 -- NB: foreign x-d's have undefined's in their types;
2954 -- hence can't show the tc_fords
2955 ast_dump = showAstData NoBlankSrcSpan NoBlankEpAnnotations (tcg_binds env)
2956
2957 -- It's unpleasant having both pprModGuts and pprModDetails here
2958 pprTcGblEnv :: TcGblEnv -> SDoc
2959 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
2960 tcg_insts = insts,
2961 tcg_fam_insts = fam_insts,
2962 tcg_rules = rules,
2963 tcg_imports = imports })
2964 = getPprDebug $ \debug ->
2965 vcat [ ppr_types debug type_env
2966 , ppr_tycons debug fam_insts type_env
2967 , ppr_datacons debug type_env
2968 , ppr_patsyns type_env
2969 , ppr_insts insts
2970 , ppr_fam_insts fam_insts
2971 , ppr_rules rules
2972 , text "Dependent modules:" <+>
2973 pprUFM (imp_direct_dep_mods imports) (ppr . sort)
2974 , text "Dependent packages:" <+>
2975 ppr (S.toList $ imp_dep_direct_pkgs imports)]
2976 -- The use of sort is just to reduce unnecessary
2977 -- wobbling in testsuite output
2978
2979 ppr_rules :: [LRuleDecl GhcTc] -> SDoc
2980 ppr_rules rules
2981 = ppUnless (null rules) $
2982 hang (text "RULES")
2983 2 (vcat (map ppr rules))
2984
2985 ppr_types :: Bool -> TypeEnv -> SDoc
2986 ppr_types debug type_env
2987 = ppr_things "TYPE SIGNATURES" ppr_sig
2988 (sortBy (comparing getOccName) ids)
2989 where
2990 ids = [id | id <- typeEnvIds type_env, want_sig id]
2991 want_sig id
2992 | debug = True
2993 | otherwise = hasTopUserName id
2994 && case idDetails id of
2995 VanillaId -> True
2996 RecSelId {} -> True
2997 ClassOpId {} -> True
2998 FCallId {} -> True
2999 _ -> False
3000 -- Data cons (workers and wrappers), pattern synonyms,
3001 -- etc are suppressed (unless -dppr-debug),
3002 -- because they appear elsewhere
3003
3004 ppr_sig id = hang (pprPrefixOcc id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
3005
3006 ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc
3007 ppr_tycons debug fam_insts type_env
3008 = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons
3009 , ppr_things "COERCION AXIOMS" ppr_ax
3010 (typeEnvCoAxioms type_env) ]
3011 where
3012 fi_tycons = famInstsRepTyCons fam_insts
3013
3014 tycons = sortBy (comparing getOccName) $
3015 [tycon | tycon <- typeEnvTyCons type_env
3016 , want_tycon tycon]
3017 -- Sort by OccName to reduce unnecessary changes
3018 want_tycon tycon | debug = True
3019 | otherwise = isExternalName (tyConName tycon) &&
3020 not (tycon `elem` fi_tycons)
3021 ppr_tc tc
3022 = vcat [ hang (ppr (tyConFlavour tc) <+> pprPrefixOcc (tyConName tc)
3023 <> braces (ppr (tyConArity tc)) <+> dcolon)
3024 2 (ppr (tidyTopType (tyConKind tc)))
3025 , nest 2 $
3026 ppWhen show_roles $
3027 text "roles" <+> (sep (map ppr roles)) ]
3028 where
3029 show_roles = debug || not (all (== boring_role) roles)
3030 roles = tyConRoles tc
3031 boring_role | isClassTyCon tc = Nominal
3032 | otherwise = Representational
3033 -- Matches the choice in GHC.Iface.Syntax, calls to pprRoles
3034
3035 ppr_ax ax = ppr (coAxiomToIfaceDecl ax)
3036 -- We go via IfaceDecl rather than using pprCoAxiom
3037 -- This way we get the full axiom (both LHS and RHS) with
3038 -- wildcard binders tidied to _1, _2, etc.
3039
3040 ppr_datacons :: Bool -> TypeEnv -> SDoc
3041 ppr_datacons debug type_env
3042 = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs
3043 -- The filter gets rid of class data constructors
3044 where
3045 ppr_dc dc = sdocOption sdocLinearTypes (\show_linear_types ->
3046 ppr dc <+> dcolon <+> ppr (dataConDisplayType show_linear_types dc))
3047 all_dcs = typeEnvDataCons type_env
3048 wanted_dcs | debug = all_dcs
3049 | otherwise = filterOut is_cls_dc all_dcs
3050 is_cls_dc dc = isClassTyCon (dataConTyCon dc)
3051
3052 ppr_patsyns :: TypeEnv -> SDoc
3053 ppr_patsyns type_env
3054 = ppr_things "PATTERN SYNONYMS" ppr_ps
3055 (typeEnvPatSyns type_env)
3056 where
3057 ppr_ps ps = pprPrefixOcc ps <+> dcolon <+> pprPatSynType ps
3058
3059 ppr_insts :: [ClsInst] -> SDoc
3060 ppr_insts ispecs
3061 = ppr_things "CLASS INSTANCES" pprInstance ispecs
3062
3063 ppr_fam_insts :: [FamInst] -> SDoc
3064 ppr_fam_insts fam_insts
3065 = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts
3066
3067 ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc
3068 ppr_things herald ppr_one things
3069 | null things = empty
3070 | otherwise = text herald $$ nest 2 (vcat (map ppr_one things))
3071
3072 hasTopUserName :: NamedThing x => x -> Bool
3073 -- A top-level thing whose name is not "derived"
3074 -- Thus excluding things like $tcX, from Typeable boilerplate
3075 -- and C:Coll from class-dictionary data constructors
3076 hasTopUserName x
3077 = isExternalName name && not (isDerivedOccName (nameOccName name))
3078 where
3079 name = getName x
3080
3081 {-
3082 ********************************************************************************
3083
3084 Type Checker Plugins
3085
3086 ********************************************************************************
3087 -}
3088
3089 withTcPlugins :: HscEnv -> TcM a -> TcM a
3090 withTcPlugins hsc_env m =
3091 case catMaybes $ mapPlugins hsc_env tcPlugin of
3092 [] -> m -- Common fast case
3093 plugins -> do
3094 ev_binds_var <- newTcEvBinds
3095 (solvers, rewriters, stops) <-
3096 unzip3 `fmap` mapM (start_plugin ev_binds_var) plugins
3097 let
3098 rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter]
3099 !rewritersUniqFM = sequenceUFMList rewriters
3100 -- The following ensures that tcPluginStop is called even if a type
3101 -- error occurs during compilation (Fix of #10078)
3102 eitherRes <- tryM $
3103 updGblEnv (\e -> e { tcg_tc_plugin_solvers = solvers
3104 , tcg_tc_plugin_rewriters = rewritersUniqFM }) m
3105 mapM_ runTcPluginM stops
3106 case eitherRes of
3107 Left _ -> failM
3108 Right res -> return res
3109 where
3110 start_plugin ev_binds_var (TcPlugin start solve rewrite stop) =
3111 do s <- runTcPluginM start
3112 return (solve s ev_binds_var, rewrite s, stop s)
3113
3114 withDefaultingPlugins :: HscEnv -> TcM a -> TcM a
3115 withDefaultingPlugins hsc_env m =
3116 do case catMaybes $ mapPlugins hsc_env defaultingPlugin of
3117 [] -> m -- Common fast case
3118 plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins
3119 -- This ensures that dePluginStop is called even if a type
3120 -- error occurs during compilation
3121 eitherRes <- tryM $ do
3122 updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) m
3123 mapM_ runTcPluginM stops
3124 case eitherRes of
3125 Left _ -> failM
3126 Right res -> return res
3127 where
3128 start_plugin (DefaultingPlugin start fill stop) =
3129 do s <- runTcPluginM start
3130 return (fill s, stop s)
3131
3132 withHoleFitPlugins :: HscEnv -> TcM a -> TcM a
3133 withHoleFitPlugins hsc_env m =
3134 case catMaybes $ mapPlugins hsc_env holeFitPlugin of
3135 [] -> m -- Common fast case
3136 plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins
3137 -- This ensures that hfPluginStop is called even if a type
3138 -- error occurs during compilation.
3139 eitherRes <- tryM $
3140 updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m
3141 sequence_ stops
3142 case eitherRes of
3143 Left _ -> failM
3144 Right res -> return res
3145 where
3146 start_plugin (HoleFitPluginR init plugin stop) =
3147 do ref <- init
3148 return (plugin ref, stop ref)
3149
3150
3151 runRenamerPlugin :: TcGblEnv
3152 -> HsGroup GhcRn
3153 -> TcM (TcGblEnv, HsGroup GhcRn)
3154 runRenamerPlugin gbl_env hs_group = do
3155 hsc_env <- getTopEnv
3156 withPlugins hsc_env
3157 (\p opts (e, g) -> ( mark_plugin_unsafe (hsc_dflags hsc_env)
3158 >> renamedResultAction p opts e g))
3159 (gbl_env, hs_group)
3160
3161
3162 -- XXX: should this really be a Maybe X? Check under which circumstances this
3163 -- can become a Nothing and decide whether this should instead throw an
3164 -- exception/signal an error.
3165 type RenamedStuff =
3166 (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
3167 Maybe LHsDocString))
3168
3169 -- | Extract the renamed information from TcGblEnv.
3170 getRenamedStuff :: TcGblEnv -> RenamedStuff
3171 getRenamedStuff tc_result
3172 = fmap (\decls -> ( decls, tcg_rn_imports tc_result
3173 , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) )
3174 (tcg_rn_decls tc_result)
3175
3176 runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv
3177 runTypecheckerPlugin sum gbl_env = do
3178 hsc_env <- getTopEnv
3179 withPlugins hsc_env
3180 (\p opts env -> mark_plugin_unsafe (hsc_dflags hsc_env)
3181 >> typeCheckResultAction p opts sum env)
3182 gbl_env
3183
3184 mark_plugin_unsafe :: DynFlags -> TcM ()
3185 mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $
3186 recordUnsafeInfer pluginUnsafe
3187 where
3188 !diag_opts = initDiagOpts dflags
3189 pluginUnsafe =
3190 singleMessage $
3191 mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin