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