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