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