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