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