{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}

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

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

-}

-- | 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)
        withTcPlugins,       -- Used by GHC API clients (#20499)
        withHoleFitPlugins,  -- Used by GHC API clients (#20499)
        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 GHC.Driver.Env
import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Config.Diagnostic

import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )
import GHC.Tc.Errors.Types
import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers )
import GHC.Tc.Gen.HsType
import GHC.Tc.Validity( checkValidType )
import GHC.Tc.Gen.Match
import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma )
import GHC.Tc.Utils.Zonk
import GHC.Tc.Gen.Expr
import GHC.Tc.Gen.App( tcInferSigma )
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 GHC.Tc.Instance.Family
import GHC.Tc.Gen.Annotation
import GHC.Tc.Gen.Bind
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.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Instantiate (tcGetInsts)
import GHC.Tc.Solver
import GHC.Tc.TyCl
import GHC.Tc.Instance.Typeable ( mkTypeableBinds )
import GHC.Tc.Utils.Backpack

import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
import GHC.Rename.HsType
import GHC.Rename.Expr
import GHC.Rename.Fixity ( lookupFixityRn )
import GHC.Rename.Names
import GHC.Rename.Env
import GHC.Rename.Module
import GHC.Rename.Doc

import GHC.Iface.Syntax   ( ShowSub(..), showToHeader )
import GHC.Iface.Type     ( ShowForAllFlag(..) )
import GHC.Iface.Env     ( externaliseName )
import GHC.Iface.Make   ( coAxiomToIfaceDecl )
import GHC.Iface.Load

import GHC.Builtin.Types ( unitTy, mkListTy )
import GHC.Builtin.Names
import GHC.Builtin.Utils

import GHC.Hs
import GHC.Hs.Dump

import GHC.Core.PatSyn    ( pprPatSynType )
import GHC.Core.Predicate ( classMethodTy )
import GHC.Core.InstEnv
import GHC.Core.TyCon
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Core.Class
import GHC.Core.Coercion.Axiom
import GHC.Core.Reduction ( Reduction(..) )
import GHC.Core.RoughMap( RoughMatchTc(..) )
import GHC.Core.TyCo.Ppr( debugPprType )
import GHC.Core.FamInstEnv
   ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst
   , famInstEnvElts, extendFamInstEnvList, normaliseType )

import GHC.Parser.Header       ( mkPrelImports )

import GHC.IfaceToCore

import GHC.Runtime.Context

import GHC.Utils.Error
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Logger

import GHC.Types.Error
import GHC.Types.Name.Reader
import GHC.Types.Fixity.Env
import GHC.Types.Id as Id
import GHC.Types.Id.Info( IdDetails(..) )
import GHC.Types.Var.Env
import GHC.Types.TypeEnv
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.Types.Basic hiding( SuccessFlag(..) )
import GHC.Types.Annotations
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.TyThing.Ppr ( pprTyThingInContext )
import GHC.Types.PkgQual
import qualified GHC.LanguageExtensions as LangExt

import GHC.Unit.External
import GHC.Unit.Types
import GHC.Unit.State
import GHC.Unit.Home
import GHC.Unit.Module
import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Deps

import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.List.SetOps
import GHC.Data.Bag
import qualified GHC.Data.BooleanFormula as BF

import Data.Functor.Classes ( liftEq )
import Data.List ( sortBy, sort )
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Data.Ord
import Data.Data ( Data )
import qualified Data.Set as S
import Control.DeepSeq
import Control.Monad

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

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

tcRnModule :: HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnModule HscEnv
hsc_env ModSummary
mod_sum Bool
save_rn_syntax
   parsedModule :: HsParsedModule
parsedModule@HsParsedModule {hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module= L SrcSpan
loc HsModule GhcPs
this_module}
 | RealSrcSpan RealSrcSpan
real_loc Maybe BufSpan
_ <- SrcSpan
loc
 = Logger
-> SDoc
-> ((Messages TcRnMessage, Maybe TcGblEnv) -> ())
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
              (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Renamer/typechecker"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
              (() -> (Messages TcRnMessage, Maybe TcGblEnv) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages TcRnMessage, Maybe TcGblEnv)
 -> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
   HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc HscEnv
hsc_env HscSource
hsc_src Bool
save_rn_syntax Module
this_mod RealSrcSpan
real_loc (TcM TcGblEnv -> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> TcM TcGblEnv -> IO (Messages TcRnMessage, 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
withDefaultingPlugins 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

  | Bool
otherwise
  = (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MsgEnvelope TcRnMessage
err_msg MsgEnvelope TcRnMessage
-> Messages TcRnMessage -> Messages TcRnMessage
forall e. MsgEnvelope e -> Messages e -> Messages e
`addMessage` Messages TcRnMessage
forall e. Messages e
emptyMessages, Maybe TcGblEnv
forall a. Maybe a
Nothing)

  where
    hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_sum
    logger :: Logger
logger  = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
    err_msg :: MsgEnvelope TcRnMessage
err_msg = SrcSpan -> TcRnMessage -> MsgEnvelope TcRnMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (TcRnMessage -> MsgEnvelope TcRnMessage)
-> TcRnMessage -> MsgEnvelope TcRnMessage
forall a b. (a -> b) -> a -> b
$
              Module -> TcRnMessage
TcRnModMissingRealSrcSpan Module
this_mod

    pair :: (Module, SrcSpan)
    pair :: (Module, SrcSpan)
pair@(Module
this_mod,SrcSpan
_)
      | Just (L SrcSpanAnnA
mod_loc ModuleName
mod) <- HsModule GhcPs -> Maybe (XRec GhcPs ModuleName)
forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName HsModule GhcPs
this_module
      = (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod, SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
mod_loc)

      | Bool
otherwise   -- 'module M where' is omitted
      = (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mAIN_NAME, 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 GhcPs)
hpm_module =
                      (L SrcSpan
loc (HsModule (XModulePs EpAnn AnnsModule
_ LayoutInfo GhcPs
_ Maybe (LocatedP (WarningTxt GhcPs))
mod_deprec Maybe (LHsDoc GhcPs)
maybe_doc_hdr)
                                       Maybe (XRec GhcPs ModuleName)
maybe_mod Maybe (XRec GhcPs [XRec GhcPs (IE GhcPs)])
export_ies [LImportDecl GhcPs]
import_decls [LHsDecl GhcPs]
local_decls)),
                   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 :: Bool
explicit_mod_hdr = Maybe (GenLocated SrcSpanAnnA ModuleName) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (XRec GhcPs ModuleName)
Maybe (GenLocated SrcSpanAnnA 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.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv (TcGblEnv
tcg_env { tcg_self_boot = 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
          Bool
implicit_prelude <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ImplicitPrelude
        ; let { prel_imports :: [LImportDecl GhcPs]
prel_imports = ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod) SrcSpan
prel_imp_loc
                               Bool
implicit_prelude [LImportDecl GhcPs]
import_decls }

        ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
prel_imports) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
            let msg :: TcRnMessage
msg = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
                        DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnImplicitPrelude) [GhcHint]
noHints (SDoc
implicitPreludeWarn)
            TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnostic TcRnMessage
msg

        ; -- TODO This is a little skeevy; maybe handle a bit more directly
          let { simplifyImport :: GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (PkgQual, Located ModuleName)
simplifyImport (L SrcSpanAnnA
_ ImportDecl GhcPs
idecl) =
                  ( UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
renameRawPkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
idecl) (ImportDecl GhcPs -> ImportDeclPkgQual GhcPs
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl GhcPs
idecl)
                  , GenLocated SrcSpanAnnA ModuleName -> Located ModuleName
forall a e. LocatedAn a e -> Located e
reLoc (GenLocated SrcSpanAnnA ModuleName -> Located ModuleName)
-> GenLocated SrcSpanAnnA ModuleName -> Located ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
idecl)
              }
        ; [ModuleName]
raw_sig_imports <- IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName]
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                             (IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName])
-> IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName]
forall a b. (a -> b) -> a -> b
$ HscEnv -> HscSource -> ModuleName -> IO [ModuleName]
findExtraSigImports HscEnv
hsc_env HscSource
hsc_src
                                 (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod)
        ; [ModuleName]
raw_req_imports <- IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName]
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                             (IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName])
-> IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName]
forall a b. (a -> b) -> a -> b
$ HscEnv -> [(PkgQual, Located ModuleName)] -> IO [ModuleName]
implicitRequirements HscEnv
hsc_env
                                ((GenLocated SrcSpanAnnA (ImportDecl GhcPs)
 -> (PkgQual, Located ModuleName))
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(PkgQual, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (PkgQual, Located ModuleName)
simplifyImport ([LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
prel_imports
                                                     [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
import_decls))
        ; let { mkImport :: ModuleName -> LocatedAn an (ImportDecl pass)
mkImport ModuleName
mod_name = ImportDecl pass -> LocatedAn an (ImportDecl pass)
forall a an. a -> LocatedAn an a
noLocA
                (ImportDecl pass -> LocatedAn an (ImportDecl pass))
-> ImportDecl pass -> LocatedAn an (ImportDecl pass)
forall a b. (a -> b) -> a -> b
$ (ModuleName -> ImportDecl GhcPs
simpleImportDecl ModuleName
mod_name)
                  { ideclImportList = Just (Exactly, noLocA [])}}
        ; let { withReason :: String -> [a] -> [(a, t)]
withReason String
t [a]
imps = (a -> (a, t)) -> [a] -> [(a, t)]
forall a b. (a -> b) -> [a] -> [b]
map (,String -> t
forall doc. IsLine doc => String -> doc
text String
t) [a]
imps }
        ; let { all_imports :: [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
all_imports = String
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall {t} {a}. IsLine t => String -> [a] -> [(a, t)]
withReason String
"is implicitly imported" [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
prel_imports
                  [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall a. [a] -> [a] -> [a]
++ String
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall {t} {a}. IsLine t => String -> [a] -> [(a, t)]
withReason String
"is directly imported" [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
import_decls
                  [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall a. [a] -> [a] -> [a]
++ String
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall {t} {a}. IsLine t => String -> [a] -> [(a, t)]
withReason String
"is an extra sig import" ((ModuleName -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> [ModuleName] -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall {pass} {an} {an}.
(ImportDeclPkgQual pass ~ RawPkgQual,
 XCImportDecl pass ~ XImportDeclPass,
 XRec pass [XRec pass (IE pass)]
 ~ LocatedAn an [XRec pass (IE pass)],
 XRec pass ModuleName ~ GenLocated SrcSpanAnnA ModuleName) =>
ModuleName -> LocatedAn an (ImportDecl pass)
mkImport [ModuleName]
raw_sig_imports)
                  [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall a. [a] -> [a] -> [a]
++ String
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall {t} {a}. IsLine t => String -> [a] -> [(a, t)]
withReason String
"is an implicit req import" ((ModuleName -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> [ModuleName] -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall {pass} {an} {an}.
(ImportDeclPkgQual pass ~ RawPkgQual,
 XCImportDecl pass ~ XImportDeclPass,
 XRec pass [XRec pass (IE pass)]
 ~ LocatedAn an [XRec pass (IE pass)],
 XRec pass ModuleName ~ GenLocated SrcSpanAnnA ModuleName) =>
ModuleName -> LocatedAn an (ImportDecl pass)
mkImport [ModuleName]
raw_req_imports) }
        ; -- OK now finally rename the imports
          TcGblEnv
tcg_env <- {-# SCC "tcRnImports" #-}
                     HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv
tcRnImports HscEnv
hsc_env [(LImportDecl GhcPs, SDoc)]
[(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
all_imports

        -- Put a version of the header without identifier info into the tcg_env
        -- Make sure to do this before 'tcRnSrcDecls', because we need the
        -- module header when we're splicing TH, since it can be accessed via
        -- 'getDoc'.
        -- We will rename it properly after renaming everything else so that
        -- haddock can link the identifiers
        ; TcGblEnv
tcg_env <- TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env
                              { tcg_doc_hdr = fmap (\(WithHsDocIdentifiers HsDocString
str [Located (IdP GhcPs)]
_) -> HsDocString
-> [Located (IdP (GhcPass 'Renamed))] -> HsDoc (GhcPass 'Renamed)
forall a pass.
a -> [Located (IdP pass)] -> WithHsDocIdentifiers a pass
WithHsDocIdentifiers HsDocString
str [])
                                                                                 <$> maybe_doc_hdr })
        ; -- 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
        ; TcGblEnv
tcg_env1 <- case Maybe (LocatedP (WarningTxt GhcPs))
mod_deprec of
                             Just (L SrcSpanAnnP
_ WarningTxt GhcPs
txt) -> do { WarningTxt (GhcPass 'Renamed)
txt' <- WarningTxt GhcPs -> RnM (WarningTxt (GhcPass 'Renamed))
rnWarningTxt WarningTxt GhcPs
txt
                                                  ; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcGblEnv -> TcM TcGblEnv) -> TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ TcGblEnv
tcg_env {tcg_warns = WarnAll txt'}
                                                  }
                             Maybe (LocatedP (WarningTxt GhcPs))
Nothing            -> TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TcGblEnv
tcg_env
        ; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn1a" SDoc
forall doc. IsOutput doc => doc
empty
               ; TcGblEnv
tcg_env <- if HscSource -> Bool
isHsBootOrSig HscSource
hsc_src
                            then do {
                              ; TcGblEnv
tcg_env <- HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnHsBootDecls HscSource
hsc_src [LHsDecl GhcPs]
local_decls
                              ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn4a: before exports" SDoc
forall doc. IsOutput doc => doc
empty
                              ; TcGblEnv
tcg_env <- TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
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
$
                                           Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> TcM TcGblEnv
rnExports Bool
explicit_mod_hdr Maybe (XRec GhcPs [XRec GhcPs (IE GhcPs)])
Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies
                              ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn4b: after exports" SDoc
forall doc. IsOutput doc => doc
empty
                              ; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
                              }
                            else {-# SCC "tcRnSrcDecls" #-}
                                 Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> [LHsDecl GhcPs]
-> TcM TcGblEnv
tcRnSrcDecls Bool
explicit_mod_hdr Maybe (XRec GhcPs [XRec GhcPs (IE GhcPs)])
Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies [LHsDecl GhcPs]
local_decls

               ; TcRnIf TcGblEnv TcLclEnv Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_DoCoreLinting) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
                 Logger -> DynFlags -> TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()
lintGblEnv (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) TcGblEnv
tcg_env

               ; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
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 { -- 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.
                      ; -- Report unused names
                        -- Do this /after/ typeinference, so that when reporting
                        -- a function with no type signature we can give the
                        -- inferred type
                      ; TcGblEnv -> HscSource -> IOEnv (Env TcGblEnv TcLclEnv) ()
reportUnusedNames TcGblEnv
tcg_env HscSource
hsc_src

                      -- Rename the module header properly after we have renamed everything else
                      ; Maybe (GenLocated SrcSpan (HsDoc (GhcPass 'Renamed)))
maybe_doc_hdr <- (LHsDoc GhcPs
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated SrcSpan (HsDoc (GhcPass 'Renamed))))
-> Maybe (LHsDoc GhcPs)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Maybe (GenLocated SrcSpan (HsDoc (GhcPass 'Renamed))))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse LHsDoc GhcPs
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpan (HsDoc (GhcPass 'Renamed)))
rnLHsDoc Maybe (LHsDoc GhcPs)
maybe_doc_hdr;
                      ; TcGblEnv
tcg_env <- TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env
                                            { tcg_doc_hdr = maybe_doc_hdr })

                      ; -- add extra source files to tcg_dependent_files
                        [String] -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDependentFiles [String]
src_files
                        -- Ensure plugins run with the same tcg_env that we pass in
                      ; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
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 { TcGblEnv
tcg_env <- ModSummary -> TcGblEnv -> TcM TcGblEnv
runTypecheckerPlugin ModSummary
mod_sum TcGblEnv
tcg_env
                             ; -- Dump output and return
                               TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcDump TcGblEnv
tcg_env
                             ; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
                             }
                      }
               }
        }
      }

implicitPreludeWarn :: SDoc
implicitPreludeWarn :: SDoc
implicitPreludeWarn
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Module `Prelude' implicitly imported"

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

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

        ; Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
        ; TcGblEnv
gbl_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; let { -- 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.
              ; (InstEnv
home_insts, [FamInst]
home_fam_insts) =

                    HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst])
hptInstancesBelow HscEnv
hsc_env (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId (HomeUnit -> UnitId) -> HomeUnit -> UnitId
forall a b. (a -> b) -> a -> b
$ HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod)(HscSource -> IsBootInterface
hscSourceToIsBoot (TcGblEnv -> HscSource
tcg_src TcGblEnv
gbl_env)))

              } ;

                -- Record boot-file info in the EPS, so that it's
                -- visible to loadHiBootInterface in tcRnSrcDecls,
                -- and any other incrementally-performed imports
              ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do {
                  (ExternalPackageState -> ExternalPackageState)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl.
(ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ ((ExternalPackageState -> ExternalPackageState)
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (ExternalPackageState -> ExternalPackageState)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ \ExternalPackageState
eps  -> ExternalPackageState
eps { eps_is_boot = imp_boot_mods imports }
               }

                -- 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      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
              tcg_rn_imports   = rn_imports,
              tcg_inst_env     = tcg_inst_env gbl `unionInstEnv` home_insts,
              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
                                                      home_fam_insts,
              tcg_hpc          = hpc_info
            }) (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {

        ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn1" (InstalledModuleEnv ModuleNameWithIsBoot -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ImportAvails -> InstalledModuleEnv ModuleNameWithIsBoot
imp_direct_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)
        ; IOEnv (Env 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] -> IOEnv (Env TcGblEnv TcLclEnv) ()
loadModuleInterfaces (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Loading orphan modules")
                               ((Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter (Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn1: checking family instance consistency {" SDoc
forall doc. IsOutput doc => doc
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] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkFamInstConsistency [Module]
dir_imp_mods
        ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn1: } checking family instance consistency" SDoc
forall doc. IsOutput doc => doc
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
             -> Maybe (LocatedL [LIE GhcPs])
             -> [LHsDecl GhcPs]               -- Declarations
             -> TcM TcGblEnv
tcRnSrcDecls :: Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> [LHsDecl GhcPs]
-> TcM TcGblEnv
tcRnSrcDecls Bool
explicit_mod_hdr Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies [LHsDecl GhcPs]
decls
 = 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

      ------ Simplify constraints ---------
      --
      -- We do this after checkMainType, so that we use the type
      -- info that checkMainType adds
      --
      -- We do it with both global and local env in scope:
      --  * the global env exposes the instances to simplifyTop,
      --    and affects how names are rendered in error messages
      --  * 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" #-}
                        (TcGblEnv, TcLclEnv) -> TcRn (Bag EvBind) -> TcRn (Bag EvBind)
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRn (Bag EvBind) -> TcRn (Bag EvBind))
-> TcRn (Bag EvBind) -> TcRn (Bag EvBind)
forall a b. (a -> b) -> a -> b
$
                        do { WantedConstraints
lie_main <- TcGblEnv -> TcRn WantedConstraints
checkMainType TcGblEnv
tcg_env
                           ; WantedConstraints -> TcRn (Bag EvBind)
simplifyTop (WantedConstraints
lie WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
lie_main) }

        -- Emit Typeable bindings
      ; TcGblEnv
tcg_env <- TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
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
$
                   TcM TcGblEnv
mkTypeableBinds

      ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc9" SDoc
forall doc. IsOutput doc => doc
empty
      ; IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM    -- Stop now if if there have been errors
                       -- Continuing is a waste of time; and we may get debug
                       -- warnings when zonking about strangely-typed TyCons!

        -- Zonk the final code.  This must be done last.
        -- Even simplifyTop may do some unification.
        -- This pass also warns about missing type signatures
      ; (TypeEnv
id_env, Bag EvBind
ev_binds', Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
fords', [LTcSpecPrag]
imp_specs', [GenLocated SrcSpanAnnA (RuleDecl 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

      --------- Run finalizers --------------
      -- Finalizers must run after constraints are simplified, lest 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.
      ; let -- init_tcg_env:
            --   * Remove accumulated bindings, rules and so on from
            --     TcGblEnv.  They are now in ev_binds', binds', etc.
            --   * Add the zonked Ids from the value bindings to tcg_type_env
            --     Up to now these Ids are only in tcl_env's type-envt
            init_tcg_env :: TcGblEnv
init_tcg_env = TcGblEnv
tcg_env { tcg_binds     = emptyBag
                                   , tcg_ev_binds  = emptyBag
                                   , tcg_imp_specs = []
                                   , tcg_rules     = []
                                   , tcg_fords     = []
                                   , tcg_type_env  = tcg_type_env tcg_env
                                                     `plusTypeEnv` id_env }
      ; (TcGblEnv
tcg_env, TcLclEnv
tcl_env) <- 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
setGblEnv TcGblEnv
init_tcg_env
                              TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
run_th_modfinalizers
      ; IOEnv (Env TcGblEnv TcLclEnv) ()
finishTH
      ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc11" SDoc
forall doc. IsOutput doc => doc
empty

      --------- Deal with the exports ----------
      -- Can't be done earlier, because the export list must "see"
      -- the declarations created by the finalizers
      ; TcGblEnv
tcg_env <- (TcGblEnv, TcLclEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
                   Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> TcM TcGblEnv
rnExports Bool
explicit_mod_hdr Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies

      --------- Emit the ':Main.main = runMainIO main' declaration ----------
      -- Do this /after/ rnExports, so that it can consult
      -- the tcg_exports created by rnExports
      ; (TcGblEnv
tcg_env, Bag EvBind
main_ev_binds)
           <- (TcGblEnv, TcLclEnv)
-> TcRn (TcGblEnv, Bag EvBind) -> TcRn (TcGblEnv, Bag EvBind)
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRn (TcGblEnv, Bag EvBind) -> TcRn (TcGblEnv, Bag EvBind))
-> TcRn (TcGblEnv, Bag EvBind) -> TcRn (TcGblEnv, Bag EvBind)
forall a b. (a -> b) -> a -> b
$
              do { (TcGblEnv
tcg_env, WantedConstraints
lie) <- TcM TcGblEnv -> TcM (TcGblEnv, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM TcGblEnv -> TcM (TcGblEnv, WantedConstraints))
-> TcM TcGblEnv -> TcM (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                                     Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> TcM TcGblEnv
checkMain Bool
explicit_mod_hdr Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies
                 ; Bag EvBind
ev_binds <- WantedConstraints -> TcRn (Bag EvBind)
simplifyTop WantedConstraints
lie
                 ; (TcGblEnv, Bag EvBind) -> TcRn (TcGblEnv, Bag EvBind)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, Bag EvBind
ev_binds) }

      ; IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM    -- Stop now if if there have been errors
                       -- Continuing is a waste of time; and we may get debug
                       -- warnings when zonking about strangely-typed TyCons!

      ---------- Final zonking ---------------
      -- Zonk the new bindings arising from running the finalisers,
      -- and main. This won't give rise to any more finalisers as you
      -- can't nest finalisers inside finalisers.
      ; (TypeEnv
id_env_mf, Bag EvBind
ev_binds_mf, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds_mf, [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
fords_mf, [LTcSpecPrag]
imp_specs_mf, [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules_mf)
            <- Bag EvBind
-> TcGblEnv
-> TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv Bag EvBind
main_ev_binds TcGblEnv
tcg_env

      ; let { !final_type_env :: TypeEnv
final_type_env = TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
tcg_env
                                TypeEnv -> TypeEnv -> TypeEnv
`plusTypeEnv` TypeEnv
id_env_mf
              -- Add the zonked Ids from the value bindings (they were in tcl_env)
              -- Force !final_type_env, lest we retain an old reference
              -- to the previous tcg_env

            ; tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env
                          { tcg_binds     = binds'    `unionBags` binds_mf
                          , tcg_ev_binds  = ev_binds' `unionBags` ev_binds_mf
                          , tcg_imp_specs = imp_specs' ++ imp_specs_mf
                          , tcg_rules     = rules'     ++ rules_mf
                          , tcg_fords     = fords'     ++ 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
ev_binds tcg_env :: TcGblEnv
tcg_env@(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 })
  = {-# SCC "zonkTopDecls" #-}
    TcGblEnv
-> TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
-> TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM
   (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
    [LTcSpecPrag], [LRuleDecl GhcTc])
 -> TcM
      (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
       [LTcSpecPrag], [LRuleDecl GhcTc]))
-> TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
-> TcM
     (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
      [LTcSpecPrag], [LRuleDecl GhcTc])
forall a b. (a -> b) -> a -> b
$ -- This sets the GlobalRdrEnv which is used when rendering
                        --   error messages during zonking (notably levity errors)
    do { let 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
ev_binds
       ; 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 }

-- | 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 a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
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)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
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)]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var []
    let run_finalizer :: (TcLclEnv, ThModFinalizers) -> IOEnv (Env TcGblEnv TcLclEnv) ()
run_finalizer (TcLclEnv
lcl_env, ThModFinalizers
f) =
            TcLclEnv
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl a.
TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
restoreLclEnv TcLclEnv
lcl_env (ThModFinalizers -> IOEnv (Env TcGblEnv TcLclEnv) ()
runRemoteModFinalizers ThModFinalizers
f)

    (()
_, WantedConstraints
lie_th) <- IOEnv (Env TcGblEnv TcLclEnv) () -> TcM ((), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (IOEnv (Env TcGblEnv TcLclEnv) () -> TcM ((), WantedConstraints))
-> IOEnv (Env TcGblEnv TcLclEnv) () -> TcM ((), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                   ((TcLclEnv, ThModFinalizers) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [(TcLclEnv, ThModFinalizers)]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcLclEnv, ThModFinalizers) -> IOEnv (Env TcGblEnv TcLclEnv) ()
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 a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (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 -> TcRn (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, [GenLocated SrcSpanAnnA (HsDecl 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 [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_topdecls_var <- (TcGblEnv -> TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> TcM TcGblEnv
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> TcRef [LHsDecl GhcPs]
TcGblEnv -> TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
tcg_th_topdecls TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
      ; [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_ds <- TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> TcRnIf TcGblEnv TcLclEnv [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_topdecls_var
      ; TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_topdecls_var []

      ; (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls) <-
            if [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_ds
            then (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls)
            else do { (HsGroup GhcPs
th_group, Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
th_group_tail) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_ds
                    ; case Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
th_group_tail of
                        { Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
Nothing -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        ; Just (SpliceDecl XSpliceDecl GhcPs
_ (L SrcSpanAnnA
loc HsUntypedSplice GhcPs
_) SpliceDecoration
_, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
_) ->
                            SrcSpanAnnA
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc
                            (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
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.
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceSplice
                        (SpliceInfo -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SpliceInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ SpliceInfo { spliceDescription :: String
spliceDescription = String
msg
                                     , spliceIsDecl :: Bool
spliceIsDecl    = Bool
True
                                     , spliceSource :: Maybe (LHsExpr (GhcPass 'Renamed))
spliceSource    = Maybe (LHsExpr (GhcPass 'Renamed))
Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall a. Maybe a
Nothing
                                     , spliceGenerated :: SDoc
spliceGenerated = HsGroup (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsGroup (GhcPass 'Renamed)
th_rn_decls }
                    ; (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
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.
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 a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (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, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
group_tail of
          { Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
Nothing -> (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie1)

            -- If there's a splice, we must carry on
          ; Just (SpliceDecl XSpliceDecl GhcPs
_ (L SrcSpanAnnA
_ HsUntypedSplice GhcPs
splice) SpliceDecoration
_, [GenLocated SrcSpanAnnA (HsDecl 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 -> TcRn (Bag EvBind)
simplifyTop WantedConstraints
lie1

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

                 -- Glue them on the front of the remaining decls and loop
               ; TcGblEnv
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall gbl' lcl a gbl.
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 ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
spliced_decls [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
rest_ds)
               }
          }
      }

{-
************************************************************************
*                                                                      *
        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, [GenLocated SrcSpanAnnA (HsDecl 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
-> TcM (TcGblEnv, WantedConstraints)
-> TcM (TcGblEnv, WantedConstraints)
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM (TcGblEnv, WantedConstraints)
 -> TcM (TcGblEnv, WantedConstraints))
-> TcM (TcGblEnv, WantedConstraints)
-> TcM (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$ TcM TcGblEnv -> TcM (TcGblEnv, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM TcGblEnv -> TcM (TcGblEnv, WantedConstraints))
-> TcM TcGblEnv -> TcM (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, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
group_tail of
             Just (SpliceDecl XSpliceDecl GhcPs
_ XRec GhcPs (HsUntypedSplice GhcPs)
d SpliceDecoration
_, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
_) -> HscSource
-> String
-> GenLocated SrcSpanAnnA (HsUntypedSplice GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall decl.
HscSource
-> String -> LocatedA decl -> IOEnv (Env TcGblEnv TcLclEnv) ()
badBootDecl HscSource
hsc_src String
"splice" XRec GhcPs (HsUntypedSplice GhcPs)
GenLocated SrcSpanAnnA (HsUntypedSplice GhcPs)
d
             Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
Nothing                    -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ; (LocatedA (ForeignDecl (GhcPass 'Renamed))
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [LocatedA (ForeignDecl (GhcPass 'Renamed))]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HscSource
-> String
-> LocatedA (ForeignDecl (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall decl.
HscSource
-> String -> LocatedA decl -> IOEnv (Env TcGblEnv TcLclEnv) ()
badBootDecl HscSource
hsc_src String
"foreign") [LForeignDecl (GhcPass 'Renamed)]
[LocatedA (ForeignDecl (GhcPass 'Renamed))]
for_decls
        ; (LocatedA (DefaultDecl (GhcPass 'Renamed))
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [LocatedA (DefaultDecl (GhcPass 'Renamed))]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HscSource
-> String
-> LocatedA (DefaultDecl (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall decl.
HscSource
-> String -> LocatedA decl -> IOEnv (Env TcGblEnv TcLclEnv) ()
badBootDecl HscSource
hsc_src String
"default") [LDefaultDecl (GhcPass 'Renamed)]
[LocatedA (DefaultDecl (GhcPass 'Renamed))]
def_decls
        ; (LocatedA (RuleDecls (GhcPass 'Renamed))
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [LocatedA (RuleDecls (GhcPass 'Renamed))]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HscSource
-> String
-> LocatedA (RuleDecls (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall decl.
HscSource
-> String -> LocatedA decl -> IOEnv (Env TcGblEnv TcLclEnv) ()
badBootDecl HscSource
hsc_src String
"rule")    [LRuleDecls (GhcPass 'Renamed)]
[LocatedA (RuleDecls (GhcPass 'Renamed))]
rule_decls

                -- Typecheck type/class/instance decls
        ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc2 (boot)" SDoc
forall doc. IsOutput doc => doc
empty
        ; (TcGblEnv
tcg_env, [InstInfo (GhcPass 'Renamed)]
inst_infos, ThBindEnv
_deriv_binds, HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
_th_bndrs)
             <- [TyClGroup (GhcPass 'Renamed)]
-> [LDerivDecl (GhcPass 'Renamed)]
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      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.
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.
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc5" SDoc
forall doc. IsOutput doc => doc
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc7a" SDoc
forall doc. IsOutput doc => doc
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"boot" (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie); TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
gbl_env }

badBootDecl :: HscSource -> String -> LocatedA decl -> TcM ()
badBootDecl :: forall decl.
HscSource
-> String -> LocatedA decl -> IOEnv (Env TcGblEnv TcLclEnv) ()
badBootDecl HscSource
hsc_src String
what (L SrcSpanAnnA
loc decl
_)
  = SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
    (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'A' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
what
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"declaration is not (currently) allowed in a"
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (case HscSource
hsc_src of
            HscSource
HsBootFile -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs-boot"
            HscSource
HsigFile -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hsig"
            HscSource
_ -> String -> SDoc
forall a. HasCallStack => String -> a
panic String
"badBootDecl: should be an hsig or hs-boot file")
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
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 :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
dfun_binds = [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [a] -> Bag a
listToBag [ IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP GhcTc
Var
boot_dfun (IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Var
dfun)
                                     | (Var
boot_dfun, Var
dfun) <- [(Var, Var)]
dfun_prs ]
              tcg_env_w_binds :: TcGblEnv
tcg_env_w_binds
                = TcGblEnv
tcg_env { tcg_binds = binds `unionBags` dfun_binds }

        ; TypeEnv
type_env' TypeEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. a -> b -> b
`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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"checkHiBootIface" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
             [ TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeEnv
boot_type_env, [AvailInfo] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AvailInfo]
boot_exports]

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

                -- Check for no family instances
        ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FamInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FamInst]
boot_fam_insts) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
            String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. HasCallStack => 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Var -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
check_cls_inst [Var]
boot_dfuns

        ; IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM

        ; [(Var, Var)] -> TcM [(Var, Var)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
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 -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_export AvailInfo
boot_avail     -- boot_avail is exported by the boot iface
      | Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
boot_dfun_names = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        -- Check that the actual module exports the same thing
      | Name
missing_name:[Name]
_ <- [Name]
missing_names
      = SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt (Name -> SrcSpan
nameSrcSpan Name
missing_name)
                 (Bool -> Name -> String -> TcRnMessage
missingBootThing Bool
True Name
missing_name 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 -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TyThing
mb_boot_thing = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
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
      = Bool -> TyThing -> TyThing -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkBootDeclM Bool
True TyThing
boot_thing TyThing
real_thing

      | Bool
otherwise
      = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (Bool -> Name -> String -> TcRnMessage
missingBootThing Bool
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]
`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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
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.

      | Bool
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
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"check_cls_inst" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
                [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"local_insts"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                     [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> SDoc
forall a. Outputable a => a -> SDoc
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
forall doc. IsLine doc => String -> doc
text String
"boot_dfun_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
idType Var
boot_dfun) ]

           ; TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (Var -> TcRnMessage
instMisMatch Var
boot_dfun)
           ; Maybe (Var, Var)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
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 -> Bool
`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 :: Bool -> TyThing -> TyThing -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkBootDeclM Bool
is_boot TyThing
boot_thing TyThing
real_thing
  = Maybe SDoc
-> (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Bool -> TyThing -> TyThing -> Maybe SDoc
checkBootDecl Bool
is_boot TyThing
boot_thing TyThing
real_thing) ((SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ \ SDoc
err ->
       SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
span
                (Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage
bootMisMatch Bool
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
getName TyThing
boot_thing)
      , SrcSpan -> Bool
isGoodSrcSpan SrcSpan
span
      = SrcSpan
span
      | Bool
otherwise
      = Name -> SrcSpan
nameSrcSpan (TyThing -> Name
forall a. NamedThing a => a -> Name
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 :: Bool -> TyThing -> TyThing -> Maybe SDoc
checkBootDecl Bool
_ (AnId Var
id1) (AnId Var
id2)
  = Bool -> Maybe SDoc -> Maybe SDoc
forall a. HasCallStack => Bool -> a -> a
assert (Var
id1 Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
id2) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
    Bool -> SDoc -> Maybe SDoc
check (Var -> Type
idType Var
id1 Type -> Type -> Bool
`eqType` Var -> Type
idType Var
id2)
          (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The two types are different")

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

checkBootDecl Bool
_ (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
ppr DataCon
dc1)

checkBootDecl Bool
_ TyThing
_ TyThing
_ = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
forall doc. IsOutput doc => doc
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
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 :: Bool -> Maybe SDoc -> Maybe SDoc
checkUnless Bool
True  Maybe SDoc
_ = Maybe SDoc
forall a. Maybe a
Nothing
checkUnless Bool
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 :: forall a.
(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
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
whats SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon) Arity
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)
                            Arity
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"There are different numbers of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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 :: Bool -> SDoc -> Maybe SDoc
check Bool
True  SDoc
_   = Maybe SDoc
forall a. Maybe a
Nothing
check Bool
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 :: Bool -> TyCon -> TyCon -> Maybe SDoc
checkBootTyCon Bool
is_boot TyCon
tc1 TyCon
tc2
  | Bool -> Bool
not (Type -> Type -> Bool
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
forall doc. IsLine doc => String -> doc
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)
         = Bool -> SDoc -> Maybe SDoc
check (Name
name1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name2)
                 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The names" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"are different") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
           Bool -> SDoc -> Maybe SDoc
check (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
op_ty1 Type
op_ty2)
                 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The types of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"are different") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
           if Bool
is_boot
               then Bool -> SDoc -> Maybe SDoc
check (((Name, DefMethSpec Type) -> (Name, DefMethSpec Type) -> Bool)
-> Maybe (Name, DefMethSpec Type)
-> Maybe (Name, DefMethSpec Type)
-> Bool
forall a b. (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (Name, DefMethSpec Type) -> (Name, DefMethSpec Type) -> Bool
eqDM Maybe (Name, DefMethSpec Type)
def_meth1 Maybe (Name, DefMethSpec Type)
def_meth2)
                          (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The default methods associated with" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                           String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"are different")
               else Bool -> SDoc -> Maybe SDoc
check (Type
-> Maybe (Name, DefMethSpec Type)
-> Maybe (Name, DefMethSpec Type)
-> Bool
subDM Type
op_ty1 Maybe (Name, DefMethSpec Type)
def_meth1 Maybe (Name, DefMethSpec Type)
def_meth2)
                          (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The default methods associated with" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                           String -> SDoc
forall doc. IsLine doc => String -> doc
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
ppr Name
name1)
          pname2 :: SDoc
pname2 = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name2)
          op_ty1 :: Type
op_ty1 = Var -> Type
classMethodTy Var
id1
          op_ty2 :: Type
op_ty2 = Var -> Type
classMethodTy Var
id2

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

       eqDM :: (Name, DefMethSpec Type) -> (Name, DefMethSpec Type) -> Bool
eqDM (Name
_, DefMethSpec Type
VanillaDM)    (Name
_, DefMethSpec Type
VanillaDM)    = Bool
True
       eqDM (Name
_, GenericDM Type
t1) (Name
_, GenericDM Type
t2) = RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
       eqDM (Name, DefMethSpec Type)
_ (Name, DefMethSpec Type)
_ = Bool
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)
-> Bool
subDM Type
_ Maybe (Name, DefMethSpec Type)
Nothing Maybe (Name, DefMethSpec Type)
_ = Bool
True
       subDM Type
_ Maybe (Name, DefMethSpec Type)
_ Maybe (Name, DefMethSpec Type)
Nothing = Bool
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
gdm_t1)) (Just (Name
_, DefMethSpec Type
VanillaDM))
        = Type -> Type -> Bool
eqType Type
t1 Type
gdm_t1   -- Take care (#22476).  Both t1 and gdm_t1 come
                             -- from tc1, so use eqType, and /not/ eqTypeX

       -- This case can occur when merging signatures
       subDM Type
t1 (Just (Name
_, DefMethSpec Type
VanillaDM)) (Just (Name
_, GenericDM Type
t2))
        = RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2

       subDM Type
_ (Just (Name
_, DefMethSpec Type
VanillaDM)) (Just (Name
_, DefMethSpec Type
VanillaDM)) = Bool
True
       subDM Type
_ (Just (Name
_, GenericDM Type
t1)) (Just (Name
_, GenericDM Type
t2))
        = RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2

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

       eqFD :: FunDep Var -> FunDep Var -> Bool
eqFD ([Var]
as1,[Var]
bs1) ([Var]
as2,[Var]
bs2) =
         (Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env) ([Var] -> [Type]
mkTyVarTys [Var]
as1) ([Var] -> [Type]
mkTyVarTys [Var]
as2) Bool -> Bool -> Bool
&&
         (Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (RnEnv2 -> Type -> Type -> Bool
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
    Bool -> SDoc -> Maybe SDoc
check ((FunDep Var -> FunDep Var -> Bool)
-> [FunDep Var] -> [FunDep Var] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq FunDep Var -> FunDep Var -> Bool
eqFD [FunDep Var]
clas_fds1 [FunDep Var]
clas_fds2)
          (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The functional dependencies do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    Bool -> Maybe SDoc -> Maybe SDoc
checkUnless (TyCon -> Bool
isAbstractTyCon TyCon
tc1) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
    Bool -> SDoc -> Maybe SDoc
check ((Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env) [Type]
sc_theta1 [Type]
sc_theta2)
          (String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"associated types") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    Bool -> SDoc -> Maybe SDoc
check (Class -> ClassMinimalDef
classMinimalDef Class
c1 ClassMinimalDef -> ClassMinimalDef -> Bool
forall a.
Uniquable a =>
BooleanFormula a -> BooleanFormula a -> Bool
`BF.implies` Class -> ClassMinimalDef
classMinimalDef Class
c2)
        (String -> SDoc
forall doc. IsLine doc => String -> doc
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)
  = Bool -> Maybe SDoc -> Maybe SDoc
forall a. HasCallStack => Bool -> a -> a
assert (TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
    [Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 [Role]
roles2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    Bool -> SDoc -> Maybe SDoc
check (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
syn_rhs1 Type
syn_rhs2) SDoc
forall doc. IsOutput doc => doc
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]
  | Bool -> Bool
not Bool
is_boot -- don't support for hs-boot yet
  , TyCon -> Bool
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.
  | Bool -> Bool
not Bool
is_boot
  , TyCon -> Bool
isAbstractTyCon TyCon
tc1
  , Just ([Var]
_,Type
ty2) <- TyCon -> Maybe ([Var], Type)
synTyConDefn_maybe TyCon
tc2
  , Maybe TyLit -> Bool
forall a. Maybe a -> Bool
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
  = Bool -> Maybe SDoc -> Maybe SDoc
forall a. HasCallStack => Bool -> a -> a
assert (TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
    let eqFamFlav :: FamTyConFlav -> FamTyConFlav -> Bool
eqFamFlav FamTyConFlav
OpenSynFamilyTyCon   FamTyConFlav
OpenSynFamilyTyCon = Bool
True
        eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = Bool
True
        -- This case only happens for hsig merging:
        eqFamFlav FamTyConFlav
AbstractClosedSynFamilyTyCon FamTyConFlav
AbstractClosedSynFamilyTyCon = Bool
True
        eqFamFlav FamTyConFlav
AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = Bool
True
        eqFamFlav (ClosedSynFamilyTyCon {}) FamTyConFlav
AbstractClosedSynFamilyTyCon = Bool
True
        eqFamFlav (ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
ax1) (ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
ax2)
            = Maybe (CoAxiom Branched) -> Maybe (CoAxiom Branched) -> Bool
forall {br :: BranchFlag} {br :: BranchFlag}.
Maybe (CoAxiom br) -> Maybe (CoAxiom br) -> Bool
eqClosedFamilyAx Maybe (CoAxiom Branched)
ax1 Maybe (CoAxiom Branched)
ax2
        eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
        eqFamFlav FamTyConFlav
_ FamTyConFlav
_ = Bool
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`
    Bool -> SDoc -> Maybe SDoc
check (FamTyConFlav -> FamTyConFlav -> Bool
eqFamFlav FamTyConFlav
fam_flav1 FamTyConFlav
fam_flav2)
        (SDoc -> SDoc
forall doc. IsOutput doc => doc -> doc
whenPprDebug (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Family flavours" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FamTyConFlav -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamTyConFlav
fam_flav1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FamTyConFlav -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamTyConFlav
fam_flav2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    Bool -> SDoc -> Maybe SDoc
check (Injectivity
injInfo1 Injectivity -> Injectivity -> Bool
forall a. Eq a => a -> a -> Bool
== Injectivity
injInfo2) (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Injectivities do not match")

  | TyCon -> Bool
isAlgTyCon TyCon
tc1 Bool -> Bool -> Bool
&& TyCon -> Bool
isAlgTyCon TyCon
tc2
  , Just RnEnv2
env <- RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 (TyCon -> [Var]
tyConTyVars TyCon
tc1) (TyCon -> [Var]
tyConTyVars TyCon
tc2)
  = Bool -> Maybe SDoc -> Maybe SDoc
forall a. HasCallStack => Bool -> a -> a
assert (TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
    [Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 [Role]
roles2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
    Bool -> SDoc -> Maybe SDoc
check ((Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env)
                     (TyCon -> [Type]
tyConStupidTheta TyCon
tc1) (TyCon -> [Type]
tyConStupidTheta TyCon
tc2))
          (String -> SDoc
forall doc. IsLine doc => String -> doc
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)

  | Bool
otherwise = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
forall doc. IsOutput doc => doc
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
forall doc. IsLine doc => String -> doc
text String
"The roles do not match." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Roles on abstract types default to" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                 SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"representational") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in boot files.")

    roles_subtype_msg :: SDoc
roles_subtype_msg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The roles are not compatible:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Main module:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Role] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Role]
roles2 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Hsig file:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Role] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Role]
roles1

    checkRoles :: [Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
r1 [Role]
r2
      | Bool
is_boot Bool -> Bool -> Bool
|| TyCon -> Role -> Bool
isInjectiveTyCon TyCon
tc1 Role
Representational -- See Note [Role subtyping]
      = Bool -> SDoc -> Maybe SDoc
check ([Role]
r1 [Role] -> [Role] -> Bool
forall a. Eq a => a -> a -> Bool
== [Role]
r2) SDoc
roles_msg
      | Bool
otherwise = Bool -> SDoc -> Maybe SDoc
check ([Role]
r2 [Role] -> [Role] -> Bool
forall {a}. Ord a => [a] -> [a] -> Bool
`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 (mkSelCo).  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] -> Bool
rolesSubtypeOf [] [] = Bool
True
    -- NB: this relation is the OPPOSITE of the subroling relation
    rolesSubtypeOf (a
x:[a]
xs) (a
y:[a]
ys) = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
y Bool -> Bool -> Bool
&& [a] -> [a] -> Bool
rolesSubtypeOf [a]
xs [a]
ys
    rolesSubtypeOf [a]
_ [a]
_ = Bool
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 parameters),
    --
    --    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 =
        Bool -> SDoc -> Maybe SDoc
check ([(TyCon, [Type])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [(TyCon, [Type])]
tcTyFamInsts Type
ty))
              (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Illegal type family application in implementation of abstract data.")
                Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
        Bool -> SDoc -> Maybe SDoc
check ([Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
tvs)
              (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Illegal parameterized type synonym in implementation of abstract data." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
               String -> SDoc
forall doc. IsLine doc => String -> doc
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
        Bool -> Maybe SDoc -> Maybe SDoc
checkUnless (Bool -> Bool
not ([Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
tvs)) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
            Bool -> Maybe SDoc -> Maybe SDoc
forall a. HasCallStack => Bool -> a -> a
assert ([Role] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Role]
roles2) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
            -- 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 a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
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
_ (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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"Cannot match a" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"data") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                           String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"definition with a" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"newtype") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                           String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"definition")

    eqCon :: DataCon -> DataCon -> Maybe SDoc
eqCon DataCon
c1 DataCon
c2
      =  Bool -> SDoc -> Maybe SDoc
check (Name
name1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name2)
               (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The names" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
         Bool -> SDoc -> Maybe SDoc
check (DataCon -> Bool
dataConIsInfix DataCon
c1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Bool
dataConIsInfix DataCon
c2)
               (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The fixities of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
         Bool -> SDoc -> Maybe SDoc
check ((HsImplBang -> HsImplBang -> Bool)
-> [HsImplBang] -> [HsImplBang] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq HsImplBang -> HsImplBang -> Bool
eqHsBang (DataCon -> [HsImplBang]
dataConImplBangs DataCon
c1) (DataCon -> [HsImplBang]
dataConImplBangs DataCon
c2))
               (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The strictness annotations for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
         Bool -> SDoc -> Maybe SDoc
check ((FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
c1) [Name] -> [Name] -> Bool
forall a. Eq a => a -> a -> Bool
== (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
c2))
               (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The record label lists for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
         Bool -> SDoc -> Maybe SDoc
check (Type -> Type -> Bool
eqType (DataCon -> Type
dataConWrapperType DataCon
c1) (DataCon -> Type
dataConWrapperType DataCon
c2))
               (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The types for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
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
ppr Name
name1)
        pname2 :: SDoc
pname2 = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name2)

    eqClosedFamilyAx :: Maybe (CoAxiom br) -> Maybe (CoAxiom br) -> Bool
eqClosedFamilyAx Maybe (CoAxiom br)
Nothing Maybe (CoAxiom br)
Nothing  = Bool
True
    eqClosedFamilyAx Maybe (CoAxiom br)
Nothing (Just CoAxiom br
_) = Bool
False
    eqClosedFamilyAx (Just CoAxiom br
_) Maybe (CoAxiom br)
Nothing = Bool
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 -> Bool
forall a. Eq a => a -> a -> Bool
== Branches br -> Arity
forall (br :: BranchFlag). Branches br -> Arity
numBranches Branches br
branches2
      Bool -> Bool -> Bool
&& ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (CoAxBranch -> CoAxBranch -> Bool)
-> [CoAxBranch] -> [CoAxBranch] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CoAxBranch -> CoAxBranch -> Bool
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 -> Bool
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 -> Bool) -> [Type] -> [Type] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env) [Type]
lhs1 [Type]
lhs2 Bool -> Bool -> Bool
&&
        RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
rhs1 Type
rhs2

      | Bool
otherwise = Bool
False

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

----------------
missingBootThing :: Bool -> Name -> String -> TcRnMessage
missingBootThing :: Bool -> Name -> String -> TcRnMessage
missingBootThing Bool
is_boot Name
name String
what
  = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
    SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is exported by the"
    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (if Bool
is_boot then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs-boot" else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hsig")
    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"file, but not"
    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the module"

badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage
badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage
badReexportedBootThing Bool
is_boot Name
name Name
name'
  = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
    NamePprCtx -> Depth -> SDoc -> SDoc
withUserStyle NamePprCtx
alwaysQualify Depth
AllTheWay (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
        [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (if Bool
is_boot then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs-boot" else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hsig")
           SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"file (re)exports" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"but the implementing module exports a different identifier" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name')
        ]

bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage
bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage
bootMisMatch Bool
is_boot SDoc
extra_info TyThing
real_thing TyThing
boot_thing
  = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
    Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
pprBootMisMatch Bool
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 =
                                              if is_boot
                                                then ShowForAllMust
                                                else 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 :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
pprBootMisMatch Bool
is_boot SDoc
extra_info TyThing
real_thing SDoc
real_doc SDoc
boot_doc
      = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
          [ TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
real_thing SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has conflicting definitions in the module",
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and its" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
              (if Bool
is_boot
                then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs-boot file"
                else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hsig file"),
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Main module:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
real_doc,
              (if Bool
is_boot
                then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Boot file:  "
                else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Hsig file: ")
                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
boot_doc,
            SDoc
extra_info
          ]

instMisMatch :: DFunId -> TcRnMessage
instMisMatch :: Var -> TcRnMessage
instMisMatch Var
dfun
  = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
    SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"instance" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
idType Var
dfun))
       Arity
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn12" SDoc
forall doc. IsOutput doc => doc
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn13" SDoc
forall doc. IsOutput doc => doc
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn13-plugin" SDoc
forall doc. IsOutput doc => doc
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 = Just (appendGroups grp rn_decls) }
                | Bool
otherwise
                   = TcGblEnv
tcg_env };

                -- Dump trace of renaming part
        HsGroup (GhcPass 'Renamed) -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a.
(Outputable a, Data a) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) ()
rnDump HsGroup (GhcPass 'Renamed)
rn_decls ;
        (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc2 (src)" SDoc
forall doc. IsOutput doc => doc
empty ;

                -- Source-language instances, including derivings,
                -- and import the supporting declarations
        String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc3" SDoc
forall doc. IsOutput doc => doc
empty ;
        (TcGblEnv
tcg_env, [InstInfo (GhcPass 'Renamed)]
inst_infos, ThBindEnv
th_bndrs,
         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)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
tcTyClsInstDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls [LDerivDecl (GhcPass 'Renamed)]
deriv_decls [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds ;

        (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
tcl_env -> TcLclEnv
tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs 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
$
        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
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc3b" SDoc
forall doc. IsOutput doc => doc
empty ;

                -- Generate Semigroup/Monoid warnings
        String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc3c" SDoc
forall doc. IsOutput doc => doc
empty ;
        IOEnv (Env TcGblEnv TcLclEnv) ()
tcSemigroupWarnings ;

                -- Foreign import declarations next.
        String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc4" SDoc
forall doc. IsOutput doc => doc
empty ;
        ([Var]
fi_ids, [GenLocated SrcSpanAnnA (ForeignDecl 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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc4a" SDoc
forall doc. IsOutput doc => doc
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 = 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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc5" SDoc
forall doc. IsOutput doc => doc
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 a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (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 a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc6" SDoc
forall doc. IsOutput doc => doc
empty ;
        Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc 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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc7" SDoc
forall doc. IsOutput doc => doc
empty ;
        (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
foe_binds, [GenLocated SrcSpanAnnA (ForeignDecl 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
        [GenLocated SrcSpanAnnA (RuleDecls GhcTc)]
rules <- [LRuleDecls (GhcPass 'Renamed)] -> TcM [LRuleDecls GhcTc]
tcRules [LRuleDecls (GhcPass 'Renamed)]
rule_decls ;

                -- Wrap up
        String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc7a" SDoc
forall doc. IsOutput doc => doc
empty ;
        let { all_binds :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
all_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
inst_binds     Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a -> Bag a -> Bag a
`unionBags`
                          Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc 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 a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\GlobalRdrElt
gre FreeVars
fvs -> FreeVars
fvs FreeVars -> Name -> FreeVars
`addOneFV` GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)
                                FreeVars
emptyFVs Bag GlobalRdrElt
fo_gres

            ; sig_names :: FreeVars
sig_names = [Name] -> FreeVars
mkNameSet (CollectFlag (GhcPass 'Renamed)
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> [IdP (GhcPass 'Renamed)]
forall (idL :: Pass) idR.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)]
collectHsValBinders CollectFlag (GhcPass 'Renamed)
forall p. CollectFlag p
CollNoDictBinders 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   = tcg_binds tcg_env `unionBags` all_binds
                                 , tcg_sigs    = tcg_sigs tcg_env `unionNameSet` sig_names
                                 , tcg_rules   = tcg_rules tcg_env
                                                      ++ flattenRuleDecls rules
                                 , tcg_anns    = tcg_anns tcg_env ++ annotations
                                 , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
                                 , tcg_fords   = tcg_fords tcg_env ++ foe_decls ++ fi_decls
                                 , tcg_dus     = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
                                 -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]

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

        (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env', TcLclEnv
tcl_env)
    }}}}}}

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


tcSemigroupWarnings :: TcM ()
tcSemigroupWarnings :: IOEnv (Env TcGblEnv TcLclEnv) ()
tcSemigroupWarnings = do
    Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
    -- ghc-prim doesn't depend on base
    Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
primUnit) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
      String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcSemigroupWarnings" SDoc
forall doc. IsOutput doc => doc
empty
      let warnFlag :: WarningFlag
warnFlag = WarningFlag
Opt_WarnSemigroup
      WarningFlag -> Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcPreludeClashWarn WarningFlag
warnFlag Name
sappendName
      WarningFlag -> Name -> Name -> IOEnv (Env 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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcPreludeClashWarn WarningFlag
warnFlag Name
name = do
    { Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
warnFlag
    ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
    { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcPreludeClashWarn/wouldBeImported" SDoc
forall doc. IsOutput doc => doc
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 a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))
 -> ImportDecl (GhcPass 'Renamed))
-> [GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))]
-> [ImportDecl (GhcPass 'Renamed)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))
-> ImportDecl (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc ([GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))]
 -> [ImportDecl (GhcPass 'Renamed)])
-> (TcGblEnv
    -> [GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))])
-> TcGblEnv
-> [ImportDecl (GhcPass 'Renamed)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> [LImportDecl (GhcPass 'Renamed)]
TcGblEnv
-> [GenLocated SrcSpanAnnA (ImportDecl (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
    ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> [ImportDecl (GhcPass 'Renamed)] -> Bool
importedViaPrelude Name
name [ImportDecl (GhcPass 'Renamed)]
rnImports) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env 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 a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([[GlobalRdrElt]] -> [GlobalRdrElt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[GlobalRdrElt]] -> [GlobalRdrElt])
-> (TcGblEnv -> [[GlobalRdrElt]]) -> TcGblEnv -> [GlobalRdrElt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrEnv -> [[GlobalRdrElt]]
forall a. OccEnv a -> [a]
nonDetOccEnvElts (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 -> Bool
clashes GlobalRdrElt
x = Bool
isLocalDef Bool -> Bool -> Bool
&& Bool
nameClashes Bool -> Bool -> Bool
&& Bool
isNotInProperModule
            where
              isLocalDef :: Bool
isLocalDef = GlobalRdrElt -> Bool
gre_lcl GlobalRdrElt
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True
              -- Names are identical ...
              nameClashes :: Bool
nameClashes = Name -> OccName
nameOccName (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
x) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== 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 :: Bool
isNotInProperModule = GlobalRdrElt -> Name
greMangledName GlobalRdrElt
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
name

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

    ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcPreludeClashWarn/prelude_functions"
                (SDoc -> Arity -> SDoc -> SDoc
hang (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) Arity
4 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [[GlobalRdrElt] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GlobalRdrElt]
clashingElts]))

    ; let warn_msg :: GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn_msg GlobalRdrElt
x = SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticAt (Name -> SrcSpan
nameSrcSpan (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
x)) (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
            DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
            DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
warnFlag) [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
              [ String -> SDoc
forall doc. IsLine doc => String -> doc
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
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
greMangledName) GlobalRdrElt
x
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"clashes with a future Prelude name." ]
              SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"This will become an error in a future release." )
    ; (GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GlobalRdrElt -> IOEnv (Env 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)] -> Bool
importedViaPrelude Name
name = (ImportDecl (GhcPass 'Renamed) -> Bool)
-> [ImportDecl (GhcPass 'Renamed)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ImportDecl (GhcPass 'Renamed) -> Bool
importViaPrelude
      where
        isPrelude :: ImportDecl GhcRn -> Bool
        isPrelude :: ImportDecl (GhcPass 'Renamed) -> Bool
isPrelude ImportDecl (GhcPass 'Renamed)
imp = GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl (GhcPass 'Renamed) -> XRec (GhcPass 'Renamed) ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl (GhcPass 'Renamed)
imp) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME

        -- Implicit (Prelude) import?
        isImplicit :: ImportDecl GhcRn -> Bool
        isImplicit :: ImportDecl (GhcPass 'Renamed) -> Bool
isImplicit = XImportDeclPass -> Bool
ideclImplicit (XImportDeclPass -> Bool)
-> (ImportDecl (GhcPass 'Renamed) -> XImportDeclPass)
-> ImportDecl (GhcPass 'Renamed)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl (GhcPass 'Renamed) -> XCImportDecl (GhcPass 'Renamed)
ImportDecl (GhcPass 'Renamed) -> XImportDeclPass
forall pass. ImportDecl pass -> XCImportDecl pass
ideclExt

        -- Unqualified import?
        isUnqualified :: ImportDecl GhcRn -> Bool
        isUnqualified :: ImportDecl (GhcPass 'Renamed) -> Bool
isUnqualified = Bool -> Bool
not (Bool -> Bool)
-> (ImportDecl (GhcPass 'Renamed) -> Bool)
-> ImportDecl (GhcPass 'Renamed)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDeclQualifiedStyle -> Bool
isImportDeclQualified (ImportDeclQualifiedStyle -> Bool)
-> (ImportDecl (GhcPass 'Renamed) -> ImportDeclQualifiedStyle)
-> ImportDecl (GhcPass 'Renamed)
-> Bool
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 (ImportListInterpretation, [Name])
        importListOf :: ImportDecl (GhcPass 'Renamed)
-> Maybe (ImportListInterpretation, [Name])
importListOf = ((ImportListInterpretation,
  GenLocated
    SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
 -> (ImportListInterpretation, [Name]))
-> Maybe
     (ImportListInterpretation,
      GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
-> Maybe (ImportListInterpretation, [Name])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ImportListInterpretation,
 GenLocated
   SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
-> (ImportListInterpretation, [Name])
(ImportListInterpretation,
 GenLocated
   SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
-> (ImportListInterpretation, [IdGhcP 'Renamed])
forall {a} {l} {l} {p :: Pass}.
(a, GenLocated l [GenLocated l (IE (GhcPass p))])
-> (a, [IdGhcP p])
toImportList (Maybe
   (ImportListInterpretation,
    GenLocated
      SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
 -> Maybe (ImportListInterpretation, [Name]))
-> (ImportDecl (GhcPass 'Renamed)
    -> Maybe
         (ImportListInterpretation,
          GenLocated
            SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))]))
-> ImportDecl (GhcPass 'Renamed)
-> Maybe (ImportListInterpretation, [Name])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl (GhcPass 'Renamed)
-> Maybe
     (ImportListInterpretation,
      XRec (GhcPass 'Renamed) [LIE (GhcPass 'Renamed)])
ImportDecl (GhcPass 'Renamed)
-> Maybe
     (ImportListInterpretation,
      GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
forall pass.
ImportDecl pass
-> Maybe (ImportListInterpretation, XRec pass [LIE pass])
ideclImportList
          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) -> IdP (GhcPass p)
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) -> Bool
isExplicit ImportDecl (GhcPass 'Renamed)
x = case ImportDecl (GhcPass 'Renamed)
-> Maybe (ImportListInterpretation, [Name])
importListOf ImportDecl (GhcPass 'Renamed)
x of
            Maybe (ImportListInterpretation, [Name])
Nothing -> Bool
False
            Just (ImportListInterpretation
Exactly, [Name]
explicit)
                -> Name -> OccName
nameOccName Name
name OccName -> [OccName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`    (Name -> OccName) -> [Name] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Name -> OccName
nameOccName [Name]
explicit
            Just (ImportListInterpretation
EverythingBut, [Name]
hidden)
                -> Name -> OccName
nameOccName Name
name OccName -> [OccName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`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) -> Bool
importViaPrelude ImportDecl (GhcPass 'Renamed)
x = ImportDecl (GhcPass 'Renamed) -> Bool
isPrelude ImportDecl (GhcPass 'Renamed)
x
                          Bool -> Bool -> Bool
&& ImportDecl (GhcPass 'Renamed) -> Bool
isUnqualified ImportDecl (GhcPass 'Renamed)
x
                          Bool -> Bool -> Bool
&& (ImportDecl (GhcPass 'Renamed) -> Bool
isImplicit ImportDecl (GhcPass 'Renamed)
x Bool -> Bool -> Bool
|| ImportDecl (GhcPass 'Renamed) -> Bool
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcMissingParentClassWarn WarningFlag
warnFlag Name
isName Name
shouldName
  = do { Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
warnFlag
       ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
       { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcMissingParentClassWarn" SDoc
forall doc. IsOutput doc => doc
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 -> Bool
isInstance ClsInst
m = ClsInst -> Class
is_cls ClsInst
m Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
isClass
                        isInsts :: [ClsInst]
isInsts = (ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filter ClsInst -> Bool
isInstance [ClsInst]
localInstances
                  ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcMissingParentClassWarn/isInsts" ([ClsInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ClsInst]
isInsts)
                  ; [ClsInst]
-> (ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ClsInst]
isInsts (Class -> Class -> ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShouldInst Class
isClass Class
shouldClass)
                  }
              (Maybe Class
is',Maybe Class
should') ->
                  String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcMissingParentClassWarn/notIsShould"
                          (SDoc -> Arity -> SDoc -> SDoc
hang (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
isName SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"/" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
shouldName) Arity
2 (
                            ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Is"), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"lookup for"
                                  , Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
isName
                                  , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"resulted in", Maybe Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Class
is' ])
                            SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                            ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Should"), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"lookup for"
                                  , Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
shouldName
                                  , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"resulted in", Maybe Class -> SDoc
forall a. Outputable a => a -> SDoc
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShouldInst Class
isClass Class
shouldClass ClsInst
isInst
      = do { InstEnvs
instEnv <- TcM InstEnvs
tcGetInstEnvs
           ; let ([InstMatch]
instanceMatches, PotentialUnifiers
shouldInsts, [InstMatch]
_)
                    = Bool
-> InstEnvs
-> Class
-> [Type]
-> ([InstMatch], PotentialUnifiers, [InstMatch])
lookupInstEnv Bool
False InstEnvs
instEnv Class
shouldClass (ClsInst -> [Type]
is_tys ClsInst
isInst)

           ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcMissingParentClassWarn/checkShouldInst"
                     (SDoc -> Arity -> SDoc -> SDoc
hang (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
isInst) Arity
4
                         ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [[InstMatch] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstMatch]
instanceMatches, PotentialUnifiers -> SDoc
forall a. Outputable a => a -> SDoc
ppr PotentialUnifiers
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
getName ClsInst
isInst
                 warnMsg :: [RoughMatchTc] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnMsg (RM_KnownTc Name
name:[RoughMatchTc]
_) =
                      SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticAt SrcSpan
instLoc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
                        DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
warnFlag) [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
                           [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
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
ppr (OccName -> SDoc) -> (Name -> OccName) -> Name -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) Name
name
                                , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is an instance of"
                                , (OccName -> SDoc
forall a. Outputable a => a -> SDoc
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
forall doc. IsLine doc => String -> doc
text String
"but not"
                                , (OccName -> SDoc
forall a. Outputable a => a -> SDoc
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
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"."
                           SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                           [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"This will become an error in"
                                , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a future release." ]
                 warnMsg [RoughMatchTc]
_ = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
           ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PotentialUnifiers -> Bool
nullUnifiers PotentialUnifiers
shouldInsts Bool -> Bool -> Bool
&& [InstMatch] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstMatch]
instanceMatches) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
                  [RoughMatchTc] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnMsg (ClsInst -> [RoughMatchTc]
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 a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Succeeded (ATyCon TyCon
tc) | cls :: Maybe Class
cls@(Just Class
_) <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc -> Maybe Class -> TcM (Maybe Class)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Class
cls
        MaybeErr SDoc TyThing
_else -> Maybe Class -> TcM (Maybe Class)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
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
                          ThBindEnv,          -- TH binding levels
                          HsValBinds GhcRn)   -- Supporting bindings for derived
                                              -- instances

tcTyClsInstDecls :: [TyClGroup (GhcPass 'Renamed)]
-> [LDerivDecl (GhcPass 'Renamed)]
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      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)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      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)
    -> [GenLocated SrcSpanAnnA (InstDecl (GhcPass 'Renamed))])
-> [GenLocated SrcSpanAnnA (InstDecl (GhcPass 'Renamed))]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TyClGroup (GhcPass 'Renamed) -> [LInstDecl (GhcPass 'Renamed)]
TyClGroup (GhcPass 'Renamed)
-> [GenLocated SrcSpanAnnA (InstDecl (GhcPass 'Renamed))]
forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds) (TcM
   (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
    HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
 -> TcM
      (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
       HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$
   [PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      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.
UnXRec id =>
[(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds) (TcM
   (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
    HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
 -> TcM
      (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
       HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$
   do { (TcGblEnv
tcg_env, [InstInfo (GhcPass 'Renamed)]
inst_info, [DerivInfo]
deriv_info, ThBindEnv
th_bndrs)
          <- [TyClGroup (GhcPass 'Renamed)]
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], [DerivInfo], ThBindEnv)
tcTyAndClassDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls ;
      ; TcGblEnv
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM
   (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
    HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
 -> TcM
      (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
       HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      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.
          ; IOEnv (Env 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)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env' (TcM
   (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
    HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
 -> TcM
      (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
       HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ do {
                IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM
              ; (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
 HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
     (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
      HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
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, ThBindEnv
th_bndrs, HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
val_binds )
      }}}

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

checkMainType :: TcGblEnv -> TcRn WantedConstraints
-- If this is the Main module, and it defines a function main,
--   check that its type is of form IO tau.
-- If not, do nothing
-- See Note [Dealing with main]
checkMainType :: TcGblEnv -> TcRn WantedConstraints
checkMainType TcGblEnv
tcg_env
  = do { HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; if TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= HomeUnitEnv -> Module
mainModIs (HscEnv -> HomeUnitEnv
hsc_HUE HscEnv
hsc_env)
         then WantedConstraints -> TcRn WantedConstraints
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
emptyWC else

    do { GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; let dflags :: DynFlags
dflags    = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
             main_occ :: OccName
main_occ  = DynFlags -> OccName
getMainOcc DynFlags
dflags
             main_gres :: [GlobalRdrElt]
main_gres = GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
rdr_env OccName
main_occ
       ; case (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
isLocalGRE [GlobalRdrElt]
main_gres of {
            []         -> WantedConstraints -> TcRn WantedConstraints
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
emptyWC ;
            (GlobalRdrElt
_:GlobalRdrElt
_:[GlobalRdrElt]
_)    -> WantedConstraints -> TcRn WantedConstraints
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
emptyWC ;
            [GlobalRdrElt
main_gre] ->

    do { let main_name :: Name
main_name = GlobalRdrElt -> Name
greMangledName GlobalRdrElt
main_gre
             ctxt :: UserTypeCtxt
ctxt      = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
main_name ReportRedundantConstraints
NoRRC
       ; Var
main_id   <- Name -> TcM Var
tcLookupId Name
main_name
       ; (Type
io_ty,Type
_) <- TcM (Type, Type)
getIOType
       ; let main_ty :: Type
main_ty   = Var -> Type
idType Var
main_id
             eq_orig :: CtOrigin
eq_orig   = TypeEqOrigin { uo_actual :: Type
uo_actual   = Type
main_ty
                                      , uo_expected :: Type
uo_expected = Type
io_ty
                                      , uo_thing :: Maybe TypedThing
uo_thing    = Maybe TypedThing
forall a. Maybe a
Nothing
                                      , uo_visible :: Bool
uo_visible  = Bool
True }
       ; ((TcEvBinds, HsWrapper)
_, WantedConstraints
lie)  <- TcM (TcEvBinds, HsWrapper)
-> TcM ((TcEvBinds, HsWrapper), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints       (TcM (TcEvBinds, HsWrapper)
 -> TcM ((TcEvBinds, HsWrapper), WantedConstraints))
-> TcM (TcEvBinds, HsWrapper)
-> TcM ((TcEvBinds, HsWrapper), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                      Name -> Type -> TcM HsWrapper -> TcM (TcEvBinds, HsWrapper)
forall a. Name -> Type -> TcM a -> TcM (TcEvBinds, a)
setMainCtxt Name
main_name Type
io_ty (TcM HsWrapper -> TcM (TcEvBinds, HsWrapper))
-> TcM HsWrapper -> TcM (TcEvBinds, HsWrapper)
forall a b. (a -> b) -> a -> b
$
                      CtOrigin -> UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSubTypeSigma CtOrigin
eq_orig UserTypeCtxt
ctxt Type
main_ty Type
io_ty
       ; WantedConstraints -> TcRn WantedConstraints
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
lie } } } }

checkMain :: Bool  -- False => no 'module M(..) where' header at all
          -> Maybe (LocatedL [LIE GhcPs])  -- Export specs of Main module
          -> TcM TcGblEnv
-- If we are in module Main, check that 'main' is exported,
-- and generate the runMainIO binding that calls it
-- See Note [Dealing with main]
checkMain :: Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> TcM TcGblEnv
checkMain Bool
explicit_mod_hdr Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies
 = do { HscEnv
hsc_env  <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
      ; TcGblEnv
tcg_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

      ; let dflags :: DynFlags
dflags      = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
            main_mod :: Module
main_mod    = HomeUnitEnv -> Module
mainModIs (HscEnv -> HomeUnitEnv
hsc_HUE HscEnv
hsc_env)
            main_occ :: OccName
main_occ    = DynFlags -> OccName
getMainOcc DynFlags
dflags

            exported_mains :: [Name]
            -- Exported things that are called 'main'
            exported_mains :: [Name]
exported_mains  = [ Name
name | AvailInfo
avail <- TcGblEnv -> [AvailInfo]
tcg_exports TcGblEnv
tcg_env
                                     , Name
name  <- AvailInfo -> [Name]
availNames AvailInfo
avail
                                     , Name -> OccName
nameOccName Name
name OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
main_occ ]

      ; if | TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
main_mod
           -> -- Not the main module
              TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env

           | [Name
main_name] <- [Name]
exported_mains
           -> -- The module indeed exports a function called 'main'
              TcGblEnv -> Name -> TcM TcGblEnv
generateMainBinding TcGblEnv
tcg_env Name
main_name

           | Bool
otherwise
           -> Bool -> TcM TcGblEnv -> TcM TcGblEnv
forall a. HasCallStack => Bool -> a -> a
assert ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
exported_mains) (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
              -- A fully-checked export list can't contain more
              -- than one function with the same OccName
              do { DynFlags -> Module -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain_no_main DynFlags
dflags Module
main_mod OccName
main_occ
                 ; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env } }
  where
    complain_no_main :: DynFlags -> Module -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain_no_main DynFlags
dflags Module
main_mod OccName
main_occ
      = Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
interactive Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
explicit_mod_hdr) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
        TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (Module -> OccName -> TcRnMessage
noMainMsg Module
main_mod OccName
main_occ)          -- #12906
      where
        interactive :: Bool
interactive = DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkInMemory
        -- 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.

    noMainMsg :: Module -> OccName -> TcRnMessage
noMainMsg Module
main_mod OccName
main_occ
      = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OccName -> SDoc
ppMainFn OccName
main_occ
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is not" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
defOrExp SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"module"
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
main_mod)

    defOrExp :: String
defOrExp | Bool
explicit_export_list = String
"exported by"
             | Bool
otherwise            = String
"defined in"
    explicit_export_list :: Bool
explicit_export_list = Bool
explicit_mod_hdr Bool -> Bool -> Bool
&& Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Bool
forall a. Maybe a -> Bool
isJust Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
export_ies

-- | 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
getMainOcc :: DynFlags -> OccName
getMainOcc :: DynFlags -> OccName
getMainOcc DynFlags
dflags = case DynFlags -> Maybe String
mainFunIs DynFlags
dflags of
                      Just String
fn -> FastString -> OccName
mkVarOccFS (String -> FastString
mkFastString String
fn)
                      Maybe String
Nothing -> OccName
mainOcc

ppMainFn :: OccName -> SDoc
ppMainFn :: OccName -> SDoc
ppMainFn OccName
main_occ
  | OccName
main_occ OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
mainOcc
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"IO action" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
main_occ)
  | Bool
otherwise
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"main IO action" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
main_occ)

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

generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv
-- There is a single exported 'main' function, called 'foo' (say),
-- which may be locally defined or imported
-- Define and typecheck the binding
--     :Main.main :: IO res_ty = runMainIO res_ty foo
-- This wraps the user's main function in the top-level stuff
-- defined in runMainIO (eg catching otherwise un-caught exceptions)
-- See Note [Dealing with main]
generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv
generateMainBinding TcGblEnv
tcg_env Name
main_name = do
    { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"checkMain found" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
main_name)
    ; (Type
io_ty, Type
res_ty) <- TcM (Type, Type)
getIOType
    ; let loc :: SrcSpan
loc = Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
main_name
          main_expr_rn :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
main_expr_rn = SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (XVar (GhcPass 'Renamed)
-> LIdP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) Name
main_name))
    ; (TcEvBinds
ev_binds, GenLocated SrcSpanAnnA (HsExpr GhcTc)
main_expr) <- Name
-> Type -> TcM (LHsExpr GhcTc) -> TcM (TcEvBinds, LHsExpr GhcTc)
forall a. Name -> Type -> TcM a -> TcM (TcEvBinds, a)
setMainCtxt Name
main_name Type
io_ty (TcM (LHsExpr GhcTc) -> TcM (TcEvBinds, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (TcEvBinds, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                               LHsExpr (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
main_expr_rn 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
getSrcSpan Name
main_name)
          ; root_main_id :: Var
root_main_id = Name -> Type -> Var
Id.mkExportedVanillaId Name
root_main_name Type
io_ty
          ; co :: HsWrapper
co  = [Type] -> HsWrapper
mkWpTyApps [Type
res_ty]
          -- The ev_binds of the `main` function may contain deferred
          -- type errors 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)
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
co (IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Var
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
GenLocated SrcSpanAnnA (HsExpr GhcTc)
main_expr
          ; main_bind :: LHsBind GhcTc
main_bind = IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP GhcTc
Var
root_main_id LHsExpr GhcTc
rhs }

    ; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env { tcg_main  = Just main_name
                      , tcg_binds = tcg_binds tcg_env
                                    `snocBag` main_bind
                      , tcg_dus   = tcg_dus tcg_env
                                    `plusDU` usesOnly (unitFV main_name) })
                    -- Record the use of 'main', so that we don't
                    -- complain about it being defined but not used
    }

getIOType :: TcM (TcType, TcType)
-- Return (IO alpha, alpha) for fresh alpha
getIOType :: TcM (Type, Type)
getIOType = do { TyCon
ioTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
ioTyConName
               ; Type
res_ty <- Type -> TcM Type
newFlexiTyVarTy Type
liftedTypeKind
               ; (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> [Type] -> Type
mkTyConApp TyCon
ioTyCon [Type
res_ty], Type
res_ty) }

setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a)
setMainCtxt :: forall a. Name -> Type -> TcM a -> TcM (TcEvBinds, a)
setMainCtxt Name
main_name Type
io_ty TcM a
thing_inside
  = SrcSpan -> TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
main_name) (TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a))
-> TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a)
forall a b. (a -> b) -> a -> b
$
    SDoc -> TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
main_ctxt              (TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a))
-> TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a)
forall a b. (a -> b) -> a -> b
$
    SkolemInfoAnon -> [Var] -> [Var] -> TcM a -> TcRn (TcEvBinds, a)
forall result.
SkolemInfoAnon
-> [Var] -> [Var] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints SkolemInfoAnon
skol_info [] []  (TcM a -> TcRn (TcEvBinds, a)) -> TcM a -> TcRn (TcEvBinds, a)
forall a b. (a -> b) -> a -> b
$  -- Builds an implication if necessary
    TcM a
thing_inside                         -- e.g. with -fdefer-type-errors
  where
    skol_info :: SkolemInfoAnon
skol_info = UserTypeCtxt -> Type -> [(Name, Var)] -> SkolemInfoAnon
SigSkol (Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
main_name ReportRedundantConstraints
NoRRC) Type
io_ty []
    main_ctxt :: SDoc
main_ctxt = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"When checking the type of the"
                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OccName -> SDoc
ppMainFn (Name -> OccName
nameOccName Name
main_name)

{- Note [Dealing with main]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dealing with the 'main' declaration is surprisingly tricky. Here are
the moving parts:

* The flag -main-is=M.foo allows you to set the main module to 'M',
  and the main function to 'foo'.  We access them through
      mainModIs  :: HscEnv -> Module     -- returns M
      getMainOcc :: DynFlags -> OccName  -- returns foo
  Of course usually M = Main, and foo = main.

* checkMainType: when typechecking module M, we add an extra check that
    foo :: IO tau, for some type tau.
  This avoids getting ambiguous-type errors from the monomorphism restriction
  applying to things like
      main = return ()
  Note that checkMainType does not consult the export list because
  we have not yet done rnExports (and can't do it until later).

* rnExports: checks the export list.  Very annoyingly, we can only do
  this after running any finalisers, which may add new declarations.
  That's why checkMainType and checkMain have to be separate.

* checkMain: does two things:
  - check that the export list does indeed export something called 'foo'
  - generateMainBinding: generate the root-main binding
       :Main.main = runMainIO M.foo
  See Note [Root-main Id]

An annoying consequence of having both checkMainType and checkMain is
that, when (but only when) -fdefer-type-errors is on, we may report an
ill-typed 'main' twice (as warnings): once in checkMainType and once
in checkMain. See test typecheck/should_fail/T13292.

We have the following tests to check this processing:
----------------+----------------------------------------------------------------------------------+
                |                                  Module Header:                                  |
                +-------------+-------------+-------------+-------------+-------------+------------+
                | module      | module Main | <No Header> | module Main |module       |module Main |
                |  Main(main) |             |             |   (module X)|   Main ()   |  (Sub.main)|
----------------+==================================================================================+
`main` function | ERROR:      | Main.main   | ERROR:      | Main.main   | ERROR:      | Sub.main   |
in Main module  |  Ambiguous  |             |  Ambiguous  |             |  `main` not |            |
and in imported |             |             |             |             |  exported   |            |
module Sub.     | T19397E1    | T16453M0    | T19397E2    | T16453M3    |             | T16453M1   |
                |             |             |             | X = Main    | Remark 2)   |            |
----------------+-------------+-------------+-------------+-------------+-------------+------------+
`main`function  | Sub.main    | ERROR:      | Sub.main    | Sub.main    | ERROR:      | Sub.main   |
only in imported|             | No `main` in|             |             |  `main` not |            |
submodule Sub.  |             |   `Main`    |             |             |  exported   |            |
                | T19397M0    | T16453E1    | T19397M1    | T16453M4    |             | T16453M5   |
                |             |             |             | X = Sub     | Remark 2)   |            |
----------------+-------------+-------------+-------------+-------------+-------------+------------+
`foo` function  | Sub.foo     | ERROR:      | Sub.foo     | Sub.foo     | ERROR:      | Sub.foo    |
in submodule    |             | No `foo` in |             |             |  `foo` not  |            |
Sub.            |             |   `Main`    |             |             |  exported   |            |
GHC option:     |             |             |             |             |             |            |
  -main-is foo  | T19397M2    | T19397E3    | T19397M3    | T19397M4    | T19397E4    | T16453M6   |
                | Remark 1)   |             |             | X = Sub     |             | Remark 3)  |
----------------+-------------+-------------+-------------+-------------+-------------+------------+

Remarks:
* The first line shows the exported `main` function or the error.
* The second line shows the coresponding test case.
* The module `Sub` contains the following functions:
     main :: IO ()
     foo :: IO ()
* Remark 1) Here the header is `Main (foo)`.
* Remark 2) Here we have no extra test case. It would exercise the same code path as `T19397E4`.
* Remark 3) Here the header is `Main (Sub.foo)`.


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!

When using `-fwrite-if-simplified-core` the root_main_id can end up in an interface file.
When the interface is read back in we have to add a special case when creating the
Id because otherwise we would go looking for the :Main module which obviously doesn't
exist. For this logic see GHC.IfaceToCore.mk_top_id.

There is also some similar (probably dead) logic in GHC.Rename.Env which says it
was added for External Core which faced a similar issue.


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

runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
-- Initialise the tcg_inst_env with instances from all home modules.
-- This mimics the more selective call to hptInstances in tcRnImports
runTcInteractive :: forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env TcRn a
thing_inside
  = HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
initTcInteractive HscEnv
hsc_env (TcRn a -> IO (Messages TcRnMessage, Maybe a))
-> TcRn a -> IO (Messages TcRnMessage, 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
withDefaultingPlugins 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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"setInteractiveContext" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
            [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ic_tythings:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((TyThing -> SDoc) -> [TyThing] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
icxt))
                 , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ic_insts:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> Var -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind (Var -> SDoc) -> (ClsInst -> Var) -> ClsInst -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Var
instanceDFunId) (InstEnv -> [ClsInst]
instEnvElts InstEnv
ic_insts))
                 , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"icReaderEnv (LocalDef)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                      [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (([GlobalRdrElt] -> SDoc) -> [[GlobalRdrElt]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map [GlobalRdrElt] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [