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