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