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