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