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