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