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