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