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