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