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