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