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