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