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