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