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