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