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