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