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