{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

-- | Typechecking a whole module
--
-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker
module GHC.Tc.Module (
        tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
        tcRnImportDecls,
        tcRnLookupRdrName,
        getModuleInterface,
        tcRnDeclsi,
        isGHCiMonad,
        runTcInteractive,    -- Used by GHC API clients (#8878)
        tcRnLookupName,
        tcRnGetInfo,
        tcRnModule, tcRnModuleTcRnM,
        tcTopSrcDecls,
        rnTopSrcDecls,
        checkBootDecl, checkHiBootIface',
        findExtraSigImports,
        implicitRequirements,
        checkUnit,
        mergeSignatures,
        tcRnMergeSignatures,
        instantiateSignature,
        tcRnInstantiateSignature,
        loadUnqualIfaces,
        -- More private...
        badReexportedBootThing,
        checkBootDeclM,
        missingBootThing,
        getRenamedStuff, RenamedStuff
    ) where

import GHC.Prelude

import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers )
import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
import GHC.Iface.Env     ( externaliseName )
import GHC.Tc.Gen.HsType
import GHC.Tc.Validity( checkValidType )
import GHC.Tc.Gen.Match
import GHC.Tc.Utils.Unify( checkConstraints )
import GHC.Rename.HsType
import GHC.Rename.Expr
import GHC.Rename.Utils  ( HsDocContext(..) )
import GHC.Rename.Fixity ( lookupFixityRn )
import GHC.Builtin.Types ( unitTy, mkListTy )
import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Hs
import GHC.Iface.Syntax ( ShowSub(..), showToHeader )
import GHC.Iface.Type   ( ShowForAllFlag(..) )
import GHC.Core.PatSyn( pprPatSynType )
import GHC.Builtin.Names
import GHC.Builtin.Utils
import GHC.Types.Name.Reader
import GHC.Tc.Utils.Zonk
import GHC.Tc.Gen.Expr
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.Export
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import qualified GHC.Data.BooleanFormula as BF
import GHC.Core.Ppr.TyThing ( pprTyThingInContext )
import GHC.Core.FVs         ( orphNamesOfFamInst )
import GHC.Tc.Instance.Family
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
   ( FamInst, pprFamInst, famInstsRepTyCons
   , famInstEnvElts, extendFamInstEnvList, normaliseType )
import GHC.Tc.Gen.Annotation
import GHC.Tc.Gen.Bind
import GHC.Iface.Make   ( coAxiomToIfaceDecl )
import GHC.Parser.Header       ( mkPrelImports )
import GHC.Tc.Gen.Default
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Rule
import GHC.Tc.Gen.Foreign
import GHC.Tc.TyCl.Instance
import GHC.IfaceToCore
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Solver
import GHC.Tc.TyCl
import GHC.Tc.Instance.Typeable ( mkTypeableBinds )
import GHC.Tc.Utils.Backpack
import GHC.Iface.Load
import GHC.Rename.Names
import GHC.Rename.Env
import GHC.Rename.Module
import GHC.Utils.Error
import GHC.Types.Id as Id
import GHC.Types.Id.Info( IdDetails(..) )
import GHC.Types.Var.Env
import GHC.Unit.Module
import GHC.Types.Unique.FM
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Avail
import GHC.Core.TyCon
import GHC.Types.SrcLoc
import GHC.Driver.Types
import GHC.Data.List.SetOps
import GHC.Utils.Outputable as Outputable
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Core.Class
import GHC.Types.Basic hiding( SuccessFlag(..) )
import GHC.Core.Coercion.Axiom
import GHC.Types.Annotations
import Data.List ( find, sortBy, sort )
import Data.Ord
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Data.Bag
import GHC.Tc.Utils.Instantiate (tcGetInsts)
import qualified GHC.LanguageExtensions as LangExt
import Data.Data ( Data )
import GHC.Hs.Dump
import qualified Data.Set as S

import Control.DeepSeq
import Control.Monad

import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )


#include "HsVersions.h"

{-
************************************************************************
*                                                                      *
        Typecheck and rename a module
*                                                                      *
************************************************************************
-}

-- | Top level entry point for typechecker and renamer
tcRnModule :: HscEnv
           -> ModSummary
           -> Bool              -- True <=> save renamed syntax
           -> HsParsedModule
           -> IO (Messages, Maybe TcGblEnv)

tcRnModule :: HscEnv
-> ModSummary
-> IsBootInterface
-> HsParsedModule
-> IO (Messages, Maybe TcGblEnv)
tcRnModule HscEnv
hsc_env ModSummary
mod_sum IsBootInterface
save_rn_syntax
   parsedModule :: HsParsedModule
parsedModule@HsParsedModule {hpm_module :: HsParsedModule -> Located HsModule
hpm_module= L SrcSpan
loc HsModule
this_module}
 | RealSrcSpan RealSrcSpan
real_loc Maybe BufSpan
_ <- SrcSpan
loc
 = DynFlags
-> SDoc
-> ((Messages, Maybe TcGblEnv) -> ())
-> IO (Messages, Maybe TcGblEnv)
-> IO (Messages, Maybe TcGblEnv)
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
External instance of the constraint type MonadIO IO
withTiming DynFlags
dflags
              (String -> SDoc
text String
"Renamer/typechecker"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Module
ppr Module
this_mod))
              (() -> (Messages, Maybe TcGblEnv) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages, Maybe TcGblEnv) -> IO (Messages, Maybe TcGblEnv))
-> IO (Messages, Maybe TcGblEnv) -> IO (Messages, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
   HscEnv
-> HscSource
-> IsBootInterface
-> Module
-> RealSrcSpan
-> TcM TcGblEnv
-> IO (Messages, Maybe TcGblEnv)
forall r.
HscEnv
-> HscSource
-> IsBootInterface
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
initTc HscEnv
hsc_env HscSource
hsc_src IsBootInterface
save_rn_syntax Module
this_mod RealSrcSpan
real_loc (TcM TcGblEnv -> IO (Messages, Maybe TcGblEnv))
-> TcM TcGblEnv -> IO (Messages, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
          HscEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall a. HscEnv -> TcM a -> TcM a
withTcPlugins HscEnv
hsc_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall a. HscEnv -> TcM a -> TcM a
withHoleFitPlugins HscEnv
hsc_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$

          HscEnv
-> ModSummary
-> HsParsedModule
-> (Module, SrcSpan)
-> TcM TcGblEnv
tcRnModuleTcRnM HscEnv
hsc_env ModSummary
mod_sum HsParsedModule
parsedModule (Module, SrcSpan)
pair

  | IsBootInterface
otherwise
  = (Messages, Maybe TcGblEnv) -> IO (Messages, Maybe TcGblEnv)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return ((Bag WarnMsg
forall a. Bag a
emptyBag, WarnMsg -> Bag WarnMsg
forall a. a -> Bag a
unitBag WarnMsg
err_msg), Maybe TcGblEnv
forall a. Maybe a
Nothing)

  where
    hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_sum
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    err_msg :: WarnMsg
err_msg = DynFlags -> SrcSpan -> SDoc -> WarnMsg
mkPlainErrMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) SrcSpan
loc (SDoc -> WarnMsg) -> SDoc -> WarnMsg
forall a b. (a -> b) -> a -> b
$
              String -> SDoc
text String
"Module does not have a RealSrcSpan:" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Module
ppr Module
this_mod

    this_pkg :: GenUnit UnitId
this_pkg = DynFlags -> GenUnit UnitId
thisPackage (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)

    pair :: (Module, SrcSpan)
    pair :: (Module, SrcSpan)
pair@(Module
this_mod,SrcSpan
_)
      | Just (L SrcSpan
mod_loc ModuleName
mod) <- HsModule -> Maybe (Located ModuleName)
hsmodName HsModule
this_module
      = (GenUnit UnitId -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule GenUnit UnitId
this_pkg ModuleName
mod, SrcSpan
mod_loc)

      | IsBootInterface
otherwise   -- 'module M where' is omitted
      = (Module
mAIN, SrcLoc -> SrcSpan
srcLocSpan (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
loc))




tcRnModuleTcRnM :: HscEnv
                -> ModSummary
                -> HsParsedModule
                -> (Module, SrcSpan)
                -> TcRn TcGblEnv
-- Factored out separately from tcRnModule so that a Core plugin can
-- call the type checker directly
tcRnModuleTcRnM :: HscEnv
-> ModSummary
-> HsParsedModule
-> (Module, SrcSpan)
-> TcM TcGblEnv
tcRnModuleTcRnM HscEnv
hsc_env ModSummary
mod_sum
                (HsParsedModule {
                   hpm_module :: HsParsedModule -> Located HsModule
hpm_module =
                      (L SrcSpan
loc (HsModule Maybe (Located ModuleName)
maybe_mod Maybe (Located [LIE GhcPs])
export_ies
                                       [LImportDecl GhcPs]
import_decls [LHsDecl GhcPs]
local_decls Maybe (Located WarningTxt)
mod_deprec
                                       Maybe LHsDocString
maybe_doc_hdr)),
                   hpm_src_files :: HsParsedModule -> [String]
hpm_src_files = [String]
src_files
                })
                (Module
this_mod, SrcSpan
prel_imp_loc)
 = SrcSpan -> TcM TcGblEnv -> TcM TcGblEnv
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
   do { let { explicit_mod_hdr :: IsBootInterface
explicit_mod_hdr = Maybe (Located ModuleName) -> IsBootInterface
forall a. Maybe a -> IsBootInterface
isJust Maybe (Located ModuleName)
maybe_mod
            ; hsc_src :: HscSource
hsc_src          = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_sum }
      ; -- Load the hi-boot interface for this module, if any
        -- We do this now so that the boot_names can be passed
        -- to tcTyAndClassDecls, because the boot_names are
        -- automatically considered to be loop breakers
        TcGblEnv
tcg_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
      ; SelfBootInfo
boot_info <- HscSource -> Module -> TcRn SelfBootInfo
tcHiBootIface HscSource
hsc_src Module
this_mod
      ; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv (TcGblEnv
tcg_env { tcg_self_boot :: SelfBootInfo
tcg_self_boot = SelfBootInfo
boot_info })
        (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
        { -- Deal with imports; first add implicit prelude
          IsBootInterface
implicit_prelude <- Extension -> TcRnIf TcGblEnv TcLclEnv IsBootInterface
forall gbl lcl. Extension -> TcRnIf gbl lcl IsBootInterface
xoptM Extension
LangExt.ImplicitPrelude
        ; let { prel_imports :: [LImportDecl GhcPs]
prel_imports = ModuleName
-> SrcSpan
-> IsBootInterface
-> [LImportDecl GhcPs]
-> [LImportDecl GhcPs]
mkPrelImports (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod) SrcSpan
prel_imp_loc
                               IsBootInterface
implicit_prelude [LImportDecl GhcPs]
import_decls }

        ; WarningFlag
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnImplicitPrelude (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
             IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when ([LImportDecl GhcPs] -> IsBootInterface
forall a. [a] -> IsBootInterface
notNull [LImportDecl GhcPs]
prel_imports) (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
                WarnReason -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnImplicitPrelude) (SDoc
implicitPreludeWarn)

        ; -- TODO This is a little skeevy; maybe handle a bit more directly
          let { simplifyImport :: GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
simplifyImport (L l
_ ImportDecl pass
idecl) =
                  ( (StringLiteral -> FastString)
-> Maybe StringLiteral -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor Maybe
fmap StringLiteral -> FastString
sl_fs (ImportDecl pass -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl pass
idecl) , ImportDecl pass -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl pass
idecl)
              }
        ; [(Maybe FastString, Located ModuleName)]
raw_sig_imports <- IO [(Maybe FastString, Located ModuleName)]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
External instance of the constraint type forall env. MonadIO (IOEnv env)
liftIO
                             (IO [(Maybe FastString, Located ModuleName)]
 -> IOEnv
      (Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)])
-> IO [(Maybe FastString, Located ModuleName)]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> HscSource
-> ModuleName
-> IO [(Maybe FastString, Located ModuleName)]
findExtraSigImports HscEnv
hsc_env HscSource
hsc_src
                                 (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod)
        ; [(Maybe FastString, Located ModuleName)]
raw_req_imports <- IO [(Maybe FastString, Located ModuleName)]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
External instance of the constraint type forall env. MonadIO (IOEnv env)
liftIO
                             (IO [(Maybe FastString, Located ModuleName)]
 -> IOEnv
      (Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)])
-> IO [(Maybe FastString, Located ModuleName)]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [(Maybe FastString, Located ModuleName)]
-> IO [(Maybe FastString, Located ModuleName)]
implicitRequirements HscEnv
hsc_env
                                ((LImportDecl GhcPs -> (Maybe FastString, Located ModuleName))
-> [LImportDecl GhcPs] -> [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map LImportDecl GhcPs -> (Maybe FastString, Located ModuleName)
forall {l} {pass}.
GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
simplifyImport ([LImportDecl GhcPs]
prel_imports
                                                     [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
import_decls))
        ; let { mkImport :: (Maybe a, GenLocated l ModuleName)
-> Located (ImportDecl (GhcPass p))
mkImport (Maybe a
Nothing, L l
_ ModuleName
mod_name) = ImportDecl (GhcPass p) -> Located (ImportDecl (GhcPass p))
forall e. e -> Located e
noLoc
                (ImportDecl (GhcPass p) -> Located (ImportDecl (GhcPass p)))
-> ImportDecl (GhcPass p) -> Located (ImportDecl (GhcPass p))
forall a b. (a -> b) -> a -> b
$ (ModuleName -> ImportDecl (GhcPass p)
forall (p :: Pass). ModuleName -> ImportDecl (GhcPass p)
simpleImportDecl ModuleName
mod_name)
                  { ideclHiding :: Maybe (IsBootInterface, Located [LIE (GhcPass p)])
ideclHiding = (IsBootInterface, Located [LIE (GhcPass p)])
-> Maybe (IsBootInterface, Located [LIE (GhcPass p)])
forall a. a -> Maybe a
Just (IsBootInterface
False, [LIE (GhcPass p)] -> Located [LIE (GhcPass p)]
forall e. e -> Located e
noLoc [])}
              ; mkImport (Maybe a, GenLocated l ModuleName)
_ = String -> Located (ImportDecl (GhcPass p))
forall a. String -> a
panic String
"mkImport" }
        ; let { all_imports :: [LImportDecl GhcPs]
all_imports = [LImportDecl GhcPs]
prel_imports [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
import_decls
                       [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ ((Maybe FastString, Located ModuleName) -> LImportDecl GhcPs)
-> [(Maybe FastString, Located ModuleName)] -> [LImportDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe FastString, Located ModuleName) -> LImportDecl GhcPs
forall {a} {l} {p :: Pass}.
(Maybe a, GenLocated l ModuleName)
-> Located (ImportDecl (GhcPass p))
mkImport ([(Maybe FastString, Located ModuleName)]
raw_sig_imports [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
forall a. [a] -> [a] -> [a]
++ [(Maybe FastString, Located ModuleName)]
raw_req_imports) }
        ; -- OK now finally rename the imports
          TcGblEnv
tcg_env <- {-# SCC "tcRnImports" #-}
                     HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv
tcRnImports HscEnv
hsc_env [LImportDecl GhcPs]
all_imports

        ; -- If the whole module is warned about or deprecated
          -- (via mod_deprec) record that in tcg_warns. If we do thereby add
          -- a WarnAll, it will override any subsequent deprecations added to tcg_warns
          let { tcg_env1 :: TcGblEnv
tcg_env1 = case Maybe (Located WarningTxt)
mod_deprec of
                             Just (L SrcSpan
_ WarningTxt
txt) ->
                               TcGblEnv
tcg_env {tcg_warns :: Warnings
tcg_warns = WarningTxt -> Warnings
WarnAll WarningTxt
txt}
                             Maybe (Located WarningTxt)
Nothing            -> TcGblEnv
tcg_env
              }
        ; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env1
          (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do { -- Rename and type check the declarations
                 String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn1a" SDoc
empty
               ; TcGblEnv
tcg_env <- if HscSource -> IsBootInterface
isHsBootOrSig HscSource
hsc_src
                            then HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnHsBootDecls HscSource
hsc_src [LHsDecl GhcPs]
local_decls
                            else {-# SCC "tcRnSrcDecls" #-}
                                 IsBootInterface
-> [LHsDecl GhcPs] -> Maybe (Located [LIE GhcPs]) -> TcM TcGblEnv
tcRnSrcDecls IsBootInterface
explicit_mod_hdr [LHsDecl GhcPs]
local_decls Maybe (Located [LIE GhcPs])
export_ies
               ; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env
                 (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do { -- Process the export list
                        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn4a: before exports" SDoc
empty
                      ; TcGblEnv
tcg_env <- IsBootInterface
-> Maybe (Located [LIE GhcPs]) -> TcGblEnv -> TcM TcGblEnv
tcRnExports IsBootInterface
explicit_mod_hdr Maybe (Located [LIE GhcPs])
export_ies
                                     TcGblEnv
tcg_env
                      ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn4b: after exports" SDoc
empty
                      ; -- Compare hi-boot iface (if any) with the real thing
                        -- Must be done after processing the exports
                        TcGblEnv
tcg_env <- TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
checkHiBootIface TcGblEnv
tcg_env SelfBootInfo
boot_info
                      ; -- The new type env is already available to stuff
                        -- slurped from interface files, via
                        -- GHC.Tc.Utils.Env.setGlobalTypeEnv. It's important that this
                        -- includes the stuff in checkHiBootIface,
                        -- because the latter might add new bindings for
                        -- boot_dfuns, which may be mentioned in imported
                        -- unfoldings.

                        -- Don't need to rename the Haddock documentation,
                        -- it's not parsed by GHC anymore.
                        TcGblEnv
tcg_env <- TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TcGblEnv
tcg_env
                                           { tcg_doc_hdr :: Maybe LHsDocString
tcg_doc_hdr = Maybe LHsDocString
maybe_doc_hdr })
                      ; -- Report unused names
                        -- Do this /after/ typeinference, so that when reporting
                        -- a function with no type signature we can give the
                        -- inferred type
                        TcGblEnv -> TcRnIf TcGblEnv TcLclEnv ()
reportUnusedNames TcGblEnv
tcg_env
                      ; -- add extra source files to tcg_dependent_files
                        [String] -> TcRnIf TcGblEnv TcLclEnv ()
addDependentFiles [String]
src_files
                      ; TcGblEnv
tcg_env <- ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv
runTypecheckerPlugin ModSummary
mod_sum HscEnv
hsc_env TcGblEnv
tcg_env
                      ; -- Dump output and return
                        TcGblEnv -> TcRnIf TcGblEnv TcLclEnv ()
tcDump TcGblEnv
tcg_env
                      ; TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return TcGblEnv
tcg_env }
               }
        }
      }

implicitPreludeWarn :: SDoc
implicitPreludeWarn :: SDoc
implicitPreludeWarn
  = String -> SDoc
text String
"Module `Prelude' implicitly imported"

{-
************************************************************************
*                                                                      *
                Import declarations
*                                                                      *
************************************************************************
-}

tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv
tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv
tcRnImports HscEnv
hsc_env [LImportDecl GhcPs]
import_decls
  = do  { ([LImportDecl (GhcPass 'Renamed)]
rn_imports, GlobalRdrEnv
rdr_env, ImportAvails
imports, IsBootInterface
hpc_info) <- [LImportDecl GhcPs]
-> RnM
     ([LImportDecl (GhcPass 'Renamed)], GlobalRdrEnv, ImportAvails,
      IsBootInterface)
rnImports [LImportDecl GhcPs]
import_decls ;

        ; Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
External instance of the constraint type forall env. ContainsModule env => HasModule (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsModule gbl => ContainsModule (Env gbl lcl)
External instance of the constraint type ContainsModule TcGblEnv
getModule
        ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
              ; dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
dep_mods = ImportAvails -> ModuleNameEnv (ModuleName, IsBootInterface)
imp_dep_mods ImportAvails
imports

                -- We want instance declarations from all home-package
                -- modules below this one, including boot modules, except
                -- ourselves.  The 'except ourselves' is so that we don't
                -- get the instances from this module's hs-boot file.  This
                -- filtering also ensures that we don't see instances from
                -- modules batch (@--make@) compiled before this one, but
                -- which are not below this one.
              ; want_instances :: ModuleName -> Bool
              ; want_instances :: ModuleName -> IsBootInterface
want_instances ModuleName
mod = ModuleName
mod ModuleName
-> ModuleNameEnv (ModuleName, IsBootInterface) -> IsBootInterface
forall key elt.
Uniquable key =>
key -> UniqFM elt -> IsBootInterface
External instance of the constraint type Uniquable ModuleName
`elemUFM` ModuleNameEnv (ModuleName, IsBootInterface)
dep_mods
                                   IsBootInterface -> IsBootInterface -> IsBootInterface
&& ModuleName
mod ModuleName -> ModuleName -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq ModuleName
/= Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod
              ; ([ClsInst]
home_insts, [FamInst]
home_fam_insts) = HscEnv -> (ModuleName -> IsBootInterface) -> ([ClsInst], [FamInst])
hptInstances HscEnv
hsc_env
                                                            ModuleName -> IsBootInterface
want_instances
              } ;

                -- Record boot-file info in the EPS, so that it's
                -- visible to loadHiBootInterface in tcRnSrcDecls,
                -- and any other incrementally-performed imports
        ; (ExternalPackageState -> ExternalPackageState)
-> TcRnIf TcGblEnv TcLclEnv ()
forall gbl lcl.
(ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ (\ExternalPackageState
eps -> ExternalPackageState
eps { eps_is_boot :: ModuleNameEnv (ModuleName, IsBootInterface)
eps_is_boot = ModuleNameEnv (ModuleName, IsBootInterface)
dep_mods }) ;

                -- Update the gbl env
        ; (TcGblEnv -> TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv ( \ TcGblEnv
gbl ->
            TcGblEnv
gbl {
              tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env      = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
gbl GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
`plusGlobalRdrEnv` GlobalRdrEnv
rdr_env,
              tcg_imports :: ImportAvails
tcg_imports      = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
gbl ImportAvails -> ImportAvails -> ImportAvails
`plusImportAvails` ImportAvails
imports,
              tcg_rn_imports :: [LImportDecl (GhcPass 'Renamed)]
tcg_rn_imports   = [LImportDecl (GhcPass 'Renamed)]
rn_imports,
              tcg_inst_env :: InstEnv
tcg_inst_env     = InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList (TcGblEnv -> InstEnv
tcg_inst_env TcGblEnv
gbl) [ClsInst]
home_insts,
              tcg_fam_inst_env :: FamInstEnv
tcg_fam_inst_env = FamInstEnv -> [FamInst] -> FamInstEnv
extendFamInstEnvList (TcGblEnv -> FamInstEnv
tcg_fam_inst_env TcGblEnv
gbl)
                                                      [FamInst]
home_fam_insts,
              tcg_hpc :: IsBootInterface
tcg_hpc          = IsBootInterface
hpc_info
            }) (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {

        ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn1" (ModuleNameEnv (ModuleName, IsBootInterface) -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable (UniqFM a)
External instance of the constraint type forall a b. (Outputable a, Outputable b) => Outputable (a, b)
External instance of the constraint type Outputable ModuleName
External instance of the constraint type Outputable IsBootInterface
ppr (ImportAvails -> ModuleNameEnv (ModuleName, IsBootInterface)
imp_dep_mods ImportAvails
imports))
                -- Fail if there are any errors so far
                -- The error printing (if needed) takes advantage
                -- of the tcg_env we have now set
--      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
        ; TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM

                -- Load any orphan-module (including orphan family
                -- instance-module) interfaces, so that their rules and
                -- instance decls will be found.  But filter out a
                -- self hs-boot: these instances will be checked when
                -- we define them locally.
                -- (We don't need to load non-orphan family instance
                -- modules until we either try to use the instances they
                -- define, or define our own family instances, at which
                -- point we need to check them for consistency.)
        ; SDoc -> [Module] -> TcRnIf TcGblEnv TcLclEnv ()
loadModuleInterfaces (String -> SDoc
text String
"Loading orphan modules")
                               ((Module -> IsBootInterface) -> [Module] -> [Module]
forall a. (a -> IsBootInterface) -> [a] -> [a]
filter (Module -> Module -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type forall unit. Eq unit => Eq (GenModule unit)
External instance of the constraint type Eq (GenUnit UnitId)
/= Module
this_mod) (ImportAvails -> [Module]
imp_orphs ImportAvails
imports))

                -- Check type-family consistency between imports.
                -- See Note [The type family instance consistency story]
        ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn1: checking family instance consistency {" SDoc
empty
        ; let { dir_imp_mods :: [Module]
dir_imp_mods = ModuleEnv [ImportedBy] -> [Module]
forall a. ModuleEnv a -> [Module]
moduleEnvKeys
                             (ModuleEnv [ImportedBy] -> [Module])
-> (ImportAvails -> ModuleEnv [ImportedBy])
-> ImportAvails
-> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportAvails -> ModuleEnv [ImportedBy]
imp_mods
                             (ImportAvails -> [Module]) -> ImportAvails -> [Module]
forall a b. (a -> b) -> a -> b
$ ImportAvails
imports }
        ; [Module] -> TcRnIf TcGblEnv TcLclEnv ()
checkFamInstConsistency [Module]
dir_imp_mods
        ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn1: } checking family instance consistency" SDoc
empty

        ; TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv } }

{-
************************************************************************
*                                                                      *
        Type-checking the top level of a module
*                                                                      *
************************************************************************
-}

tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
             -> [LHsDecl GhcPs]               -- Declarations
             -> Maybe (Located [LIE GhcPs])
             -> TcM TcGblEnv
tcRnSrcDecls :: IsBootInterface
-> [LHsDecl GhcPs] -> Maybe (Located [LIE GhcPs]) -> TcM TcGblEnv
tcRnSrcDecls IsBootInterface
explicit_mod_hdr [LHsDecl GhcPs]
decls Maybe (Located [LIE GhcPs])
export_ies
 = do { -- Do all the declarations
      ; (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie) <- [LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls [LHsDecl GhcPs]
decls

        -- Check for the 'main' declaration
        -- Must do this inside the captureTopConstraints
        -- NB: always set envs *before* captureTopConstraints
      ; (TcGblEnv
tcg_env, WantedConstraints
lie_main) <- (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
 -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                               TcM TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM TcGblEnv
 -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints))
-> TcM TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                               IsBootInterface -> Maybe (Located [LIE GhcPs]) -> TcM TcGblEnv
checkMain IsBootInterface
explicit_mod_hdr Maybe (Located [LIE GhcPs])
export_ies

      ; (TcGblEnv, TcLclEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {

             --         Simplify constraints
             --
             -- We do this after checkMain, so that we use the type info
             -- that checkMain adds
             --
             -- We do it with both global and local env in scope:
             --  * the global env exposes the instances to simplifyTop
             --  * the local env exposes the local Ids to simplifyTop,
             --    so that we get better error messages (monomorphism restriction)
      ; Bag EvBind
new_ev_binds <- {-# SCC "simplifyTop" #-}
                        WantedConstraints -> TcM (Bag EvBind)
simplifyTop (WantedConstraints
lie WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
lie_main)

        -- Emit Typeable bindings
      ; TcGblEnv
tcg_env <- TcM TcGblEnv
mkTypeableBinds


      ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc9" SDoc
empty

      ; TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM     -- Don't zonk if there have been errors
                        -- It's a waste of time; and we may get debug warnings
                        -- about strangely-typed TyCons!
      ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc10" SDoc
empty

        -- Zonk the final code.  This must be done last.
        -- Even simplifyTop may do some unification.
        -- This pass also warns about missing type signatures
      ; (TypeEnv
bind_env, Bag EvBind
ev_binds', LHsBinds GhcTc
binds', [LForeignDecl GhcTc]
fords', [LTcSpecPrag]
imp_specs', [LRuleDecl GhcTc]
rules')
            <- Bag EvBind
-> TcGblEnv
-> TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv Bag EvBind
new_ev_binds TcGblEnv
tcg_env

        -- Finalizers must run after constraints are simplified, or some types
        -- might not be complete when using reify (see #12777).
        -- and also after we zonk the first time because we run typed splices
        -- in the zonker which gives rise to the finalisers.
      ; (TcGblEnv
tcg_env_mf, TcLclEnv
_) <- TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv (TcGblEnv -> TcGblEnv
clearTcGblEnv TcGblEnv
tcg_env)
                                     TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
run_th_modfinalizers
      ; TcRnIf TcGblEnv TcLclEnv ()
finishTH
      ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc11" SDoc
empty

      ; -- zonk the new bindings arising from running the finalisers.
        -- This won't give rise to any more finalisers as you can't nest
        -- finalisers inside finalisers.
      ; (TypeEnv
bind_env_mf, Bag EvBind
ev_binds_mf, LHsBinds GhcTc
binds_mf, [LForeignDecl GhcTc]
fords_mf, [LTcSpecPrag]
imp_specs_mf, [LRuleDecl GhcTc]
rules_mf)
            <- Bag EvBind
-> TcGblEnv
-> TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv Bag EvBind
forall a. Bag a
emptyBag TcGblEnv
tcg_env_mf


      ; let { final_type_env :: TypeEnv
final_type_env = TypeEnv -> TypeEnv -> TypeEnv
plusTypeEnv (TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
tcg_env)
                                (TypeEnv -> TypeEnv -> TypeEnv
plusTypeEnv TypeEnv
bind_env_mf TypeEnv
bind_env)
            ; tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env_mf
                          { tcg_binds :: LHsBinds GhcTc
tcg_binds    = LHsBinds GhcTc
binds' LHsBinds GhcTc -> LHsBinds GhcTc -> LHsBinds GhcTc
forall a. Bag a -> Bag a -> Bag a
`unionBags` LHsBinds GhcTc
binds_mf,
                            tcg_ev_binds :: Bag EvBind
tcg_ev_binds = Bag EvBind
ev_binds' Bag EvBind -> Bag EvBind -> Bag EvBind
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag EvBind
ev_binds_mf ,
                            tcg_imp_specs :: [LTcSpecPrag]
tcg_imp_specs = [LTcSpecPrag]
imp_specs' [LTcSpecPrag] -> [LTcSpecPrag] -> [LTcSpecPrag]
forall a. [a] -> [a] -> [a]
++ [LTcSpecPrag]
imp_specs_mf ,
                            tcg_rules :: [LRuleDecl GhcTc]
tcg_rules    = [LRuleDecl GhcTc]
rules' [LRuleDecl GhcTc] -> [LRuleDecl GhcTc] -> [LRuleDecl GhcTc]
forall a. [a] -> [a] -> [a]
++ [LRuleDecl GhcTc]
rules_mf ,
                            tcg_fords :: [LForeignDecl GhcTc]
tcg_fords    = [LForeignDecl GhcTc]
fords' [LForeignDecl GhcTc]
-> [LForeignDecl GhcTc] -> [LForeignDecl GhcTc]
forall a. [a] -> [a] -> [a]
++ [LForeignDecl GhcTc]
fords_mf } } ;

      ; TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv TcGblEnv
tcg_env' TypeEnv
final_type_env

   } }

zonkTcGblEnv :: Bag EvBind -> TcGblEnv
             -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
                       [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv :: Bag EvBind
-> TcGblEnv
-> TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv Bag EvBind
new_ev_binds TcGblEnv
tcg_env =
  let TcGblEnv {   tcg_binds :: TcGblEnv -> LHsBinds GhcTc
tcg_binds     = LHsBinds GhcTc
binds,
                   tcg_ev_binds :: TcGblEnv -> Bag EvBind
tcg_ev_binds  = Bag EvBind
cur_ev_binds,
                   tcg_imp_specs :: TcGblEnv -> [LTcSpecPrag]
tcg_imp_specs = [LTcSpecPrag]
imp_specs,
                   tcg_rules :: TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules     = [LRuleDecl GhcTc]
rules,
                   tcg_fords :: TcGblEnv -> [LForeignDecl GhcTc]
tcg_fords     = [LForeignDecl GhcTc]
fords } = TcGblEnv
tcg_env

      all_ev_binds :: Bag EvBind
all_ev_binds = Bag EvBind
cur_ev_binds Bag EvBind -> Bag EvBind -> Bag EvBind
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag EvBind
new_ev_binds

  in {-# SCC "zonkTopDecls" #-}
      Bag EvBind
-> LHsBinds GhcTc
-> [LRuleDecl GhcTc]
-> [LTcSpecPrag]
-> [LForeignDecl GhcTc]
-> TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
zonkTopDecls Bag EvBind
all_ev_binds LHsBinds GhcTc
binds [LRuleDecl GhcTc]
rules [LTcSpecPrag]
imp_specs [LForeignDecl GhcTc]
fords


-- | Remove accumulated bindings, rules and so on from TcGblEnv
clearTcGblEnv :: TcGblEnv -> TcGblEnv
clearTcGblEnv :: TcGblEnv -> TcGblEnv
clearTcGblEnv TcGblEnv
tcg_env
  = TcGblEnv
tcg_env { tcg_binds :: LHsBinds GhcTc
tcg_binds    = LHsBinds GhcTc
forall a. Bag a
emptyBag,
              tcg_ev_binds :: Bag EvBind
tcg_ev_binds = Bag EvBind
forall a. Bag a
emptyBag ,
              tcg_imp_specs :: [LTcSpecPrag]
tcg_imp_specs = [],
              tcg_rules :: [LRuleDecl GhcTc]
tcg_rules    = [],
              tcg_fords :: [LForeignDecl GhcTc]
tcg_fords    = [] }

-- | Runs TH finalizers and renames and typechecks the top-level declarations
-- that they could introduce.
run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
run_th_modfinalizers :: TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
run_th_modfinalizers = do
  TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- (TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)])
-> TcM TcGblEnv
-> IOEnv
     (Env TcGblEnv TcLclEnv) (TcRef [(TcLclEnv, ThModFinalizers)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
fmap TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)]
tcg_th_modfinalizers TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  [(TcLclEnv, ThModFinalizers)]
th_modfinalizers <- TcRef [(TcLclEnv, ThModFinalizers)]
-> TcRnIf TcGblEnv TcLclEnv [(TcLclEnv, ThModFinalizers)]
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var
  if [(TcLclEnv, ThModFinalizers)] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [(TcLclEnv, ThModFinalizers)]
th_modfinalizers
  then TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs
  else do
    TcRef [(TcLclEnv, ThModFinalizers)]
-> [(TcLclEnv, ThModFinalizers)] -> TcRnIf TcGblEnv TcLclEnv ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var []
    let run_finalizer :: (TcLclEnv, ThModFinalizers) -> TcRnIf TcGblEnv lcl ()
run_finalizer (TcLclEnv
lcl_env, ThModFinalizers
f) =
            TcLclEnv -> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv lcl ()
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv TcLclEnv
lcl_env (ThModFinalizers -> TcRnIf TcGblEnv TcLclEnv ()
runRemoteModFinalizers ThModFinalizers
f)

    (()
_, WantedConstraints
lie_th) <- TcRnIf TcGblEnv TcLclEnv () -> TcM ((), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcRnIf TcGblEnv TcLclEnv () -> TcM ((), WantedConstraints))
-> TcRnIf TcGblEnv TcLclEnv () -> TcM ((), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                   ((TcLclEnv, ThModFinalizers) -> TcRnIf TcGblEnv TcLclEnv ())
-> [(TcLclEnv, ThModFinalizers)] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
mapM_ (TcLclEnv, ThModFinalizers) -> TcRnIf TcGblEnv TcLclEnv ()
forall {lcl}. (TcLclEnv, ThModFinalizers) -> TcRnIf TcGblEnv lcl ()
run_finalizer [(TcLclEnv, ThModFinalizers)]
th_modfinalizers

      -- Finalizers can add top-level declarations with addTopDecls, so
      -- we have to run tc_rn_src_decls to get them
    (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie_top_decls) <- [LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls []

    (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
 -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do
      -- Subsequent rounds of finalizers run after any new constraints are
      -- simplified, or some types might not be complete when using reify
      -- (see #12777).
      Bag EvBind
new_ev_binds <- {-# SCC "simplifyTop2" #-}
                      WantedConstraints -> TcM (Bag EvBind)
simplifyTop (WantedConstraints
lie_th WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
lie_top_decls)
      Bag EvBind
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. Bag EvBind -> TcM a -> TcM a
addTopEvBinds Bag EvBind
new_ev_binds TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
run_th_modfinalizers
        -- addTopDecls can add declarations which add new finalizers.

tc_rn_src_decls :: [LHsDecl GhcPs]
                -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-- Loops around dealing with each top level inter-splice group
-- in turn, until it's dealt with the entire module
-- Never emits constraints; calls captureTopConstraints internally
tc_rn_src_decls :: [LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls [LHsDecl GhcPs]
ds
 = {-# SCC "tc_rn_src_decls" #-}
   do { (HsGroup GhcPs
first_group, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
group_tail) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
ds
                -- If ds is [] we get ([], Nothing)

        -- Deal with decls up to, but not including, the first splice
      ; (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls) <- HsGroup GhcPs -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
rnTopSrcDecls HsGroup GhcPs
first_group
                -- rnTopSrcDecls fails if there are any errors

        -- Get TH-generated top-level declarations and make sure they don't
        -- contain any splices since we don't handle that at the moment
        --
        -- The plumbing here is a bit odd: see #10853
      ; TcRef [LHsDecl GhcPs]
th_topdecls_var <- (TcGblEnv -> TcRef [LHsDecl GhcPs])
-> TcM TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (TcRef [LHsDecl GhcPs])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
fmap TcGblEnv -> TcRef [LHsDecl GhcPs]
tcg_th_topdecls TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
      ; [LHsDecl GhcPs]
th_ds <- TcRef [LHsDecl GhcPs] -> TcRnIf TcGblEnv TcLclEnv [LHsDecl GhcPs]
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef [LHsDecl GhcPs]
th_topdecls_var
      ; TcRef [LHsDecl GhcPs]
-> [LHsDecl GhcPs] -> TcRnIf TcGblEnv TcLclEnv ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef [LHsDecl GhcPs]
th_topdecls_var []

      ; (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls) <-
            if [LHsDecl GhcPs] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [LHsDecl GhcPs]
th_ds
            then (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls)
            else do { (HsGroup GhcPs
th_group, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
th_group_tail) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
th_ds
                    ; case Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
th_group_tail of
                        { Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
Nothing -> () -> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ()
                        ; Just (SpliceDecl XSpliceDecl GhcPs
_ (L SrcSpan
loc HsSplice GhcPs
_) SpliceExplicitFlag
_, [LHsDecl GhcPs]
_) ->
                            SrcSpan
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc
                            (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErr (String -> SDoc
text
                                (String
"Declaration splices are not "
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"permitted inside top-level "
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"declarations added with addTopDecls"))
                        }
                      -- Rename TH-generated top-level declarations
                    ; (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
th_rn_decls) <- TcGblEnv
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env
                        (TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
 -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed)))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ HsGroup GhcPs -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
rnTopSrcDecls HsGroup GhcPs
th_group

                      -- Dump generated top-level declarations
                    ; let msg :: String
msg = String
"top-level declarations added with addTopDecls"
                    ; SpliceInfo -> TcRnIf TcGblEnv TcLclEnv ()
traceSplice
                        (SpliceInfo -> TcRnIf TcGblEnv TcLclEnv ())
-> SpliceInfo -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ SpliceInfo :: String
-> Maybe (Located (HsExpr (GhcPass 'Renamed)))
-> IsBootInterface
-> SDoc
-> SpliceInfo
SpliceInfo { spliceDescription :: String
spliceDescription = String
msg
                                     , spliceIsDecl :: IsBootInterface
spliceIsDecl    = IsBootInterface
True
                                     , spliceSource :: Maybe (Located (HsExpr (GhcPass 'Renamed)))
spliceSource    = Maybe (Located (HsExpr (GhcPass 'Renamed)))
forall a. Maybe a
Nothing
                                     , spliceGenerated :: SDoc
spliceGenerated = HsGroup (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsGroup (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
ppr HsGroup (GhcPass 'Renamed)
th_rn_decls }
                    ; (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
-> HsGroup (GhcPass 'Renamed) -> HsGroup (GhcPass 'Renamed)
forall (p :: Pass).
HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p)
appendGroups HsGroup (GhcPass 'Renamed)
rn_decls HsGroup (GhcPass 'Renamed)
th_rn_decls)
                    }

      -- Type check all declarations
      -- NB: set the env **before** captureTopConstraints so that error messages
      -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that
      -- the captureTopConstraints must go here, not in tcRnSrcDecls.
      ; ((TcGblEnv
tcg_env, TcLclEnv
tcl_env), WantedConstraints
lie1) <- TcGblEnv
-> TcRnIf
     TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
-> TcRnIf
     TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcRnIf TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
 -> TcRnIf
      TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints))
-> TcRnIf
     TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
-> TcRnIf
     TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                                      TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf
     TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
 -> TcRnIf
      TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf
     TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                                      HsGroup (GhcPass 'Renamed)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopSrcDecls HsGroup (GhcPass 'Renamed)
rn_decls

        -- If there is no splice, we're nearly done
      ; (TcGblEnv, TcLclEnv)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcM (TcGblEnv, TcLclEnv, WantedConstraints)
 -> TcM (TcGblEnv, TcLclEnv, WantedConstraints))
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
        case Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
group_tail of
          { Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
Nothing -> (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie1)

            -- If there's a splice, we must carry on
          ; Just (SpliceDecl XSpliceDecl GhcPs
_ (L SrcSpan
_ HsSplice GhcPs
splice) SpliceExplicitFlag
_, [LHsDecl GhcPs]
rest_ds) ->
            do {
                 -- We need to simplify any constraints from the previous declaration
                 -- group, or else we might reify metavariables, as in #16980.
               ; Bag EvBind
ev_binds1 <- WantedConstraints -> TcM (Bag EvBind)
simplifyTop WantedConstraints
lie1

                 -- Rename the splice expression, and get its supporting decls
               ; ([LHsDecl GhcPs]
spliced_decls, FreeVars
splice_fvs) <- HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls HsSplice GhcPs
splice

                 -- Glue them on the front of the remaining decls and loop
               ; (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie2) <-
                   TcGblEnv
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv (TcGblEnv
tcg_env TcGblEnv -> DefUses -> TcGblEnv
`addTcgDUs` FreeVars -> DefUses
usesOnly FreeVars
splice_fvs) (TcM (TcGblEnv, TcLclEnv, WantedConstraints)
 -> TcM (TcGblEnv, TcLclEnv, WantedConstraints))
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                   Bag EvBind
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a. Bag EvBind -> TcM a -> TcM a
addTopEvBinds Bag EvBind
ev_binds1 (TcM (TcGblEnv, TcLclEnv, WantedConstraints)
 -> TcM (TcGblEnv, TcLclEnv, WantedConstraints))
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                   [LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls ([LHsDecl GhcPs]
spliced_decls [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
rest_ds)

               ; (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie2)
               }
          }
      }

{-
************************************************************************
*                                                                      *
        Compiling hs-boot source files, and
        comparing the hi-boot interface with the real thing
*                                                                      *
************************************************************************
-}

tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnHsBootDecls HscSource
hsc_src [LHsDecl GhcPs]
decls
   = do { (HsGroup GhcPs
first_group, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
group_tail) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
decls

                -- Rename the declarations
        ; (TcGblEnv
tcg_env, HsGroup { hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup (GhcPass 'Renamed)]
tycl_decls
                            , hs_derivds :: forall p. HsGroup p -> [LDerivDecl p]
hs_derivds = [LDerivDecl (GhcPass 'Renamed)]
deriv_decls
                            , hs_fords :: forall p. HsGroup p -> [LForeignDecl p]
hs_fords  = [LForeignDecl (GhcPass 'Renamed)]
for_decls
                            , hs_defds :: forall p. HsGroup p -> [LDefaultDecl p]
hs_defds  = [LDefaultDecl (GhcPass 'Renamed)]
def_decls
                            , hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds = [LRuleDecls (GhcPass 'Renamed)]
rule_decls
                            , hs_annds :: forall p. HsGroup p -> [LAnnDecl p]
hs_annds  = [LAnnDecl (GhcPass 'Renamed)]
_
                            , hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds  = XValBindsLR (NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds [LSig (GhcPass 'Renamed)]
val_sigs) })
              <- HsGroup GhcPs -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
rnTopSrcDecls HsGroup GhcPs
first_group

        -- The empty list is for extra dependencies coming from .hs-boot files
        -- See Note [Extra dependencies from .hs-boot files] in GHC.Rename.Module

        ; (TcGblEnv
gbl_env, WantedConstraints
lie) <- TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
 -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$ TcM TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM TcGblEnv
 -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints))
-> TcM TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$ do {
              -- NB: setGblEnv **before** captureTopConstraints so that
              -- if the latter reports errors, it knows what's in scope

                -- Check for illegal declarations
        ; case Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
group_tail of
             Just (SpliceDecl XSpliceDecl GhcPs
_ GenLocated SrcSpan (HsSplice GhcPs)
d SpliceExplicitFlag
_, [LHsDecl GhcPs]
_) -> HscSource
-> String
-> GenLocated SrcSpan (HsSplice GhcPs)
-> TcRnIf TcGblEnv TcLclEnv ()
forall decl.
HscSource -> String -> Located decl -> TcRnIf TcGblEnv TcLclEnv ()
badBootDecl HscSource
hsc_src String
"splice" GenLocated SrcSpan (HsSplice GhcPs)
d
             Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
Nothing                    -> () -> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ()
        ; (LForeignDecl (GhcPass 'Renamed) -> TcRnIf TcGblEnv TcLclEnv ())
-> [LForeignDecl (GhcPass 'Renamed)] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
mapM_ (HscSource
-> String
-> LForeignDecl (GhcPass 'Renamed)
-> TcRnIf TcGblEnv TcLclEnv ()
forall decl.
HscSource -> String -> Located decl -> TcRnIf TcGblEnv TcLclEnv ()
badBootDecl HscSource
hsc_src String
"foreign") [LForeignDecl (GhcPass 'Renamed)]
for_decls
        ; (LDefaultDecl (GhcPass 'Renamed) -> TcRnIf TcGblEnv TcLclEnv ())
-> [LDefaultDecl (GhcPass 'Renamed)] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
mapM_ (HscSource
-> String
-> LDefaultDecl (GhcPass 'Renamed)
-> TcRnIf TcGblEnv TcLclEnv ()
forall decl.
HscSource -> String -> Located decl -> TcRnIf TcGblEnv TcLclEnv ()
badBootDecl HscSource
hsc_src String
"default") [LDefaultDecl (GhcPass 'Renamed)]
def_decls
        ; (LRuleDecls (GhcPass 'Renamed) -> TcRnIf TcGblEnv TcLclEnv ())
-> [LRuleDecls (GhcPass 'Renamed)] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
mapM_ (HscSource
-> String
-> LRuleDecls (GhcPass 'Renamed)
-> TcRnIf TcGblEnv TcLclEnv ()
forall decl.
HscSource -> String -> Located decl -> TcRnIf TcGblEnv TcLclEnv ()
badBootDecl HscSource
hsc_src String
"rule")    [LRuleDecls (GhcPass 'Renamed)]
rule_decls

                -- Typecheck type/class/instance decls
        ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc2 (boot)" SDoc
empty
        ; (TcGblEnv
tcg_env, [InstInfo (GhcPass 'Renamed)]
inst_infos, HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
_deriv_binds)
             <- [TyClGroup (GhcPass 'Renamed)]
-> [LDerivDecl (GhcPass 'Renamed)]
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
tcTyClsInstDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls [LDerivDecl (GhcPass 'Renamed)]
deriv_decls [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds
        ; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env     (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {

        -- Emit Typeable bindings
        ; TcGblEnv
tcg_env <- TcM TcGblEnv
mkTypeableBinds
        ; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {

                -- Typecheck value declarations
        ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc5" SDoc
empty
        ; [Var]
val_ids <- [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)] -> TcM [Var]
tcHsBootSigs [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds [LSig (GhcPass 'Renamed)]
val_sigs

                -- Wrap up
                -- No simplification or zonking to do
        ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc7a" SDoc
empty
        ; TcGblEnv
gbl_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

                -- Make the final type-env
                -- Include the dfun_ids so that their type sigs
                -- are written into the interface file.
        ; let { type_env0 :: TypeEnv
type_env0 = TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
gbl_env
              ; type_env1 :: TypeEnv
type_env1 = TypeEnv -> [Var] -> TypeEnv
extendTypeEnvWithIds TypeEnv
type_env0 [Var]
val_ids
              ; type_env2 :: TypeEnv
type_env2 = TypeEnv -> [Var] -> TypeEnv
extendTypeEnvWithIds TypeEnv
type_env1 [Var]
dfun_ids
              ; dfun_ids :: [Var]
dfun_ids = (InstInfo (GhcPass 'Renamed) -> Var)
-> [InstInfo (GhcPass 'Renamed)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map InstInfo (GhcPass 'Renamed) -> Var
forall a. InstInfo a -> Var
iDFunId [InstInfo (GhcPass 'Renamed)]
inst_infos
              }

        ; TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv TcGblEnv
gbl_env TypeEnv
type_env2
   }}}
   ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"boot" (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable WantedConstraints
ppr WantedConstraints
lie); TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return TcGblEnv
gbl_env }

badBootDecl :: HscSource -> String -> Located decl -> TcM ()
badBootDecl :: HscSource -> String -> Located decl -> TcRnIf TcGblEnv TcLclEnv ()
badBootDecl HscSource
hsc_src String
what (L SrcSpan
loc decl
_)
  = SrcSpan -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrAt SrcSpan
loc (Char -> SDoc
char Char
'A' SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
what
      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"declaration is not (currently) allowed in a"
      SDoc -> SDoc -> SDoc
<+> (case HscSource
hsc_src of
            HscSource
HsBootFile -> String -> SDoc
text String
"hs-boot"
            HscSource
HsigFile -> String -> SDoc
text String
"hsig"
            HscSource
_ -> String -> SDoc
forall a. String -> a
panic String
"badBootDecl: should be an hsig or hs-boot file")
      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"file")

{-
Once we've typechecked the body of the module, we want to compare what
we've found (gathered in a TypeEnv) with the hi-boot details (if any).
-}

checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
-- In the common case where there is no hi-boot file, the list
-- of boot_names is empty.

checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
checkHiBootIface TcGblEnv
tcg_env SelfBootInfo
boot_info
  | SelfBootInfo
NoSelfBoot <- SelfBootInfo
boot_info  -- Common case
  = TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return TcGblEnv
tcg_env

  | HscSource
HsBootFile <- TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env   -- Current module is already a hs-boot file!
  = TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return TcGblEnv
tcg_env

  | SelfBoot { sb_mds :: SelfBootInfo -> ModDetails
sb_mds = ModDetails
boot_details } <- SelfBootInfo
boot_info
  , TcGblEnv { tcg_binds :: TcGblEnv -> LHsBinds GhcTc
tcg_binds    = LHsBinds GhcTc
binds
             , tcg_insts :: TcGblEnv -> [ClsInst]
tcg_insts    = [ClsInst]
local_insts
             , tcg_type_env :: TcGblEnv -> TypeEnv
tcg_type_env = TypeEnv
local_type_env
             , tcg_exports :: TcGblEnv -> [AvailInfo]
tcg_exports  = [AvailInfo]
local_exports } <- TcGblEnv
tcg_env
  = do  { -- This code is tricky, see Note [DFun knot-tying]
        ; [(Var, Var)]
dfun_prs <- [ClsInst]
-> TypeEnv -> [AvailInfo] -> ModDetails -> TcM [(Var, Var)]
checkHiBootIface' [ClsInst]
local_insts TypeEnv
local_type_env
                                        [AvailInfo]
local_exports ModDetails
boot_details

        -- Now add the boot-dfun bindings  $fxblah = $fblah
        -- to (a) the type envt, and (b) the top-level bindings
        ; let boot_dfuns :: [Var]
boot_dfuns = ((Var, Var) -> Var) -> [(Var, Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Var) -> Var
forall a b. (a, b) -> a
fst [(Var, Var)]
dfun_prs
              type_env' :: TypeEnv
type_env'  = TypeEnv -> [Var] -> TypeEnv
extendTypeEnvWithIds TypeEnv
local_type_env [Var]
boot_dfuns
              dfun_binds :: LHsBinds GhcTc
dfun_binds = [GenLocated SrcSpan (HsBindLR GhcTc GhcTc)] -> LHsBinds GhcTc
forall a. [a] -> Bag a
listToBag [ IdP GhcTc
-> LHsExpr GhcTc -> GenLocated SrcSpan (HsBindLR GhcTc GhcTc)
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Var
IdP GhcTc
boot_dfun (IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Var
IdP GhcTc
dfun)
                                     | (Var
boot_dfun, Var
dfun) <- [(Var, Var)]
dfun_prs ]
              tcg_env_w_binds :: TcGblEnv
tcg_env_w_binds
                = TcGblEnv
tcg_env { tcg_binds :: LHsBinds GhcTc
tcg_binds = LHsBinds GhcTc
binds LHsBinds GhcTc -> LHsBinds GhcTc -> LHsBinds GhcTc
forall a. Bag a -> Bag a -> Bag a
`unionBags` LHsBinds GhcTc
dfun_binds }

        ; TypeEnv
type_env' TypeEnv -> TcM TcGblEnv -> TcM TcGblEnv
`seq`
             -- Why the seq?  Without, we will put a TypeEnv thunk in
             -- tcg_type_env_var.  That thunk will eventually get
             -- forced if we are typechecking interfaces, but that
             -- is no good if we are trying to typecheck the very
             -- DFun we were going to put in.
             -- TODO: Maybe setGlobalTypeEnv should be strict.
          TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv TcGblEnv
tcg_env_w_binds TypeEnv
type_env' }

#if __GLASGOW_HASKELL__ <= 810
  | otherwise = panic "checkHiBootIface: unreachable code"
#endif

{- Note [DFun impedance matching]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We return a list of "impedance-matching" bindings for the dfuns
defined in the hs-boot file, such as
          $fxEqT = $fEqT
We need these because the module and hi-boot file might differ in
the name it chose for the dfun: the name of a dfun is not
uniquely determined by its type; there might be multiple dfuns
which, individually, would map to the same name (in which case
we have to disambiguate them.)  There's no way for the hi file
to know exactly what disambiguation to use... without looking
at the hi-boot file itself.

In fact, the names will always differ because we always pick names
prefixed with "$fx" for boot dfuns, and "$f" for real dfuns
(so that this impedance matching is always possible).

Note [DFun knot-tying]
~~~~~~~~~~~~~~~~~~~~~~
The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from
typechecking the hi-boot file that we are presently implementing.
Suppose we are typechecking the module A: when we typecheck the
hi-boot file, whenever we see an identifier A.T, we knot-tie this
identifier to the *local* type environment (via if_rec_types.)  The
contract then is that we don't *look* at 'SelfBootInfo' until we've
finished typechecking the module and updated the type environment with
the new tycons and ids.

This most works well, but there is one problem: DFuns!  We do not want
to look at the mb_insts of the ModDetails in SelfBootInfo, because a
dfun in one of those ClsInsts is gotten (in GHC.IfaceToCore.tcIfaceInst) by a
(lazily evaluated) lookup in the if_rec_types.  We could extend the
type env, do a setGloblaTypeEnv etc; but that all seems very indirect.
It is much more directly simply to extract the DFunIds from the
md_types of the SelfBootInfo.

See #4003, #16038 for why we need to take care here.
-}

checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
                  -> ModDetails -> TcM [(Id, Id)]
-- Variant which doesn't require a full TcGblEnv; you could get the
-- local components from another ModDetails.
checkHiBootIface' :: [ClsInst]
-> TypeEnv -> [AvailInfo] -> ModDetails -> TcM [(Var, Var)]
checkHiBootIface'
        [ClsInst]
local_insts TypeEnv
local_type_env [AvailInfo]
local_exports
        (ModDetails { md_types :: ModDetails -> TypeEnv
md_types = TypeEnv
boot_type_env
                    , md_fam_insts :: ModDetails -> [FamInst]
md_fam_insts = [FamInst]
boot_fam_insts
                    , md_exports :: ModDetails -> [AvailInfo]
md_exports = [AvailInfo]
boot_exports })
  = do  { String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"checkHiBootIface" (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
             [ TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable (UniqFM a)
External instance of the constraint type Outputable TyThing
ppr TypeEnv
boot_type_env, [AvailInfo] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable AvailInfo
ppr [AvailInfo]
boot_exports]

                -- Check the exports of the boot module, one by one
        ; (AvailInfo -> TcRnIf TcGblEnv TcLclEnv ())
-> [AvailInfo] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
mapM_ AvailInfo -> TcRnIf TcGblEnv TcLclEnv ()
check_export [AvailInfo]
boot_exports

                -- Check for no family instances
        ; IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
unless ([FamInst] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [FamInst]
boot_fam_insts) (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
            String -> TcRnIf TcGblEnv TcLclEnv ()
forall a. String -> a
panic (String
"GHC.Tc.Module.checkHiBootIface: Cannot handle family " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String
"instances in boot files yet...")
            -- FIXME: Why?  The actual comparison is not hard, but what would
            --        be the equivalent to the dfun bindings returned for class
            --        instances?  We can't easily equate tycons...

                -- Check instance declarations
                -- and generate an impedance-matching binding
        ; [Maybe (Var, Var)]
mb_dfun_prs <- (Var -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var)))
-> [Var] -> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (Var, Var)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM Var -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
check_cls_inst [Var]
boot_dfuns

        ; TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM

        ; [(Var, Var)] -> TcM [(Var, Var)]
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([Maybe (Var, Var)] -> [(Var, Var)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Var, Var)]
mb_dfun_prs) }

  where
    boot_dfun_names :: [Name]
boot_dfun_names = (Var -> Name) -> [Var] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Name
idName [Var]
boot_dfuns
    boot_dfuns :: [Var]
boot_dfuns      = (Var -> IsBootInterface) -> [Var] -> [Var]
forall a. (a -> IsBootInterface) -> [a] -> [a]
filter Var -> IsBootInterface
isDFunId ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ TypeEnv -> [Var]
typeEnvIds TypeEnv
boot_type_env
       -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts
       --     We don't want to look at md_insts!
       --     Why not?  See Note [DFun knot-tying]

    check_export :: AvailInfo -> TcRnIf TcGblEnv TcLclEnv ()
check_export AvailInfo
boot_avail     -- boot_avail is exported by the boot iface
      | Name
name Name -> [Name] -> IsBootInterface
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> IsBootInterface
External instance of the constraint type Eq Name
External instance of the constraint type Foldable []
`elem` [Name]
boot_dfun_names = () -> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ()
      | Name -> IsBootInterface
isWiredInName Name
name          = () -> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return () -- No checking for wired-in names.  In particular,
                                                -- 'error' is handled by a rather gross hack
                                                -- (see comments in GHC.Err.hs-boot)

        -- Check that the actual module exports the same thing
      | IsBootInterface -> IsBootInterface
not ([Name] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [Name]
missing_names)
      = SrcSpan -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrAt (Name -> SrcSpan
nameSrcSpan ([Name] -> Name
forall a. [a] -> a
head [Name]
missing_names))
                 (IsBootInterface -> Name -> String -> SDoc
missingBootThing IsBootInterface
True ([Name] -> Name
forall a. [a] -> a
head [Name]
missing_names) String
"exported by")

        -- If the boot module does not *define* the thing, we are done
        -- (it simply re-exports it, and names match, so nothing further to do)
      | Maybe TyThing -> IsBootInterface
forall a. Maybe a -> IsBootInterface
isNothing Maybe TyThing
mb_boot_thing = () -> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ()

        -- Check that the actual module also defines the thing, and
        -- then compare the definitions
      | Just TyThing
real_thing <- TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
local_type_env Name
name,
        Just TyThing
boot_thing <- Maybe TyThing
mb_boot_thing
      = IsBootInterface
-> TyThing -> TyThing -> TcRnIf TcGblEnv TcLclEnv ()
checkBootDeclM IsBootInterface
True TyThing
boot_thing TyThing
real_thing

      | IsBootInterface
otherwise
      = SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrTc (IsBootInterface -> Name -> String -> SDoc
missingBootThing IsBootInterface
True Name
name String
"defined in")
      where
        name :: Name
name          = AvailInfo -> Name
availName AvailInfo
boot_avail
        mb_boot_thing :: Maybe TyThing
mb_boot_thing = TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
boot_type_env Name
name
        missing_names :: [Name]
missing_names = case NameEnv AvailInfo -> Name -> Maybe AvailInfo
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv AvailInfo
local_export_env Name
name of
                          Maybe AvailInfo
Nothing    -> [Name
name]
                          Just AvailInfo
avail -> AvailInfo -> [Name]
availNames AvailInfo
boot_avail [Name] -> [Name] -> [Name]
forall a. Ord a => [a] -> [a] -> [a]
External instance of the constraint type Ord Name
`minusList` AvailInfo -> [Name]
availNames AvailInfo
avail

    local_export_env :: NameEnv AvailInfo
    local_export_env :: NameEnv AvailInfo
local_export_env = [AvailInfo] -> NameEnv AvailInfo
availsToNameEnv [AvailInfo]
local_exports

    check_cls_inst :: DFunId -> TcM (Maybe (Id, Id))
        -- Returns a pair of the boot dfun in terms of the equivalent
        -- real dfun. Delicate (like checkBootDecl) because it depends
        -- on the types lining up precisely even to the ordering of
        -- the type variables in the foralls.
    check_cls_inst :: Var -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
check_cls_inst Var
boot_dfun
      | (Var
real_dfun : [Var]
_) <- Var -> [Var]
find_real_dfun Var
boot_dfun
      , let local_boot_dfun :: Var
local_boot_dfun = Name -> Type -> Var
Id.mkExportedVanillaId
                                  (Var -> Name
idName Var
boot_dfun) (Var -> Type
idType Var
real_dfun)
      = Maybe (Var, Var)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ((Var, Var) -> Maybe (Var, Var)
forall a. a -> Maybe a
Just (Var
local_boot_dfun, Var
real_dfun))
          -- Two tricky points here:
          --
          --  * The local_boot_fun should have a Name from the /boot-file/,
          --    but type from the dfun defined in /this module/.
          --    That ensures that the TyCon etc inside the type are
          --    the ones defined in this module, not the ones gotten
          --    from the hi-boot file, which may have a lot less info
          --    (#8743, comment:10).
          --
          --  * The DFunIds from boot_details are /GlobalIds/, because
          --    they come from typechecking M.hi-boot.
          --    But all bindings in this module should be for /LocalIds/,
          --    otherwise dependency analysis fails (#16038). This
          --    is another reason for using mkExportedVanillaId, rather
          --    that modifying boot_dfun, to make local_boot_fun.

      | IsBootInterface
otherwise
      = SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
nameSrcSpan (Var -> Name
forall a. NamedThing a => a -> Name
External instance of the constraint type NamedThing Var
getName Var
boot_dfun)) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var)))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
forall a b. (a -> b) -> a -> b
$
        do { String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"check_cls_inst" (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
                [ String -> SDoc
text String
"local_insts"  SDoc -> SDoc -> SDoc
<+>
                     [SDoc] -> SDoc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Type
ppr (Type -> SDoc) -> (ClsInst -> Type) -> ClsInst -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Type
idType (Var -> Type) -> (ClsInst -> Var) -> ClsInst -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Var
instanceDFunId) [ClsInst]
local_insts)
                , String -> SDoc
text String
"boot_dfun_ty" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Type
ppr (Var -> Type
idType Var
boot_dfun) ]

           ; SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrTc (Var -> SDoc
instMisMatch Var
boot_dfun)
           ; Maybe (Var, Var)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return Maybe (Var, Var)
forall a. Maybe a
Nothing }

    find_real_dfun :: DFunId -> [DFunId]
    find_real_dfun :: Var -> [Var]
find_real_dfun Var
boot_dfun
       = [Var
dfun | ClsInst
inst <- [ClsInst]
local_insts
               , let dfun :: Var
dfun = ClsInst -> Var
instanceDFunId ClsInst
inst
               , Var -> Type
idType Var
dfun Type -> Type -> IsBootInterface
`eqType` Type
boot_dfun_ty ]
       where
          boot_dfun_ty :: Type
boot_dfun_ty   = Var -> Type
idType Var
boot_dfun


-- In general, to perform these checks we have to
-- compare the TyThing from the .hi-boot file to the TyThing
-- in the current source file.  We must be careful to allow alpha-renaming
-- where appropriate, and also the boot declaration is allowed to omit
-- constructors and class methods.
--
-- See rnfail055 for a good test of this stuff.

-- | Compares two things for equivalence between boot-file and normal code,
-- reporting an error if they don't match up.
checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
               -> TyThing -> TyThing -> TcM ()
checkBootDeclM :: IsBootInterface
-> TyThing -> TyThing -> TcRnIf TcGblEnv TcLclEnv ()
checkBootDeclM IsBootInterface
is_boot TyThing
boot_thing TyThing
real_thing
  = Maybe SDoc
-> (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
whenIsJust (IsBootInterface -> TyThing -> TyThing -> Maybe SDoc
checkBootDecl IsBootInterface
is_boot TyThing
boot_thing TyThing
real_thing) ((SDoc -> TcRnIf TcGblEnv TcLclEnv ())
 -> TcRnIf TcGblEnv TcLclEnv ())
-> (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ \ SDoc
err ->
       SrcSpan -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrAt SrcSpan
span
                (IsBootInterface -> SDoc -> TyThing -> TyThing -> SDoc
bootMisMatch IsBootInterface
is_boot SDoc
err TyThing
real_thing TyThing
boot_thing)
  where
    -- Here we use the span of the boot thing or, if it doesn't have a sensible
    -- span, that of the real thing,
    span :: SrcSpan
span
      | let span :: SrcSpan
span = Name -> SrcSpan
nameSrcSpan (TyThing -> Name
forall a. NamedThing a => a -> Name
External instance of the constraint type NamedThing TyThing
getName TyThing
boot_thing)
      , SrcSpan -> IsBootInterface
isGoodSrcSpan SrcSpan
span
      = SrcSpan
span
      | IsBootInterface
otherwise
      = Name -> SrcSpan
nameSrcSpan (TyThing -> Name
forall a. NamedThing a => a -> Name
External instance of the constraint type NamedThing TyThing
getName TyThing
real_thing)

-- | Compares the two things for equivalence between boot-file and normal
-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
-- failure. If the difference will be apparent to the user, @Just empty@ is
-- perfectly suitable.
checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc

checkBootDecl :: IsBootInterface -> TyThing -> TyThing -> Maybe SDoc
checkBootDecl IsBootInterface
_ (AnId Var
id1) (AnId Var
id2)
  = ASSERT(id1 == id2)
    IsBootInterface -> SDoc -> Maybe SDoc
check (Var -> Type
idType Var
id1 Type -> Type -> IsBootInterface
`eqType` Var -> Type
idType Var
id2)
          (String -> SDoc
text String
"The two types are different")

checkBootDecl IsBootInterface
is_boot (ATyCon TyCon
tc1) (ATyCon TyCon
tc2)
  = IsBootInterface -> TyCon -> TyCon -> Maybe SDoc
checkBootTyCon IsBootInterface
is_boot TyCon
tc1 TyCon
tc2

checkBootDecl IsBootInterface
_ (AConLike (RealDataCon DataCon
dc1)) (AConLike (RealDataCon DataCon
_))
  = String -> SDoc -> Maybe SDoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"checkBootDecl" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable DataCon
ppr DataCon
dc1)

checkBootDecl IsBootInterface
_ TyThing
_ TyThing
_ = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
empty -- probably shouldn't happen

-- | Combines two potential error messages
andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
Maybe SDoc
Nothing andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck` Maybe SDoc
msg     = Maybe SDoc
msg
Maybe SDoc
msg     `andThenCheck` Maybe SDoc
Nothing = Maybe SDoc
msg
Just SDoc
d1 `andThenCheck` Just SDoc
d2 = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc
d1 SDoc -> SDoc -> SDoc
$$ SDoc
d2)
infixr 0 `andThenCheck`

-- | If the test in the first parameter is True, succeed with @Nothing@;
-- otherwise, return the provided check
checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
checkUnless :: IsBootInterface -> Maybe SDoc -> Maybe SDoc
checkUnless IsBootInterface
True  Maybe SDoc
_ = Maybe SDoc
forall a. Maybe a
Nothing
checkUnless IsBootInterface
False Maybe SDoc
k = Maybe SDoc
k

-- | Run the check provided for every pair of elements in the lists.
-- The provided SDoc should name the element type, in the plural.
checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
            -> Maybe SDoc
checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc -> Maybe SDoc
checkListBy a -> a -> Maybe SDoc
check_fun [a]
as [a]
bs SDoc
whats = [SDoc] -> [a] -> [a] -> Maybe SDoc
go [] [a]
as [a]
bs
  where
    herald :: SDoc
herald = String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> SDoc
whats SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"do not match"

    go :: [SDoc] -> [a] -> [a] -> Maybe SDoc
go []   [] [] = Maybe SDoc
forall a. Maybe a
Nothing
    go [SDoc]
docs [] [] = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Arity -> SDoc -> SDoc
hang (SDoc
herald SDoc -> SDoc -> SDoc
<> SDoc
colon) Arity
2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse [SDoc]
docs))
    go [SDoc]
docs (a
x:[a]
xs) (a
y:[a]
ys) = case a -> a -> Maybe SDoc
check_fun a
x a
y of
      Just SDoc
doc -> [SDoc] -> [a] -> [a] -> Maybe SDoc
go (SDoc
docSDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:[SDoc]
docs) [a]
xs [a]
ys
      Maybe SDoc
Nothing  -> [SDoc] -> [a] -> [a] -> Maybe SDoc
go [SDoc]
docs       [a]
xs [a]
ys
    go [SDoc]
_    [a]
_  [a]
_ = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Arity -> SDoc -> SDoc
hang (SDoc
herald SDoc -> SDoc -> SDoc
<> SDoc
colon)
                            Arity
2 (String -> SDoc
text String
"There are different numbers of" SDoc -> SDoc -> SDoc
<+> SDoc
whats))

-- | If the test in the first parameter is True, succeed with @Nothing@;
-- otherwise, fail with the given SDoc.
check :: Bool -> SDoc -> Maybe SDoc
check :: IsBootInterface -> SDoc -> Maybe SDoc
check IsBootInterface
True  SDoc
_   = Maybe SDoc
forall a. Maybe a
Nothing
check IsBootInterface
False SDoc
doc = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
doc

-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.
checkSuccess :: Maybe SDoc
checkSuccess :: Maybe SDoc
checkSuccess = Maybe SDoc
forall a. Maybe a
Nothing

----------------
checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc
checkBootTyCon :: IsBootInterface -> TyCon -> TyCon -> Maybe SDoc
checkBootTyCon IsBootInterface
is_boot TyCon
tc1 TyCon
tc2
  | IsBootInterface -> IsBootInterface
not (Type -> Type -> IsBootInterface
eqType (TyCon -> Type
tyConKind TyCon
tc1) (TyCon -> Type
tyConKind TyCon
tc2))
  = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"The types have different kinds"    -- First off, check the kind

  | Just Class
c1 <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc1
  , Just Class
c2 <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc2
  , let ([Var]
clas_tvs1, [FunDep Var]
clas_fds1, [Type]
sc_theta1, [Var]
_, [ClassATItem]
ats1, [ClassOpItem]
op_stuff1)
          = Class
-> ([Var], [FunDep Var], [Type], [Var], [ClassATItem],
    [ClassOpItem])
classExtraBigSig Class
c1
        ([Var]
clas_tvs2, [FunDep Var]
clas_fds2, [Type]
sc_theta2, [Var]
_, [ClassATItem]
ats2, [ClassOpItem]
op_stuff2)
          = Class
-> ([Var], [FunDep Var], [Type], [Var], [ClassATItem],
    [ClassOpItem])
classExtraBigSig Class
c2
  , Just RnEnv2
env <- RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 [Var]
clas_tvs1 [Var]
clas_tvs2
  = let
       eqSig :: ClassOpItem -> ClassOpItem -> Maybe SDoc
eqSig (Var
id1, Maybe (Name, DefMethSpec Type)
def_meth1) (Var
id2, Maybe (Name, DefMethSpec Type)
def_meth2)
         = IsBootInterface -> SDoc -> Maybe SDoc
check (Name
name1 Name -> Name -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq Name
== Name
name2)
                 (String -> SDoc
text String
"The names" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> SDoc
pname2 SDoc -> SDoc -> SDoc
<+>
                  String -> SDoc
text String
"are different") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
           IsBootInterface -> SDoc -> Maybe SDoc
check (RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env Type
op_ty1 Type
op_ty2)
                 (String -> SDoc
text String
"The types of" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
                  String -> SDoc
text String
"are different") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
           if IsBootInterface
is_boot
               then IsBootInterface -> SDoc -> Maybe SDoc
check (((Name, DefMethSpec Type)
 -> (Name, DefMethSpec Type) -> IsBootInterface)
-> Maybe (Name, DefMethSpec Type)
-> Maybe (Name, DefMethSpec Type)
-> IsBootInterface
forall a.
(a -> a -> IsBootInterface)
-> Maybe a -> Maybe a -> IsBootInterface
eqMaybeBy (Name, DefMethSpec Type)
-> (Name, DefMethSpec Type) -> IsBootInterface
eqDM Maybe (Name, DefMethSpec Type)
def_meth1 Maybe (Name, DefMethSpec Type)
def_meth2)
                          (String -> SDoc
text String
"The default methods associated with" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
                           String -> SDoc
text String
"are different")
               else IsBootInterface -> SDoc -> Maybe SDoc
check (Type
-> Maybe (Name, DefMethSpec Type)
-> Maybe (Name, DefMethSpec Type)
-> IsBootInterface
subDM Type
op_ty1 Maybe (Name, DefMethSpec Type)
def_meth1 Maybe (Name, DefMethSpec Type)
def_meth2)
                          (String -> SDoc
text String
"The default methods associated with" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
                           String -> SDoc
text String
"are not compatible")
         where
          name1 :: Name
name1 = Var -> Name
idName Var
id1
          name2 :: Name
name2 = Var -> Name
idName Var
id2
          pname1 :: SDoc
pname1 = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
name1)
          pname2 :: SDoc
pname2 = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
name2)
          ([Var]
_, Type
rho_ty1) = Type -> ([Var], Type)
splitForAllTys (Var -> Type
idType Var
id1)
          op_ty1 :: Type
op_ty1 = Type -> Type
funResultTy Type
rho_ty1
          ([Var]
_, Type
rho_ty2) = Type -> ([Var], Type)
splitForAllTys (Var -> Type
idType Var
id2)
          op_ty2 :: Type
op_ty2 = Type -> Type
funResultTy Type
rho_ty2

       eqAT :: ClassATItem -> ClassATItem -> Maybe SDoc
eqAT (ATI TyCon
tc1 Maybe (Type, SrcSpan)
def_ats1) (ATI TyCon
tc2 Maybe (Type, SrcSpan)
def_ats2)
         = IsBootInterface -> TyCon -> TyCon -> Maybe SDoc
checkBootTyCon IsBootInterface
is_boot TyCon
tc1 TyCon
tc2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
           IsBootInterface -> SDoc -> Maybe SDoc
check (Maybe (Type, SrcSpan) -> Maybe (Type, SrcSpan) -> IsBootInterface
eqATDef Maybe (Type, SrcSpan)
def_ats1 Maybe (Type, SrcSpan)
def_ats2)
                 (String -> SDoc
text String
"The associated type defaults differ")

       eqDM :: (Name, DefMethSpec Type)
-> (Name, DefMethSpec Type) -> IsBootInterface
eqDM (Name
_, DefMethSpec Type
VanillaDM)    (Name
_, DefMethSpec Type
VanillaDM)    = IsBootInterface
True
       eqDM (Name
_, GenericDM Type
t1) (Name
_, GenericDM Type
t2) = RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env Type
t1 Type
t2
       eqDM (Name, DefMethSpec Type)
_ (Name, DefMethSpec Type)
_ = IsBootInterface
False

       -- NB: first argument is from hsig, second is from real impl.
       -- Order of pattern matching matters.
       subDM :: Type
-> Maybe (Name, DefMethSpec Type)
-> Maybe (Name, DefMethSpec Type)
-> IsBootInterface
subDM Type
_ Maybe (Name, DefMethSpec Type)
Nothing Maybe (Name, DefMethSpec Type)
_ = IsBootInterface
True
       subDM Type
_ Maybe (Name, DefMethSpec Type)
_ Maybe (Name, DefMethSpec Type)
Nothing = IsBootInterface
False
       -- If the hsig wrote:
       --
       --   f :: a -> a
       --   default f :: a -> a
       --
       -- this should be validly implementable using an old-fashioned
       -- vanilla default method.
       subDM Type
t1 (Just (Name
_, GenericDM Type
t2)) (Just (Name
_, DefMethSpec Type
VanillaDM))
        = RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env Type
t1 Type
t2
       -- This case can occur when merging signatures
       subDM Type
t1 (Just (Name
_, DefMethSpec Type
VanillaDM)) (Just (Name
_, GenericDM Type
t2))
        = RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env Type
t1 Type
t2
       subDM Type
_ (Just (Name
_, DefMethSpec Type
VanillaDM)) (Just (Name
_, DefMethSpec Type
VanillaDM)) = IsBootInterface
True
       subDM Type
_ (Just (Name
_, GenericDM Type
t1)) (Just (Name
_, GenericDM Type
t2))
        = RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env Type
t1 Type
t2

       -- Ignore the location of the defaults
       eqATDef :: Maybe (Type, SrcSpan) -> Maybe (Type, SrcSpan) -> IsBootInterface
eqATDef Maybe (Type, SrcSpan)
Nothing             Maybe (Type, SrcSpan)
Nothing             = IsBootInterface
True
       eqATDef (Just (Type
ty1, SrcSpan
_loc1)) (Just (Type
ty2, SrcSpan
_loc2)) = RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env Type
ty1 Type
ty2
       eqATDef Maybe (Type, SrcSpan)
_ Maybe (Type, SrcSpan)
_ = IsBootInterface
False

       eqFD :: FunDep Var -> FunDep Var -> IsBootInterface
eqFD ([Var]
as1,[Var]
bs1) ([Var]
as2,[Var]
bs2) =
         (Type -> Type -> IsBootInterface)
-> [Type] -> [Type] -> IsBootInterface
forall a.
(a -> a -> IsBootInterface) -> [a] -> [a] -> IsBootInterface
eqListBy (RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env) ([Var] -> [Type]
mkTyVarTys [Var]
as1) ([Var] -> [Type]
mkTyVarTys [Var]
as2) IsBootInterface -> IsBootInterface -> IsBootInterface
&&
         (Type -> Type -> IsBootInterface)
-> [Type] -> [Type] -> IsBootInterface
forall a.
(a -> a -> IsBootInterface) -> [a] -> [a] -> IsBootInterface
eqListBy (RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env) ([Var] -> [Type]
mkTyVarTys [Var]
bs1) ([Var] -> [Type]
mkTyVarTys [Var]
bs2)
    in
    [Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 [Role]
roles2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
          -- Checks kind of class
    IsBootInterface -> SDoc -> Maybe SDoc
check ((FunDep Var -> FunDep Var -> IsBootInterface)
-> [FunDep Var] -> [FunDep Var] -> IsBootInterface
forall a.
(a -> a -> IsBootInterface) -> [a] -> [a] -> IsBootInterface
eqListBy FunDep Var -> FunDep Var -> IsBootInterface
eqFD [FunDep Var]
clas_fds1 [FunDep Var]
clas_fds2)
          (String -> SDoc
text String
"The functional dependencies do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    IsBootInterface -> Maybe SDoc -> Maybe SDoc
checkUnless (TyCon -> IsBootInterface
isAbstractTyCon TyCon
tc1) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
    IsBootInterface -> SDoc -> Maybe SDoc
check ((Type -> Type -> IsBootInterface)
-> [Type] -> [Type] -> IsBootInterface
forall a.
(a -> a -> IsBootInterface) -> [a] -> [a] -> IsBootInterface
eqListBy (RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env) [Type]
sc_theta1 [Type]
sc_theta2)
          (String -> SDoc
text String
"The class constraints do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    (ClassOpItem -> ClassOpItem -> Maybe SDoc)
-> [ClassOpItem] -> [ClassOpItem] -> SDoc -> Maybe SDoc
forall a.
(a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc -> Maybe SDoc
checkListBy ClassOpItem -> ClassOpItem -> Maybe SDoc
eqSig [ClassOpItem]
op_stuff1 [ClassOpItem]
op_stuff2 (String -> SDoc
text String
"methods") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    (ClassATItem -> ClassATItem -> Maybe SDoc)
-> [ClassATItem] -> [ClassATItem] -> SDoc -> Maybe SDoc
forall a.
(a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc -> Maybe SDoc
checkListBy ClassATItem -> ClassATItem -> Maybe SDoc
eqAT [ClassATItem]
ats1 [ClassATItem]
ats2 (String -> SDoc
text String
"associated types") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    IsBootInterface -> SDoc -> Maybe SDoc
check (Class -> ClassMinimalDef
classMinimalDef Class
c1 ClassMinimalDef -> ClassMinimalDef -> IsBootInterface
forall a.
Uniquable a =>
BooleanFormula a -> BooleanFormula a -> IsBootInterface
External instance of the constraint type Uniquable Name
`BF.implies` Class -> ClassMinimalDef
classMinimalDef Class
c2)
        (String -> SDoc
text String
"The MINIMAL pragmas are not compatible")

  | Just Type
syn_rhs1 <- TyCon -> DFunInstType
synTyConRhs_maybe TyCon
tc1
  , Just Type
syn_rhs2 <- TyCon -> DFunInstType
synTyConRhs_maybe TyCon
tc2
  , Just RnEnv2
env <- RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 (TyCon -> [Var]
tyConTyVars TyCon
tc1) (TyCon -> [Var]
tyConTyVars TyCon
tc2)
  = ASSERT(tc1 == tc2)
    [Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 [Role]
roles2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    IsBootInterface -> SDoc -> Maybe SDoc
check (RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env Type
syn_rhs1 Type
syn_rhs2) SDoc
empty   -- nothing interesting to say
  -- This allows abstract 'data T a' to be implemented using 'type T = ...'
  -- and abstract 'class K a' to be implement using 'type K = ...'
  -- See Note [Synonyms implement abstract data]
  | IsBootInterface -> IsBootInterface
not IsBootInterface
is_boot -- don't support for hs-boot yet
  , TyCon -> IsBootInterface
isAbstractTyCon TyCon
tc1
  , Just ([Var]
tvs, Type
ty) <- TyCon -> Maybe ([Var], Type)
synTyConDefn_maybe TyCon
tc2
  , Just (TyCon
tc2', [Type]
args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
  = [Var] -> Type -> TyCon -> [Type] -> Maybe SDoc
checkSynAbsData [Var]
tvs Type
ty TyCon
tc2' [Type]
args
    -- TODO: When it's a synonym implementing a class, we really
    -- should check if the fundeps are satisfied, but
    -- there is not an obvious way to do this for a constraint synonym.
    -- So for now, let it all through (it won't cause segfaults, anyway).
    -- Tracked at #12704.

  -- This allows abstract 'data T :: Nat' to be implemented using
  -- 'type T = 42' Since the kinds already match (we have checked this
  -- upfront) all we need to check is that the implementation 'type T
  -- = ...' defined an actual literal.  See #15138 for the case this
  -- handles.
  | IsBootInterface -> IsBootInterface
not IsBootInterface
is_boot
  , TyCon -> IsBootInterface
isAbstractTyCon TyCon
tc1
  , Just ([Var]
_,Type
ty2) <- TyCon -> Maybe ([Var], Type)
synTyConDefn_maybe TyCon
tc2
  , Maybe TyLit -> IsBootInterface
forall a. Maybe a -> IsBootInterface
isJust (Type -> Maybe TyLit
isLitTy Type
ty2)
  = Maybe SDoc
forall a. Maybe a
Nothing

  | Just FamTyConFlav
fam_flav1 <- TyCon -> Maybe FamTyConFlav
famTyConFlav_maybe TyCon
tc1
  , Just FamTyConFlav
fam_flav2 <- TyCon -> Maybe FamTyConFlav
famTyConFlav_maybe TyCon
tc2
  = ASSERT(tc1 == tc2)
    let eqFamFlav :: FamTyConFlav -> FamTyConFlav -> IsBootInterface
eqFamFlav FamTyConFlav
OpenSynFamilyTyCon   FamTyConFlav
OpenSynFamilyTyCon = IsBootInterface
True
        eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = IsBootInterface
True
        -- This case only happens for hsig merging:
        eqFamFlav FamTyConFlav
AbstractClosedSynFamilyTyCon FamTyConFlav
AbstractClosedSynFamilyTyCon = IsBootInterface
True
        eqFamFlav FamTyConFlav
AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = IsBootInterface
True
        eqFamFlav (ClosedSynFamilyTyCon {}) FamTyConFlav
AbstractClosedSynFamilyTyCon = IsBootInterface
True
        eqFamFlav (ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
ax1) (ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
ax2)
            = Maybe (CoAxiom Branched)
-> Maybe (CoAxiom Branched) -> IsBootInterface
forall {br :: BranchFlag} {br :: BranchFlag}.
Maybe (CoAxiom br) -> Maybe (CoAxiom br) -> IsBootInterface
eqClosedFamilyAx Maybe (CoAxiom Branched)
ax1 Maybe (CoAxiom Branched)
ax2
        eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = TyCon
tc1 TyCon -> TyCon -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq TyCon
== TyCon
tc2
        eqFamFlav FamTyConFlav
_ FamTyConFlav
_ = IsBootInterface
False
        injInfo1 :: Injectivity
injInfo1 = TyCon -> Injectivity
tyConInjectivityInfo TyCon
tc1
        injInfo2 :: Injectivity
injInfo2 = TyCon -> Injectivity
tyConInjectivityInfo TyCon
tc2
    in
    -- check equality of roles, family flavours and injectivity annotations
    -- (NB: Type family roles are always nominal. But the check is
    -- harmless enough.)
    [Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 [Role]
roles2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    IsBootInterface -> SDoc -> Maybe SDoc
check (FamTyConFlav -> FamTyConFlav -> IsBootInterface
eqFamFlav FamTyConFlav
fam_flav1 FamTyConFlav
fam_flav2)
        (SDoc -> SDoc
whenPprDebug (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
text String
"Family flavours" SDoc -> SDoc -> SDoc
<+> FamTyConFlav -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable FamTyConFlav
ppr FamTyConFlav
fam_flav1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> FamTyConFlav -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable FamTyConFlav
ppr FamTyConFlav
fam_flav2 SDoc -> SDoc -> SDoc
<+>
            String -> SDoc
text String
"do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    IsBootInterface -> SDoc -> Maybe SDoc
check (Injectivity
injInfo1 Injectivity -> Injectivity -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq Injectivity
== Injectivity
injInfo2) (String -> SDoc
text String
"Injectivities do not match")

  | TyCon -> IsBootInterface
isAlgTyCon TyCon
tc1 IsBootInterface -> IsBootInterface -> IsBootInterface
&& TyCon -> IsBootInterface
isAlgTyCon TyCon
tc2
  , Just RnEnv2
env <- RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 (TyCon -> [Var]
tyConTyVars TyCon
tc1) (TyCon -> [Var]
tyConTyVars TyCon
tc2)
  = ASSERT(tc1 == tc2)
    [Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 [Role]
roles2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    IsBootInterface -> SDoc -> Maybe SDoc
check ((Type -> Type -> IsBootInterface)
-> [Type] -> [Type] -> IsBootInterface
forall a.
(a -> a -> IsBootInterface) -> [a] -> [a] -> IsBootInterface
eqListBy (RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env)
                     (TyCon -> [Type]
tyConStupidTheta TyCon
tc1) (TyCon -> [Type]
tyConStupidTheta TyCon
tc2))
          (String -> SDoc
text String
"The datatype contexts do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    TyCon -> AlgTyConRhs -> AlgTyConRhs -> Maybe SDoc
forall {p}. p -> AlgTyConRhs -> AlgTyConRhs -> Maybe SDoc
eqAlgRhs TyCon
tc1 (TyCon -> AlgTyConRhs
algTyConRhs TyCon
tc1) (TyCon -> AlgTyConRhs
algTyConRhs TyCon
tc2)

  | IsBootInterface
otherwise = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
empty   -- two very different types -- should be obvious
  where
    roles1 :: [Role]
roles1 = TyCon -> [Role]
tyConRoles TyCon
tc1 -- the abstract one
    roles2 :: [Role]
roles2 = TyCon -> [Role]
tyConRoles TyCon
tc2
    roles_msg :: SDoc
roles_msg = String -> SDoc
text String
"The roles do not match." SDoc -> SDoc -> SDoc
$$
                (String -> SDoc
text String
"Roles on abstract types default to" SDoc -> SDoc -> SDoc
<+>
                 SDoc -> SDoc
quotes (String -> SDoc
text String
"representational") SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in boot files.")

    roles_subtype_msg :: SDoc
roles_subtype_msg = String -> SDoc
text String
"The roles are not compatible:" SDoc -> SDoc -> SDoc
$$
                        String -> SDoc
text String
"Main module:" SDoc -> SDoc -> SDoc
<+> [Role] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable Role
ppr [Role]
roles2 SDoc -> SDoc -> SDoc
$$
                        String -> SDoc
text String
"Hsig file:" SDoc -> SDoc -> SDoc
<+> [Role] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable Role
ppr [Role]
roles1

    checkRoles :: [Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
r1 [Role]
r2
      | IsBootInterface
is_boot IsBootInterface -> IsBootInterface -> IsBootInterface
|| TyCon -> Role -> IsBootInterface
isInjectiveTyCon TyCon
tc1 Role
Representational -- See Note [Role subtyping]
      = IsBootInterface -> SDoc -> Maybe SDoc
check ([Role]
r1 [Role] -> [Role] -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type Eq Role
== [Role]
r2) SDoc
roles_msg
      | IsBootInterface
otherwise = IsBootInterface -> SDoc -> Maybe SDoc
check ([Role]
r2 [Role] -> [Role] -> IsBootInterface
forall {a}. Ord a => [a] -> [a] -> IsBootInterface
External instance of the constraint type Ord Role
`rolesSubtypeOf` [Role]
r1) SDoc
roles_subtype_msg

    -- Note [Role subtyping]
    -- ~~~~~~~~~~~~~~~~~~~~~
    -- In the current formulation of roles, role subtyping is only OK if the
    -- "abstract" TyCon was not representationally injective.  Among the most
    -- notable examples of non representationally injective TyCons are abstract
    -- data, which can be implemented via newtypes (which are not
    -- representationally injective).  The key example is
    -- in this example from #13140:
    --
    --      -- In an hsig file
    --      data T a -- abstract!
    --      type role T nominal
    --
    --      -- Elsewhere
    --      foo :: Coercible (T a) (T b) => a -> b
    --      foo x = x
    --
    -- We must NOT allow foo to typecheck, because if we instantiate
    -- T with a concrete data type with a phantom role would cause
    -- Coercible (T a) (T b) to be provable.  Fortunately, if T is not
    -- representationally injective, we cannot make the inference that a ~N b if
    -- T a ~R T b.
    --
    -- Unconditional role subtyping would be possible if we setup
    -- an extra set of roles saying when we can project out coercions
    -- (we call these proj-roles); then it would NOT be valid to instantiate T
    -- with a data type at phantom since the proj-role subtyping check
    -- would fail.  See #13140 for more details.
    --
    -- One consequence of this is we get no role subtyping for non-abstract
    -- data types in signatures. Suppose you have:
    --
    --      signature A where
    --          type role T nominal
    --          data T a = MkT
    --
    -- If you write this, we'll treat T as injective, and make inferences
    -- like T a ~R T b ==> a ~N b (mkNthCo).  But if we can
    -- subsequently replace T with one at phantom role, we would then be able to
    -- infer things like T Int ~R T Bool which is bad news.
    --
    -- We could allow role subtyping here if we didn't treat *any* data types
    -- defined in signatures as injective.  But this would be a bit surprising,
    -- replacing a data type in a module with one in a signature could cause
    -- your code to stop typechecking (whereas if you made the type abstract,
    -- it is more understandable that the type checker knows less).
    --
    -- It would have been best if this was purely a question of defaults
    -- (i.e., a user could explicitly ask for one behavior or another) but
    -- the current role system isn't expressive enough to do this.
    -- Having explicit proj-roles would solve this problem.

    rolesSubtypeOf :: [a] -> [a] -> IsBootInterface
rolesSubtypeOf [] [] = IsBootInterface
True
    -- NB: this relation is the OPPOSITE of the subroling relation
    rolesSubtypeOf (a
x:[a]
xs) (a
y:[a]
ys) = a
x a -> a -> IsBootInterface
forall a. Ord a => a -> a -> IsBootInterface
Evidence bound by a type signature of the constraint type Ord a
>= a
y IsBootInterface -> IsBootInterface -> IsBootInterface
&& [a] -> [a] -> IsBootInterface
rolesSubtypeOf [a]
xs [a]
ys
    rolesSubtypeOf [a]
_ [a]
_ = IsBootInterface
False

    -- Note [Synonyms implement abstract data]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- An abstract data type or class can be implemented using a type synonym,
    -- but ONLY if the type synonym is nullary and has no type family
    -- applications.  This arises from two properties of skolem abstract data:
    --
    --    For any T (with some number of paramaters),
    --
    --    1. T is a valid type (it is "curryable"), and
    --
    --    2. T is valid in an instance head (no type families).
    --
    -- See also 'HowAbstract' and Note [Skolem abstract data].

    -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@,
    -- check that this synonym is an acceptable implementation of @tc1@.
    -- See Note [Synonyms implement abstract data]
    checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc
    checkSynAbsData :: [Var] -> Type -> TyCon -> [Type] -> Maybe SDoc
checkSynAbsData [Var]
tvs Type
ty TyCon
tc2' [Type]
args =
        IsBootInterface -> SDoc -> Maybe SDoc
check ([(TyCon, [Type])] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null (Type -> [(TyCon, [Type])]
tcTyFamInsts Type
ty))
              (String -> SDoc
text String
"Illegal type family application in implementation of abstract data.")
                Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
        IsBootInterface -> SDoc -> Maybe SDoc
check ([Var] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [Var]
tvs)
              (String -> SDoc
text String
"Illegal parameterized type synonym in implementation of abstract data." SDoc -> SDoc -> SDoc
$$
               String -> SDoc
text String
"(Try eta reducing your type synonym so that it is nullary.)")
                Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
        -- Don't report roles errors unless the type synonym is nullary
        IsBootInterface -> Maybe SDoc -> Maybe SDoc
checkUnless (IsBootInterface -> IsBootInterface
not ([Var] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [Var]
tvs)) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
            ASSERT( null roles2 )
            -- If we have something like:
            --
            --  signature H where
            --      data T a
            --  module H where
            --      data K a b = ...
            --      type T = K Int
            --
            -- we need to drop the first role of K when comparing!
            [Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 (Arity -> [Role] -> [Role]
forall a. Arity -> [a] -> [a]
drop ([Type] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
External instance of the constraint type Foldable []
length [Type]
args) (TyCon -> [Role]
tyConRoles TyCon
tc2'))
{-
        -- Hypothetically, if we were allow to non-nullary type synonyms, here
        -- is how you would check the roles
        if length tvs == length roles1
            then checkRoles roles1 roles2
            else case tcSplitTyConApp_maybe ty of
                    Just (tc2', args) ->
                        checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2)
                    Nothing -> Just roles_msg
-}

    eqAlgRhs :: p -> AlgTyConRhs -> AlgTyConRhs -> Maybe SDoc
eqAlgRhs p
_ AlgTyConRhs
AbstractTyCon AlgTyConRhs
_rhs2
      = Maybe SDoc
checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon
    eqAlgRhs p
_  tc1 :: AlgTyConRhs
tc1@DataTyCon{} tc2 :: AlgTyConRhs
tc2@DataTyCon{} =
        (DataCon -> DataCon -> Maybe SDoc)
-> [DataCon] -> [DataCon] -> SDoc -> Maybe SDoc
forall a.
(a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc -> Maybe SDoc
checkListBy DataCon -> DataCon -> Maybe SDoc
eqCon (AlgTyConRhs -> [DataCon]
data_cons AlgTyConRhs
tc1) (AlgTyConRhs -> [DataCon]
data_cons AlgTyConRhs
tc2) (String -> SDoc
text String
"constructors")
    eqAlgRhs p
_  tc1 :: AlgTyConRhs
tc1@NewTyCon{} tc2 :: AlgTyConRhs
tc2@NewTyCon{} =
        DataCon -> DataCon -> Maybe SDoc
eqCon (AlgTyConRhs -> DataCon
data_con AlgTyConRhs
tc1) (AlgTyConRhs -> DataCon
data_con AlgTyConRhs
tc2)
    eqAlgRhs p
_ AlgTyConRhs
_ AlgTyConRhs
_ = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
"Cannot match a" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"data") SDoc -> SDoc -> SDoc
<+>
                           String -> SDoc
text String
"definition with a" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"newtype") SDoc -> SDoc -> SDoc
<+>
                           String -> SDoc
text String
"definition")

    eqCon :: DataCon -> DataCon -> Maybe SDoc
eqCon DataCon
c1 DataCon
c2
      =  IsBootInterface -> SDoc -> Maybe SDoc
check (Name
name1 Name -> Name -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq Name
== Name
name2)
               (String -> SDoc
text String
"The names" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> SDoc
pname2 SDoc -> SDoc -> SDoc
<+>
                String -> SDoc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
         IsBootInterface -> SDoc -> Maybe SDoc
check (DataCon -> IsBootInterface
dataConIsInfix DataCon
c1 IsBootInterface -> IsBootInterface -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq IsBootInterface
== DataCon -> IsBootInterface
dataConIsInfix DataCon
c2)
               (String -> SDoc
text String
"The fixities of" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
                String -> SDoc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
         IsBootInterface -> SDoc -> Maybe SDoc
check ((HsImplBang -> HsImplBang -> IsBootInterface)
-> [HsImplBang] -> [HsImplBang] -> IsBootInterface
forall a.
(a -> a -> IsBootInterface) -> [a] -> [a] -> IsBootInterface
eqListBy HsImplBang -> HsImplBang -> IsBootInterface
eqHsBang (DataCon -> [HsImplBang]
dataConImplBangs DataCon
c1) (DataCon -> [HsImplBang]
dataConImplBangs DataCon
c2))
               (String -> SDoc
text String
"The strictness annotations for" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
                String -> SDoc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
         IsBootInterface -> SDoc -> Maybe SDoc
check ((FieldLbl Name -> Name) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector (DataCon -> [FieldLbl Name]
dataConFieldLabels DataCon
c1) [Name] -> [Name] -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type Eq Name
== (FieldLbl Name -> Name) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector (DataCon -> [FieldLbl Name]
dataConFieldLabels DataCon
c2))
               (String -> SDoc
text String
"The record label lists for" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
                String -> SDoc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
         IsBootInterface -> SDoc -> Maybe SDoc
check (Type -> Type -> IsBootInterface
eqType (DataCon -> Type
dataConUserType DataCon
c1) (DataCon -> Type
dataConUserType DataCon
c2))
               (String -> SDoc
text String
"The types for" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"differ")
      where
        name1 :: Name
name1 = DataCon -> Name
dataConName DataCon
c1
        name2 :: Name
name2 = DataCon -> Name
dataConName DataCon
c2
        pname1 :: SDoc
pname1 = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
name1)
        pname2 :: SDoc
pname2 = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
name2)

    eqClosedFamilyAx :: Maybe (CoAxiom br) -> Maybe (CoAxiom br) -> IsBootInterface
eqClosedFamilyAx Maybe (CoAxiom br)
Nothing Maybe (CoAxiom br)
Nothing  = IsBootInterface
True
    eqClosedFamilyAx Maybe (CoAxiom br)
Nothing (Just CoAxiom br
_) = IsBootInterface
False
    eqClosedFamilyAx (Just CoAxiom br
_) Maybe (CoAxiom br)
Nothing = IsBootInterface
False
    eqClosedFamilyAx (Just (CoAxiom { co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
co_ax_branches = Branches br
branches1 }))
                     (Just (CoAxiom { co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
co_ax_branches = Branches br
branches2 }))
      =  Branches br -> Arity
forall (br :: BranchFlag). Branches br -> Arity
numBranches Branches br
branches1 Arity -> Arity -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq Arity
== Branches br -> Arity
forall (br :: BranchFlag). Branches br -> Arity
numBranches Branches br
branches2
      IsBootInterface -> IsBootInterface -> IsBootInterface
&& ([IsBootInterface] -> IsBootInterface
forall (t :: * -> *).
Foldable t =>
t IsBootInterface -> IsBootInterface
External instance of the constraint type Foldable []
and ([IsBootInterface] -> IsBootInterface)
-> [IsBootInterface] -> IsBootInterface
forall a b. (a -> b) -> a -> b
$ (CoAxBranch -> CoAxBranch -> IsBootInterface)
-> [CoAxBranch] -> [CoAxBranch] -> [IsBootInterface]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CoAxBranch -> CoAxBranch -> IsBootInterface
eqClosedFamilyBranch [CoAxBranch]
branch_list1 [CoAxBranch]
branch_list2)
      where
        branch_list1 :: [CoAxBranch]
branch_list1 = Branches br -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches Branches br
branches1
        branch_list2 :: [CoAxBranch]
branch_list2 = Branches br -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches Branches br
branches2

    eqClosedFamilyBranch :: CoAxBranch -> CoAxBranch -> IsBootInterface
eqClosedFamilyBranch (CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs1, cab_cvs :: CoAxBranch -> [Var]
cab_cvs = [Var]
cvs1
                                     , cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs1, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs1 })
                         (CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs2, cab_cvs :: CoAxBranch -> [Var]
cab_cvs = [Var]
cvs2
                                     , cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs2, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs2 })
      | Just RnEnv2
env1 <- RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 [Var]
tvs1 [Var]
tvs2
      , Just RnEnv2
env  <- RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
eqVarBndrs RnEnv2
env1        [Var]
cvs1 [Var]
cvs2
      = (Type -> Type -> IsBootInterface)
-> [Type] -> [Type] -> IsBootInterface
forall a.
(a -> a -> IsBootInterface) -> [a] -> [a] -> IsBootInterface
eqListBy (RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env) [Type]
lhs1 [Type]
lhs2 IsBootInterface -> IsBootInterface -> IsBootInterface
&&
        RnEnv2 -> Type -> Type -> IsBootInterface
eqTypeX RnEnv2
env Type
rhs1 Type
rhs2

      | IsBootInterface
otherwise = IsBootInterface
False

emptyRnEnv2 :: RnEnv2
emptyRnEnv2 :: RnEnv2
emptyRnEnv2 = InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
emptyInScopeSet

----------------
missingBootThing :: Bool -> Name -> String -> SDoc
missingBootThing :: IsBootInterface -> Name -> String -> SDoc
missingBootThing IsBootInterface
is_boot Name
name String
what
  = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is exported by the"
    SDoc -> SDoc -> SDoc
<+> (if IsBootInterface
is_boot then String -> SDoc
text String
"hs-boot" else String -> SDoc
text String
"hsig")
    SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"file, but not"
    SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"the module"

badReexportedBootThing :: Bool -> Name -> Name -> SDoc
badReexportedBootThing :: IsBootInterface -> Name -> Name -> SDoc
badReexportedBootThing IsBootInterface
is_boot Name
name Name
name'
  = PrintUnqualified -> Depth -> SDoc -> SDoc
withUserStyle PrintUnqualified
alwaysQualify Depth
AllTheWay (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
        [ String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> (if IsBootInterface
is_boot then String -> SDoc
text String
"hs-boot" else String -> SDoc
text String
"hsig")
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"file (re)exports" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
name)
        , String -> SDoc
text String
"but the implementing module exports a different identifier" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
name')
        ]

bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc
bootMisMatch :: IsBootInterface -> SDoc -> TyThing -> TyThing -> SDoc
bootMisMatch IsBootInterface
is_boot SDoc
extra_info TyThing
real_thing TyThing
boot_thing
  = IsBootInterface -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
pprBootMisMatch IsBootInterface
is_boot SDoc
extra_info TyThing
real_thing SDoc
real_doc SDoc
boot_doc
  where
    to_doc :: TyThing -> SDoc
to_doc
      = ShowSub -> TyThing -> SDoc
pprTyThingInContext (ShowSub -> TyThing -> SDoc) -> ShowSub -> TyThing -> SDoc
forall a b. (a -> b) -> a -> b
$ ShowSub
showToHeader { ss_forall :: ShowForAllFlag
ss_forall =
                                              if IsBootInterface
is_boot
                                                then ShowForAllFlag
ShowForAllMust
                                                else ShowForAllFlag
ShowForAllWhen }

    real_doc :: SDoc
real_doc = TyThing -> SDoc
to_doc TyThing
real_thing
    boot_doc :: SDoc
boot_doc = TyThing -> SDoc
to_doc TyThing
boot_thing

    pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
    pprBootMisMatch :: IsBootInterface -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
pprBootMisMatch IsBootInterface
is_boot SDoc
extra_info TyThing
real_thing SDoc
real_doc SDoc
boot_doc
      = [SDoc] -> SDoc
vcat
          [ TyThing -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable TyThing
ppr TyThing
real_thing SDoc -> SDoc -> SDoc
<+>
            String -> SDoc
text String
"has conflicting definitions in the module",
            String -> SDoc
text String
"and its" SDoc -> SDoc -> SDoc
<+>
              (if IsBootInterface
is_boot
                then String -> SDoc
text String
"hs-boot file"
                else String -> SDoc
text String
"hsig file"),
            String -> SDoc
text String
"Main module:" SDoc -> SDoc -> SDoc
<+> SDoc
real_doc,
              (if IsBootInterface
is_boot
                then String -> SDoc
text String
"Boot file:  "
                else String -> SDoc
text String
"Hsig file: ")
                SDoc -> SDoc -> SDoc
<+> SDoc
boot_doc,
            SDoc
extra_info
          ]

instMisMatch :: DFunId -> SDoc
instMisMatch :: Var -> SDoc
instMisMatch Var
dfun
  = SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"instance" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Type
ppr (Var -> Type
idType Var
dfun))
       Arity
2 (String -> SDoc
text String
"is defined in the hs-boot file, but not in the module itself")

{-
************************************************************************
*                                                                      *
        Type-checking the top level of a module (continued)
*                                                                      *
************************************************************************
-}

rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
-- Fails if there are any errors
rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
rnTopSrcDecls HsGroup GhcPs
group
 = do { -- Rename the source decls
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn12" SDoc
empty ;
        (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls) <- TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall r. TcM r -> TcM r
checkNoErrs (TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
 -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed)))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ HsGroup GhcPs -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
rnSrcDecls HsGroup GhcPs
group ;
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn13" SDoc
empty ;
        (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls) <- TcGblEnv
-> HsGroup (GhcPass 'Renamed)
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
runRenamerPlugin TcGblEnv
tcg_env HsGroup (GhcPass 'Renamed)
rn_decls ;
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn13-plugin" SDoc
empty ;

        -- save the renamed syntax, if we want it
        let { tcg_env' :: TcGblEnv
tcg_env'
                | Just HsGroup (GhcPass 'Renamed)
grp <- TcGblEnv -> Maybe (HsGroup (GhcPass 'Renamed))
tcg_rn_decls TcGblEnv
tcg_env
                  = TcGblEnv
tcg_env{ tcg_rn_decls :: Maybe (HsGroup (GhcPass 'Renamed))
tcg_rn_decls = HsGroup (GhcPass 'Renamed) -> Maybe (HsGroup (GhcPass 'Renamed))
forall a. a -> Maybe a
Just (HsGroup (GhcPass 'Renamed)
-> HsGroup (GhcPass 'Renamed) -> HsGroup (GhcPass 'Renamed)
forall (p :: Pass).
HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p)
appendGroups HsGroup (GhcPass 'Renamed)
grp HsGroup (GhcPass 'Renamed)
rn_decls) }
                | IsBootInterface
otherwise
                   = TcGblEnv
tcg_env };

                -- Dump trace of renaming part
        HsGroup (GhcPass 'Renamed) -> TcRnIf TcGblEnv TcLclEnv ()
forall a.
(Outputable a, Data a) =>
a -> TcRnIf TcGblEnv TcLclEnv ()
External instance of the constraint type Data (HsGroup (GhcPass 'Renamed))
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsGroup (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
rnDump HsGroup (GhcPass 'Renamed)
rn_decls ;
        (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TcGblEnv
tcg_env', HsGroup (GhcPass 'Renamed)
rn_decls)
   }

tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls :: HsGroup (GhcPass 'Renamed)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopSrcDecls (HsGroup { hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup (GhcPass 'Renamed)]
tycl_decls,
                         hs_derivds :: forall p. HsGroup p -> [LDerivDecl p]
hs_derivds = [LDerivDecl (GhcPass 'Renamed)]
deriv_decls,
                         hs_fords :: forall p. HsGroup p -> [LForeignDecl p]
hs_fords  = [LForeignDecl (GhcPass 'Renamed)]
foreign_decls,
                         hs_defds :: forall p. HsGroup p -> [LDefaultDecl p]
hs_defds  = [LDefaultDecl (GhcPass 'Renamed)]
default_decls,
                         hs_annds :: forall p. HsGroup p -> [LAnnDecl p]
hs_annds  = [LAnnDecl (GhcPass 'Renamed)]
annotation_decls,
                         hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds = [LRuleDecls (GhcPass 'Renamed)]
rule_decls,
                         hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds  = hs_val_binds :: HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
hs_val_binds@(XValBindsLR
                                              (NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds [LSig (GhcPass 'Renamed)]
val_sigs)) })
 = do {         -- Type-check the type and class decls, and all imported decls
                -- The latter come in via tycl_decls
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc2 (src)" SDoc
empty ;

                -- Source-language instances, including derivings,
                -- and import the supporting declarations
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc3" SDoc
empty ;
        (TcGblEnv
tcg_env, [InstInfo (GhcPass 'Renamed)]
inst_infos, XValBindsLR (NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
deriv_binds [LSig (GhcPass 'Renamed)]
deriv_sigs))
            <- [TyClGroup (GhcPass 'Renamed)]
-> [LDerivDecl (GhcPass 'Renamed)]
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
tcTyClsInstDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls [LDerivDecl (GhcPass 'Renamed)]
deriv_decls [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds ;

        TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env       (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
 -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {

                -- Generate Applicative/Monad proposal (AMP) warnings
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc3b" SDoc
empty ;

                -- Generate Semigroup/Monoid warnings
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc3c" SDoc
empty ;
        TcRnIf TcGblEnv TcLclEnv ()
tcSemigroupWarnings ;

                -- Foreign import declarations next.
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc4" SDoc
empty ;
        ([Var]
fi_ids, [LForeignDecl GhcTc]
fi_decls, Bag GlobalRdrElt
fi_gres) <- [LForeignDecl (GhcPass 'Renamed)]
-> TcM ([Var], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports [LForeignDecl (GhcPass 'Renamed)]
foreign_decls ;
        [Var]
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv [Var]
fi_ids     (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
 -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {

                -- Default declarations
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc4a" SDoc
empty ;
        Maybe [Type]
default_tys <- [LDefaultDecl (GhcPass 'Renamed)] -> TcM (Maybe [Type])
tcDefaults [LDefaultDecl (GhcPass 'Renamed)]
default_decls ;
        (TcGblEnv -> TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
gbl -> TcGblEnv
gbl { tcg_default :: Maybe [Type]
tcg_default = Maybe [Type]
default_tys }) (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
 -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {

                -- Value declarations next.
                -- It is important that we check the top-level value bindings
                -- before the GHC-generated derived bindings, since the latter
                -- may be defined in terms of the former. (For instance,
                -- the bindings produced in a Data instance.)
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc5" SDoc
empty ;
        (TcGblEnv, TcLclEnv)
tc_envs <- [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)]
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds [LSig (GhcPass 'Renamed)]
val_sigs;
        (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
tc_envs (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
 -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {

                -- Now GHC-generated derived bindings, generics, and selectors
                -- Do not generate warnings from compiler-generated code;
                -- hence the use of discardWarnings
        tc_envs :: (TcGblEnv, TcLclEnv)
tc_envs@(TcGblEnv
tcg_env, TcLclEnv
tcl_env)
            <- TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall r. TcM r -> TcM r
discardWarnings ([(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)]
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
deriv_binds [LSig (GhcPass 'Renamed)]
deriv_sigs) ;
        (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
tc_envs (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
 -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {  -- Environment doesn't change now

                -- Second pass over class and instance declarations,
                -- now using the kind-checked decls
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc6" SDoc
empty ;
        LHsBinds GhcTc
inst_binds <- [LTyClDecl (GhcPass 'Renamed)]
-> [InstInfo (GhcPass 'Renamed)] -> TcM (LHsBinds GhcTc)
tcInstDecls2 ([TyClGroup (GhcPass 'Renamed)] -> [LTyClDecl (GhcPass 'Renamed)]
forall pass. [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls) [InstInfo (GhcPass 'Renamed)]
inst_infos ;

                -- Foreign exports
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc7" SDoc
empty ;
        (LHsBinds GhcTc
foe_binds, [LForeignDecl GhcTc]
foe_decls, Bag GlobalRdrElt
foe_gres) <- [LForeignDecl (GhcPass 'Renamed)]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports [LForeignDecl (GhcPass 'Renamed)]
foreign_decls ;

                -- Annotations
        [Annotation]
annotations <- [LAnnDecl (GhcPass 'Renamed)] -> TcM [Annotation]
tcAnnotations [LAnnDecl (GhcPass 'Renamed)]
annotation_decls ;

                -- Rules
        [LRuleDecls GhcTc]
rules <- [LRuleDecls (GhcPass 'Renamed)] -> TcM [LRuleDecls GhcTc]
tcRules [LRuleDecls (GhcPass 'Renamed)]
rule_decls ;

                -- Wrap up
        String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc7a" SDoc
empty ;
        let { all_binds :: LHsBinds GhcTc
all_binds = LHsBinds GhcTc
inst_binds     LHsBinds GhcTc -> LHsBinds GhcTc -> LHsBinds GhcTc
forall a. Bag a -> Bag a -> Bag a
`unionBags`
                          LHsBinds GhcTc
foe_binds

            ; fo_gres :: Bag GlobalRdrElt
fo_gres = Bag GlobalRdrElt
fi_gres Bag GlobalRdrElt -> Bag GlobalRdrElt -> Bag GlobalRdrElt
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag GlobalRdrElt
foe_gres
            ; fo_fvs :: FreeVars
fo_fvs = (GlobalRdrElt -> FreeVars -> FreeVars)
-> FreeVars -> Bag GlobalRdrElt -> FreeVars
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
External instance of the constraint type Foldable Bag
foldr (\GlobalRdrElt
gre FreeVars
fvs -> FreeVars
fvs FreeVars -> Name -> FreeVars
`addOneFV` GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre)
                                FreeVars
emptyFVs Bag GlobalRdrElt
fo_gres

            ; sig_names :: FreeVars
sig_names = [Name] -> FreeVars
mkNameSet (HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> [IdP (GhcPass 'Renamed)]
forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
External instance of the constraint type CollectPass (GhcPass 'Renamed)
collectHsValBinders HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
hs_val_binds)
                          FreeVars -> FreeVars -> FreeVars
`minusNameSet` [LSig (GhcPass 'Renamed)] -> FreeVars
getTypeSigNames [LSig (GhcPass 'Renamed)]
val_sigs

                -- Extend the GblEnv with the (as yet un-zonked)
                -- bindings, rules, foreign decls
            ; tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env { tcg_binds :: LHsBinds GhcTc
tcg_binds   = TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
tcg_env LHsBinds GhcTc -> LHsBinds GhcTc -> LHsBinds GhcTc
forall a. Bag a -> Bag a -> Bag a
`unionBags` LHsBinds GhcTc
all_binds
                                 , tcg_sigs :: FreeVars
tcg_sigs    = TcGblEnv -> FreeVars
tcg_sigs TcGblEnv
tcg_env FreeVars -> FreeVars -> FreeVars
`unionNameSet` FreeVars
sig_names
                                 , tcg_rules :: [LRuleDecl GhcTc]
tcg_rules   = TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env
                                                      [LRuleDecl GhcTc] -> [LRuleDecl GhcTc] -> [LRuleDecl GhcTc]
forall a. [a] -> [a] -> [a]
++ [LRuleDecls GhcTc] -> [LRuleDecl GhcTc]
forall pass. [LRuleDecls pass] -> [LRuleDecl pass]
flattenRuleDecls [LRuleDecls GhcTc]
rules
                                 , tcg_anns :: [Annotation]
tcg_anns    = TcGblEnv -> [Annotation]
tcg_anns TcGblEnv
tcg_env [Annotation] -> [Annotation] -> [Annotation]
forall a. [a] -> [a] -> [a]
++ [Annotation]
annotations
                                 , tcg_ann_env :: AnnEnv
tcg_ann_env = AnnEnv -> [Annotation] -> AnnEnv
extendAnnEnvList (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
tcg_env) [Annotation]
annotations
                                 , tcg_fords :: [LForeignDecl GhcTc]
tcg_fords   = TcGblEnv -> [LForeignDecl GhcTc]
tcg_fords TcGblEnv
tcg_env [LForeignDecl GhcTc]
-> [LForeignDecl GhcTc] -> [LForeignDecl GhcTc]
forall a. [a] -> [a] -> [a]
++ [LForeignDecl GhcTc]
foe_decls [LForeignDecl GhcTc]
-> [LForeignDecl GhcTc] -> [LForeignDecl GhcTc]
forall a. [a] -> [a] -> [a]
++ [LForeignDecl GhcTc]
fi_decls
                                 , tcg_dus :: DefUses
tcg_dus     = TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env DefUses -> DefUses -> DefUses
`plusDU` FreeVars -> DefUses
usesOnly FreeVars
fo_fvs } } ;
                                 -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]

        -- See Note [Newtype constructor usage in foreign declarations]
        [GlobalRdrElt] -> TcRnIf TcGblEnv TcLclEnv ()
addUsedGREs (Bag GlobalRdrElt -> [GlobalRdrElt]
forall a. Bag a -> [a]
bagToList Bag GlobalRdrElt
fo_gres) ;

        (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TcGblEnv
tcg_env', TcLclEnv
tcl_env)
    }}}}}}

tcTopSrcDecls HsGroup (GhcPass 'Renamed)
_ = String -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. String -> a
panic String
"tcTopSrcDecls: ValBindsIn"


tcSemigroupWarnings :: TcM ()
tcSemigroupWarnings :: TcRnIf TcGblEnv TcLclEnv ()
tcSemigroupWarnings = do
    String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcSemigroupWarnings" SDoc
empty
    let warnFlag :: WarningFlag
warnFlag = WarningFlag
Opt_WarnSemigroup
    WarningFlag -> Name -> TcRnIf TcGblEnv TcLclEnv ()
tcPreludeClashWarn WarningFlag
warnFlag Name
sappendName
    WarningFlag -> Name -> Name -> TcRnIf TcGblEnv TcLclEnv ()
tcMissingParentClassWarn WarningFlag
warnFlag Name
monoidClassName Name
semigroupClassName


-- | Warn on local definitions of names that would clash with future Prelude
-- elements.
--
--   A name clashes if the following criteria are met:
--       1. It would is imported (unqualified) from Prelude
--       2. It is locally defined in the current module
--       3. It has the same literal name as the reference function
--       4. It is not identical to the reference function
tcPreludeClashWarn :: WarningFlag
                   -> Name
                   -> TcM ()
tcPreludeClashWarn :: WarningFlag -> Name -> TcRnIf TcGblEnv TcLclEnv ()
tcPreludeClashWarn WarningFlag
warnFlag Name
name = do
    { IsBootInterface
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv IsBootInterface
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl IsBootInterface
woptM WarningFlag
warnFlag
    ; IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when IsBootInterface
warn (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ do
    { String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcPreludeClashWarn/wouldBeImported" SDoc
empty
    -- Is the name imported (unqualified) from Prelude? (Point 4 above)
    ; [ImportDecl (GhcPass 'Renamed)]
rnImports <- (TcGblEnv -> [ImportDecl (GhcPass 'Renamed)])
-> TcM TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) [ImportDecl (GhcPass 'Renamed)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
fmap ((LImportDecl (GhcPass 'Renamed) -> ImportDecl (GhcPass 'Renamed))
-> [LImportDecl (GhcPass 'Renamed)]
-> [ImportDecl (GhcPass 'Renamed)]
forall a b. (a -> b) -> [a] -> [b]
map LImportDecl (GhcPass 'Renamed) -> ImportDecl (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc ([LImportDecl (GhcPass 'Renamed)]
 -> [ImportDecl (GhcPass 'Renamed)])
-> (TcGblEnv -> [LImportDecl (GhcPass 'Renamed)])
-> TcGblEnv
-> [ImportDecl (GhcPass 'Renamed)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> [LImportDecl (GhcPass 'Renamed)]
tcg_rn_imports) TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
    -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude
    -- will not appear in rnImports automatically if it is set.)

    -- Continue only the name is imported from Prelude
    ; IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when (Name -> [ImportDecl (GhcPass 'Renamed)] -> IsBootInterface
importedViaPrelude Name
name [ImportDecl (GhcPass 'Renamed)]
rnImports) (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ do
      -- Handle 2.-4.
    { [GlobalRdrElt]
rdrElts <- (TcGblEnv -> [GlobalRdrElt])
-> TcM TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrElt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
fmap ([[GlobalRdrElt]] -> [GlobalRdrElt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
External instance of the constraint type Foldable []
concat ([[GlobalRdrElt]] -> [GlobalRdrElt])
-> (TcGblEnv -> [[GlobalRdrElt]]) -> TcGblEnv -> [GlobalRdrElt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrEnv -> [[GlobalRdrElt]]
forall a. OccEnv a -> [a]
occEnvElts (GlobalRdrEnv -> [[GlobalRdrElt]])
-> (TcGblEnv -> GlobalRdrEnv) -> TcGblEnv -> [[GlobalRdrElt]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> GlobalRdrEnv
tcg_rdr_env) TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

    ; let clashes :: GlobalRdrElt -> Bool
          clashes :: GlobalRdrElt -> IsBootInterface
clashes GlobalRdrElt
x = IsBootInterface
isLocalDef IsBootInterface -> IsBootInterface -> IsBootInterface
&& IsBootInterface
nameClashes IsBootInterface -> IsBootInterface -> IsBootInterface
&& IsBootInterface
isNotInProperModule
            where
              isLocalDef :: IsBootInterface
isLocalDef = GlobalRdrElt -> IsBootInterface
gre_lcl GlobalRdrElt
x IsBootInterface -> IsBootInterface -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq IsBootInterface
== IsBootInterface
True
              -- Names are identical ...
              nameClashes :: IsBootInterface
nameClashes = Name -> OccName
nameOccName (GlobalRdrElt -> Name
gre_name GlobalRdrElt
x) OccName -> OccName -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq OccName
== Name -> OccName
nameOccName Name
name
              -- ... but not the actual definitions, because we don't want to
              -- warn about a bad definition of e.g. <> in Data.Semigroup, which
              -- is the (only) proper place where this should be defined
              isNotInProperModule :: IsBootInterface
isNotInProperModule = GlobalRdrElt -> Name
gre_name GlobalRdrElt
x Name -> Name -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq Name
/= Name
name

          -- List of all offending definitions
          clashingElts :: [GlobalRdrElt]
          clashingElts :: [GlobalRdrElt]
clashingElts = (GlobalRdrElt -> IsBootInterface)
-> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> IsBootInterface) -> [a] -> [a]
filter GlobalRdrElt -> IsBootInterface
clashes [GlobalRdrElt]
rdrElts

    ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcPreludeClashWarn/prelude_functions"
                (SDoc -> Arity -> SDoc -> SDoc
hang (Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
name) Arity
4 ([SDoc] -> SDoc
sep [[GlobalRdrElt] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable GlobalRdrElt
ppr [GlobalRdrElt]
clashingElts]))

    ; let warn_msg :: GlobalRdrElt -> TcRnIf TcGblEnv TcLclEnv ()
warn_msg GlobalRdrElt
x = WarnReason -> SrcSpan -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
warnFlag) (Name -> SrcSpan
nameSrcSpan (GlobalRdrElt -> Name
gre_name GlobalRdrElt
x)) ([SDoc] -> SDoc
hsep
              [ String -> SDoc
text String
"Local definition of"
              , (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (GlobalRdrElt -> SDoc) -> GlobalRdrElt -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable OccName
ppr (OccName -> SDoc)
-> (GlobalRdrElt -> OccName) -> GlobalRdrElt -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName)
-> (GlobalRdrElt -> Name) -> GlobalRdrElt -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrElt -> Name
gre_name) GlobalRdrElt
x
              , String -> SDoc
text String
"clashes with a future Prelude name." ]
              SDoc -> SDoc -> SDoc
$$
              String -> SDoc
text String
"This will become an error in a future release." )
    ; (GlobalRdrElt -> TcRnIf TcGblEnv TcLclEnv ())
-> [GlobalRdrElt] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
mapM_ GlobalRdrElt -> TcRnIf TcGblEnv TcLclEnv ()
warn_msg [GlobalRdrElt]
clashingElts
    }}}

  where

    -- Is the given name imported via Prelude?
    --
    -- Possible scenarios:
    --   a) Prelude is imported implicitly, issue warnings.
    --   b) Prelude is imported explicitly, but without mentioning the name in
    --      question. Issue no warnings.
    --   c) Prelude is imported hiding the name in question. Issue no warnings.
    --   d) Qualified import of Prelude, no warnings.
    importedViaPrelude :: Name
                       -> [ImportDecl GhcRn]
                       -> Bool
    importedViaPrelude :: Name -> [ImportDecl (GhcPass 'Renamed)] -> IsBootInterface
importedViaPrelude Name
name = (ImportDecl (GhcPass 'Renamed) -> IsBootInterface)
-> [ImportDecl (GhcPass 'Renamed)] -> IsBootInterface
forall (t :: * -> *) a.
Foldable t =>
(a -> IsBootInterface) -> t a -> IsBootInterface
External instance of the constraint type Foldable []
any ImportDecl (GhcPass 'Renamed) -> IsBootInterface
importViaPrelude
      where
        isPrelude :: ImportDecl GhcRn -> Bool
        isPrelude :: ImportDecl (GhcPass 'Renamed) -> IsBootInterface
isPrelude ImportDecl (GhcPass 'Renamed)
imp = Located ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl (GhcPass 'Renamed) -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl (GhcPass 'Renamed)
imp) ModuleName -> ModuleName -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq ModuleName
== ModuleName
pRELUDE_NAME

        -- Implicit (Prelude) import?
        isImplicit :: ImportDecl GhcRn -> Bool
        isImplicit :: ImportDecl (GhcPass 'Renamed) -> IsBootInterface
isImplicit = ImportDecl (GhcPass 'Renamed) -> IsBootInterface
forall pass. ImportDecl pass -> IsBootInterface
ideclImplicit

        -- Unqualified import?
        isUnqualified :: ImportDecl GhcRn -> Bool
        isUnqualified :: ImportDecl (GhcPass 'Renamed) -> IsBootInterface
isUnqualified = IsBootInterface -> IsBootInterface
not (IsBootInterface -> IsBootInterface)
-> (ImportDecl (GhcPass 'Renamed) -> IsBootInterface)
-> ImportDecl (GhcPass 'Renamed)
-> IsBootInterface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDeclQualifiedStyle -> IsBootInterface
isImportDeclQualified (ImportDeclQualifiedStyle -> IsBootInterface)
-> (ImportDecl (GhcPass 'Renamed) -> ImportDeclQualifiedStyle)
-> ImportDecl (GhcPass 'Renamed)
-> IsBootInterface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl (GhcPass 'Renamed) -> ImportDeclQualifiedStyle
forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified

        -- List of explicitly imported (or hidden) Names from a single import.
        --   Nothing -> No explicit imports
        --   Just (False, <names>) -> Explicit import list of <names>
        --   Just (True , <names>) -> Explicit hiding of <names>
        importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name])
        importListOf :: ImportDecl (GhcPass 'Renamed) -> Maybe (IsBootInterface, [Name])
importListOf = ((IsBootInterface,
  GenLocated SrcSpan [GenLocated SrcSpan (IE (GhcPass 'Renamed))])
 -> (IsBootInterface, [Name]))
-> Maybe
     (IsBootInterface,
      GenLocated SrcSpan [GenLocated SrcSpan (IE (GhcPass 'Renamed))])
-> Maybe (IsBootInterface, [Name])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor Maybe
fmap (IsBootInterface,
 GenLocated SrcSpan [GenLocated SrcSpan (IE (GhcPass 'Renamed))])
-> (IsBootInterface, [Name])
forall {a} {l} {l} {p :: Pass}.
(a, GenLocated l [GenLocated l (IE (GhcPass p))])
-> (a, [IdGhcP p])
toImportList (Maybe
   (IsBootInterface,
    GenLocated SrcSpan [GenLocated SrcSpan (IE (GhcPass 'Renamed))])
 -> Maybe (IsBootInterface, [Name]))
-> (ImportDecl (GhcPass 'Renamed)
    -> Maybe
         (IsBootInterface,
          GenLocated SrcSpan [GenLocated SrcSpan (IE (GhcPass 'Renamed))]))
-> ImportDecl (GhcPass 'Renamed)
-> Maybe (IsBootInterface, [Name])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl (GhcPass 'Renamed)
-> Maybe
     (IsBootInterface,
      GenLocated SrcSpan [GenLocated SrcSpan (IE (GhcPass 'Renamed))])
forall pass.
ImportDecl pass -> Maybe (IsBootInterface, Located [LIE pass])
ideclHiding
          where
            toImportList :: (a, GenLocated l [GenLocated l (IE (GhcPass p))])
-> (a, [IdGhcP p])
toImportList (a
h, GenLocated l [GenLocated l (IE (GhcPass p))]
loc) = (a
h, (GenLocated l (IE (GhcPass p)) -> IdGhcP p)
-> [GenLocated l (IE (GhcPass p))] -> [IdGhcP p]
forall a b. (a -> b) -> [a] -> [b]
map (IE (GhcPass p) -> IdGhcP p
forall (p :: Pass). IE (GhcPass p) -> IdP (GhcPass p)
ieName (IE (GhcPass p) -> IdGhcP p)
-> (GenLocated l (IE (GhcPass p)) -> IE (GhcPass p))
-> GenLocated l (IE (GhcPass p))
-> IdGhcP p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated l (IE (GhcPass p)) -> IE (GhcPass p)
forall l e. GenLocated l e -> e
unLoc) (GenLocated l [GenLocated l (IE (GhcPass p))]
-> [GenLocated l (IE (GhcPass p))]
forall l e. GenLocated l e -> e
unLoc GenLocated l [GenLocated l (IE (GhcPass p))]
loc))

        isExplicit :: ImportDecl GhcRn -> Bool
        isExplicit :: ImportDecl (GhcPass 'Renamed) -> IsBootInterface
isExplicit ImportDecl (GhcPass 'Renamed)
x = case ImportDecl (GhcPass 'Renamed) -> Maybe (IsBootInterface, [Name])
importListOf ImportDecl (GhcPass 'Renamed)
x of
            Maybe (IsBootInterface, [Name])
Nothing -> IsBootInterface
False
            Just (IsBootInterface
False, [Name]
explicit)
                -> Name -> OccName
nameOccName Name
name OccName -> [OccName] -> IsBootInterface
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> IsBootInterface
External instance of the constraint type Eq OccName
External instance of the constraint type Foldable []
`elem`    (Name -> OccName) -> [Name] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Name -> OccName
nameOccName [Name]
explicit
            Just (IsBootInterface
True, [Name]
hidden)
                -> Name -> OccName
nameOccName Name
name OccName -> [OccName] -> IsBootInterface
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> IsBootInterface
External instance of the constraint type Eq OccName
External instance of the constraint type Foldable []
`notElem` (Name -> OccName) -> [Name] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Name -> OccName
nameOccName [Name]
hidden

        -- Check whether the given name would be imported (unqualified) from
        -- an import declaration.
        importViaPrelude :: ImportDecl GhcRn -> Bool
        importViaPrelude :: ImportDecl (GhcPass 'Renamed) -> IsBootInterface
importViaPrelude ImportDecl (GhcPass 'Renamed)
x = ImportDecl (GhcPass 'Renamed) -> IsBootInterface
isPrelude ImportDecl (GhcPass 'Renamed)
x
                          IsBootInterface -> IsBootInterface -> IsBootInterface
&& ImportDecl (GhcPass 'Renamed) -> IsBootInterface
isUnqualified ImportDecl (GhcPass 'Renamed)
x
                          IsBootInterface -> IsBootInterface -> IsBootInterface
&& (ImportDecl (GhcPass 'Renamed) -> IsBootInterface
isImplicit ImportDecl (GhcPass 'Renamed)
x IsBootInterface -> IsBootInterface -> IsBootInterface
|| ImportDecl (GhcPass 'Renamed) -> IsBootInterface
isExplicit ImportDecl (GhcPass 'Renamed)
x)


-- Notation: is* is for classes the type is an instance of, should* for those
--           that it should also be an instance of based on the corresponding
--           is*.
tcMissingParentClassWarn :: WarningFlag
                         -> Name -- ^ Instances of this ...
                         -> Name -- ^ should also be instances of this
                         -> TcM ()
tcMissingParentClassWarn :: WarningFlag -> Name -> Name -> TcRnIf TcGblEnv TcLclEnv ()
tcMissingParentClassWarn WarningFlag
warnFlag Name
isName Name
shouldName
  = do { IsBootInterface
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv IsBootInterface
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl IsBootInterface
woptM WarningFlag
warnFlag
       ; IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when IsBootInterface
warn (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ do
       { String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcMissingParentClassWarn" SDoc
empty
       ; Maybe Class
isClass'     <- Name -> TcM (Maybe Class)
tcLookupClass_maybe Name
isName
       ; Maybe Class
shouldClass' <- Name -> TcM (Maybe Class)
tcLookupClass_maybe Name
shouldName
       ; case (Maybe Class
isClass', Maybe Class
shouldClass') of
              (Just Class
isClass, Just Class
shouldClass) -> do
                  { [ClsInst]
localInstances <- TcM [ClsInst]
tcGetInsts
                  ; let isInstance :: ClsInst -> IsBootInterface
isInstance ClsInst
m = ClsInst -> Class
is_cls ClsInst
m Class -> Class -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq Class
== Class
isClass
                        isInsts :: [ClsInst]
isInsts = (ClsInst -> IsBootInterface) -> [ClsInst] -> [ClsInst]
forall a. (a -> IsBootInterface) -> [a] -> [a]
filter ClsInst -> IsBootInterface
isInstance [ClsInst]
localInstances
                  ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcMissingParentClassWarn/isInsts" ([ClsInst] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable ClsInst
ppr [ClsInst]
isInsts)
                  ; [ClsInst]
-> (ClsInst -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
forM_ [ClsInst]
isInsts (Class -> Class -> ClsInst -> TcRnIf TcGblEnv TcLclEnv ()
checkShouldInst Class
isClass Class
shouldClass)
                  }
              (Maybe Class
is',Maybe Class
should') ->
                  String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcMissingParentClassWarn/notIsShould"
                          (SDoc -> Arity -> SDoc -> SDoc
hang (Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
isName SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"/" SDoc -> SDoc -> SDoc
<> Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
shouldName) Arity
2 (
                            ([SDoc] -> SDoc
hsep [ SDoc -> SDoc
quotes (String -> SDoc
text String
"Is"), String -> SDoc
text String
"lookup for"
                                  , Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
isName
                                  , String -> SDoc
text String
"resulted in", Maybe Class -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable (Maybe a)
External instance of the constraint type Outputable Class
ppr Maybe Class
is' ])
                            SDoc -> SDoc -> SDoc
$$
                            ([SDoc] -> SDoc
hsep [ SDoc -> SDoc
quotes (String -> SDoc
text String
"Should"), String -> SDoc
text String
"lookup for"
                                  , Name -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Name
ppr Name
shouldName
                                  , String -> SDoc
text String
"resulted in", Maybe Class -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable (Maybe a)
External instance of the constraint type Outputable Class
ppr Maybe Class
should' ])))
       }}
  where
    -- Check whether the desired superclass exists in a given environment.
    checkShouldInst :: Class   -- ^ Class of existing instance
                    -> Class   -- ^ Class there should be an instance of
                    -> ClsInst -- ^ Existing instance
                    -> TcM ()
    checkShouldInst :: Class -> Class -> ClsInst -> TcRnIf TcGblEnv TcLclEnv ()
checkShouldInst Class
isClass Class
shouldClass ClsInst
isInst
      = do { InstEnvs
instEnv <- TcM InstEnvs
tcGetInstEnvs
           ; let ([InstMatch]
instanceMatches, [ClsInst]
shouldInsts, [InstMatch]
_)
                    = IsBootInterface
-> InstEnvs
-> Class
-> [Type]
-> ([InstMatch], [ClsInst], [InstMatch])
lookupInstEnv IsBootInterface
False InstEnvs
instEnv Class
shouldClass (ClsInst -> [Type]
is_tys ClsInst
isInst)

           ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcMissingParentClassWarn/checkShouldInst"
                     (SDoc -> Arity -> SDoc -> SDoc
hang (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable ClsInst
ppr ClsInst
isInst) Arity
4
                         ([SDoc] -> SDoc
sep [[InstMatch] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type forall a b. (Outputable a, Outputable b) => Outputable (a, b)
External instance of the constraint type Outputable ClsInst
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type forall a. Outputable a => Outputable (Maybe a)
External instance of the constraint type Outputable Type
ppr [InstMatch]
instanceMatches, [ClsInst] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable ClsInst
ppr [ClsInst]
shouldInsts]))

           -- "<location>: Warning: <type> is an instance of <is> but not
           -- <should>" e.g. "Foo is an instance of Monad but not Applicative"
           ; let instLoc :: SrcSpan
instLoc = SrcLoc -> SrcSpan
srcLocSpan (SrcLoc -> SrcSpan) -> (Name -> SrcLoc) -> Name -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SrcLoc
nameSrcLoc (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ ClsInst -> Name
forall a. NamedThing a => a -> Name
External instance of the constraint type NamedThing ClsInst
getName ClsInst
isInst
                 warnMsg :: [Maybe Name] -> TcRnIf TcGblEnv TcLclEnv ()
warnMsg (Just Name
name:[Maybe Name]
_) =
                      WarnReason -> SrcSpan -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
warnFlag) SrcSpan
instLoc (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
                           [SDoc] -> SDoc
hsep [ (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (Name -> SDoc) -> Name -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable OccName
ppr (OccName -> SDoc) -> (Name -> OccName) -> Name -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) Name
name
                                , String -> SDoc
text String
"is an instance of"
                                , (OccName -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable OccName
ppr (OccName -> SDoc) -> (Class -> OccName) -> Class -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (Class -> Name) -> Class -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Name
className) Class
isClass
                                , String -> SDoc
text String
"but not"
                                , (OccName -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable OccName
ppr (OccName -> SDoc) -> (Class -> OccName) -> Class -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (Class -> Name) -> Class -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Name
className) Class
shouldClass ]
                                SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"."
                           SDoc -> SDoc -> SDoc
$$
                           [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"This will become an error in"
                                , String -> SDoc
text String
"a future release." ]
                 warnMsg [Maybe Name]
_ = () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *) a. Applicative f => a -> f a
External instance of the constraint type forall m. Applicative (IOEnv m)
pure ()
           ; IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when ([ClsInst] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [ClsInst]
shouldInsts IsBootInterface -> IsBootInterface -> IsBootInterface
&& [InstMatch] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [InstMatch]
instanceMatches) (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
                  [Maybe Name] -> TcRnIf TcGblEnv TcLclEnv ()
warnMsg (ClsInst -> [Maybe Name]
is_tcs ClsInst
isInst)
           }

    tcLookupClass_maybe :: Name -> TcM (Maybe Class)
    tcLookupClass_maybe :: Name -> TcM (Maybe Class)
tcLookupClass_maybe Name
name = Name -> TcM (MaybeErr SDoc TyThing)
tcLookupImported_maybe Name
name TcM (MaybeErr SDoc TyThing)
-> (MaybeErr SDoc TyThing -> TcM (Maybe Class))
-> TcM (Maybe Class)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
External instance of the constraint type forall m. Monad (IOEnv m)
>>= \case
        Succeeded (ATyCon TyCon
tc) | cls :: Maybe Class
cls@(Just Class
_) <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc -> Maybe Class -> TcM (Maybe Class)
forall (f :: * -> *) a. Applicative f => a -> f a
External instance of the constraint type forall m. Applicative (IOEnv m)
pure Maybe Class
cls
        MaybeErr SDoc TyThing
_else -> Maybe Class -> TcM (Maybe Class)
forall (f :: * -> *) a. Applicative f => a -> f a
External instance of the constraint type forall m. Applicative (IOEnv m)
pure Maybe Class
forall a. Maybe a
Nothing


---------------------------
tcTyClsInstDecls :: [TyClGroup GhcRn]
                 -> [LDerivDecl GhcRn]
                 -> [(RecFlag, LHsBinds GhcRn)]
                 -> TcM (TcGblEnv,            -- The full inst env
                         [InstInfo GhcRn],    -- Source-code instance decls to
                                              -- process; contains all dfuns for
                                              -- this module
                          HsValBinds GhcRn)   -- Supporting bindings for derived
                                              -- instances

tcTyClsInstDecls :: [TyClGroup (GhcPass 'Renamed)]
-> [LDerivDecl (GhcPass 'Renamed)]
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
tcTyClsInstDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls [LDerivDecl (GhcPass 'Renamed)]
deriv_decls [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds
 = [LInstDecl (GhcPass 'Renamed)]
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a. [LInstDecl (GhcPass 'Renamed)] -> TcM a -> TcM a
tcAddDataFamConPlaceholders ([TyClGroup (GhcPass 'Renamed)]
tycl_decls [TyClGroup (GhcPass 'Renamed)]
-> (TyClGroup (GhcPass 'Renamed) -> [LInstDecl (GhcPass 'Renamed)])
-> [LInstDecl (GhcPass 'Renamed)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
External instance of the constraint type Monad []
>>= TyClGroup (GhcPass 'Renamed) -> [LInstDecl (GhcPass 'Renamed)]
forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds) (TcM
   (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
    HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
 -> TcM
      (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
       HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$
   [PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a.
[PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
-> TcM a -> TcM a
tcAddPatSynPlaceholders ([(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
forall id. [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds) (TcM
   (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
    HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
 -> TcM
      (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
       HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$
   do { (TcGblEnv
tcg_env, [InstInfo (GhcPass 'Renamed)]
inst_info, [DerivInfo]
deriv_info)
          <- [TyClGroup (GhcPass 'Renamed)]
-> TcM (TcGblEnv, [InstInfo (GhcPass 'Renamed)], [DerivInfo])
tcTyAndClassDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls ;
      ; TcGblEnv
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM
   (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
    HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
 -> TcM
      (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
       HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ do {
          -- With the @TyClDecl@s and @InstDecl@s checked we're ready to
          -- process the deriving clauses, including data family deriving
          -- clauses discovered in @tcTyAndClassDecls@.
          --
          -- Careful to quit now in case there were instance errors, so that
          -- the deriving errors don't pile up as well.
          ; TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM
          ; (TcGblEnv
tcg_env', [InstInfo (GhcPass 'Renamed)]
inst_info', HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
val_binds)
              <- [DerivInfo]
-> [LDerivDecl (GhcPass 'Renamed)]
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
tcInstDeclsDeriv [DerivInfo]
deriv_info [LDerivDecl (GhcPass 'Renamed)]
deriv_decls
          ; TcGblEnv
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env' (TcM
   (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
    HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
 -> TcM
      (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
       HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ do {
                TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM
              ; (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
 HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)],
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall (f :: * -> *) a. Applicative f => a -> f a
External instance of the constraint type forall m. Applicative (IOEnv m)
pure (TcGblEnv
tcg_env', [InstInfo (GhcPass 'Renamed)]
inst_info' [InstInfo (GhcPass 'Renamed)]
-> [InstInfo (GhcPass 'Renamed)] -> [InstInfo (GhcPass 'Renamed)]
forall a. [a] -> [a] -> [a]
++ [InstInfo (GhcPass 'Renamed)]
inst_info, HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
val_binds)
      }}}

{- *********************************************************************
*                                                                      *
        Checking for 'main'
*                                                                      *
************************************************************************
-}

checkMain :: Bool  -- False => no 'module M(..) where' header at all
          -> Maybe (Located [LIE GhcPs])  -- Export specs of Main module
          -> TcM TcGblEnv
-- If we are in module Main, check that 'main' is defined and exported.
checkMain :: IsBootInterface -> Maybe (Located [LIE GhcPs]) -> TcM TcGblEnv
checkMain IsBootInterface
explicit_mod_hdr Maybe (Located [LIE GhcPs])
export_ies
 = do   { DynFlags
dflags  <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
        ; TcGblEnv
tcg_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; DynFlags
-> TcGblEnv
-> IsBootInterface
-> Maybe (Located [LIE GhcPs])
-> TcM TcGblEnv
check_main DynFlags
dflags TcGblEnv
tcg_env IsBootInterface
explicit_mod_hdr Maybe (Located [LIE GhcPs])
export_ies }

check_main :: DynFlags -> TcGblEnv -> Bool -> Maybe (Located [LIE GhcPs])
           -> TcM TcGblEnv
check_main :: DynFlags
-> TcGblEnv
-> IsBootInterface
-> Maybe (Located [LIE GhcPs])
-> TcM TcGblEnv
check_main DynFlags
dflags TcGblEnv
tcg_env IsBootInterface
explicit_mod_hdr Maybe (Located [LIE GhcPs])
export_ies
 | Module
mod Module -> Module -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type forall unit. Eq unit => Eq (GenModule unit)
External instance of the constraint type Eq (GenUnit UnitId)
/= Module
main_mod
 = String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"checkMain not" (Module -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Module
ppr Module
main_mod SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Module
ppr Module
mod) TcRnIf TcGblEnv TcLclEnv () -> TcM TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
External instance of the constraint type forall m. Monad (IOEnv m)
>>
   TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return TcGblEnv
tcg_env

 | IsBootInterface
otherwise
   -- Compare the list of main functions in scope with those
   --   specified in the export list.
 = do [Name]
mains_all <- RdrName -> RnM [Name]
lookupInfoOccRn RdrName
main_fn
                    -- get all 'main' functions in scope
                    -- They may also be imported from other modules!
      case [ModuleName]
exportedMains of -- check the main(s) specified in the export list
        [ ] -> do
          -- The module has no main functions in the export spec, so we must give
          -- some kind of error message. The tricky part is giving an error message
          -- that accurately characterizes what the problem is.
          -- See Note [Main module without a main function in the export spec]
          String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"checkMain no main module exported" SDoc
ppr_mod_mainfn
          TcRnIf TcGblEnv TcLclEnv ()
complain_no_main
          -- In order to reduce the number of potential error messages, we check
          -- to see if there are any main functions defined (but not exported)...
          case [Name] -> Maybe Name
getSomeMain [Name]
mains_all of
            Maybe Name
Nothing -> TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return TcGblEnv
tcg_env
              -- ...if there are no such main functions, there is nothing we can do...
            Just Name
some_main -> Name -> TcM TcGblEnv
use_as_main Name
some_main
                -- ...if there is such a main function, then communicate this to the
                -- typechecker. This can prevent a spurious "Ambiguous type variable"
                -- error message in certain cases, as described in
                -- Note [Main module without a main function in the export spec].
        [ModuleName]
_ -> do    -- The module has one or more main functions in the export spec
          let mains :: [Name]
mains = [ModuleName] -> [Name] -> [Name]
filterInsMains [ModuleName]
exportedMains [Name]
mains_all
          case [Name]
mains of
            [] -> do  --
              String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"checkMain fail" SDoc
ppr_mod_mainfn
              TcRnIf TcGblEnv TcLclEnv ()
complain_no_main
              TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return TcGblEnv
tcg_env
            [Name
main_name] -> Name -> TcM TcGblEnv
use_as_main Name
main_name
            [Name]
_ -> do           -- multiple main functions are exported
              RdrName -> TcRnIf TcGblEnv TcLclEnv ()
addAmbiguousNameErr RdrName
main_fn          -- issue error msg
              TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return TcGblEnv
tcg_env
  where
    mod :: Module
mod         = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
    main_mod :: Module
main_mod    = DynFlags -> Module
mainModIs DynFlags
dflags
    main_mod_nm :: ModuleName
main_mod_nm = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
main_mod
    main_fn :: RdrName
main_fn     = DynFlags -> RdrName
getMainFun DynFlags
dflags
    occ_main_fn :: OccName
occ_main_fn = RdrName -> OccName
forall name. HasOccName name => name -> OccName
External instance of the constraint type HasOccName RdrName
occName RdrName
main_fn
    interactive :: IsBootInterface
interactive = DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq GhcLink
== GhcLink
LinkInMemory
    exportedMains :: [ModuleName]
exportedMains = Maybe (Located [LIE GhcPs]) -> [ModuleName]
selExportMains Maybe (Located [LIE GhcPs])
export_ies
    ppr_mod_mainfn :: SDoc
ppr_mod_mainfn = Module -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Module
ppr Module
main_mod SDoc -> SDoc -> SDoc
<+> RdrName -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable RdrName
ppr RdrName
main_fn

    -- There is a single exported 'main' function.
    use_as_main :: Name -> TcM TcGblEnv
    use_as_main :: Name -> TcM TcGblEnv
use_as_main Name
main_name = do
        { String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"checkMain found" (Module -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Module
ppr Module
main_mod SDoc -> SDoc -> SDoc
<+> RdrName -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable RdrName
ppr RdrName
main_fn)
        ; let loc :: SrcSpan
loc       = SrcLoc -> SrcSpan
srcLocSpan (Name -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
External instance of the constraint type NamedThing Name
getSrcLoc Name
main_name)
        ; TyCon
ioTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
ioTyConName
        ; Type
res_ty <- Type -> TcM Type
newFlexiTyVarTy Type
liftedTypeKind
        ; let io_ty :: Type
io_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
ioTyCon [Type
res_ty]
              skol_info :: SkolemInfo
skol_info = UserTypeCtxt -> Type -> [(Name, Var)] -> SkolemInfo
SigSkol (Name -> IsBootInterface -> UserTypeCtxt
FunSigCtxt Name
main_name IsBootInterface
False) Type
io_ty []
        ; (TcEvBinds
ev_binds, LHsExpr GhcTc
main_expr)
               <- SkolemInfo
-> [Var]
-> [Var]
-> TcM (LHsExpr GhcTc)
-> TcM (TcEvBinds, LHsExpr GhcTc)
forall result.
SkolemInfo
-> [Var] -> [Var] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints SkolemInfo
skol_info [] [] (TcM (LHsExpr GhcTc) -> TcM (TcEvBinds, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (TcEvBinds, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                  SDoc -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
mainCtxt    (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                  Located (HsExpr (GhcPass 'Renamed))
-> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr (SrcSpan
-> HsExpr (GhcPass 'Renamed) -> Located (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XVar (GhcPass 'Renamed)
-> Located (IdP (GhcPass 'Renamed)) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
main_name)))
                          (Type -> ExpRhoType
mkCheckExpType Type
io_ty)

                -- See Note [Root-main Id]
                -- Construct the binding
                --      :Main.main :: IO res_ty = runMainIO res_ty main
        ; Var
run_main_id <- Name -> TcM Var
tcLookupId Name
runMainIOName
        ; let { root_main_name :: Name
root_main_name =  Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
rootMainKey Module
rOOT_MAIN
                                   (FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"main"))
                                   (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
External instance of the constraint type NamedThing Name
getSrcSpan Name
main_name)
              ; root_main_id :: Var
root_main_id = Name -> Type -> Var
Id.mkExportedVanillaId Name
root_main_name
                                                      (TyCon -> [Type] -> Type
mkTyConApp TyCon
ioTyCon [Type
res_ty])
              ; co :: HsWrapper
co  = [Type] -> HsWrapper
mkWpTyApps [Type
res_ty]
              -- The ev_binds of the `main` function may contain deferred
              -- type error when type of `main` is not `IO a`. The `ev_binds`
              -- must be put inside `runMainIO` to ensure the deferred type
              -- error can be emitted correctly. See #13838.
              ; rhs :: LHsExpr GhcTc
rhs = LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Typechecked
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
co (IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Var
IdP GhcTc
run_main_id)) (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                        TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet TcEvBinds
ev_binds LHsExpr GhcTc
main_expr
              ; main_bind :: GenLocated SrcSpan (HsBindLR GhcTc GhcTc)
main_bind = IdP GhcTc
-> LHsExpr GhcTc -> GenLocated SrcSpan (HsBindLR GhcTc GhcTc)
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Var
IdP GhcTc
root_main_id LHsExpr GhcTc
rhs }

        ; TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TcGblEnv
tcg_env { tcg_main :: Maybe Name
tcg_main  = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
main_name,
                            tcg_binds :: LHsBinds GhcTc
tcg_binds = TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
tcg_env
                                        LHsBinds GhcTc
-> GenLocated SrcSpan (HsBindLR GhcTc GhcTc) -> LHsBinds GhcTc
forall a. Bag a -> a -> Bag a
`snocBag` GenLocated SrcSpan (HsBindLR GhcTc GhcTc)
main_bind,
                            tcg_dus :: DefUses
tcg_dus   = TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env
                                        DefUses -> DefUses -> DefUses
`plusDU` FreeVars -> DefUses
usesOnly (Name -> FreeVars
unitFV Name
main_name)
                        -- Record the use of 'main', so that we don't
                        -- complain about it being defined but not used
        })}

    complain_no_main :: TcRnIf TcGblEnv TcLclEnv ()
complain_no_main = IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
unless (IsBootInterface
interactive IsBootInterface -> IsBootInterface -> IsBootInterface
&& IsBootInterface -> IsBootInterface
not IsBootInterface
explicit_mod_hdr)
                              (SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrTc SDoc
noMainMsg)                  -- #12906
        -- Without an explicit module header...
          -- in interactive mode, don't worry about the absence of 'main'.
          -- in other modes, add error message and go on with typechecking.

    mainCtxt :: SDoc
mainCtxt  = String -> SDoc
text String
"When checking the type of the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_main_fn
    noMainMsg :: SDoc
noMainMsg = String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> SDoc
pp_main_fn
                SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
defOrExp SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"module"
                SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Module
ppr Module
main_mod)
    defOrExp :: String
defOrExp  = if [ModuleName] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [ModuleName]
exportedMains then String
"exported by" else String
"defined in"

    pp_main_fn :: SDoc
pp_main_fn = RdrName -> SDoc
ppMainFn RdrName
main_fn

    -- Select the main functions from the export list.
    -- Only the module name is needed, the function name is fixed.
    selExportMains :: Maybe (Located [LIE GhcPs]) -> [ModuleName]    -- #16453
    selExportMains :: Maybe (Located [LIE GhcPs]) -> [ModuleName]
selExportMains Maybe (Located [LIE GhcPs])
Nothing = [ModuleName
main_mod_nm]
        -- no main specified, but there is a header.
    selExportMains (Just Located [LIE GhcPs]
exps) = ((ModuleName, OccName) -> ModuleName)
-> [(ModuleName, OccName)] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor []
fmap (ModuleName, OccName) -> ModuleName
forall a b. (a, b) -> a
fst ([(ModuleName, OccName)] -> [ModuleName])
-> [(ModuleName, OccName)] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
        ((ModuleName, OccName) -> IsBootInterface)
-> [(ModuleName, OccName)] -> [(ModuleName, OccName)]
forall a. (a -> IsBootInterface) -> [a] -> [a]
filter (\(ModuleName
_,OccName
n) -> OccName
n OccName -> OccName -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq OccName
== OccName
occ_main_fn ) [(ModuleName, OccName)]
texp
      where
        ies :: [IE GhcPs]
ies = (LIE GhcPs -> IE GhcPs) -> [LIE GhcPs] -> [IE GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor []
fmap LIE GhcPs -> IE GhcPs
forall l e. GenLocated l e -> e
unLoc ([LIE GhcPs] -> [IE GhcPs]) -> [LIE GhcPs] -> [IE GhcPs]
forall a b. (a -> b) -> a -> b
$ Located [LIE GhcPs] -> [LIE GhcPs]
forall l e. GenLocated l e -> e
unLoc Located [LIE GhcPs]
exps
        texp :: [(ModuleName, OccName)]
texp = (IE GhcPs -> Maybe (ModuleName, OccName))
-> [IE GhcPs] -> [(ModuleName, OccName)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe IE GhcPs -> Maybe (ModuleName, OccName)
transExportIE [IE GhcPs]
ies

    -- Filter all main functions in scope that match the export specs
    filterInsMains :: [ModuleName] -> [Name] -> [Name]               -- #16453
    filterInsMains :: [ModuleName] -> [Name] -> [Name]
filterInsMains [ModuleName]
export_mains [Name]
inscope_mains =
      [Name
mod | Name
mod <- [Name]
inscope_mains,
          (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> (Name -> Module) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Name -> Module
Name -> Module
External instance of the constraint type HasDebugCallStack
nameModule) Name
mod ModuleName -> [ModuleName] -> IsBootInterface
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> IsBootInterface
External instance of the constraint type Eq ModuleName
External instance of the constraint type Foldable []
`elem` [ModuleName]
export_mains]

    -- Transform an export_ie to a (ModuleName, OccName) pair.
    -- 'IEVar' constructors contain exported values (functions), eg '(Main.main)'
    -- 'IEModuleContents' constructors contain fully exported modules, eg '(Main)'
    -- All other 'IE...' constructors are not used and transformed to Nothing.
    transExportIE :: IE GhcPs -> Maybe (ModuleName, OccName)         -- #16453
    transExportIE :: IE GhcPs -> Maybe (ModuleName, OccName)
transExportIE (IEVar XIEVar GhcPs
_  LIEWrappedName (IdP GhcPs)
var) = RdrName -> Maybe (ModuleName, OccName)
isQual_maybe (RdrName -> Maybe (ModuleName, OccName))
-> RdrName -> Maybe (ModuleName, OccName)
forall a b. (a -> b) -> a -> b
$
         RdrName -> RdrName
upqual (RdrName -> RdrName) -> RdrName -> RdrName
forall a b. (a -> b) -> a -> b
$ IEWrappedName RdrName -> RdrName
forall name. IEWrappedName name -> name
ieWrappedName (IEWrappedName RdrName -> RdrName)
-> IEWrappedName RdrName -> RdrName
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan (IEWrappedName RdrName) -> IEWrappedName RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (IEWrappedName RdrName)
LIEWrappedName (IdP GhcPs)
var
       where
         -- A module name is always needed, so qualify 'UnQual' rdr names.
         upqual :: RdrName -> RdrName
upqual (Unqual OccName
occ) = ModuleName -> OccName -> RdrName
Qual ModuleName
main_mod_nm OccName
occ
         upqual RdrName
rdr = RdrName
rdr
    transExportIE (IEModuleContents XIEModuleContents GhcPs
_ Located ModuleName
mod) = (ModuleName, OccName) -> Maybe (ModuleName, OccName)
forall a. a -> Maybe a
Just (Located ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc Located ModuleName
mod, OccName
occ_main_fn)
    transExportIE IE GhcPs
_ = Maybe (ModuleName, OccName)
forall a. Maybe a
Nothing

    -- Get a main function that is in scope.
    -- See Note [Main module without a main function in the export spec]
    getSomeMain :: [Name] -> Maybe Name                            -- #16453
    getSomeMain :: [Name] -> Maybe Name
getSomeMain [Name]
all_mains = case [Name]
all_mains of
        []  -> Maybe Name
forall a. Maybe a
Nothing                -- No main function in scope
        [Name
m] -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
m                 -- Just one main function in scope
        [Name]
_   -> case Maybe Name
mbMainOfMain of
          Maybe Name
Nothing -> [Name] -> Maybe Name
forall a. [a] -> Maybe a
listToMaybe [Name]
all_mains -- Take the first main function in scope or Nothing
          Maybe Name
_       -> Maybe Name
mbMainOfMain          -- Take the Main module's main function or Nothing
      where
        mbMainOfMain :: Maybe Name
mbMainOfMain = (Name -> IsBootInterface) -> [Name] -> Maybe Name
forall (t :: * -> *) a.
Foldable t =>
(a -> IsBootInterface) -> t a -> Maybe a
External instance of the constraint type Foldable []
find (\Name
n -> (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> (Name -> Module) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Name -> Module
Name -> Module
External instance of the constraint type HasDebugCallStack
nameModule) Name
n ModuleName -> ModuleName -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq ModuleName
== ModuleName
main_mod_nm )
                          [Name]
all_mains         -- the main function of the Main module

-- | Get the unqualified name of the function to use as the \"main\" for the main module.
-- Either returns the default name or the one configured on the command line with -main-is
getMainFun :: DynFlags -> RdrName
getMainFun :: DynFlags -> RdrName
getMainFun DynFlags
dflags = case DynFlags -> Maybe String
mainFunIs DynFlags
dflags of
                      Just String
fn -> OccName -> RdrName
mkRdrUnqual (FastString -> OccName
mkVarOccFS (String -> FastString
mkFastString String
fn))
                      Maybe String
Nothing -> RdrName
main_RDR_Unqual

ppMainFn :: RdrName -> SDoc
ppMainFn :: RdrName -> SDoc
ppMainFn RdrName
main_fn
  | RdrName -> OccName
rdrNameOcc RdrName
main_fn OccName -> OccName -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq OccName
== OccName
mainOcc
  = String -> SDoc
text String
"IO action" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable RdrName
ppr RdrName
main_fn)
  | IsBootInterface
otherwise
  = String -> SDoc
text String
"main IO action" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable RdrName
ppr RdrName
main_fn)

mainOcc :: OccName
mainOcc :: OccName
mainOcc = FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"main")

{-
Note [Root-main Id]
~~~~~~~~~~~~~~~~~~~
The function that the RTS invokes is always :Main.main, which we call
root_main_id.  (Because GHC allows the user to have a module not
called Main as the main module, we can't rely on the main function
being called "Main.main".  That's why root_main_id has a fixed module
":Main".)

This is unusual: it's a LocalId whose Name has a Module from another
module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we
get two defns for 'main' in the interface file!


Note [Main module without a main function in the export spec]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Giving accurate error messages for a Main module that does not export a main
function is surprisingly tricky. To see why, consider a module in a file
`Foo.hs` that has no `main` function in the explicit export specs of the module
header:

    module Main () where
    foo = return ()

This does not export a main function and therefore should be rejected, per
chapter 5 of the Haskell Report 2010:

   A Haskell program is a collection of modules, one of which, by convention,
   must be called Main and must export the value main. The value of the
   program is the value of the identifier main in module Main, which must be
   a computation of type IO τ for some type τ.

In fact, when you compile the program above using `ghc Foo.hs`, you will
actually get *two* errors:

 - The IO action ‘main’ is not defined in module ‘Main’

 - Ambiguous type variable ‘m0’ arising from a use of ‘return’
   prevents the constraint ‘(Monad m0)’ from being solved.

The first error is self-explanatory, while the second error message occurs
due to the monomorphism restriction.

Now consider what would happen if the program above were compiled with
`ghc -main-is foo Foo`. The has the effect of `foo` being designated as the
main function. The program will still be rejected since it does not export
`foo` (and therefore does not export its main function), but there is one
important difference: `foo` will be checked against the type `IO τ`. As a
result, we would *not* expect the monomorphism restriction error message
to occur, since the typechecker should have no trouble figuring out the type
of `foo`. In other words, we should only throw the former error message,
not the latter.

The implementation uses the function `getSomeMain` to find a potential main
function that is defined but not exported. If one is found, it is passed to
`use_as_main` to inform the typechecker that the main function should be of
type `IO τ`. See also the `T414` and `T17171a` test cases for similar examples
of programs whose error messages are influenced by the situation described in
this Note.


*********************************************************
*                                                       *
                GHCi stuff
*                                                       *
*********************************************************
-}

runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
-- Initialise the tcg_inst_env with instances from all home modules.
-- This mimics the more selective call to hptInstances in tcRnImports
runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env TcRn a
thing_inside
  = HscEnv -> TcRn a -> IO (Messages, Maybe a)
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
initTcInteractive HscEnv
hsc_env (TcRn a -> IO (Messages, Maybe a))
-> TcRn a -> IO (Messages, Maybe a)
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcRn a -> TcRn a
forall a. HscEnv -> TcM a -> TcM a
withTcPlugins HscEnv
hsc_env (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcRn a -> TcRn a
forall a. HscEnv -> TcM a -> TcM a
withHoleFitPlugins HscEnv
hsc_env (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall a b. (a -> b) -> a -> b
$
    do { String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"setInteractiveContext" (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
            [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"ic_tythings:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((TyThing -> SDoc) -> [TyThing] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable TyThing
ppr (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
icxt))
                 , String -> SDoc
text String
"ic_insts:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> Var -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
External instance of the constraint type OutputableBndr Var
pprBndr BindingSite
LetBind (Var -> SDoc) -> (ClsInst -> Var) -> ClsInst -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Var
instanceDFunId) [ClsInst]
ic_insts)
                 , String -> SDoc
text String
"ic_rn_gbl_env (LocalDef)" SDoc -> SDoc -> SDoc
<+>
                      [SDoc] -> SDoc
vcat (([GlobalRdrElt] -> SDoc) -> [[GlobalRdrElt]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map [GlobalRdrElt] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable GlobalRdrElt
ppr [ [GlobalRdrElt]
local_gres | [GlobalRdrElt]
gres <- GlobalRdrEnv -> [[GlobalRdrElt]]
forall a. OccEnv a -> [a]
occEnvElts (InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
icxt)
                                                 , let local_gres :: [GlobalRdrElt]
local_gres = (GlobalRdrElt -> IsBootInterface)
-> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> IsBootInterface) -> [a] -> [a]
filter GlobalRdrElt -> IsBootInterface
isLocalGRE [GlobalRdrElt]
gres
                                                 , IsBootInterface -> IsBootInterface
not ([GlobalRdrElt] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [GlobalRdrElt]
local_gres) ]) ]

       ; let getOrphans :: ModuleName
-> Maybe FastString -> IOEnv (Env TcGblEnv TcLclEnv) [Module]
getOrphans ModuleName
m Maybe FastString
mb_pkg = (ModIface_ 'ModIfaceFinal -> [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
-> IOEnv (Env TcGblEnv TcLclEnv) [Module]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
fmap (\ModIface_ 'ModIfaceFinal
iface -> ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface_ 'ModIfaceFinal
iface
                                          Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: Dependencies -> [Module]
dep_orphs (ModIface_ 'ModIfaceFinal -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface_ 'ModIfaceFinal
iface))
                                 (SDoc
-> ModuleName
-> IsBootInterface
-> Maybe FastString
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
loadSrcInterface (String -> SDoc
text String
"runTcInteractive") ModuleName
m
                                                   IsBootInterface
False Maybe FastString
mb_pkg)

       ; ![Module]
orphs <- ([[Module]] -> [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) [[Module]]
-> IOEnv (Env TcGblEnv TcLclEnv) [Module]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
fmap ([Module] -> [Module]
forall a. NFData a => a -> a
External instance of the constraint type forall a. NFData a => NFData [a]
External instance of the constraint type forall a. NFData (GenModule a)
force ([Module] -> [Module])
-> ([[Module]] -> [Module]) -> [[Module]] -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Module]] -> [Module]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
External instance of the constraint type Foldable []
concat) (IOEnv (Env TcGblEnv TcLclEnv) [[Module]]
 -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> ((InteractiveImport -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
    -> IOEnv (Env TcGblEnv TcLclEnv) [[Module]])
-> (InteractiveImport -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InteractiveImport]
-> (InteractiveImport -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) [[Module]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
forM (InteractiveContext -> [InteractiveImport]
ic_imports InteractiveContext
icxt) ((InteractiveImport -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
 -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> (InteractiveImport -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) [Module]
forall a b. (a -> b) -> a -> b
$ \InteractiveImport
i ->
            case InteractiveImport
i of                   -- force above: see #15111
                IIModule ModuleName
n -> ModuleName
-> Maybe FastString -> IOEnv (Env TcGblEnv TcLclEnv) [Module]
getOrphans ModuleName
n Maybe FastString
forall a. Maybe a
Nothing
                IIDecl ImportDecl GhcPs
i ->
                  let mb_pkg :: Maybe FastString
mb_pkg = StringLiteral -> FastString
sl_fs (StringLiteral -> FastString)
-> Maybe StringLiteral -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor Maybe
<$> ImportDecl GhcPs -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl GhcPs
i in
                  ModuleName
-> Maybe FastString -> IOEnv (Env TcGblEnv TcLclEnv) [Module]
getOrphans (Located ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcPs
i)) Maybe FastString
mb_pkg

       ; let imports :: ImportAvails
imports = ImportAvails
emptyImportAvails {
                            imp_orphs :: [Module]
imp_orphs = [Module]
orphs
                        }

       ; (TcGblEnv
gbl_env, TcLclEnv
lcl_env) <- TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs
       ; let gbl_env' :: TcGblEnv
gbl_env' = TcGblEnv
gbl_env {
                           tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env      = InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
icxt
                         , tcg_type_env :: TypeEnv
tcg_type_env     = TypeEnv
type_env
                         , tcg_inst_env :: InstEnv
tcg_inst_env     = InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList
                                               (InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList (TcGblEnv -> InstEnv
tcg_inst_env TcGblEnv
gbl_env) [ClsInst]
ic_insts)
                                               [ClsInst]
home_insts
                         , tcg_fam_inst_env :: FamInstEnv
tcg_fam_inst_env = FamInstEnv -> [FamInst] -> FamInstEnv
extendFamInstEnvList
                                               (FamInstEnv -> [FamInst] -> FamInstEnv
extendFamInstEnvList (TcGblEnv -> FamInstEnv
tcg_fam_inst_env TcGblEnv
gbl_env)
                                                                     [FamInst]
ic_finsts)
                                               [FamInst]
home_fam_insts
                         , tcg_field_env :: RecFieldEnv
tcg_field_env    = [(Name, [FieldLbl Name])] -> RecFieldEnv
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name, [FieldLbl Name])]
con_fields
                              -- setting tcg_field_env is necessary
                              -- to make RecordWildCards work (test: ghci049)
                         , tcg_fix_env :: FixityEnv
tcg_fix_env      = InteractiveContext -> FixityEnv
ic_fix_env InteractiveContext
icxt
                         , tcg_default :: Maybe [Type]
tcg_default      = InteractiveContext -> Maybe [Type]
ic_default InteractiveContext
icxt
                              -- must calculate imp_orphs of the ImportAvails
                              -- so that instance visibility is done correctly
                         , tcg_imports :: ImportAvails
tcg_imports      = ImportAvails
imports
                         }

             lcl_env' :: TcLclEnv
lcl_env' = TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv
tcExtendLocalTypeEnv TcLclEnv
lcl_env [(Name, TcTyThing)]
lcl_ids

       ; (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
gbl_env', TcLclEnv
lcl_env') TcRn a
thing_inside }
  where
    ([ClsInst]
home_insts, [FamInst]
home_fam_insts) = HscEnv -> (ModuleName -> IsBootInterface) -> ([ClsInst], [FamInst])
hptInstances HscEnv
hsc_env (\ModuleName
_ -> IsBootInterface
True)

    icxt :: InteractiveContext
icxt                     = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
    ([ClsInst]
ic_insts, [FamInst]
ic_finsts)    = InteractiveContext -> ([ClsInst], [FamInst])
ic_instances InteractiveContext
icxt
    ([(Name, TcTyThing)]
lcl_ids, [TyThing]
top_ty_things) = (TyThing -> Either (Name, TcTyThing) TyThing)
-> [TyThing] -> ([(Name, TcTyThing)], [TyThing])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith TyThing -> Either (Name, TcTyThing) TyThing
is_closed (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
icxt)

    is_closed :: TyThing -> Either (Name, TcTyThing) TyThing
    -- Put Ids with free type variables (always RuntimeUnks)
    -- in the *local* type environment
    -- See Note [Initialising the type environment for GHCi]
    is_closed :: TyThing -> Either (Name, TcTyThing) TyThing
is_closed TyThing
thing
      | AnId Var
id <- TyThing
thing
      , IsBootInterface -> IsBootInterface
not (Var -> IsBootInterface
isTypeClosedLetBndr Var
id)
      = (Name, TcTyThing) -> Either (Name, TcTyThing) TyThing
forall a b. a -> Either a b
Left (Var -> Name
idName Var
id, ATcId :: Var -> IdBindingInfo -> TcTyThing
ATcId { tct_id :: Var
tct_id = Var
id
                               , tct_info :: IdBindingInfo
tct_info = IdBindingInfo
NotLetBound })
      | IsBootInterface
otherwise
      = TyThing -> Either (Name, TcTyThing) TyThing
forall a b. b -> Either a b
Right TyThing
thing

    type_env1 :: TypeEnv
type_env1 = [TyThing] -> TypeEnv
mkTypeEnvWithImplicits [TyThing]
top_ty_things
    type_env :: TypeEnv
type_env  = TypeEnv -> [Var] -> TypeEnv
extendTypeEnvWithIds TypeEnv
type_env1 ((ClsInst -> Var) -> [ClsInst] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> Var
instanceDFunId [ClsInst]
ic_insts)
                -- Putting the dfuns in the type_env
                -- is just to keep Core Lint happy

    con_fields :: [(Name, [FieldLbl Name])]
con_fields = [ (DataCon -> Name
dataConName DataCon
c, DataCon -> [FieldLbl Name]
dataConFieldLabels DataCon
c)
                 | ATyCon TyCon
t <- [TyThing]
top_ty_things
                 , DataCon
c <- TyCon -> [DataCon]
tyConDataCons TyCon
t ]


{- Note [Initialising the type environment for GHCi]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Most of the Ids in ic_things, defined by the user in 'let' stmts,
have closed types. E.g.
   ghci> let foo x y = x && not y

However the GHCi debugger creates top-level bindings for Ids whose
types have free RuntimeUnk skolem variables, standing for unknown
types.  If we don't register these free TyVars as global TyVars then
the typechecker will try to quantify over them and fall over in
skolemiseQuantifiedTyVar. so we must add any free TyVars to the
typechecker's global TyVar set.  That is done by using
tcExtendLocalTypeEnv.

We do this by splitting out the Ids with open types, using 'is_closed'
to do the partition.  The top-level things go in the global TypeEnv;
the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the
local TypeEnv.

Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope
things are already in the interactive context's GlobalRdrEnv.
Extending the local RdrEnv isn't terrible, but it means there is an
entry for the same Name in both global and local RdrEnvs, and that
lead to duplicate "perhaps you meant..." suggestions (e.g. T5564).

We don't bother with the tcl_th_bndrs environment either.
-}

-- | The returned [Id] is the list of new Ids bound by this statement. It can
-- be used to extend the InteractiveContext via extendInteractiveContext.
--
-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
-- values, coerced to ().
tcRnStmt :: HscEnv -> GhciLStmt GhcPs
         -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
tcRnStmt :: HscEnv
-> GhciLStmt GhcPs
-> IO (Messages, Maybe ([Var], LHsExpr GhcTc, FixityEnv))
tcRnStmt HscEnv
hsc_env GhciLStmt GhcPs
rdr_stmt
  = HscEnv
-> TcRn ([Var], LHsExpr GhcTc, FixityEnv)
-> IO (Messages, Maybe ([Var], LHsExpr GhcTc, FixityEnv))
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn ([Var], LHsExpr GhcTc, FixityEnv)
 -> IO (Messages, Maybe ([Var], LHsExpr GhcTc, FixityEnv)))
-> TcRn ([Var], LHsExpr GhcTc, FixityEnv)
-> IO (Messages, Maybe ([Var], LHsExpr GhcTc, FixityEnv))
forall a b. (a -> b) -> a -> b
$ do {

    -- The real work is done here
    (([Var]
bound_ids, LHsExpr GhcTc
tc_expr), FixityEnv
fix_env) <- GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
tcUserStmt GhciLStmt GhcPs
rdr_stmt ;
    LHsExpr GhcTc
zonked_expr <- LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkTopLExpr LHsExpr GhcTc
tc_expr ;
    [Var]
zonked_ids  <- [Var] -> TcM [Var]
zonkTopBndrs [Var]
bound_ids ;

    TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM ;  -- we can't do the next step if there are levity polymorphism errors
                   -- test case: ghci/scripts/T13202{,a}

        -- None of the Ids should be of unboxed type, because we
        -- cast them all to HValues in the end!
    (Var -> TcRnIf TcGblEnv TcLclEnv ())
-> [Var] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
mapM_ Var -> TcRnIf TcGblEnv TcLclEnv ()
bad_unboxed ((Var -> IsBootInterface) -> [Var] -> [Var]
forall a. (a -> IsBootInterface) -> [a] -> [a]
filter (HasDebugCallStack => Type -> IsBootInterface
Type -> IsBootInterface
External instance of the constraint type HasDebugCallStack
isUnliftedType (Type -> IsBootInterface)
-> (Var -> Type) -> Var -> IsBootInterface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Type
idType) [Var]
zonked_ids) ;

    String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcs 1" SDoc
empty ;
    Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
External instance of the constraint type forall env. ContainsModule env => HasModule (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsModule gbl => ContainsModule (Env gbl lcl)
External instance of the constraint type ContainsModule TcGblEnv
getModule ;
    [Var]
global_ids <- (Var -> TcM Var) -> [Var] -> TcM [Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM (Module -> Var -> TcM Var
externaliseAndTidyId Module
this_mod) [Var]
zonked_ids ;
        -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types

{- ---------------------------------------------
   At one stage I removed any shadowed bindings from the type_env;
   they are inaccessible but might, I suppose, cause a space leak if we leave them there.
   However, with Template Haskell they aren't necessarily inaccessible.  Consider this
   GHCi session
         Prelude> let f n = n * 2 :: Int
         Prelude> fName <- runQ [| f |]
         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
         14
         Prelude> let f n = n * 3 :: Int
         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
   In the last line we use 'fName', which resolves to the *first* 'f'
   in scope. If we delete it from the type env, GHCi crashes because
   it doesn't expect that.

   Hence this code is commented out

-------------------------------------------------- -}

    DumpFlag -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceOptTcRn DumpFlag
Opt_D_dump_tc
        ([SDoc] -> SDoc
vcat [String -> SDoc
text String
"Bound Ids" SDoc -> SDoc -> SDoc
<+> (Var -> SDoc) -> [Var] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Var -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Var
ppr [Var]
global_ids,
               String -> SDoc
text String
"Typechecked expr" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Var
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr LHsExpr GhcTc
zonked_expr]) ;

    ([Var], LHsExpr GhcTc, FixityEnv)
-> TcRn ([Var], LHsExpr GhcTc, FixityEnv)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([Var]
global_ids, LHsExpr GhcTc
zonked_expr, FixityEnv
fix_env)
    }
  where
    bad_unboxed :: Var -> TcRnIf TcGblEnv TcLclEnv ()
bad_unboxed Var
id = SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErr ([SDoc] -> SDoc
sep [String -> SDoc
text String
"GHCi can't bind a variable of unlifted type:",
                                  Arity -> SDoc -> SDoc
nest Arity
2 (Var -> SDoc
forall a. OutputableBndr a => a -> SDoc
External instance of the constraint type OutputableBndr Var
pprPrefixOcc Var
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Type
ppr (Var -> Type
idType Var
id))])

{-
--------------------------------------------------------------------------
                Typechecking Stmts in GHCi

Here is the grand plan, implemented in tcUserStmt

        What you type                   The IO [HValue] that hscStmt returns
        -------------                   ------------------------------------
        let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
                                        bindings: [x,y,...]

        pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
                                        bindings: [x,y,...]

        expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
          [NB: result not printed]      bindings: [it]

        expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
          result showable)              bindings: [it]

        expr (of non-IO type,
          result not showable)  ==>     error
-}

-- | A plan is an attempt to lift some code into the IO monad.
type PlanResult = ([Id], LHsExpr GhcTc)
type Plan = TcM PlanResult

-- | Try the plans in order. If one fails (by raising an exn), try the next.
-- If one succeeds, take it.
runPlans :: [Plan] -> TcM PlanResult
runPlans :: [Plan] -> Plan
runPlans []     = String -> Plan
forall a. String -> a
panic String
"runPlans"
runPlans [Plan
p]    = Plan
p
runPlans (Plan
p:[Plan]
ps) = Plan -> Plan -> Plan
forall r. TcM r -> TcM r -> TcM r
tryTcDiscardingErrs ([Plan] -> Plan
runPlans [Plan]
ps) Plan
p

-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
-- GHCi 'environment'.
--
-- By 'lift' and 'environment we mean that the code is changed to
-- execute properly in an IO monad. See Note [Interactively-bound Ids
-- in GHCi] in GHC.Driver.Types for more details. We do this lifting by trying
-- different ways ('plans') of lifting the code into the IO monad and
-- type checking each plan until one succeeds.
tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)

-- An expression typed at the prompt is treated very specially
tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
tcUserStmt (L SrcSpan
loc (BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LHsExpr GhcPs
expr SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_))
  = do  { (Located (HsExpr (GhcPass 'Renamed))
rn_expr, FreeVars
fvs) <- TcM (Located (HsExpr (GhcPass 'Renamed)), FreeVars)
-> TcM (Located (HsExpr (GhcPass 'Renamed)), FreeVars)
forall r. TcM r -> TcM r
checkNoErrs (LHsExpr GhcPs
-> TcM (Located (HsExpr (GhcPass 'Renamed)), FreeVars)
rnLExpr LHsExpr GhcPs
expr)
               -- Don't try to typecheck if the renamer fails!
        ; Located (HsExpr (GhcPass 'Renamed))
ghciStep <- TcM (Located (HsExpr (GhcPass 'Renamed)))
getGhciStepIO
        ; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
        ; Name
interPrintName <- TcRn Name
getInteractivePrintName
        ; let fresh_it :: Name
fresh_it  = Unique -> SrcSpan -> Name
itName Unique
uniq SrcSpan
loc
              matches :: [LMatch (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
matches   = [HsMatchContext (NoGhcTc (GhcPass 'Renamed))
-> [LPat (GhcPass 'Renamed)]
-> Located (HsExpr (GhcPass 'Renamed))
-> Located (HsLocalBinds (GhcPass 'Renamed))
-> LMatch (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
External instance of the constraint type IsPass 'Renamed
mkMatch (Located (IdP (GhcPass 'Renamed))
-> HsMatchContext (GhcPass 'Renamed)
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
fresh_it)) [] Located (HsExpr (GhcPass 'Renamed))
rn_expr
                                   (HsLocalBinds (GhcPass 'Renamed)
-> Located (HsLocalBinds (GhcPass 'Renamed))
forall e. e -> Located e
noLoc HsLocalBinds (GhcPass 'Renamed)
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)]
              -- [it = expr]
              the_bind :: GenLocated SrcSpan (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
the_bind  = SrcSpan
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> GenLocated
     SrcSpan (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
 -> GenLocated
      SrcSpan (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> GenLocated
     SrcSpan (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ (Origin
-> GenLocated SrcSpan Name
-> [LMatch
      (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
mkTopFunBind Origin
FromSource
                                     (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
fresh_it) [LMatch (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
matches)
                                         { fun_ext :: XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fun_ext = FreeVars
XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fvs }
              -- Care here!  In GHCi the expression might have
              -- free variables, and they in turn may have free type variables
              -- (if we are at a breakpoint, say).  We must put those free vars

              -- [let it = expr]
              let_stmt :: LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
let_stmt  = SrcSpan
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StmtLR
   (GhcPass 'Renamed)
   (GhcPass 'Renamed)
   (Located (HsExpr (GhcPass 'Renamed)))
 -> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed))))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ XLetStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
-> Located (HsLocalBinds (GhcPass 'Renamed))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField (Located (HsLocalBinds (GhcPass 'Renamed))
 -> StmtLR
      (GhcPass 'Renamed)
      (GhcPass 'Renamed)
      (Located (HsExpr (GhcPass 'Renamed))))
-> Located (HsLocalBinds (GhcPass 'Renamed))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ HsLocalBinds (GhcPass 'Renamed)
-> Located (HsLocalBinds (GhcPass 'Renamed))
forall e. e -> Located e
noLoc (HsLocalBinds (GhcPass 'Renamed)
 -> Located (HsLocalBinds (GhcPass 'Renamed)))
-> HsLocalBinds (GhcPass 'Renamed)
-> Located (HsLocalBinds (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ XHsValBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsLocalBinds (GhcPass 'Renamed)
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
NoExtField
noExtField
                           (HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
 -> HsLocalBinds (GhcPass 'Renamed))
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsLocalBinds (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ XXValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR
                               ([(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR (GhcPass 'Renamed)
forall idL.
[(RecFlag, LHsBinds idL)]
-> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR idL
NValBinds [(RecFlag
NonRecursive,GenLocated SrcSpan (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> LHsBinds (GhcPass 'Renamed)
forall a. a -> Bag a
unitBag GenLocated SrcSpan (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
the_bind)] [])

              -- [it <- e]
              bind_stmt :: LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
bind_stmt = SrcSpan
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StmtLR
   (GhcPass 'Renamed)
   (GhcPass 'Renamed)
   (Located (HsExpr (GhcPass 'Renamed)))
 -> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed))))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ XBindStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
-> LPat (GhcPass 'Renamed)
-> Located (HsExpr (GhcPass 'Renamed))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt
                                       (XBindStmtRn :: SyntaxExpr (GhcPass 'Renamed)
-> FailOperator (GhcPass 'Renamed) -> XBindStmtRn
XBindStmtRn
                                          { xbsrn_bindOp :: SyntaxExpr (GhcPass 'Renamed)
xbsrn_bindOp = Name -> SyntaxExprRn
mkRnSyntaxExpr Name
bindIOName
                                          , xbsrn_failOp :: FailOperator (GhcPass 'Renamed)
xbsrn_failOp = FailOperator (GhcPass 'Renamed)
forall a. Maybe a
Nothing
                                          })
                                       (SrcSpan
-> Pat (GhcPass 'Renamed)
-> GenLocated SrcSpan (Pat (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XVarPat (GhcPass 'Renamed)
-> Located (IdP (GhcPass 'Renamed)) -> Pat (GhcPass 'Renamed)
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat XVarPat (GhcPass 'Renamed)
NoExtField
noExtField (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
fresh_it)))
                                       (Located (HsExpr (GhcPass 'Renamed))
-> Located (HsExpr (GhcPass 'Renamed))
-> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Renamed
nlHsApp Located (HsExpr (GhcPass 'Renamed))
ghciStep Located (HsExpr (GhcPass 'Renamed))
rn_expr)

              -- [; print it]
              print_it :: LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
print_it  = SrcSpan
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StmtLR
   (GhcPass 'Renamed)
   (GhcPass 'Renamed)
   (Located (HsExpr (GhcPass 'Renamed)))
 -> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed))))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ XBodyStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
-> Located (HsExpr (GhcPass 'Renamed))
-> SyntaxExpr (GhcPass 'Renamed)
-> SyntaxExpr (GhcPass 'Renamed)
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField
                                           (Located (HsExpr (GhcPass 'Renamed))
-> Located (HsExpr (GhcPass 'Renamed))
-> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Renamed
nlHsApp (IdP (GhcPass 'Renamed) -> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP (GhcPass 'Renamed)
interPrintName)
                                           (IdP (GhcPass 'Renamed) -> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP (GhcPass 'Renamed)
fresh_it))
                                           (Name -> SyntaxExprRn
mkRnSyntaxExpr Name
thenIOName)
                                                  SyntaxExpr (GhcPass 'Renamed)
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Renamed
noSyntaxExpr

              -- NewA
              no_it_a :: LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
no_it_a = SrcSpan
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StmtLR
   (GhcPass 'Renamed)
   (GhcPass 'Renamed)
   (Located (HsExpr (GhcPass 'Renamed)))
 -> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed))))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ XBodyStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
-> Located (HsExpr (GhcPass 'Renamed))
-> SyntaxExpr (GhcPass 'Renamed)
-> SyntaxExpr (GhcPass 'Renamed)
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField (IdP (GhcPass 'Renamed)
-> [Located (HsExpr (GhcPass 'Renamed))]
-> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Renamed
nlHsApps Name
IdP (GhcPass 'Renamed)
bindIOName
                                       [Located (HsExpr (GhcPass 'Renamed))
rn_expr , IdP (GhcPass 'Renamed) -> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP (GhcPass 'Renamed)
interPrintName])
                                       (Name -> SyntaxExprRn
mkRnSyntaxExpr Name
thenIOName)
                                       SyntaxExpr (GhcPass 'Renamed)
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Renamed
noSyntaxExpr

              no_it_b :: LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
no_it_b = SrcSpan
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StmtLR
   (GhcPass 'Renamed)
   (GhcPass 'Renamed)
   (Located (HsExpr (GhcPass 'Renamed)))
 -> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed))))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ XBodyStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
-> Located (HsExpr (GhcPass 'Renamed))
-> SyntaxExpr (GhcPass 'Renamed)
-> SyntaxExpr (GhcPass 'Renamed)
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField (Located (HsExpr (GhcPass 'Renamed))
rn_expr)
                                       (Name -> SyntaxExprRn
mkRnSyntaxExpr Name
thenIOName)
                                       SyntaxExpr (GhcPass 'Renamed)
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Renamed
noSyntaxExpr

              no_it_c :: LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
no_it_c = SrcSpan
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StmtLR
   (GhcPass 'Renamed)
   (GhcPass 'Renamed)
   (Located (HsExpr (GhcPass 'Renamed)))
 -> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed))))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ XBodyStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
-> Located (HsExpr (GhcPass 'Renamed))
-> SyntaxExpr (GhcPass 'Renamed)
-> SyntaxExpr (GhcPass 'Renamed)
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField
                                      (Located (HsExpr (GhcPass 'Renamed))
-> Located (HsExpr (GhcPass 'Renamed))
-> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Renamed
nlHsApp (IdP (GhcPass 'Renamed) -> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP (GhcPass 'Renamed)
interPrintName) Located (HsExpr (GhcPass 'Renamed))
rn_expr)
                                      (Name -> SyntaxExprRn
mkRnSyntaxExpr Name
thenIOName)
                                      SyntaxExpr (GhcPass 'Renamed)
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Renamed
noSyntaxExpr

              -- See Note [GHCi Plans]

              it_plans :: [Plan]
it_plans = [
                    -- Plan A
                    do { stuff :: PlanResult
stuff@([Var
it_id], LHsExpr GhcTc
_) <- [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> Plan
tcGhciStmts [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
bind_stmt, LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
print_it]
                       ; Type
it_ty <- Type -> TcM Type
zonkTcType (Var -> Type
idType Var
it_id)
                       ; IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when (Type -> IsBootInterface
isUnitTy (Type -> IsBootInterface) -> Type -> IsBootInterface
forall a b. (a -> b) -> a -> b
$ Type
it_ty) TcRnIf TcGblEnv TcLclEnv ()
forall env a. IOEnv env a
failM
                       ; PlanResult -> Plan
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return PlanResult
stuff },

                        -- Plan B; a naked bind statement
                    [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> Plan
tcGhciStmts [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
bind_stmt],

                        -- Plan C; check that the let-binding is typeable all by itself.
                        -- If not, fail; if so, try to print it.
                        -- The two-step process avoids getting two errors: one from
                        -- the expression itself, and one from the 'print it' part
                        -- This two-step story is very clunky, alas
                    do { PlanResult
_ <- Plan -> Plan
forall r. TcM r -> TcM r
checkNoErrs ([LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> Plan
tcGhciStmts [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
let_stmt])
                                --- checkNoErrs defeats the error recovery of let-bindings
                       ; [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> Plan
tcGhciStmts [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
let_stmt, LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
print_it] } ]

              -- Plans where we don't bind "it"
              no_it_plans :: [Plan]
no_it_plans = [
                    [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> Plan
tcGhciStmts [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
no_it_a] ,
                    [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> Plan
tcGhciStmts [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
no_it_b] ,
                    [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> Plan
tcGhciStmts [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
no_it_c] ]

        ; IsBootInterface
generate_it <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv IsBootInterface
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl IsBootInterface
goptM GeneralFlag
Opt_NoIt

        -- We disable `-fdefer-type-errors` in GHCi for naked expressions.
        -- See Note [Deferred type errors in GHCi]

        -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes`
        -- and `-fdefer-out-of-scope-variables`. However the flag
        -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and
        -- `-fno-defer-out-of-scope-variables`. Thus the later two flags
        -- also need to be unset here.
        ; PlanResult
plan <- GeneralFlag -> Plan -> Plan
forall gbl lcl a.
GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM GeneralFlag
Opt_DeferTypeErrors (Plan -> Plan) -> Plan -> Plan
forall a b. (a -> b) -> a -> b
$
                  GeneralFlag -> Plan -> Plan
forall gbl lcl a.
GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM GeneralFlag
Opt_DeferTypedHoles (Plan -> Plan) -> Plan -> Plan
forall a b. (a -> b) -> a -> b
$
                  GeneralFlag -> Plan -> Plan
forall gbl lcl a.
GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM GeneralFlag
Opt_DeferOutOfScopeVariables (Plan -> Plan) -> Plan -> Plan
forall a b. (a -> b) -> a -> b
$
                    [Plan] -> Plan
runPlans ([Plan] -> Plan) -> [Plan] -> Plan
forall a b. (a -> b) -> a -> b
$ if IsBootInterface
generate_it
                                 then [Plan]
no_it_plans
                                 else [Plan]
it_plans

        ; FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv
        ; (PlanResult, FixityEnv) -> TcM (PlanResult, FixityEnv)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (PlanResult
plan, FixityEnv
fix_env) }

{- Note [Deferred type errors in GHCi]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In GHCi, we ensure that type errors don't get deferred when type checking the
naked expressions. Deferring type errors here is unhelpful because the
expression gets evaluated right away anyway. It also would potentially emit
two redundant type-error warnings, one from each plan.

#14963 reveals another bug that when deferred type errors is enabled
in GHCi, any reference of imported/loaded variables (directly or indirectly)
in interactively issued naked expressions will cause ghc panic. See more
detailed discussion in #14963.

The interactively issued declarations, statements, as well as the modules
loaded into GHCi, are not affected. That means, for declaration, you could
have

    Prelude> :set -fdefer-type-errors
    Prelude> x :: IO (); x = putStrLn True
    <interactive>:14:26: warning: [-Wdeferred-type-errors]
        ? Couldn't match type ‘Bool’ with ‘[Char]’
          Expected type: String
            Actual type: Bool
        ? In the first argument of ‘putStrLn’, namely ‘True’
          In the expression: putStrLn True
          In an equation for ‘x’: x = putStrLn True

But for naked expressions, you will have

    Prelude> :set -fdefer-type-errors
    Prelude> putStrLn True
    <interactive>:2:10: error:
        ? Couldn't match type ‘Bool’ with ‘[Char]’
          Expected type: String
            Actual type: Bool
        ? In the first argument of ‘putStrLn’, namely ‘True’
          In the expression: putStrLn True
          In an equation for ‘it’: it = putStrLn True

    Prelude> let x = putStrLn True
    <interactive>:2:18: warning: [-Wdeferred-type-errors]
        ? Couldn't match type ‘Bool’ with ‘[Char]’
          Expected type: String
            Actual type: Bool
        ? In the first argument of ‘putStrLn’, namely ‘True’
          In the expression: putStrLn True
          In an equation for ‘x’: x = putStrLn True
-}

tcUserStmt rdr_stmt :: GhciLStmt GhcPs
rdr_stmt@(L SrcSpan
loc StmtLR GhcPs GhcPs (LHsExpr GhcPs)
_)
  = do { (([LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
rn_stmt], FixityEnv
fix_env), FreeVars
fvs) <- TcM
  (([LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))],
    FixityEnv),
   FreeVars)
-> TcM
     (([LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))],
       FixityEnv),
      FreeVars)
forall r. TcM r -> TcM r
checkNoErrs (TcM
   (([LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))],
     FixityEnv),
    FreeVars)
 -> TcM
      (([LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))],
        FixityEnv),
       FreeVars))
-> TcM
     (([LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))],
       FixityEnv),
      FreeVars)
-> TcM
     (([LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))],
       FixityEnv),
      FreeVars)
forall a b. (a -> b) -> a -> b
$
           HsStmtContext (GhcPass 'Renamed)
-> (LHsExpr GhcPs
    -> TcM (Located (HsExpr (GhcPass 'Renamed)), FreeVars))
-> [GhciLStmt GhcPs]
-> ([Name] -> RnM (FixityEnv, FreeVars))
-> TcM
     (([LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))],
       FixityEnv),
      FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext (GhcPass 'Renamed)
-> (Located (body GhcPs)
    -> RnM (Located (body (GhcPass 'Renamed)), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([LStmt (GhcPass 'Renamed) (Located (body (GhcPass 'Renamed)))],
       thing),
      FreeVars)
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr RdrName
External instance of the constraint type OutputableBndr RdrName
External instance of the constraint type IsPass 'Parsed
rnStmts HsStmtContext (GhcPass 'Renamed)
forall p. HsStmtContext p
GhciStmtCtxt LHsExpr GhcPs
-> TcM (Located (HsExpr (GhcPass 'Renamed)), FreeVars)
rnLExpr [GhciLStmt GhcPs
rdr_stmt] (([Name] -> RnM (FixityEnv, FreeVars))
 -> TcM
      (([LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))],
        FixityEnv),
       FreeVars))
-> ([Name] -> RnM (FixityEnv, FreeVars))
-> TcM
     (([LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))],
       FixityEnv),
      FreeVars)
forall a b. (a -> b) -> a -> b
$ \[Name]
_ -> do
             FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv
             (FixityEnv, FreeVars) -> RnM (FixityEnv, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (FixityEnv
fix_env, FreeVars
emptyFVs)
            -- Don't try to typecheck if the renamer fails!
       ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"tcRnStmt" ([SDoc] -> SDoc
vcat [GhciLStmt GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (pl :: Pass) (pr :: Pass) body.
(OutputableBndrId pl, OutputableBndrId pr, Outputable body) =>
Outputable (StmtLR (GhcPass pl) (GhcPass pr) body)
External instance of the constraint type OutputableBndr RdrName
External instance of the constraint type OutputableBndr RdrName
External instance of the constraint type IsPass 'Parsed
External instance of the constraint type OutputableBndr RdrName
External instance of the constraint type OutputableBndr RdrName
External instance of the constraint type IsPass 'Parsed
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr RdrName
External instance of the constraint type OutputableBndr RdrName
External instance of the constraint type IsPass 'Parsed
ppr GhciLStmt GhcPs
rdr_stmt, LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
-> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (pl :: Pass) (pr :: Pass) body.
(OutputableBndrId pl, OutputableBndrId pr, Outputable body) =>
Outputable (StmtLR (GhcPass pl) (GhcPass pr) body)
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
ppr LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
rn_stmt, FreeVars -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable (UniqSet a)
External instance of the constraint type Outputable Name
ppr FreeVars
fvs])
       ; LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
-> TcRnIf TcGblEnv TcLclEnv ()
forall a.
(Outputable a, Data a) =>
a -> TcRnIf TcGblEnv TcLclEnv ()
External instance of the constraint type forall l e. (Data l, Data e) => Data (GenLocated l e)
External instance of the constraint type Data SrcSpan
External instance of the constraint type forall body.
Data body =>
Data (StmtLR (GhcPass 'Renamed) (GhcPass 'Renamed) body)
External instance of the constraint type forall l e. (Data l, Data e) => Data (GenLocated l e)
External instance of the constraint type Data SrcSpan
External instance of the constraint type Data (HsExpr (GhcPass 'Renamed))
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (pl :: Pass) (pr :: Pass) body.
(OutputableBndrId pl, OutputableBndrId pr, Outputable body) =>
Outputable (StmtLR (GhcPass pl) (GhcPass pr) body)
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
rnDump LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
rn_stmt ;

       ; Located (HsExpr (GhcPass 'Renamed))
ghciStep <- TcM (Located (HsExpr (GhcPass 'Renamed)))
getGhciStepIO
       ; let gi_stmt :: LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
gi_stmt
               | (L SrcSpan
loc (BindStmt XBindStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
x LPat (GhcPass 'Renamed)
pat Located (HsExpr (GhcPass 'Renamed))
expr)) <- LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
rn_stmt
                     = SrcSpan
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StmtLR
   (GhcPass 'Renamed)
   (GhcPass 'Renamed)
   (Located (HsExpr (GhcPass 'Renamed)))
 -> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed))))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ XBindStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
-> LPat (GhcPass 'Renamed)
-> Located (HsExpr (GhcPass 'Renamed))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
x LPat (GhcPass 'Renamed)
pat (Located (HsExpr (GhcPass 'Renamed))
-> Located (HsExpr (GhcPass 'Renamed))
-> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Renamed
nlHsApp Located (HsExpr (GhcPass 'Renamed))
ghciStep Located (HsExpr (GhcPass 'Renamed))
expr)
               | IsBootInterface
otherwise = LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
rn_stmt

       ; IsBootInterface
opt_pr_flag <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv IsBootInterface
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl IsBootInterface
goptM GeneralFlag
Opt_PrintBindResult
       ; let print_result_plan :: [Plan]
print_result_plan
               | IsBootInterface
opt_pr_flag                         -- The flag says "print result"
               , [IdP (GhcPass 'Renamed)
v] <- LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
-> [IdP (GhcPass 'Renamed)]
forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
External instance of the constraint type CollectPass (GhcPass 'Renamed)
collectLStmtBinders LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
gi_stmt  -- One binder
                           =  [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
-> Name -> Plan
mk_print_result_plan LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
gi_stmt Name
IdP (GhcPass 'Renamed)
v]
               | IsBootInterface
otherwise = []

        -- The plans are:
        --      [stmt; print v]         if one binder and not v::()
        --      [stmt]                  otherwise
       ; PlanResult
plan <- [Plan] -> Plan
runPlans ([Plan]
print_result_plan [Plan] -> [Plan] -> [Plan]
forall a. [a] -> [a] -> [a]
++ [[LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> Plan
tcGhciStmts [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
gi_stmt]])
       ; (PlanResult, FixityEnv) -> TcM (PlanResult, FixityEnv)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (PlanResult
plan, FixityEnv
fix_env) }
  where
    mk_print_result_plan :: LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
-> Name -> Plan
mk_print_result_plan LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
stmt Name
v
      = do { stuff :: PlanResult
stuff@([Var
v_id], LHsExpr GhcTc
_) <- [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> Plan
tcGhciStmts [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
stmt, LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
print_v]
           ; Type
v_ty <- Type -> TcM Type
zonkTcType (Var -> Type
idType Var
v_id)
           ; IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when (Type -> IsBootInterface
isUnitTy Type
v_ty IsBootInterface -> IsBootInterface -> IsBootInterface
|| IsBootInterface -> IsBootInterface
not (Type -> IsBootInterface
isTauTy Type
v_ty)) TcRnIf TcGblEnv TcLclEnv ()
forall env a. IOEnv env a
failM
           ; PlanResult -> Plan
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return PlanResult
stuff }
      where
        print_v :: LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
print_v  = SrcSpan
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StmtLR
   (GhcPass 'Renamed)
   (GhcPass 'Renamed)
   (Located (HsExpr (GhcPass 'Renamed)))
 -> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed))))
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
-> LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ XBodyStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
-> Located (HsExpr (GhcPass 'Renamed))
-> SyntaxExpr (GhcPass 'Renamed)
-> SyntaxExpr (GhcPass 'Renamed)
-> StmtLR
     (GhcPass 'Renamed)
     (GhcPass 'Renamed)
     (Located (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt
  (GhcPass 'Renamed)
  (GhcPass 'Renamed)
  (Located (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField (Located (HsExpr (GhcPass 'Renamed))
-> Located (HsExpr (GhcPass 'Renamed))
-> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Renamed
nlHsApp (IdP (GhcPass 'Renamed) -> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP (GhcPass 'Renamed)
printName)
                                    (IdP (GhcPass 'Renamed) -> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP (GhcPass 'Renamed)
v))
                                    (Name -> SyntaxExprRn
mkRnSyntaxExpr Name
thenIOName) SyntaxExpr (GhcPass 'Renamed)
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
External instance of the constraint type IsPass 'Renamed
noSyntaxExpr

{-
Note [GHCi Plans]
~~~~~~~~~~~~~~~~~
When a user types an expression in the repl we try to print it in three different
ways. Also, depending on whether -fno-it is set, we bind a variable called `it`
which can be used to refer to the result of the expression subsequently in the repl.

The normal plans are :
  A. [it <- e; print e]     but not if it::()
  B. [it <- e]
  C. [let it = e; print it]

When -fno-it is set, the plans are:
  A. [e >>= print]
  B. [e]
  C. [let it = e in print it]

The reason for -fno-it is explained in #14336. `it` can lead to the repl
leaking memory as it is repeatedly queried.
-}

-- | Typecheck the statements given and then return the results of the
-- statement in the form 'IO [()]'.
tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult
tcGhciStmts :: [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> Plan
tcGhciStmts [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
stmts
 = do { TyCon
ioTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
ioTyConName
      ; Var
ret_id  <- Name -> TcM Var
tcLookupId Name
returnIOName             -- return @ IO
      ; let ret_ty :: Type
ret_ty      = Type -> Type
mkListTy Type
unitTy
            io_ret_ty :: Type
io_ret_ty   = TyCon -> [Type] -> Type
mkTyConApp TyCon
ioTyCon [Type
ret_ty]
            tc_io_stmts :: (ExpRhoType -> TcM [Var])
-> TcM ([LStmt GhcTc (LHsExpr GhcTc)], [Var])
tc_io_stmts = HsStmtContext (GhcPass 'Renamed)
-> TcStmtChecker HsExpr ExpRhoType
-> [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> ExpRhoType
-> (ExpRhoType -> TcM [Var])
-> TcM ([LStmt GhcTc (LHsExpr GhcTc)], [Var])
forall (body :: * -> *) rho_type thing.
Outputable (body (GhcPass 'Renamed)) =>
HsStmtContext (GhcPass 'Renamed)
-> TcStmtChecker body rho_type
-> [LStmt (GhcPass 'Renamed) (Located (body (GhcPass 'Renamed)))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (Located (body GhcTc))], thing)
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
tcStmtsAndThen HsStmtContext (GhcPass 'Renamed)
forall p. HsStmtContext p
GhciStmtCtxt TcStmtChecker HsExpr ExpRhoType
tcDoStmt [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
stmts
                                         (Type -> ExpRhoType
mkCheckExpType Type
io_ret_ty)
            names :: [IdP (GhcPass 'Renamed)]
names = [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
-> [IdP (GhcPass 'Renamed)]
forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
[LStmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)]
External instance of the constraint type CollectPass (GhcPass 'Renamed)
collectLStmtsBinders [LStmt (GhcPass 'Renamed) (Located (HsExpr (GhcPass 'Renamed)))]
stmts

        -- OK, we're ready to typecheck the stmts
      ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"GHC.Tc.Module.tcGhciStmts: tc stmts" SDoc
empty
      ; (([LStmt GhcTc (LHsExpr GhcTc)]
tc_stmts, [Var]
ids), WantedConstraints
lie) <- TcM ([LStmt GhcTc (LHsExpr GhcTc)], [Var])
-> TcM (([LStmt GhcTc (LHsExpr GhcTc)], [Var]), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM ([LStmt GhcTc (LHsExpr GhcTc)], [Var])
 -> TcM (([LStmt GhcTc (LHsExpr GhcTc)], [Var]), WantedConstraints))
-> TcM ([LStmt GhcTc (LHsExpr GhcTc)], [Var])
-> TcM (([LStmt GhcTc (LHsExpr GhcTc)], [Var]), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                                  (ExpRhoType -> TcM [Var])
-> TcM ([LStmt GhcTc (LHsExpr GhcTc)], [Var])
tc_io_stmts ((ExpRhoType -> TcM [Var])
 -> TcM ([LStmt GhcTc (LHsExpr GhcTc)], [Var]))
-> (ExpRhoType -> TcM [Var])
-> TcM ([LStmt GhcTc (LHsExpr GhcTc)], [Var])
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
_ ->
                                  (Name -> TcM Var) -> [Name] -> TcM [Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM Name -> TcM Var
tcLookupId [Name]
[IdP (GhcPass 'Renamed)]
names
                        -- Look up the names right in the middle,
                        -- where they will all be in scope

        -- Simplify the context
      ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"GHC.Tc.Module.tcGhciStmts: simplify ctxt" SDoc
empty
      ; Bag EvBind
const_binds <- TcM (Bag EvBind) -> TcM (Bag EvBind)
forall r. TcM r -> TcM r
checkNoErrs (WantedConstraints -> TcM (Bag EvBind)
simplifyInteractive WantedConstraints
lie)
                -- checkNoErrs ensures that the plan fails if context redn fails


      ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"GHC.Tc.Module.tcGhciStmts: done" SDoc
empty

      -- rec_expr is the expression
      --      returnIO @ [()] [unsafeCoerce# () x, ..,  unsafeCorece# () z]
      --
      -- Despite the inconvenience of building the type applications etc,
      -- this *has* to be done in type-annotated post-typecheck form
      -- because we are going to return a list of *polymorphic* values
      -- coerced to type (). If we built a *source* stmt
      --      return [coerce x, ..., coerce z]
      -- then the type checker would instantiate x..z, and we wouldn't
      -- get their *polymorphic* values.  (And we'd get ambiguity errs
      -- if they were overloaded, since they aren't applied to anything.)

      ; AnId Var
unsafe_coerce_id <- Name -> TcM TyThing
tcLookupGlobal Name
unsafeCoercePrimName
           -- We use unsafeCoerce# here because of (U11) in
           -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce

      ; let ret_expr :: LHsExpr GhcTc
ret_expr = LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Typechecked
nlHsApp (Var -> [Type] -> LHsExpr GhcTc
nlHsTyApp Var
ret_id [Type
ret_ty]) (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                       HsExpr GhcTc -> LHsExpr GhcTc
forall e. e -> Located e
noLoc (HsExpr GhcTc -> LHsExpr GhcTc) -> HsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTc
-> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> HsExpr GhcTc
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList Type
XExplicitList GhcTc
unitTy Maybe (SyntaxExpr GhcTc)
forall a. Maybe a
Nothing ([LHsExpr GhcTc] -> HsExpr GhcTc)
-> [LHsExpr GhcTc] -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                       (Var -> LHsExpr GhcTc) -> [Var] -> [LHsExpr GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map Var -> LHsExpr GhcTc
mk_item [Var]
ids

            mk_item :: Var -> LHsExpr GhcTc
mk_item Var
id = Var
unsafe_coerce_id Var -> [Type] -> LHsExpr GhcTc
`nlHsTyApp` [ HasDebugCallStack => Type -> Type
Type -> Type
External instance of the constraint type HasDebugCallStack
getRuntimeRep (Var -> Type
idType Var
id)
                                                      , HasDebugCallStack => Type -> Type
Type -> Type
External instance of the constraint type HasDebugCallStack
getRuntimeRep Type
unitTy
                                                      , Var -> Type
idType Var
id, Type
unitTy]
                                          LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Typechecked
`nlHsApp` IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Var
IdP GhcTc
id
            stmts :: [LStmt GhcTc (LHsExpr GhcTc)]
stmts = [LStmt GhcTc (LHsExpr GhcTc)]
tc_stmts [LStmt GhcTc (LHsExpr GhcTc)]
-> [LStmt GhcTc (LHsExpr GhcTc)] -> [LStmt GhcTc (LHsExpr GhcTc)]
forall a. [a] -> [a] -> [a]
++ [StmtLR GhcTc GhcTc (LHsExpr GhcTc) -> LStmt GhcTc (LHsExpr GhcTc)
forall e. e -> Located e
noLoc (LHsExpr GhcTc -> StmtLR GhcTc GhcTc (LHsExpr GhcTc)
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
Located (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
External instance of the constraint type IsPass 'Typechecked
mkLastStmt LHsExpr GhcTc
ret_expr)]

      ; PlanResult -> Plan
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([Var]
ids, TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet (Bag EvBind -> TcEvBinds
EvBinds Bag EvBind
const_binds) (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                     HsExpr GhcTc -> LHsExpr GhcTc
forall e. e -> Located e
noLoc (XDo GhcTc
-> HsStmtContext (GhcPass 'Renamed)
-> Located [LStmt GhcTc (LHsExpr GhcTc)]
-> HsExpr GhcTc
forall p.
XDo p
-> HsStmtContext (GhcPass 'Renamed)
-> Located [ExprLStmt p]
-> HsExpr p
HsDo Type
XDo GhcTc
io_ret_ty HsStmtContext (GhcPass 'Renamed)
forall p. HsStmtContext p
GhciStmtCtxt ([LStmt GhcTc (LHsExpr GhcTc)]
-> Located [LStmt GhcTc (LHsExpr GhcTc)]
forall e. e -> Located e
noLoc [LStmt GhcTc (LHsExpr GhcTc)]
stmts)))
    }

-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
getGhciStepIO :: TcM (LHsExpr GhcRn)
getGhciStepIO :: TcM (Located (HsExpr (GhcPass 'Renamed)))
getGhciStepIO = do
    Name
ghciTy <- TcRn Name
getGHCiMonad
    Name
a_tv <- OccName -> TcRn Name
newName (FastString -> OccName
mkTyVarOccFS (String -> FastString
fsLit String
"a"))
    let ghciM :: LHsType (GhcPass 'Renamed)
ghciM   = LHsType (GhcPass 'Renamed)
-> LHsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsAppTy (IdP (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar Name
IdP (GhcPass 'Renamed)
ghciTy) (IdP (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar Name
IdP (GhcPass 'Renamed)
a_tv)
        ioM :: LHsType (GhcPass 'Renamed)
ioM     = LHsType (GhcPass 'Renamed)
-> LHsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsAppTy (IdP (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar Name
IdP (GhcPass 'Renamed)
ioTyConName) (IdP (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar Name
IdP (GhcPass 'Renamed)
a_tv)

        step_ty :: LHsType (GhcPass 'Renamed)
step_ty = HsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall e. e -> Located e
noLoc (HsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed))
-> HsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ HsForAllTy :: forall pass.
XForAllTy pass
-> ForallVisFlag
-> [LHsTyVarBndr Specificity pass]
-> LHsType pass
-> HsType pass
HsForAllTy
                     { hst_fvf :: ForallVisFlag
hst_fvf = ForallVisFlag
ForallInvis
                     , hst_bndrs :: [LHsTyVarBndr Specificity (GhcPass 'Renamed)]
hst_bndrs = [HsTyVarBndr Specificity (GhcPass 'Renamed)
-> LHsTyVarBndr Specificity (GhcPass 'Renamed)
forall e. e -> Located e
noLoc (HsTyVarBndr Specificity (GhcPass 'Renamed)
 -> LHsTyVarBndr Specificity (GhcPass 'Renamed))
-> HsTyVarBndr Specificity (GhcPass 'Renamed)
-> LHsTyVarBndr Specificity (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ XUserTyVar (GhcPass 'Renamed)
-> Specificity
-> Located (IdP (GhcPass 'Renamed))
-> HsTyVarBndr Specificity (GhcPass 'Renamed)
forall flag pass.
XUserTyVar pass
-> flag -> Located (IdP pass) -> HsTyVarBndr flag pass
UserTyVar XUserTyVar (GhcPass 'Renamed)
NoExtField
noExtField Specificity
SpecifiedSpec (Name -> GenLocated SrcSpan Name
forall e. e -> Located e
noLoc Name
a_tv)]
                     , hst_xforall :: XForAllTy (GhcPass 'Renamed)
hst_xforall = XForAllTy (GhcPass 'Renamed)
NoExtField
noExtField
                     , hst_body :: LHsType (GhcPass 'Renamed)
hst_body  = LHsType (GhcPass 'Renamed)
-> LHsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsFunTy LHsType (GhcPass 'Renamed)
ghciM LHsType (GhcPass 'Renamed)
ioM }

        stepTy :: LHsSigWcType GhcRn
        stepTy :: LHsSigWcType (GhcPass 'Renamed)
stepTy = HsImplicitBndrs (GhcPass 'Renamed) (LHsType (GhcPass 'Renamed))
-> LHsSigWcType (GhcPass 'Renamed)
forall thing. thing -> HsWildCardBndrs (GhcPass 'Renamed) thing
mkEmptyWildCardBndrs (LHsType (GhcPass 'Renamed)
-> HsImplicitBndrs (GhcPass 'Renamed) (LHsType (GhcPass 'Renamed))
forall thing. thing -> HsImplicitBndrs (GhcPass 'Renamed) thing
mkEmptyImplicitBndrs LHsType (GhcPass 'Renamed)
step_ty)

    Located (HsExpr (GhcPass 'Renamed))
-> TcM (Located (HsExpr (GhcPass 'Renamed)))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (HsExpr (GhcPass 'Renamed) -> Located (HsExpr (GhcPass 'Renamed))
forall e. e -> Located e
noLoc (HsExpr (GhcPass 'Renamed) -> Located (HsExpr (GhcPass 'Renamed)))
-> HsExpr (GhcPass 'Renamed) -> Located (HsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ XExprWithTySig (GhcPass 'Renamed)
-> Located (HsExpr (GhcPass 'Renamed))
-> LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig (GhcPass 'Renamed)
NoExtField
noExtField (IdP (GhcPass 'Renamed) -> Located (HsExpr (GhcPass 'Renamed))
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP (GhcPass 'Renamed)
ghciStepIoMName) LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
stepTy)

isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
isGHCiMonad HscEnv
hsc_env String
ty
  = HscEnv -> TcRn Name -> IO (Messages, Maybe Name)
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn Name -> IO (Messages, Maybe Name))
-> TcRn Name -> IO (Messages, Maybe Name)
forall a b. (a -> b) -> a -> b
$ do
        GlobalRdrEnv
rdrEnv <- TcRn GlobalRdrEnv
getGlobalRdrEnv
        let occIO :: Maybe [GlobalRdrElt]
occIO = GlobalRdrEnv -> OccName -> Maybe [GlobalRdrElt]
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv GlobalRdrEnv
rdrEnv (NameSpace -> String -> OccName
mkOccName NameSpace
tcName String
ty)
        case Maybe [GlobalRdrElt]
occIO of
            Just [GlobalRdrElt
n] -> do
                let name :: Name
name = GlobalRdrElt -> Name
gre_name GlobalRdrElt
n
                Class
ghciClass <- Name -> TcM Class
tcLookupClass Name
ghciIoClassName
                TyCon
userTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
name
                let userTy :: Type
userTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
userTyCon []
                ClsInst
_ <- Class -> [Type] -> TcM ClsInst
tcLookupInstance Class
ghciClass [Type
userTy]
                Name -> TcRn Name
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return Name
name

            Just [GlobalRdrElt]
_  -> SDoc -> TcRn Name
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcRn Name) -> SDoc -> TcRn Name
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Ambiguous type!"
            Maybe [GlobalRdrElt]
Nothing -> SDoc -> TcRn Name
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcRn Name) -> SDoc -> TcRn Name
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text (String
"Can't find type:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty)

-- | How should we infer a type? See Note [TcRnExprMode]
data TcRnExprMode = TM_Inst    -- ^ Instantiate the type fully (:type)
                  | TM_NoInst  -- ^ Do not instantiate the type (:type +v)
                  | TM_Default -- ^ Default the type eagerly (:type +d)

-- | tcRnExpr just finds the type of an expression
tcRnExpr :: HscEnv
         -> TcRnExprMode
         -> LHsExpr GhcPs
         -> IO (Messages, Maybe Type)
tcRnExpr :: HscEnv
-> TcRnExprMode -> LHsExpr GhcPs -> IO (Messages, DFunInstType)
tcRnExpr HscEnv
hsc_env TcRnExprMode
mode LHsExpr GhcPs
rdr_expr
  = HscEnv -> TcM Type -> IO (Messages, DFunInstType)
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcM Type -> IO (Messages, DFunInstType))
-> TcM Type -> IO (Messages, DFunInstType)
forall a b. (a -> b) -> a -> b
$
    do {

    (Located (HsExpr (GhcPass 'Renamed))
rn_expr, FreeVars
_fvs) <- LHsExpr GhcPs
-> TcM (Located (HsExpr (GhcPass 'Renamed)), FreeVars)
rnLExpr LHsExpr GhcPs
rdr_expr ;
    TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM ;

        -- Now typecheck the expression, and generalise its type
        -- it might have a rank-2 type (e.g. :t runST)
    Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique ;
    let { fresh_it :: Name
fresh_it  = Unique -> SrcSpan -> Name
itName Unique
uniq (LHsExpr GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsExpr GhcPs
rdr_expr) } ;
    ((TcLevel
tclvl, (LHsExpr GhcTc
_tc_expr, Type
res_ty)), WantedConstraints
lie)
          <- TcM (TcLevel, (LHsExpr GhcTc, Type))
-> TcM ((TcLevel, (LHsExpr GhcTc, Type)), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM (TcLevel, (LHsExpr GhcTc, Type))
 -> TcM ((TcLevel, (LHsExpr GhcTc, Type)), WantedConstraints))
-> TcM (TcLevel, (LHsExpr GhcTc, Type))
-> TcM ((TcLevel, (LHsExpr GhcTc, Type)), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
             TcM (LHsExpr GhcTc, Type) -> TcM (TcLevel, (LHsExpr GhcTc, Type))
forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM          (TcM (LHsExpr GhcTc, Type) -> TcM (TcLevel, (LHsExpr GhcTc, Type)))
-> TcM (LHsExpr GhcTc, Type)
-> TcM (TcLevel, (LHsExpr GhcTc, Type))
forall a b. (a -> b) -> a -> b
$
             Located (HsExpr (GhcPass 'Renamed)) -> TcM (LHsExpr GhcTc, Type)
tc_infer Located (HsExpr (GhcPass 'Renamed))
rn_expr ;

    -- Generalise
    ([Var]
qtvs, [Var]
dicts, TcEvBinds
_, WantedConstraints
residual, IsBootInterface
_)
         <- TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, Type)]
-> WantedConstraints
-> TcM
     ([Var], [Var], TcEvBinds, WantedConstraints, IsBootInterface)
simplifyInfer TcLevel
tclvl InferMode
infer_mode
                          []    {- No sig vars -}
                          [(Name
fresh_it, Type
res_ty)]
                          WantedConstraints
lie ;

    -- Ignore the dictionary bindings
    Bag EvBind
_ <- TcM (Bag EvBind) -> TcM (Bag EvBind)
perhaps_disable_default_warnings (TcM (Bag EvBind) -> TcM (Bag EvBind))
-> TcM (Bag EvBind) -> TcM (Bag EvBind)
forall a b. (a -> b) -> a -> b
$
         WantedConstraints -> TcM (Bag EvBind)
simplifyInteractive WantedConstraints
residual ;

    let { all_expr_ty :: Type
all_expr_ty = [Var] -> Type -> Type
mkInfForAllTys [Var]
qtvs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                        [Type] -> Type -> Type
mkPhiTy ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
idType [Var]
dicts) Type
res_ty } ;
    Type
ty <- Type -> TcM Type
zonkTcType Type
all_expr_ty ;

    -- We normalise type families, so that the type of an expression is the
    -- same as of a bound expression (GHC.Tc.Gen.Bind.mkInferredPolyId). See Trac
    -- #10321 for further discussion.
    FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs ;
    -- normaliseType returns a coercion which we discard, so the Role is
    -- irrelevant
    Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ((Coercion, Type) -> Type
forall a b. (a, b) -> b
snd (FamInstEnvs -> Role -> Type -> (Coercion, Type)
normaliseType FamInstEnvs
fam_envs Role
Nominal Type
ty))
    }
  where
    tc_infer :: Located (HsExpr (GhcPass 'Renamed)) -> TcM (LHsExpr GhcTc, Type)
tc_infer Located (HsExpr (GhcPass 'Renamed))
expr | IsBootInterface
inst      = Located (HsExpr (GhcPass 'Renamed)) -> TcM (LHsExpr GhcTc, Type)
tcInferRho Located (HsExpr (GhcPass 'Renamed))
expr
                  | IsBootInterface
otherwise = Located (HsExpr (GhcPass 'Renamed)) -> TcM (LHsExpr GhcTc, Type)
tcInferSigma Located (HsExpr (GhcPass 'Renamed))
expr
                  -- tcInferSigma: see Note [Implementing :type]

    -- See Note [TcRnExprMode]
    (IsBootInterface
inst, InferMode
infer_mode, TcM (Bag EvBind) -> TcM (Bag EvBind)
perhaps_disable_default_warnings) = case TcRnExprMode
mode of
      TcRnExprMode
TM_Inst    -> (IsBootInterface
True,  InferMode
NoRestrictions, TcM (Bag EvBind) -> TcM (Bag EvBind)
forall a. a -> a
id)
      TcRnExprMode
TM_NoInst  -> (IsBootInterface
False, InferMode
NoRestrictions, TcM (Bag EvBind) -> TcM (Bag EvBind)
forall a. a -> a
id)
      TcRnExprMode
TM_Default -> (IsBootInterface
True,  InferMode
EagerDefaulting, WarningFlag -> TcM (Bag EvBind) -> TcM (Bag EvBind)
forall gbl lcl a.
WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM WarningFlag
Opt_WarnTypeDefaults)

{- Note [Implementing :type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider   :type const

We want    forall a b. a -> b -> a
and not    forall {a}{b}. a -> b -> a

The latter is what we'd get if we eagerly instantiated and then
re-generalised with Inferred binders.  It makes a difference, because
it tells us we where we can use Visible Type Application (VTA).

And also for   :type const @Int
we want        forall b. Int -> b -> Int
and not        forall {b}. Int -> b -> Int

Solution: use tcInferSigma, which in turn uses tcInferApp, which
has a special case for application chains.
-}

--------------------------
tcRnImportDecls :: HscEnv
                -> [LImportDecl GhcPs]
                -> IO (Messages, Maybe GlobalRdrEnv)
-- Find the new chunk of GlobalRdrEnv created by this list of import
-- decls.  In contract tcRnImports *extends* the TcGblEnv.
tcRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO (Messages, Maybe GlobalRdrEnv)
tcRnImportDecls HscEnv
hsc_env [LImportDecl GhcPs]
import_decls
 =  HscEnv -> TcRn GlobalRdrEnv -> IO (Messages, Maybe GlobalRdrEnv)
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn GlobalRdrEnv -> IO (Messages, Maybe GlobalRdrEnv))
-> TcRn GlobalRdrEnv -> IO (Messages, Maybe GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$
    do { TcGblEnv
gbl_env <- (TcGblEnv -> TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv TcGblEnv -> TcGblEnv
zap_rdr_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
                    HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv
tcRnImports HscEnv
hsc_env [LImportDecl GhcPs]
import_decls
       ; GlobalRdrEnv -> TcRn GlobalRdrEnv
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
gbl_env) }
  where
    zap_rdr_env :: TcGblEnv -> TcGblEnv
zap_rdr_env TcGblEnv
gbl_env = TcGblEnv
gbl_env { tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env = GlobalRdrEnv
emptyGlobalRdrEnv }

-- tcRnType just finds the kind of a type
tcRnType :: HscEnv
         -> ZonkFlexi
         -> Bool        -- Normalise the returned type
         -> LHsType GhcPs
         -> IO (Messages, Maybe (Type, Kind))
tcRnType :: HscEnv
-> ZonkFlexi
-> IsBootInterface
-> LHsType GhcPs
-> IO (Messages, Maybe (Type, Type))
tcRnType HscEnv
hsc_env ZonkFlexi
flexi IsBootInterface
normalise LHsType GhcPs
rdr_type
  = HscEnv -> TcRn (Type, Type) -> IO (Messages, Maybe (Type, Type))
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn (Type, Type) -> IO (Messages, Maybe (Type, Type)))
-> TcRn (Type, Type) -> IO (Messages, Maybe (Type, Type))
forall a b. (a -> b) -> a -> b
$
    Extension -> TcRn (Type, Type) -> TcRn (Type, Type)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.PolyKinds (TcRn (Type, Type) -> TcRn (Type, Type))
-> TcRn (Type, Type) -> TcRn (Type, Type)
forall a b. (a -> b) -> a -> b
$   -- See Note [Kind-generalise in tcRnType]
    do { (HsWC { hswc_ext :: forall pass thing. HsWildCardBndrs pass thing -> XHsWC pass thing
hswc_ext = XHsWC (GhcPass 'Renamed) (LHsType (GhcPass 'Renamed))
wcs, hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = LHsType (GhcPass 'Renamed)
rn_type }, FreeVars
_fvs)
               <- HsDocContext
-> LHsWcType GhcPs -> RnM (LHsWcType (GhcPass 'Renamed), FreeVars)
rnHsWcType HsDocContext
GHCiCtx (LHsType GhcPs -> LHsWcType GhcPs
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs LHsType GhcPs
rdr_type)
                  -- The type can have wild cards, but no implicit
                  -- generalisation; e.g.   :kind (T _)
       ; TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM

        -- We follow Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType here

        -- Now kind-check the type
        -- It can have any rank or kind
        -- First bring into scope any wildcards
       ; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcRnType" ([SDoc] -> SDoc
vcat [[Name] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable Name
ppr [Name]
XHsWC (GhcPass 'Renamed) (LHsType (GhcPass 'Renamed))
wcs, LHsType (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsType (GhcPass p))
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Renamed
ppr LHsType (GhcPass 'Renamed)
rn_type])
       ; (Type
ty, Type
kind) <- TcRn (Type, Type) -> TcRn (Type, Type)
forall r. TcM r -> TcM r
pushTcLevelM_         (TcRn (Type, Type) -> TcRn (Type, Type))
-> TcRn (Type, Type) -> TcRn (Type, Type)
forall a b. (a -> b) -> a -> b
$
                        -- must push level to satisfy level precondition of
                        -- kindGeneralize, below
                       TcRn (Type, Type) -> TcRn (Type, Type)
forall r. TcM r -> TcM r
solveEqualities       (TcRn (Type, Type) -> TcRn (Type, Type))
-> TcRn (Type, Type) -> TcRn (Type, Type)
forall a b. (a -> b) -> a -> b
$
                       [Name] -> ([(Name, Var)] -> TcRn (Type, Type)) -> TcRn (Type, Type)
forall a. [Name] -> ([(Name, Var)] -> TcM a) -> TcM a
tcNamedWildCardBinders [Name]
XHsWC (GhcPass 'Renamed) (LHsType (GhcPass 'Renamed))
wcs (([(Name, Var)] -> TcRn (Type, Type)) -> TcRn (Type, Type))
-> ([(Name, Var)] -> TcRn (Type, Type)) -> TcRn (Type, Type)
forall a b. (a -> b) -> a -> b
$ \ [(Name, Var)]
wcs' ->
                       do { ((Name, Var) -> TcRnIf TcGblEnv TcLclEnv ())
-> [(Name, Var)] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
mapM_ (Name, Var) -> TcRnIf TcGblEnv TcLclEnv ()
emitNamedTypeHole [(Name, Var)]
wcs'
                          ; LHsType (GhcPass 'Renamed) -> TcRn (Type, Type)
tcLHsTypeUnsaturated LHsType (GhcPass 'Renamed)
rn_type }

       -- Do kind generalisation; see Note [Kind-generalise in tcRnType]
       ; [Var]
kvs <- Type -> TcM [Var]
kindGeneralizeAll Type
kind
       ; ZonkEnv
e <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
flexi

       ; Type
ty  <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
e Type
ty

       -- Do validity checking on type
       ; UserTypeCtxt -> Type -> TcRnIf TcGblEnv TcLclEnv ()
checkValidType (IsBootInterface -> UserTypeCtxt
GhciCtxt IsBootInterface
True) Type
ty

       ; Type
ty' <- if IsBootInterface
normalise
                then do { FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
                        ; let (Coercion
_, Type
ty')
                                = FamInstEnvs -> Role -> Type -> (Coercion, Type)
normaliseType FamInstEnvs
fam_envs Role
Nominal Type
ty
                        ; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return Type
ty' }
                else Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return Type
ty ;

       ; (Type, Type) -> TcRn (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Type
ty', [Var] -> Type -> Type
mkInfForAllTys [Var]
kvs (HasDebugCallStack => Type -> Type
Type -> Type
External instance of the constraint type HasDebugCallStack
tcTypeKind Type
ty')) }

{- Note [TcRnExprMode]
~~~~~~~~~~~~~~~~~~~~~~
How should we infer a type when a user asks for the type of an expression e
at the GHCi prompt? We offer 3 different possibilities, described below. Each
considers this example, with -fprint-explicit-foralls enabled:

  foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String
  :type{,-spec,-def} foo @Int

:type / TM_Inst

  In this mode, we report the type that would be inferred if a variable
  were assigned to expression e, without applying the monomorphism restriction.
  This means we deeply instantiate the type and then regeneralize, as discussed
  in #11376.

  > :type foo @Int
  forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String

  Note that the variables and constraints are reordered here, because this
  is possible during regeneralization. Also note that the variables are
  reported as Inferred instead of Specified.

:type +v / TM_NoInst

  This mode is for the benefit of users using TypeApplications. It does no
  instantiation whatsoever, sometimes meaning that class constraints are not
  solved.

  > :type +v foo @Int
  forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String

  Note that Show Int is still reported, because the solver never got a chance
  to see it.

:type +d / TM_Default

  This mode is for the benefit of users who wish to see instantiations of
  generalized types, and in particular to instantiate Foldable and Traversable.
  In this mode, any type variable that can be defaulted is defaulted. Because
  GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are
  defaulted.

  > :type +d foo @Int
  Int -> [Integer] -> String

  Note that this mode can sometimes lead to a type error, if a type variable is
  used with a defaultable class but cannot actually be defaulted:

  bar :: (Num a, Monoid a) => a -> a
  > :type +d bar
  ** error **

  The error arises because GHC tries to default a but cannot find a concrete
  type in the defaulting list that is both Num and Monoid. (If this list is
  modified to include an element that is both Num and Monoid, the defaulting
  would succeed, of course.)

Note [Kind-generalise in tcRnType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We switch on PolyKinds when kind-checking a user type, so that we will
kind-generalise the type, even when PolyKinds is not otherwise on.
This gives the right default behaviour at the GHCi prompt, where if
you say ":k T", and T has a polymorphic kind, you'd like to see that
polymorphism. Of course.  If T isn't kind-polymorphic you won't get
anything unexpected, but the apparent *loss* of polymorphism, for
types that you know are polymorphic, is quite surprising.  See Trac
#7688 for a discussion.

Note that the goal is to generalise the *kind of the type*, not
the type itself! Example:
  ghci> data SameKind :: k -> k -> Type
  ghci> :k SameKind _

We want to get `k -> Type`, not `Any -> Type`, which is what we would
get without kind-generalisation. Note that `:k SameKind` is OK, as
GHC will not instantiate SameKind here, and so we see its full kind
of `forall k. k -> k -> Type`.

************************************************************************
*                                                                      *
                 tcRnDeclsi
*                                                                      *
************************************************************************

tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
-}

tcRnDeclsi :: HscEnv
           -> [LHsDecl GhcPs]
           -> IO (Messages, Maybe TcGblEnv)
tcRnDeclsi :: HscEnv -> [LHsDecl GhcPs] -> IO (Messages, Maybe TcGblEnv)
tcRnDeclsi HscEnv
hsc_env [LHsDecl GhcPs]
local_decls
  = HscEnv -> TcM TcGblEnv -> IO (Messages, Maybe TcGblEnv)
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcM TcGblEnv -> IO (Messages, Maybe TcGblEnv))
-> TcM TcGblEnv -> IO (Messages, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
    IsBootInterface
-> [LHsDecl GhcPs] -> Maybe (Located [LIE GhcPs]) -> TcM TcGblEnv
tcRnSrcDecls IsBootInterface
False [LHsDecl GhcPs]
local_decls Maybe (Located [LIE GhcPs])
forall a. Maybe a
Nothing

externaliseAndTidyId :: Module -> Id -> TcM Id
externaliseAndTidyId :: Module -> Var -> TcM Var
externaliseAndTidyId Module
this_mod Var
id
  = do { Name
name' <- Module -> Name -> TcRn Name
forall m n. Module -> Name -> TcRnIf m n Name
externaliseName Module
this_mod (Var -> Name
idName Var
id)
       ; Var -> TcM Var
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Var -> TcM Var) -> Var -> TcM Var
forall a b. (a -> b) -> a -> b
$ Var -> Var
globaliseId Var
id
                     Var -> Name -> Var
`setIdName` Name
name'
                     Var -> Type -> Var
`setIdType` Type -> Type
tidyTopType (Var -> Type
idType Var
id) }


{-
************************************************************************
*                                                                      *
        More GHCi stuff, to do with browsing and getting info
*                                                                      *
************************************************************************
-}

-- | ASSUMES that the module is either in the 'HomePackageTable' or is
-- a package module with an interface on disk.  If neither of these is
-- true, then the result will be an error indicating the interface
-- could not be found.
getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe (ModIface_ 'ModIfaceFinal))
getModuleInterface HscEnv
hsc_env Module
mod
  = HscEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
-> IO (Messages, Maybe (ModIface_ 'ModIfaceFinal))
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
 -> IO (Messages, Maybe (ModIface_ 'ModIfaceFinal)))
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
-> IO (Messages, Maybe (ModIface_ 'ModIfaceFinal))
forall a b. (a -> b) -> a -> b
$
    SDoc
-> Module
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
loadModuleInterface (String -> SDoc
text String
"getModuleInterface") Module
mod

tcRnLookupRdrName :: HscEnv -> Located RdrName
                  -> IO (Messages, Maybe [Name])
-- ^ Find all the Names that this RdrName could mean, in GHCi
tcRnLookupRdrName :: HscEnv -> Located RdrName -> IO (Messages, Maybe [Name])
tcRnLookupRdrName HscEnv
hsc_env (L SrcSpan
loc RdrName
rdr_name)
  = HscEnv -> RnM [Name] -> IO (Messages, Maybe [Name])
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (RnM [Name] -> IO (Messages, Maybe [Name]))
-> RnM [Name] -> IO (Messages, Maybe [Name])
forall a b. (a -> b) -> a -> b
$
    SrcSpan -> RnM [Name] -> RnM [Name]
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc           (RnM [Name] -> RnM [Name]) -> RnM [Name] -> RnM [Name]
forall a b. (a -> b) -> a -> b
$
    do {   -- If the identifier is a constructor (begins with an
           -- upper-case letter), then we need to consider both
           -- constructor and type class identifiers.
         let rdr_names :: [RdrName]
rdr_names = RdrName -> [RdrName]
dataTcOccs RdrName
rdr_name
       ; [[Name]]
names_s <- (RdrName -> RnM [Name])
-> [RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM RdrName -> RnM [Name]
lookupInfoOccRn [RdrName]
rdr_names
       ; let names :: [Name]
names = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
External instance of the constraint type Foldable []
concat [[Name]]
names_s
       ; IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when ([Name] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [Name]
names) (SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrTc (String -> SDoc
text String
"Not in scope:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable RdrName
ppr RdrName
rdr_name)))
       ; [Name] -> RnM [Name]
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return [Name]
names }

tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
tcRnLookupName HscEnv
hsc_env Name
name
  = HscEnv -> TcM TyThing -> IO (Messages, Maybe TyThing)
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcM TyThing -> IO (Messages, Maybe TyThing))
-> TcM TyThing -> IO (Messages, Maybe TyThing)
forall a b. (a -> b) -> a -> b
$
    Name -> TcM TyThing
tcRnLookupName' Name
name

-- To look up a name we have to look in the local environment (tcl_lcl)
-- as well as the global environment, which is what tcLookup does.
-- But we also want a TyThing, so we have to convert:

tcRnLookupName' :: Name -> TcRn TyThing
tcRnLookupName' :: Name -> TcM TyThing
tcRnLookupName' Name
name = do
   TcTyThing
tcthing <- Name -> TcM TcTyThing
tcLookup Name
name
   case TcTyThing
tcthing of
     AGlobal TyThing
thing    -> TyThing -> TcM TyThing
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return TyThing
thing
     ATcId{tct_id :: TcTyThing -> Var
tct_id=Var
id} -> TyThing -> TcM TyThing
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Var -> TyThing
AnId Var
id)
     TcTyThing
_ -> String -> TcM TyThing
forall a. String -> a
panic String
"tcRnLookupName'"

tcRnGetInfo :: HscEnv
            -> Name
            -> IO ( Messages
                  , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))

-- Used to implement :info in GHCi
--
-- Look up a RdrName and return all the TyThings it might be
-- A capitalised RdrName is given to us in the DataName namespace,
-- but we want to treat it as *both* a data constructor
--  *and* as a type or class constructor;
-- hence the call to dataTcOccs, and we return up to two results
tcRnGetInfo :: HscEnv
-> Name
-> IO
     (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
tcRnGetInfo HscEnv
hsc_env Name
name
  = HscEnv
-> TcRn (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> IO
     (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
 -> IO
      (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> TcRn (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> IO
     (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a b. (a -> b) -> a -> b
$
    do { HscEnv -> InteractiveContext -> TcRnIf TcGblEnv TcLclEnv ()
loadUnqualIfaces HscEnv
hsc_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
           -- Load the interface for all unqualified types and classes
           -- That way we will find all the instance declarations
           -- (Packages have not orphan modules, and we assume that
           --  in the home package all relevant modules are loaded.)

       ; TyThing
thing  <- Name -> TcM TyThing
tcRnLookupName' Name
name
       ; Fixity
fixity <- Name -> RnM Fixity
lookupFixityRn Name
name
       ; ([ClsInst]
cls_insts, [FamInst]
fam_insts) <- TyThing -> TcM ([ClsInst], [FamInst])
lookupInsts TyThing
thing
       ; let info :: SDoc
info = Name -> SDoc
lookupKnownNameInfo Name
name
       ; (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> TcRn (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TyThing
thing, Fixity
fixity, [ClsInst]
cls_insts, [FamInst]
fam_insts, SDoc
info) }


-- Lookup all class and family instances for a type constructor.
--
-- This function filters all instances in the type environment, so there
-- is a lot of duplicated work if it is called many times in the same
-- type environment. If this becomes a problem, the NameEnv computed
-- in GHC.getNameToInstancesIndex could be cached in TcM and both functions
-- could be changed to consult that index.
lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
lookupInsts :: TyThing -> TcM ([ClsInst], [FamInst])
lookupInsts (ATyCon TyCon
tc)
  = do  { InstEnvs { ie_global :: InstEnvs -> InstEnv
ie_global = InstEnv
pkg_ie, ie_local :: InstEnvs -> InstEnv
ie_local = InstEnv
home_ie, ie_visible :: InstEnvs -> VisibleOrphanModules
ie_visible = VisibleOrphanModules
vis_mods } <- TcM InstEnvs
tcGetInstEnvs
        ; (FamInstEnv
pkg_fie, FamInstEnv
home_fie) <- TcM FamInstEnvs
tcGetFamInstEnvs
                -- Load all instances for all classes that are
                -- in the type environment (which are all the ones
                -- we've seen in any interface file so far)

          -- Return only the instances relevant to the given thing, i.e.
          -- the instances whose head contains the thing's name.
        ; let cls_insts :: [ClsInst]
cls_insts =
                 [ ClsInst
ispec        -- Search all
                 | ClsInst
ispec <- InstEnv -> [ClsInst]
instEnvElts InstEnv
home_ie [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ InstEnv -> [ClsInst]
instEnvElts InstEnv
pkg_ie
                 , VisibleOrphanModules -> ClsInst -> IsBootInterface
instIsVisible VisibleOrphanModules
vis_mods ClsInst
ispec
                 , Name
tc_name Name -> FreeVars -> IsBootInterface
`elemNameSet` ClsInst -> FreeVars
orphNamesOfClsInst ClsInst
ispec ]
        ; let fam_insts :: [FamInst]
fam_insts =
                 [ FamInst
fispec
                 | FamInst
fispec <- FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
home_fie [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
pkg_fie
                 , Name
tc_name Name -> FreeVars -> IsBootInterface
`elemNameSet` FamInst -> FreeVars
orphNamesOfFamInst FamInst
fispec ]
        ; ([ClsInst], [FamInst]) -> TcM ([ClsInst], [FamInst])
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([ClsInst]
cls_insts, [FamInst]
fam_insts) }
  where
    tc_name :: Name
tc_name     = TyCon -> Name
tyConName TyCon
tc

lookupInsts TyThing
_ = ([ClsInst], [FamInst]) -> TcM ([ClsInst], [FamInst])
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([],[])

loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
-- Load the interface for everything that is in scope unqualified
-- This is so that we can accurately report the instances for
-- something
loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcRnIf TcGblEnv TcLclEnv ()
loadUnqualIfaces HscEnv
hsc_env InteractiveContext
ictxt
  = IfG () -> TcRnIf TcGblEnv TcLclEnv ()
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG () -> TcRnIf TcGblEnv TcLclEnv ())
-> IfG () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ do
    (Module -> IOEnv (Env IfGblEnv ()) (ModIface_ 'ModIfaceFinal))
-> [Module] -> IfG ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
mapM_ (SDoc
-> Module -> IOEnv (Env IfGblEnv ()) (ModIface_ 'ModIfaceFinal)
forall lcl. SDoc -> Module -> IfM lcl (ModIface_ 'ModIfaceFinal)
loadSysInterface SDoc
doc) (VisibleOrphanModules -> [Module]
moduleSetElts ([Module] -> VisibleOrphanModules
mkModuleSet [Module]
unqual_mods))
  where
    this_pkg :: GenUnit UnitId
this_pkg = DynFlags -> GenUnit UnitId
thisPackage (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)

    unqual_mods :: [Module]
unqual_mods = [ HasDebugCallStack => Name -> Module
Name -> Module
External instance of the constraint type HasDebugCallStack
nameModule Name
name
                  | GlobalRdrElt
gre <- GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts (InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
ictxt)
                  , let name :: Name
name = GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre
                  , GenUnit UnitId -> Name -> IsBootInterface
nameIsFromExternalPackage GenUnit UnitId
this_pkg Name
name
                  , OccName -> IsBootInterface
isTcOcc (Name -> OccName
nameOccName Name
name)   -- Types and classes only
                  , GlobalRdrElt -> IsBootInterface
unQualOK GlobalRdrElt
gre ]               -- In scope unqualified
    doc :: SDoc
doc = String -> SDoc
text String
"Need interface for module whose export(s) are in scope unqualified"



{-
************************************************************************
*                                                                      *
                Debugging output
      This is what happens when you do -ddump-types
*                                                                      *
************************************************************************
-}

-- | Dump, with a banner, if -ddump-rn
rnDump :: (Outputable a, Data a) => a -> TcRn ()
rnDump :: a -> TcRnIf TcGblEnv TcLclEnv ()
rnDump a
rn = DumpFlag
-> String -> DumpFormat -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
dumpOptTcRn DumpFlag
Opt_D_dump_rn String
"Renamer" DumpFormat
FormatHaskell (a -> SDoc
forall a. Outputable a => a -> SDoc
Evidence bound by a type signature of the constraint type Outputable a
ppr a
rn)

tcDump :: TcGblEnv -> TcRn ()
tcDump :: TcGblEnv -> TcRnIf TcGblEnv TcLclEnv ()
tcDump TcGblEnv
env
 = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags ;

        -- Dump short output if -ddump-types or -ddump-tc
        IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when (DumpFlag -> DynFlags -> IsBootInterface
dopt DumpFlag
Opt_D_dump_types DynFlags
dflags IsBootInterface -> IsBootInterface -> IsBootInterface
|| DumpFlag -> DynFlags -> IsBootInterface
dopt DumpFlag
Opt_D_dump_tc DynFlags
dflags)
          (IsBootInterface
-> DumpOptions
-> String
-> DumpFormat
-> SDoc
-> TcRnIf TcGblEnv TcLclEnv ()
dumpTcRn IsBootInterface
True (DumpFlag -> DumpOptions
dumpOptionsFromFlag DumpFlag
Opt_D_dump_types)
            String
"" DumpFormat
FormatText SDoc
short_dump) ;

        -- Dump bindings if -ddump-tc
        DumpFlag
-> String -> DumpFormat -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
dumpOptTcRn DumpFlag
Opt_D_dump_tc String
"Typechecker" DumpFormat
FormatHaskell SDoc
full_dump;

        -- Dump bindings as an hsSyn AST if -ddump-tc-ast
        DumpFlag
-> String -> DumpFormat -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
dumpOptTcRn DumpFlag
Opt_D_dump_tc_ast String
"Typechecker AST" DumpFormat
FormatHaskell SDoc
ast_dump
   }
  where
    short_dump :: SDoc
short_dump = TcGblEnv -> SDoc
pprTcGblEnv TcGblEnv
env
    full_dump :: SDoc
full_dump  = LHsBinds GhcTc -> SDoc
forall (idL :: Pass) (idR :: Pass).
(OutputableBndrId idL, OutputableBndrId idR) =>
LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
External instance of the constraint type OutputableBndr Var
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
External instance of the constraint type OutputableBndr Var
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
pprLHsBinds (TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
env)
        -- NB: foreign x-d's have undefined's in their types;
        --     hence can't show the tc_fords
    ast_dump :: SDoc
ast_dump = BlankSrcSpan -> LHsBinds GhcTc -> SDoc
forall a. Data a => BlankSrcSpan -> a -> SDoc
External instance of the constraint type forall a. Data a => Data (Bag a)
External instance of the constraint type forall l e. (Data l, Data e) => Data (GenLocated l e)
External instance of the constraint type Data SrcSpan
External instance of the constraint type Data (HsBindLR GhcTc GhcTc)
showAstData BlankSrcSpan
NoBlankSrcSpan (TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
env)

-- It's unpleasant having both pprModGuts and pprModDetails here
pprTcGblEnv :: TcGblEnv -> SDoc
pprTcGblEnv :: TcGblEnv -> SDoc
pprTcGblEnv (TcGblEnv { tcg_type_env :: TcGblEnv -> TypeEnv
tcg_type_env  = TypeEnv
type_env,
                        tcg_insts :: TcGblEnv -> [ClsInst]
tcg_insts     = [ClsInst]
insts,
                        tcg_fam_insts :: TcGblEnv -> [FamInst]
tcg_fam_insts = [FamInst]
fam_insts,
                        tcg_rules :: TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules     = [LRuleDecl GhcTc]
rules,
                        tcg_imports :: TcGblEnv -> ImportAvails
tcg_imports   = ImportAvails
imports })
  = (IsBootInterface -> SDoc) -> SDoc
getPprDebug ((IsBootInterface -> SDoc) -> SDoc)
-> (IsBootInterface -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \IsBootInterface
debug ->
    [SDoc] -> SDoc
vcat [ IsBootInterface -> TypeEnv -> SDoc
ppr_types IsBootInterface
debug TypeEnv
type_env
         , IsBootInterface -> [FamInst] -> TypeEnv -> SDoc
ppr_tycons IsBootInterface
debug [FamInst]
fam_insts TypeEnv
type_env
         , IsBootInterface -> TypeEnv -> SDoc
ppr_datacons IsBootInterface
debug TypeEnv
type_env
         , TypeEnv -> SDoc
ppr_patsyns TypeEnv
type_env
         , [ClsInst] -> SDoc
ppr_insts [ClsInst]
insts
         , [FamInst] -> SDoc
ppr_fam_insts [FamInst]
fam_insts
         , [LRuleDecl GhcTc] -> SDoc
ppr_rules [LRuleDecl GhcTc]
rules
         , String -> SDoc
text String
"Dependent modules:" SDoc -> SDoc -> SDoc
<+>
                ModuleNameEnv (ModuleName, IsBootInterface)
-> ([(ModuleName, IsBootInterface)] -> SDoc) -> SDoc
forall a. UniqFM a -> ([a] -> SDoc) -> SDoc
pprUFM (ImportAvails -> ModuleNameEnv (ModuleName, IsBootInterface)
imp_dep_mods ImportAvails
imports) ([(ModuleName, IsBootInterface)] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type forall a b. (Outputable a, Outputable b) => Outputable (a, b)
External instance of the constraint type Outputable ModuleName
External instance of the constraint type Outputable IsBootInterface
ppr ([(ModuleName, IsBootInterface)] -> SDoc)
-> ([(ModuleName, IsBootInterface)]
    -> [(ModuleName, IsBootInterface)])
-> [(ModuleName, IsBootInterface)]
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ModuleName, IsBootInterface)] -> [(ModuleName, IsBootInterface)]
forall a. Ord a => [a] -> [a]
External instance of the constraint type forall a b. (Ord a, Ord b) => Ord (a, b)
External instance of the constraint type Ord ModuleName
External instance of the constraint type Ord IsBootInterface
sort)
         , String -> SDoc
text String
"Dependent packages:" SDoc -> SDoc -> SDoc
<+>
                [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable UnitId
ppr (Set UnitId -> [UnitId]
forall a. Set a -> [a]
S.toList (Set UnitId -> [UnitId]) -> Set UnitId -> [UnitId]
forall a b. (a -> b) -> a -> b
$ ImportAvails -> Set UnitId
imp_dep_pkgs ImportAvails
imports)]
  where         -- The use of sort is just to reduce unnecessary
                -- wobbling in testsuite output

ppr_rules :: [LRuleDecl GhcTc] -> SDoc
ppr_rules :: [LRuleDecl GhcTc] -> SDoc
ppr_rules [LRuleDecl GhcTc]
rules
  = IsBootInterface -> SDoc -> SDoc
ppUnless ([LRuleDecl GhcTc] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [LRuleDecl GhcTc]
rules) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"RULES")
       Arity
2 ([SDoc] -> SDoc
vcat ((LRuleDecl GhcTc -> SDoc) -> [LRuleDecl GhcTc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LRuleDecl GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (RuleDecl (GhcPass p))
External instance of the constraint type OutputableBndr Var
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr [LRuleDecl GhcTc]
rules))

ppr_types :: Bool -> TypeEnv -> SDoc
ppr_types :: IsBootInterface -> TypeEnv -> SDoc
ppr_types IsBootInterface
debug TypeEnv
type_env
  = String -> (Var -> SDoc) -> [Var] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"TYPE SIGNATURES" Var -> SDoc
ppr_sig
             ((Var -> Var -> Ordering) -> [Var] -> [Var]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Var -> OccName) -> Var -> Var -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
External instance of the constraint type Ord OccName
comparing Var -> OccName
forall a. NamedThing a => a -> OccName
External instance of the constraint type NamedThing Var
getOccName) [Var]
ids)
  where
    ids :: [Var]
ids = [Var
id | Var
id <- TypeEnv -> [Var]
typeEnvIds TypeEnv
type_env, Var -> IsBootInterface
want_sig Var
id]
    want_sig :: Var -> IsBootInterface
want_sig Var
id
      | IsBootInterface
debug     = IsBootInterface
True
      | IsBootInterface
otherwise = Var -> IsBootInterface
forall x. NamedThing x => x -> IsBootInterface
External instance of the constraint type NamedThing Var
hasTopUserName Var
id
                    IsBootInterface -> IsBootInterface -> IsBootInterface
&& case Var -> IdDetails
idDetails Var
id of
                         IdDetails
VanillaId    -> IsBootInterface
True
                         RecSelId {}  -> IsBootInterface
True
                         ClassOpId {} -> IsBootInterface
True
                         FCallId {}   -> IsBootInterface
True
                         IdDetails
_            -> IsBootInterface
False
             -- Data cons (workers and wrappers), pattern synonyms,
             -- etc are suppressed (unless -dppr-debug),
             -- because they appear elsewhere

    ppr_sig :: Var -> SDoc
ppr_sig Var
id = SDoc -> Arity -> SDoc -> SDoc
hang (Var -> SDoc
forall a. OutputableBndr a => a -> SDoc
External instance of the constraint type OutputableBndr Var
pprPrefixOcc Var
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon) Arity
2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Type
ppr (Type -> Type
tidyTopType (Var -> Type
idType Var
id)))

ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc
ppr_tycons :: IsBootInterface -> [FamInst] -> TypeEnv -> SDoc
ppr_tycons IsBootInterface
debug [FamInst]
fam_insts TypeEnv
type_env
  = [SDoc] -> SDoc
vcat [ String -> (TyCon -> SDoc) -> [TyCon] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"TYPE CONSTRUCTORS" TyCon -> SDoc
ppr_tc [TyCon]
tycons
         , String -> (CoAxiom Branched -> SDoc) -> [CoAxiom Branched] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"COERCION AXIOMS" CoAxiom Branched -> SDoc
forall {br :: BranchFlag}. CoAxiom br -> SDoc
ppr_ax
                      (TypeEnv -> [CoAxiom Branched]
typeEnvCoAxioms TypeEnv
type_env) ]
  where
    fi_tycons :: [TyCon]
fi_tycons = [FamInst] -> [TyCon]
famInstsRepTyCons [FamInst]
fam_insts

    tycons :: [TyCon]
tycons = (TyCon -> TyCon -> Ordering) -> [TyCon] -> [TyCon]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((TyCon -> OccName) -> TyCon -> TyCon -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
External instance of the constraint type Ord OccName
comparing TyCon -> OccName
forall a. NamedThing a => a -> OccName
External instance of the constraint type NamedThing TyCon
getOccName) ([TyCon] -> [TyCon]) -> [TyCon] -> [TyCon]
forall a b. (a -> b) -> a -> b
$
             [TyCon
tycon | TyCon
tycon <- TypeEnv -> [TyCon]
typeEnvTyCons TypeEnv
type_env
                    , TyCon -> IsBootInterface
want_tycon TyCon
tycon]
             -- Sort by OccName to reduce unnecessary changes
    want_tycon :: TyCon -> IsBootInterface
want_tycon TyCon
tycon | IsBootInterface
debug      = IsBootInterface
True
                     | IsBootInterface
otherwise  = Name -> IsBootInterface
isExternalName (TyCon -> Name
tyConName TyCon
tycon) IsBootInterface -> IsBootInterface -> IsBootInterface
&&
                                    IsBootInterface -> IsBootInterface
not (TyCon
tycon TyCon -> [TyCon] -> IsBootInterface
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> IsBootInterface
External instance of the constraint type Eq TyCon
External instance of the constraint type Foldable []
`elem` [TyCon]
fi_tycons)
    ppr_tc :: TyCon -> SDoc
ppr_tc TyCon
tc
       = [SDoc] -> SDoc
vcat [ SDoc -> Arity -> SDoc -> SDoc
hang (TyConFlavour -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable TyConFlavour
ppr (TyCon -> TyConFlavour
tyConFlavour TyCon
tc) SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. OutputableBndr a => a -> SDoc
External instance of the constraint type OutputableBndr Name
pprPrefixOcc (TyCon -> Name
tyConName TyCon
tc)
                      SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (Arity -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Arity
ppr (TyCon -> Arity
tyConArity TyCon
tc)) SDoc -> SDoc -> SDoc
<+> SDoc
dcolon)
                   Arity
2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Type
ppr (Type -> Type
tidyTopType (TyCon -> Type
tyConKind TyCon
tc)))
              , Arity -> SDoc -> SDoc
nest Arity
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                IsBootInterface -> SDoc -> SDoc
ppWhen IsBootInterface
show_roles (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                String -> SDoc
text String
"roles" SDoc -> SDoc -> SDoc
<+> ([SDoc] -> SDoc
sep ((Role -> SDoc) -> [Role] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Role -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Role
ppr [Role]
roles)) ]
       where
         show_roles :: IsBootInterface
show_roles = IsBootInterface
debug IsBootInterface -> IsBootInterface -> IsBootInterface
|| IsBootInterface -> IsBootInterface
not ((Role -> IsBootInterface) -> [Role] -> IsBootInterface
forall (t :: * -> *) a.
Foldable t =>
(a -> IsBootInterface) -> t a -> IsBootInterface
External instance of the constraint type Foldable []
all (Role -> Role -> IsBootInterface
forall a. Eq a => a -> a -> IsBootInterface
External instance of the constraint type Eq Role
== Role
boring_role) [Role]
roles)
         roles :: [Role]
roles = TyCon -> [Role]
tyConRoles TyCon
tc
         boring_role :: Role
boring_role | TyCon -> IsBootInterface
isClassTyCon TyCon
tc = Role
Nominal
                     | IsBootInterface
otherwise       = Role
Representational
            -- Matches the choice in GHC.Iface.Syntax, calls to pprRoles

    ppr_ax :: CoAxiom br -> SDoc
ppr_ax CoAxiom br
ax = IfaceDecl -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable IfaceDecl
ppr (CoAxiom br -> IfaceDecl
forall (br :: BranchFlag). CoAxiom br -> IfaceDecl
coAxiomToIfaceDecl CoAxiom br
ax)
      -- We go via IfaceDecl rather than using pprCoAxiom
      -- This way we get the full axiom (both LHS and RHS) with
      -- wildcard binders tidied to _1, _2, etc.

ppr_datacons :: Bool -> TypeEnv -> SDoc
ppr_datacons :: IsBootInterface -> TypeEnv -> SDoc
ppr_datacons IsBootInterface
debug TypeEnv
type_env
  = String -> (DataCon -> SDoc) -> [DataCon] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"DATA CONSTRUCTORS" DataCon -> SDoc
ppr_dc [DataCon]
wanted_dcs
      -- The filter gets rid of class data constructors
  where
    ppr_dc :: DataCon -> SDoc
ppr_dc DataCon
dc = DataCon -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable DataCon
ppr DataCon
dc SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Type
ppr (DataCon -> Type
dataConUserType DataCon
dc)
    all_dcs :: [DataCon]
all_dcs    = TypeEnv -> [DataCon]
typeEnvDataCons TypeEnv
type_env
    wanted_dcs :: [DataCon]
wanted_dcs | IsBootInterface
debug     = [DataCon]
all_dcs
               | IsBootInterface
otherwise = (DataCon -> IsBootInterface) -> [DataCon] -> [DataCon]
forall a. (a -> IsBootInterface) -> [a] -> [a]
filterOut DataCon -> IsBootInterface
is_cls_dc [DataCon]
all_dcs
    is_cls_dc :: DataCon -> IsBootInterface
is_cls_dc DataCon
dc = TyCon -> IsBootInterface
isClassTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)

ppr_patsyns :: TypeEnv -> SDoc
ppr_patsyns :: TypeEnv -> SDoc
ppr_patsyns TypeEnv
type_env
  = String -> (PatSyn -> SDoc) -> [PatSyn] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"PATTERN SYNONYMS" PatSyn -> SDoc
ppr_ps
               (TypeEnv -> [PatSyn]
typeEnvPatSyns TypeEnv
type_env)
  where
    ppr_ps :: PatSyn -> SDoc
ppr_ps PatSyn
ps = PatSyn -> SDoc
forall a. OutputableBndr a => a -> SDoc
External instance of the constraint type OutputableBndr PatSyn
pprPrefixOcc PatSyn
ps SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> PatSyn -> SDoc
pprPatSynType PatSyn
ps

ppr_insts :: [ClsInst] -> SDoc
ppr_insts :: [ClsInst] -> SDoc
ppr_insts [ClsInst]
ispecs
  = String -> (ClsInst -> SDoc) -> [ClsInst] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"CLASS INSTANCES" ClsInst -> SDoc
pprInstance [ClsInst]
ispecs

ppr_fam_insts :: [FamInst] -> SDoc
ppr_fam_insts :: [FamInst] -> SDoc
ppr_fam_insts [FamInst]
fam_insts
  = String -> (FamInst -> SDoc) -> [FamInst] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"FAMILY INSTANCES" FamInst -> SDoc
pprFamInst [FamInst]
fam_insts

ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc
ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
herald a -> SDoc
ppr_one [a]
things
  | [a] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
External instance of the constraint type Foldable []
null [a]
things = SDoc
empty
  | IsBootInterface
otherwise   = String -> SDoc
text String
herald SDoc -> SDoc -> SDoc
$$ Arity -> SDoc -> SDoc
nest Arity
2 ([SDoc] -> SDoc
vcat ((a -> SDoc) -> [a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map a -> SDoc
ppr_one [a]
things))

hasTopUserName :: NamedThing x => x -> Bool
-- A top-level thing whose name is not "derived"
-- Thus excluding things like $tcX, from Typeable boilerplate
-- and C:Coll from class-dictionary data constructors
hasTopUserName :: x -> IsBootInterface
hasTopUserName x
x
  = Name -> IsBootInterface
isExternalName Name
name IsBootInterface -> IsBootInterface -> IsBootInterface
&& IsBootInterface -> IsBootInterface
not (OccName -> IsBootInterface
isDerivedOccName (Name -> OccName
nameOccName Name
name))
  where
    name :: Name
name = x -> Name
forall a. NamedThing a => a -> Name
Evidence bound by a type signature of the constraint type NamedThing x
getName x
x

{-
********************************************************************************

Type Checker Plugins

********************************************************************************
-}

withTcPlugins :: HscEnv -> TcM a -> TcM a
withTcPlugins :: HscEnv -> TcM a -> TcM a
withTcPlugins HscEnv
hsc_env TcM a
m =
  do let plugins :: [TcPlugin]
plugins = DynFlags -> [TcPlugin]
getTcPlugins (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
     case [TcPlugin]
plugins of
       [] -> TcM a
m  -- Common fast case
       [TcPlugin]
_  -> do EvBindsVar
ev_binds_var <- TcM EvBindsVar
newTcEvBinds
                ([TcPluginSolver]
solvers,[TcPluginM ()]
stops) <- [(TcPluginSolver, TcPluginM ())]
-> ([TcPluginSolver], [TcPluginM ()])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(TcPluginSolver, TcPluginM ())]
 -> ([TcPluginSolver], [TcPluginM ()]))
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcPluginSolver, TcPluginM ())]
-> IOEnv (Env TcGblEnv TcLclEnv) ([TcPluginSolver], [TcPluginM ()])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
`fmap` (TcPlugin
 -> IOEnv (Env TcGblEnv TcLclEnv) (TcPluginSolver, TcPluginM ()))
-> [TcPlugin]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TcPluginSolver, TcPluginM ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM (EvBindsVar
-> TcPlugin
-> IOEnv (Env TcGblEnv TcLclEnv) (TcPluginSolver, TcPluginM ())
startPlugin EvBindsVar
ev_binds_var) [TcPlugin]
plugins
                -- This ensures that tcPluginStop is called even if a type
                -- error occurs during compilation (Fix of #10078)
                Either IOEnvFailure a
eitherRes <- TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM (TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a))
-> TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$ do
                  (TcGblEnv -> TcGblEnv) -> TcM a -> TcM a
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
e -> TcGblEnv
e { tcg_tc_plugins :: [TcPluginSolver]
tcg_tc_plugins = [TcPluginSolver]
solvers }) TcM a
m
                (TcPluginM () -> TcRnIf TcGblEnv TcLclEnv ())
-> [TcPluginM ()] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
mapM_ ((TcPluginM () -> EvBindsVar -> TcRnIf TcGblEnv TcLclEnv ())
-> EvBindsVar -> TcPluginM () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip TcPluginM () -> EvBindsVar -> TcRnIf TcGblEnv TcLclEnv ()
forall a. TcPluginM a -> EvBindsVar -> TcM a
runTcPluginM EvBindsVar
ev_binds_var) [TcPluginM ()]
stops
                case Either IOEnvFailure a
eitherRes of
                  Left IOEnvFailure
_ -> TcM a
forall env a. IOEnv env a
failM
                  Right a
res -> a -> TcM a
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return a
res
  where
  startPlugin :: EvBindsVar
-> TcPlugin
-> IOEnv (Env TcGblEnv TcLclEnv) (TcPluginSolver, TcPluginM ())
startPlugin EvBindsVar
ev_binds_var (TcPlugin TcPluginM s
start s -> TcPluginSolver
solve s -> TcPluginM ()
stop) =
    do s
s <- TcPluginM s -> EvBindsVar -> TcM s
forall a. TcPluginM a -> EvBindsVar -> TcM a
runTcPluginM TcPluginM s
start EvBindsVar
ev_binds_var
       (TcPluginSolver, TcPluginM ())
-> IOEnv (Env TcGblEnv TcLclEnv) (TcPluginSolver, TcPluginM ())
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (s -> TcPluginSolver
solve s
s, s -> TcPluginM ()
stop s
s)

getTcPlugins :: DynFlags -> [GHC.Tc.Utils.Monad.TcPlugin]
getTcPlugins :: DynFlags -> [TcPlugin]
getTcPlugins DynFlags
dflags = [Maybe TcPlugin] -> [TcPlugin]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TcPlugin] -> [TcPlugin]) -> [Maybe TcPlugin] -> [TcPlugin]
forall a b. (a -> b) -> a -> b
$ DynFlags
-> (Plugin -> [String] -> Maybe TcPlugin) -> [Maybe TcPlugin]
forall a. DynFlags -> (Plugin -> [String] -> a) -> [a]
mapPlugins DynFlags
dflags (\Plugin
p [String]
args -> Plugin -> [String] -> Maybe TcPlugin
tcPlugin Plugin
p [String]
args)


withHoleFitPlugins :: HscEnv -> TcM a -> TcM a
withHoleFitPlugins :: HscEnv -> TcM a -> TcM a
withHoleFitPlugins HscEnv
hsc_env TcM a
m =
  case (DynFlags -> [HoleFitPluginR]
getHfPlugins (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) of
    [] -> TcM a
m  -- Common fast case
    [HoleFitPluginR]
plugins -> do ([HoleFitPlugin]
plugins,[TcRnIf TcGblEnv TcLclEnv ()]
stops) <- [(HoleFitPlugin, TcRnIf TcGblEnv TcLclEnv ())]
-> ([HoleFitPlugin], [TcRnIf TcGblEnv TcLclEnv ()])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(HoleFitPlugin, TcRnIf TcGblEnv TcLclEnv ())]
 -> ([HoleFitPlugin], [TcRnIf TcGblEnv TcLclEnv ()]))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [(HoleFitPlugin, TcRnIf TcGblEnv TcLclEnv ())]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([HoleFitPlugin], [TcRnIf TcGblEnv TcLclEnv ()])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
`fmap` (HoleFitPluginR
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (HoleFitPlugin, TcRnIf TcGblEnv TcLclEnv ()))
-> [HoleFitPluginR]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [(HoleFitPlugin, TcRnIf TcGblEnv TcLclEnv ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM HoleFitPluginR
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (HoleFitPlugin, TcRnIf TcGblEnv TcLclEnv ())
startPlugin [HoleFitPluginR]
plugins
                  -- This ensures that hfPluginStop is called even if a type
                  -- error occurs during compilation.
                  Either IOEnvFailure a
eitherRes <- TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM (TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a))
-> TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$ do
                    (TcGblEnv -> TcGblEnv) -> TcM a -> TcM a
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
e -> TcGblEnv
e { tcg_hf_plugins :: [HoleFitPlugin]
tcg_hf_plugins = [HoleFitPlugin]
plugins }) TcM a
m
                  [TcRnIf TcGblEnv TcLclEnv ()] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
sequence_ [TcRnIf TcGblEnv TcLclEnv ()]
stops
                  case Either IOEnvFailure a
eitherRes of
                    Left IOEnvFailure
_ -> TcM a
forall env a. IOEnv env a
failM
                    Right a
res -> a -> TcM a
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return a
res
  where
    startPlugin :: HoleFitPluginR
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (HoleFitPlugin, TcRnIf TcGblEnv TcLclEnv ())
startPlugin (HoleFitPluginR TcM (TcRef s)
init TcRef s -> HoleFitPlugin
plugin TcRef s -> TcRnIf TcGblEnv TcLclEnv ()
stop) =
      do TcRef s
ref <- TcM (TcRef s)
init
         (HoleFitPlugin, TcRnIf TcGblEnv TcLclEnv ())
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (HoleFitPlugin, TcRnIf TcGblEnv TcLclEnv ())
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (TcRef s -> HoleFitPlugin
plugin TcRef s
ref, TcRef s -> TcRnIf TcGblEnv TcLclEnv ()
stop TcRef s
ref)

getHfPlugins :: DynFlags -> [HoleFitPluginR]
getHfPlugins :: DynFlags -> [HoleFitPluginR]
getHfPlugins DynFlags
dflags =
  [Maybe HoleFitPluginR] -> [HoleFitPluginR]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe HoleFitPluginR] -> [HoleFitPluginR])
-> [Maybe HoleFitPluginR] -> [HoleFitPluginR]
forall a b. (a -> b) -> a -> b
$ DynFlags
-> (Plugin -> [String] -> Maybe HoleFitPluginR)
-> [Maybe HoleFitPluginR]
forall a. DynFlags -> (Plugin -> [String] -> a) -> [a]
mapPlugins DynFlags
dflags (\Plugin
p [String]
args -> Plugin -> [String] -> Maybe HoleFitPluginR
holeFitPlugin Plugin
p [String]
args)


runRenamerPlugin :: TcGblEnv
                 -> HsGroup GhcRn
                 -> TcM (TcGblEnv, HsGroup GhcRn)
runRenamerPlugin :: TcGblEnv
-> HsGroup (GhcPass 'Renamed)
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
runRenamerPlugin TcGblEnv
gbl_env HsGroup (GhcPass 'Renamed)
hs_group = do
    DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
    DynFlags
-> PluginOperation
     (IOEnv (Env TcGblEnv TcLclEnv))
     (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall (m :: * -> *) a.
Monad m =>
DynFlags -> PluginOperation m a -> a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
withPlugins DynFlags
dflags
      (\Plugin
p [String]
opts (TcGblEnv
e, HsGroup (GhcPass 'Renamed)
g) -> ( DynFlags -> TcRnIf TcGblEnv TcLclEnv ()
mark_plugin_unsafe DynFlags
dflags TcRnIf TcGblEnv TcLclEnv ()
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
External instance of the constraint type forall m. Monad (IOEnv m)
>> Plugin
-> [String]
-> TcGblEnv
-> HsGroup (GhcPass 'Renamed)
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
renamedResultAction Plugin
p [String]
opts TcGblEnv
e HsGroup (GhcPass 'Renamed)
g))
      (TcGblEnv
gbl_env, HsGroup (GhcPass 'Renamed)
hs_group)


-- XXX: should this really be a Maybe X?  Check under which circumstances this
-- can become a Nothing and decide whether this should instead throw an
-- exception/signal an error.
type RenamedStuff =
        (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
                Maybe LHsDocString))

-- | Extract the renamed information from TcGblEnv.
getRenamedStuff :: TcGblEnv -> RenamedStuff
getRenamedStuff :: TcGblEnv -> RenamedStuff
getRenamedStuff TcGblEnv
tc_result
  = (HsGroup (GhcPass 'Renamed)
 -> (HsGroup (GhcPass 'Renamed), [LImportDecl (GhcPass 'Renamed)],
     Maybe [(GenLocated SrcSpan (IE (GhcPass 'Renamed)), [AvailInfo])],
     Maybe LHsDocString))
-> Maybe (HsGroup (GhcPass 'Renamed)) -> RenamedStuff
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor Maybe
fmap (\HsGroup (GhcPass 'Renamed)
decls -> ( HsGroup (GhcPass 'Renamed)
decls, TcGblEnv -> [LImportDecl (GhcPass 'Renamed)]
tcg_rn_imports TcGblEnv
tc_result
                    , TcGblEnv
-> Maybe
     [(GenLocated SrcSpan (IE (GhcPass 'Renamed)), [AvailInfo])]
tcg_rn_exports TcGblEnv
tc_result, TcGblEnv -> Maybe LHsDocString
tcg_doc_hdr TcGblEnv
tc_result ) )
         (TcGblEnv -> Maybe (HsGroup (GhcPass 'Renamed))
tcg_rn_decls TcGblEnv
tc_result)

runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv
runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv
runTypecheckerPlugin ModSummary
sum HscEnv
hsc_env TcGblEnv
gbl_env = do
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    DynFlags
-> PluginOperation (IOEnv (Env TcGblEnv TcLclEnv)) TcGblEnv
-> TcGblEnv
-> TcM TcGblEnv
forall (m :: * -> *) a.
Monad m =>
DynFlags -> PluginOperation m a -> a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
withPlugins DynFlags
dflags
      (\Plugin
p [String]
opts TcGblEnv
env -> DynFlags -> TcRnIf TcGblEnv TcLclEnv ()
mark_plugin_unsafe DynFlags
dflags
                        TcRnIf TcGblEnv TcLclEnv () -> TcM TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
External instance of the constraint type forall m. Monad (IOEnv m)
>> Plugin -> [String] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typeCheckResultAction Plugin
p [String]
opts ModSummary
sum TcGblEnv
env)
      TcGblEnv
gbl_env

mark_plugin_unsafe :: DynFlags -> TcM ()
mark_plugin_unsafe :: DynFlags -> TcRnIf TcGblEnv TcLclEnv ()
mark_plugin_unsafe DynFlags
dflags = IsBootInterface
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *).
Applicative f =>
IsBootInterface -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
unless (GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_PluginTrustworthy DynFlags
dflags) (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
  Bag WarnMsg -> TcRnIf TcGblEnv TcLclEnv ()
recordUnsafeInfer Bag WarnMsg
pluginUnsafe
  where
    unsafeText :: String
unsafeText = String
"Use of plugins makes the module unsafe"
    pluginUnsafe :: Bag WarnMsg
pluginUnsafe = WarnMsg -> Bag WarnMsg
forall a. a -> Bag a
unitBag ( DynFlags -> SrcSpan -> SDoc -> WarnMsg
mkPlainWarnMsg DynFlags
dflags SrcSpan
noSrcSpan
                                   (String -> SDoc
Outputable.text String
unsafeText) )