{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module TcRnDriver (
tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
tcRnImportDecls,
tcRnLookupRdrName,
getModuleInterface,
tcRnDeclsi,
isGHCiMonad,
runTcInteractive,
tcRnLookupName,
tcRnGetInfo,
tcRnModule, tcRnModuleTcRnM,
tcTopSrcDecls,
rnTopSrcDecls,
checkBootDecl, checkHiBootIface',
findExtraSigImports,
implicitRequirements,
checkUnitId,
mergeSignatures,
tcRnMergeSignatures,
instantiateSignature,
tcRnInstantiateSignature,
loadUnqualIfaces,
badReexportedBootThing,
checkBootDeclM,
missingBootThing,
getRenamedStuff, RenamedStuff
) where
import GhcPrelude
import {-# SOURCE #-} TcSplice ( finishTH, runRemoteModFinalizers )
import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
import IfaceEnv( externaliseName )
import TcHsType
import TcValidity( checkValidType )
import TcMatches
import Inst( deeplyInstantiate )
import TcUnify( checkConstraints )
import RnTypes
import RnExpr
import RnUtils ( HsDocContext(..) )
import RnFixity ( lookupFixityRn )
import MkId
import TysWiredIn ( unitTy, mkListTy )
import Plugins
import DynFlags
import GHC.Hs
import IfaceSyn ( ShowSub(..), showToHeader )
import IfaceType( ShowForAllFlag(..) )
import PatSyn( pprPatSynType )
import PrelNames
import PrelInfo
import RdrName
import TcHsSyn
import TcExpr
import TcRnMonad
import TcRnExports
import TcEvidence
import Constraint
import TcOrigin
import qualified BooleanFormula as BF
import PprTyThing( pprTyThingInContext )
import CoreFVs( orphNamesOfFamInst )
import FamInst
import InstEnv
import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons
, famInstEnvElts, extendFamInstEnvList, normaliseType )
import TcAnnotations
import TcBinds
import MkIface ( coAxiomToIfaceDecl )
import HeaderInfo ( mkPrelImports )
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
import TcMType
import TcType
import TcSimplify
import TcTyClsDecls
import TcTypeable ( mkTypeableBinds )
import TcBackpack
import LoadIface
import RnNames
import RnEnv
import RnSource
import ErrUtils
import Id
import IdInfo( IdDetails(..) )
import VarEnv
import Module
import UniqFM
import Name
import NameEnv
import NameSet
import Avail
import TyCon
import SrcLoc
import HscTypes
import ListSetOps
import Outputable
import ConLike
import DataCon
import Type
import Class
import BasicTypes hiding( SuccessFlag(..) )
import CoAxiom
import Annotations
import Data.List ( sortBy, sort )
import Data.Ord
import FastString
import Maybes
import Util
import Bag
import Inst (tcGetInsts)
import qualified GHC.LanguageExtensions as LangExt
import Data.Data ( Data )
import GHC.Hs.Dump
import qualified Data.Set as S
import Control.DeepSeq
import Control.Monad
import TcHoleFitTypes ( HoleFitPluginR (..) )
#include "HsVersions.h"
tcRnModule :: HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO (Messages, Maybe TcGblEnv)
tcRnModule :: HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO (Messages, 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= (Located (HsModule GhcPs)
-> Located (SrcSpanLess (Located (HsModule GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located (HsModule GhcPs))
this_module)}
| RealSrcSpan RealSrcSpan
real_loc <- SrcSpan
loc
= DynFlags
-> SDoc
-> ((Messages, Maybe TcGblEnv) -> ())
-> IO (Messages, Maybe TcGblEnv)
-> IO (Messages, Maybe TcGblEnv)
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags
(String -> SDoc
text String
"Renamer/typechecker"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(() -> (Messages, Maybe TcGblEnv) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages, Maybe TcGblEnv) -> IO (Messages, Maybe TcGblEnv))
-> IO (Messages, Maybe TcGblEnv) -> IO (Messages, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM TcGblEnv
-> IO (Messages, Maybe TcGblEnv)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
initTc HscEnv
hsc_env HscSource
hsc_src Bool
save_rn_syntax Module
this_mod RealSrcSpan
real_loc (TcM TcGblEnv -> IO (Messages, Maybe TcGblEnv))
-> TcM TcGblEnv -> IO (Messages, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
HscEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall a. HscEnv -> TcM a -> TcM a
withTcPlugins HscEnv
hsc_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall a. HscEnv -> TcM a -> TcM a
withHoleFitPlugins HscEnv
hsc_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
HscEnv
-> ModSummary
-> HsParsedModule
-> (Module, SrcSpan)
-> TcM TcGblEnv
tcRnModuleTcRnM HscEnv
hsc_env ModSummary
mod_sum HsParsedModule
parsedModule (Module, SrcSpan)
pair
| Bool
otherwise
= (Messages, Maybe TcGblEnv) -> IO (Messages, Maybe TcGblEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bag WarnMsg
forall a. Bag a
emptyBag, WarnMsg -> Bag WarnMsg
forall a. a -> Bag a
unitBag WarnMsg
err_msg), Maybe TcGblEnv
forall a. Maybe a
Nothing)
where
hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_sum
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
err_msg :: WarnMsg
err_msg = DynFlags -> SrcSpan -> SDoc -> WarnMsg
mkPlainErrMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) SrcSpan
loc (SDoc -> WarnMsg) -> SDoc -> WarnMsg
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Module does not have a RealSrcSpan:" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
this_pkg :: UnitId
this_pkg = DynFlags -> UnitId
thisPackage (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
pair :: (Module, SrcSpan)
pair :: (Module, SrcSpan)
pair@(Module
this_mod,SrcSpan
_)
| Just (Located ModuleName -> Located (SrcSpanLess (Located ModuleName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
mod_loc SrcSpanLess (Located ModuleName)
mod) <- HsModule GhcPs -> Maybe (Located ModuleName)
forall pass. HsModule pass -> Maybe (Located ModuleName)
hsmodName SrcSpanLess (Located (HsModule GhcPs))
HsModule GhcPs
this_module
= (UnitId -> ModuleName -> Module
mkModule UnitId
this_pkg ModuleName
SrcSpanLess (Located ModuleName)
mod, SrcSpan
mod_loc)
| Bool
otherwise
= (Module
mAIN, SrcLoc -> SrcSpan
srcLocSpan (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
loc))
tcRnModuleTcRnM :: HscEnv
-> ModSummary
-> HsParsedModule
-> (Module, SrcSpan)
-> TcRn TcGblEnv
tcRnModuleTcRnM :: HscEnv
-> ModSummary
-> HsParsedModule
-> (Module, SrcSpan)
-> TcM TcGblEnv
tcRnModuleTcRnM HscEnv
hsc_env ModSummary
mod_sum
(HsParsedModule {
hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module =
(Located (HsModule GhcPs)
-> Located (SrcSpanLess (Located (HsModule GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (HsModule maybe_mod export_ies
import_decls local_decls mod_deprec
maybe_doc_hdr)),
hpm_src_files :: HsParsedModule -> [String]
hpm_src_files = [String]
src_files
})
(Module
this_mod, SrcSpan
prel_imp_loc)
= SrcSpan -> TcM TcGblEnv -> TcM TcGblEnv
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
do { let { explicit_mod_hdr :: Bool
explicit_mod_hdr = Maybe (Located ModuleName) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Located ModuleName)
maybe_mod
; hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_sum }
;
TcGblEnv
tcg_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; SelfBootInfo
boot_info <- HscSource -> Module -> TcRn SelfBootInfo
tcHiBootIface HscSource
hsc_src Module
this_mod
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv (TcGblEnv
tcg_env { tcg_self_boot :: SelfBootInfo
tcg_self_boot = SelfBootInfo
boot_info })
(TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
{
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
moduleName Module
this_mod) SrcSpan
prel_imp_loc
Bool
implicit_prelude [LImportDecl GhcPs]
import_decls }
; WarningFlag
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnImplicitPrelude (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
Bool -> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([LImportDecl GhcPs] -> Bool
forall a. [a] -> Bool
notNull [LImportDecl GhcPs]
prel_imports) (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnImplicitPrelude) (SDoc
implicitPreludeWarn)
;
let { simplifyImport :: a -> (Maybe FastString, Located ModuleName)
simplifyImport (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess a
idecl) =
( (StringLiteral -> FastString)
-> Maybe StringLiteral -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StringLiteral -> FastString
sl_fs (ImportDecl pass -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual SrcSpanLess a
ImportDecl pass
idecl) , ImportDecl pass -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName SrcSpanLess a
ImportDecl pass
idecl)
}
; [(Maybe FastString, Located ModuleName)]
raw_sig_imports <- IO [(Maybe FastString, Located ModuleName)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO [(Maybe FastString, Located ModuleName)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)])
-> IO [(Maybe FastString, Located ModuleName)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> HscSource
-> ModuleName
-> IO [(Maybe FastString, Located ModuleName)]
findExtraSigImports HscEnv
hsc_env HscSource
hsc_src
(Module -> ModuleName
moduleName Module
this_mod)
; [(Maybe FastString, Located ModuleName)]
raw_req_imports <- IO [(Maybe FastString, Located ModuleName)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO [(Maybe FastString, Located ModuleName)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)])
-> IO [(Maybe FastString, Located ModuleName)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [(Maybe FastString, Located ModuleName)]
-> IO [(Maybe FastString, Located ModuleName)]
implicitRequirements HscEnv
hsc_env
((LImportDecl GhcPs -> (Maybe FastString, Located ModuleName))
-> [LImportDecl GhcPs] -> [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map LImportDecl GhcPs -> (Maybe FastString, Located ModuleName)
forall a pass.
(HasSrcSpan a, SrcSpanLess a ~ ImportDecl pass) =>
a -> (Maybe FastString, Located ModuleName)
simplifyImport ([LImportDecl GhcPs]
prel_imports
[LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
import_decls))
; let { mkImport :: (Maybe a, a) -> p
mkImport (Maybe a
Nothing, a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess a
mod_name) = SrcSpanLess p -> p
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc
(SrcSpanLess p -> p) -> SrcSpanLess p -> p
forall a b. (a -> b) -> a -> b
$ (ModuleName -> ImportDecl (GhcPass p)
forall (p :: Pass). ModuleName -> ImportDecl (GhcPass p)
simpleImportDecl ModuleName
SrcSpanLess a
mod_name)
{ ideclHiding :: Maybe (Bool, Located [LIE (GhcPass p)])
ideclHiding = (Bool, Located [LIE (GhcPass p)])
-> Maybe (Bool, Located [LIE (GhcPass p)])
forall a. a -> Maybe a
Just (Bool
False, SrcSpanLess (Located [LIE (GhcPass p)])
-> Located [LIE (GhcPass p)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [])}
; mkImport (Maybe a, a)
_ = String -> p
forall a. String -> a
panic String
"mkImport" }
; let { all_imports :: [LImportDecl GhcPs]
all_imports = [LImportDecl GhcPs]
prel_imports [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
import_decls
[LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ ((Maybe FastString, Located ModuleName) -> LImportDecl GhcPs)
-> [(Maybe FastString, Located ModuleName)] -> [LImportDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe FastString, Located ModuleName) -> LImportDecl GhcPs
forall a p (p :: Pass) a.
(HasSrcSpan a, HasSrcSpan p,
SrcSpanLess p ~ ImportDecl (GhcPass p),
SrcSpanLess a ~ ModuleName) =>
(Maybe a, a) -> p
mkImport ([(Maybe FastString, Located ModuleName)]
raw_sig_imports [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
forall a. [a] -> [a] -> [a]
++ [(Maybe FastString, Located ModuleName)]
raw_req_imports) }
;
TcGblEnv
tcg_env <- {-# SCC "tcRnImports" #-}
HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv
tcRnImports HscEnv
hsc_env [LImportDecl GhcPs]
all_imports
;
let { tcg_env1 :: TcGblEnv
tcg_env1 = case Maybe (Located WarningTxt)
mod_deprec of
Just (Located WarningTxt -> Located (SrcSpanLess (Located WarningTxt))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located WarningTxt)
txt) ->
TcGblEnv
tcg_env {tcg_warns :: Warnings
tcg_warns = WarningTxt -> Warnings
WarnAll SrcSpanLess (Located WarningTxt)
WarningTxt
txt}
Maybe (Located WarningTxt)
Nothing -> TcGblEnv
tcg_env
}
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env1
(TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn1a" SDoc
empty
; TcGblEnv
tcg_env <- if HscSource -> Bool
isHsBootOrSig HscSource
hsc_src
then HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnHsBootDecls HscSource
hsc_src [LHsDecl GhcPs]
local_decls
else {-# SCC "tcRnSrcDecls" #-}
Bool -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnSrcDecls Bool
explicit_mod_hdr [LHsDecl GhcPs]
local_decls
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env
(TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn4a: before exports" SDoc
empty
; TcGblEnv
tcg_env <- Bool -> Maybe (Located [LIE GhcPs]) -> TcGblEnv -> TcM TcGblEnv
tcRnExports Bool
explicit_mod_hdr Maybe (Located [LIE GhcPs])
export_ies
TcGblEnv
tcg_env
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn4b: after exports" SDoc
empty
;
Bool -> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
explicit_mod_hdr (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> TcRnIf TcGblEnv TcLclEnv ()
checkMainExported TcGblEnv
tcg_env
;
TcGblEnv
tcg_env <- TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
checkHiBootIface TcGblEnv
tcg_env SelfBootInfo
boot_info
;
TcGblEnv
tcg_env <- TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env
{ tcg_doc_hdr :: Maybe LHsDocString
tcg_doc_hdr = Maybe LHsDocString
maybe_doc_hdr })
;
TcGblEnv -> TcRnIf TcGblEnv TcLclEnv ()
reportUnusedNames TcGblEnv
tcg_env
;
[String] -> TcRnIf TcGblEnv TcLclEnv ()
addDependentFiles [String]
src_files
; TcGblEnv
tcg_env <- ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv
runTypecheckerPlugin ModSummary
mod_sum HscEnv
hsc_env TcGblEnv
tcg_env
;
TcGblEnv -> TcRnIf TcGblEnv TcLclEnv ()
tcDump TcGblEnv
tcg_env
; TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env }
}
}
}
implicitPreludeWarn :: SDoc
implicitPreludeWarn :: SDoc
implicitPreludeWarn
= String -> SDoc
text String
"Module `Prelude' implicitly imported"
tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv
tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv
tcRnImports HscEnv
hsc_env [LImportDecl GhcPs]
import_decls
= do { ([LImportDecl GhcRn]
rn_imports, GlobalRdrEnv
rdr_env, ImportAvails
imports, Bool
hpc_info) <- [LImportDecl GhcPs]
-> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, Bool)
rnImports [LImportDecl GhcPs]
import_decls ;
; Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
; dep_mods :: ModuleNameEnv (ModuleName, Bool)
dep_mods = ImportAvails -> ModuleNameEnv (ModuleName, Bool)
imp_dep_mods ImportAvails
imports
; want_instances :: ModuleName -> Bool
; want_instances :: ModuleName -> Bool
want_instances ModuleName
mod = ModuleName
mod ModuleName -> ModuleNameEnv (ModuleName, Bool) -> Bool
forall key elt. Uniquable key => key -> UniqFM elt -> Bool
`elemUFM` ModuleNameEnv (ModuleName, Bool)
dep_mods
Bool -> Bool -> Bool
&& ModuleName
mod ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> ModuleName
moduleName Module
this_mod
; ([ClsInst]
home_insts, [FamInst]
home_fam_insts) = HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])
hptInstances HscEnv
hsc_env
ModuleName -> Bool
want_instances
} ;
; (ExternalPackageState -> ExternalPackageState)
-> TcRnIf TcGblEnv TcLclEnv ()
forall gbl lcl.
(ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ (\ExternalPackageState
eps -> ExternalPackageState
eps { eps_is_boot :: ModuleNameEnv (ModuleName, Bool)
eps_is_boot = ModuleNameEnv (ModuleName, Bool)
dep_mods }) ;
; (TcGblEnv -> TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv ( \ TcGblEnv
gbl ->
TcGblEnv
gbl {
tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
gbl GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
`plusGlobalRdrEnv` GlobalRdrEnv
rdr_env,
tcg_imports :: ImportAvails
tcg_imports = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
gbl ImportAvails -> ImportAvails -> ImportAvails
`plusImportAvails` ImportAvails
imports,
tcg_rn_imports :: [LImportDecl GhcRn]
tcg_rn_imports = [LImportDecl GhcRn]
rn_imports,
tcg_inst_env :: InstEnv
tcg_inst_env = InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList (TcGblEnv -> InstEnv
tcg_inst_env TcGblEnv
gbl) [ClsInst]
home_insts,
tcg_fam_inst_env :: FamInstEnv
tcg_fam_inst_env = FamInstEnv -> [FamInst] -> FamInstEnv
extendFamInstEnvList (TcGblEnv -> FamInstEnv
tcg_fam_inst_env TcGblEnv
gbl)
[FamInst]
home_fam_insts,
tcg_hpc :: Bool
tcg_hpc = Bool
hpc_info
}) (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn1" (ModuleNameEnv (ModuleName, Bool) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ImportAvails -> ModuleNameEnv (ModuleName, Bool)
imp_dep_mods ImportAvails
imports))
; TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM
; SDoc -> [Module] -> TcRnIf TcGblEnv TcLclEnv ()
loadModuleInterfaces (String -> SDoc
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))
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn1: checking family instance consistency {" SDoc
empty
; let { dir_imp_mods :: [Module]
dir_imp_mods = ModuleEnv [ImportedBy] -> [Module]
forall a. ModuleEnv a -> [Module]
moduleEnvKeys
(ModuleEnv [ImportedBy] -> [Module])
-> (ImportAvails -> ModuleEnv [ImportedBy])
-> ImportAvails
-> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportAvails -> ModuleEnv [ImportedBy]
imp_mods
(ImportAvails -> [Module]) -> ImportAvails -> [Module]
forall a b. (a -> b) -> a -> b
$ ImportAvails
imports }
; [Module] -> TcRnIf TcGblEnv TcLclEnv ()
checkFamInstConsistency [Module]
dir_imp_mods
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn1: } checking family instance consistency" SDoc
empty
; TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv } }
tcRnSrcDecls :: Bool
-> [LHsDecl GhcPs]
-> TcM TcGblEnv
tcRnSrcDecls :: Bool -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnSrcDecls Bool
explicit_mod_hdr [LHsDecl GhcPs]
decls
= do {
; (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie) <- [LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls [LHsDecl GhcPs]
decls
; (TcGblEnv
tcg_env, WantedConstraints
lie_main) <- (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
TcM TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints))
-> TcM TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
Bool -> TcM TcGblEnv
checkMain Bool
explicit_mod_hdr
; (TcGblEnv, TcLclEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {
; Bag EvBind
new_ev_binds <- {-# SCC "simplifyTop" #-}
WantedConstraints -> TcM (Bag EvBind)
simplifyTop (WantedConstraints
lie WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
lie_main)
; TcGblEnv
tcg_env <- TcM TcGblEnv
mkTypeableBinds
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc9" SDoc
empty
; TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc10" SDoc
empty
; (TypeEnv
bind_env, Bag EvBind
ev_binds', LHsBinds GhcTc
binds', [LForeignDecl GhcTc]
fords', [LTcSpecPrag]
imp_specs', [LRuleDecl GhcTc]
rules')
<- Bag EvBind
-> TcGblEnv
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv Bag EvBind
new_ev_binds TcGblEnv
tcg_env
; (TcGblEnv
tcg_env_mf, TcLclEnv
_) <- TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv (TcGblEnv -> TcGblEnv
clearTcGblEnv TcGblEnv
tcg_env)
TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
run_th_modfinalizers
; TcRnIf TcGblEnv TcLclEnv ()
finishTH
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc11" SDoc
empty
;
; (TypeEnv
bind_env_mf, Bag EvBind
ev_binds_mf, LHsBinds GhcTc
binds_mf, [LForeignDecl GhcTc]
fords_mf, [LTcSpecPrag]
imp_specs_mf, [LRuleDecl GhcTc]
rules_mf)
<- Bag EvBind
-> TcGblEnv
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv Bag EvBind
forall a. Bag a
emptyBag TcGblEnv
tcg_env_mf
; let { final_type_env :: TypeEnv
final_type_env = TypeEnv -> TypeEnv -> TypeEnv
plusTypeEnv (TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
tcg_env)
(TypeEnv -> TypeEnv -> TypeEnv
plusTypeEnv TypeEnv
bind_env_mf TypeEnv
bind_env)
; tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env_mf
{ tcg_binds :: LHsBinds GhcTc
tcg_binds = LHsBinds GhcTc
binds' LHsBinds GhcTc -> LHsBinds GhcTc -> LHsBinds GhcTc
forall a. Bag a -> Bag a -> Bag a
`unionBags` LHsBinds GhcTc
binds_mf,
tcg_ev_binds :: Bag EvBind
tcg_ev_binds = Bag EvBind
ev_binds' Bag EvBind -> Bag EvBind -> Bag EvBind
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag EvBind
ev_binds_mf ,
tcg_imp_specs :: [LTcSpecPrag]
tcg_imp_specs = [LTcSpecPrag]
imp_specs' [LTcSpecPrag] -> [LTcSpecPrag] -> [LTcSpecPrag]
forall a. [a] -> [a] -> [a]
++ [LTcSpecPrag]
imp_specs_mf ,
tcg_rules :: [LRuleDecl GhcTc]
tcg_rules = [LRuleDecl GhcTc]
rules' [LRuleDecl GhcTc] -> [LRuleDecl GhcTc] -> [LRuleDecl GhcTc]
forall a. [a] -> [a] -> [a]
++ [LRuleDecl GhcTc]
rules_mf ,
tcg_fords :: [LForeignDecl GhcTc]
tcg_fords = [LForeignDecl GhcTc]
fords' [LForeignDecl GhcTc]
-> [LForeignDecl GhcTc] -> [LForeignDecl GhcTc]
forall a. [a] -> [a] -> [a]
++ [LForeignDecl GhcTc]
fords_mf } } ;
; TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv TcGblEnv
tcg_env' TypeEnv
final_type_env
} }
zonkTcGblEnv :: Bag EvBind -> TcGblEnv
-> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
[LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv :: Bag EvBind
-> TcGblEnv
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv Bag EvBind
new_ev_binds TcGblEnv
tcg_env =
let TcGblEnv { tcg_binds :: TcGblEnv -> LHsBinds GhcTc
tcg_binds = LHsBinds GhcTc
binds,
tcg_ev_binds :: TcGblEnv -> Bag EvBind
tcg_ev_binds = Bag EvBind
cur_ev_binds,
tcg_imp_specs :: TcGblEnv -> [LTcSpecPrag]
tcg_imp_specs = [LTcSpecPrag]
imp_specs,
tcg_rules :: TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules = [LRuleDecl GhcTc]
rules,
tcg_fords :: TcGblEnv -> [LForeignDecl GhcTc]
tcg_fords = [LForeignDecl GhcTc]
fords } = TcGblEnv
tcg_env
all_ev_binds :: Bag EvBind
all_ev_binds = Bag EvBind
cur_ev_binds Bag EvBind -> Bag EvBind -> Bag EvBind
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag EvBind
new_ev_binds
in {-# SCC "zonkTopDecls" #-}
Bag EvBind
-> LHsBinds GhcTc
-> [LRuleDecl GhcTc]
-> [LTcSpecPrag]
-> [LForeignDecl GhcTc]
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
zonkTopDecls Bag EvBind
all_ev_binds LHsBinds GhcTc
binds [LRuleDecl GhcTc]
rules [LTcSpecPrag]
imp_specs [LForeignDecl GhcTc]
fords
clearTcGblEnv :: TcGblEnv -> TcGblEnv
clearTcGblEnv :: TcGblEnv -> TcGblEnv
clearTcGblEnv TcGblEnv
tcg_env
= TcGblEnv
tcg_env { tcg_binds :: LHsBinds GhcTc
tcg_binds = LHsBinds GhcTc
forall a. Bag a
emptyBag,
tcg_ev_binds :: Bag EvBind
tcg_ev_binds = Bag EvBind
forall a. Bag a
emptyBag ,
tcg_imp_specs :: [LTcSpecPrag]
tcg_imp_specs = [],
tcg_rules :: [LRuleDecl GhcTc]
tcg_rules = [],
tcg_fords :: [LForeignDecl GhcTc]
tcg_fords = [] }
run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
run_th_modfinalizers :: TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
run_th_modfinalizers = do
TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- (TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)])
-> TcM TcGblEnv
-> IOEnv
(Env TcGblEnv TcLclEnv) (TcRef [(TcLclEnv, ThModFinalizers)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
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 (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)] -> TcRnIf TcGblEnv TcLclEnv ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var []
let run_finalizer :: (TcLclEnv, ThModFinalizers) -> TcRnIf TcGblEnv lcl ()
run_finalizer (TcLclEnv
lcl_env, ThModFinalizers
f) =
TcLclEnv -> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv lcl ()
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv TcLclEnv
lcl_env (ThModFinalizers -> TcRnIf TcGblEnv TcLclEnv ()
runRemoteModFinalizers ThModFinalizers
f)
(()
_, WantedConstraints
lie_th) <- TcRnIf TcGblEnv TcLclEnv () -> TcM ((), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcRnIf TcGblEnv TcLclEnv () -> TcM ((), WantedConstraints))
-> TcRnIf TcGblEnv TcLclEnv () -> TcM ((), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
((TcLclEnv, ThModFinalizers) -> TcRnIf TcGblEnv TcLclEnv ())
-> [(TcLclEnv, ThModFinalizers)] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcLclEnv, ThModFinalizers) -> TcRnIf TcGblEnv TcLclEnv ()
forall lcl. (TcLclEnv, ThModFinalizers) -> TcRnIf TcGblEnv lcl ()
run_finalizer [(TcLclEnv, ThModFinalizers)]
th_modfinalizers
(TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie_top_decls) <- [LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls []
(TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do
Bag EvBind
new_ev_binds <- {-# SCC "simplifyTop2" #-}
WantedConstraints -> TcM (Bag EvBind)
simplifyTop (WantedConstraints
lie_th WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
lie_top_decls)
Bag EvBind
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. Bag EvBind -> TcM a -> TcM a
addTopEvBinds Bag EvBind
new_ev_binds TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
run_th_modfinalizers
tc_rn_src_decls :: [LHsDecl GhcPs]
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls :: [LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls [LHsDecl GhcPs]
ds
= {-# SCC "tc_rn_src_decls" #-}
do { (HsGroup GhcPs
first_group, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
group_tail) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
ds
; (TcGblEnv
tcg_env, HsGroup GhcRn
rn_decls) <- HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
rnTopSrcDecls HsGroup GhcPs
first_group
; TcRef [LHsDecl GhcPs]
th_topdecls_var <- (TcGblEnv -> TcRef [LHsDecl GhcPs])
-> TcM TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (TcRef [LHsDecl GhcPs])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> TcRef [LHsDecl GhcPs]
tcg_th_topdecls TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; [LHsDecl GhcPs]
th_ds <- TcRef [LHsDecl GhcPs] -> TcRnIf TcGblEnv TcLclEnv [LHsDecl GhcPs]
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef [LHsDecl GhcPs]
th_topdecls_var
; TcRef [LHsDecl GhcPs]
-> [LHsDecl GhcPs] -> TcRnIf TcGblEnv TcLclEnv ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef [LHsDecl GhcPs]
th_topdecls_var []
; (TcGblEnv
tcg_env, HsGroup GhcRn
rn_decls) <-
if [LHsDecl GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsDecl GhcPs]
th_ds
then (TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, HsGroup GhcRn
rn_decls)
else do { (HsGroup GhcPs
th_group, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
th_group_tail) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
th_ds
; case Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
th_group_tail of
{ Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
Nothing -> () -> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Just (SpliceDecl XSpliceDecl GhcPs
_ (Located (HsSplice GhcPs)
-> Located (SrcSpanLess (Located (HsSplice GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located (HsSplice GhcPs))
_) SpliceExplicitFlag
_, [LHsDecl GhcPs]
_) ->
SrcSpan
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc
(TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErr (String -> SDoc
text
(String
"Declaration splices are not "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"permitted inside top-level "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"declarations added with addTopDecls"))
; Just (XSpliceDecl XXSpliceDecl GhcPs
nec, [LHsDecl GhcPs]
_) -> NoExtCon -> TcRnIf TcGblEnv TcLclEnv ()
forall a. NoExtCon -> a
noExtCon XXSpliceDecl GhcPs
NoExtCon
nec
}
; (TcGblEnv
tcg_env, HsGroup GhcRn
th_rn_decls) <- TcGblEnv
-> TcM (TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env
(TcM (TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn))
-> TcM (TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$ HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
rnTopSrcDecls HsGroup GhcPs
th_group
; let msg :: String
msg = String
"top-level declarations added with addTopDecls"
; SpliceInfo -> TcRnIf TcGblEnv TcLclEnv ()
traceSplice
(SpliceInfo -> TcRnIf TcGblEnv TcLclEnv ())
-> SpliceInfo -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ SpliceInfo :: String -> Maybe (LHsExpr GhcRn) -> Bool -> SDoc -> SpliceInfo
SpliceInfo { spliceDescription :: String
spliceDescription = String
msg
, spliceIsDecl :: Bool
spliceIsDecl = Bool
True
, spliceSource :: Maybe (LHsExpr GhcRn)
spliceSource = Maybe (LHsExpr GhcRn)
forall a. Maybe a
Nothing
, spliceGenerated :: SDoc
spliceGenerated = HsGroup GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsGroup GhcRn
th_rn_decls }
; (TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, HsGroup GhcRn -> HsGroup GhcRn -> HsGroup GhcRn
forall (p :: Pass).
HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p)
appendGroups HsGroup GhcRn
rn_decls HsGroup GhcRn
th_rn_decls)
}
; ((TcGblEnv
tcg_env, TcLclEnv
tcl_env), WantedConstraints
lie1) <- TcGblEnv
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcRnIf TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints))
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
HsGroup GhcRn -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopSrcDecls HsGroup GhcRn
rn_decls
; (TcGblEnv, TcLclEnv)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints))
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
case Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
group_tail of
{ Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
Nothing -> (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie1)
; Just (SpliceDecl XSpliceDecl GhcPs
_ (Located (HsSplice GhcPs)
-> Located (SrcSpanLess (Located (HsSplice GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located (HsSplice GhcPs))
splice) SpliceExplicitFlag
_, [LHsDecl GhcPs]
rest_ds) ->
do { SrcSpan -> TcRnIf TcGblEnv TcLclEnv ()
recordTopLevelSpliceLoc SrcSpan
loc
; ([LHsDecl GhcPs]
spliced_decls, FreeVars
splice_fvs) <- HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls SrcSpanLess (Located (HsSplice GhcPs))
HsSplice GhcPs
splice
; (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie2) <-
TcGblEnv
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv (TcGblEnv
tcg_env TcGblEnv -> DefUses -> TcGblEnv
`addTcgDUs` FreeVars -> DefUses
usesOnly FreeVars
splice_fvs) (TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints))
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
[LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls ([LHsDecl GhcPs]
spliced_decls [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
rest_ds)
; (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie1 WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
lie2)
}
; Just (XSpliceDecl XXSpliceDecl GhcPs
nec, [LHsDecl GhcPs]
_) -> NoExtCon -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a. NoExtCon -> a
noExtCon XXSpliceDecl GhcPs
NoExtCon
nec
}
}
tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnHsBootDecls HscSource
hsc_src [LHsDecl GhcPs]
decls
= do { (HsGroup GhcPs
first_group, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
group_tail) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
decls
; (TcGblEnv
tcg_env, HsGroup { hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup GhcRn]
tycl_decls
, hs_derivds :: forall p. HsGroup p -> [LDerivDecl p]
hs_derivds = [LDerivDecl GhcRn]
deriv_decls
, hs_fords :: forall p. HsGroup p -> [LForeignDecl p]
hs_fords = [LForeignDecl GhcRn]
for_decls
, hs_defds :: forall p. HsGroup p -> [LDefaultDecl p]
hs_defds = [LDefaultDecl GhcRn]
def_decls
, hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds = [LRuleDecls GhcRn]
rule_decls
, hs_annds :: forall p. HsGroup p -> [LAnnDecl p]
hs_annds = [LAnnDecl GhcRn]
_
, hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds = XValBindsLR (NValBinds val_binds val_sigs) })
<- HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
rnTopSrcDecls HsGroup GhcPs
first_group
; (TcGblEnv
gbl_env, WantedConstraints
lie) <- TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$ TcM TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints))
-> TcM TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$ do {
; case Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
group_tail of
Just (SpliceDecl XSpliceDecl GhcPs
_ Located (HsSplice GhcPs)
d SpliceExplicitFlag
_, [LHsDecl GhcPs]
_) -> HscSource
-> String
-> Located (HsSplice GhcPs)
-> TcRnIf TcGblEnv TcLclEnv ()
forall decl.
HscSource -> String -> Located decl -> TcRnIf TcGblEnv TcLclEnv ()
badBootDecl HscSource
hsc_src String
"splice" Located (HsSplice GhcPs)
d
Just (XSpliceDecl XXSpliceDecl GhcPs
nec, [LHsDecl GhcPs]
_) -> NoExtCon -> TcRnIf TcGblEnv TcLclEnv ()
forall a. NoExtCon -> a
noExtCon XXSpliceDecl GhcPs
NoExtCon
nec
Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])
Nothing -> () -> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; (LForeignDecl GhcRn -> TcRnIf TcGblEnv TcLclEnv ())
-> [LForeignDecl GhcRn] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HscSource
-> String -> LForeignDecl GhcRn -> TcRnIf TcGblEnv TcLclEnv ()
forall decl.
HscSource -> String -> Located decl -> TcRnIf TcGblEnv TcLclEnv ()
badBootDecl HscSource
hsc_src String
"foreign") [LForeignDecl GhcRn]
for_decls
; (LDefaultDecl GhcRn -> TcRnIf TcGblEnv TcLclEnv ())
-> [LDefaultDecl GhcRn] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HscSource
-> String -> LDefaultDecl GhcRn -> TcRnIf TcGblEnv TcLclEnv ()
forall decl.
HscSource -> String -> Located decl -> TcRnIf TcGblEnv TcLclEnv ()
badBootDecl HscSource
hsc_src String
"default") [LDefaultDecl GhcRn]
def_decls
; (LRuleDecls GhcRn -> TcRnIf TcGblEnv TcLclEnv ())
-> [LRuleDecls GhcRn] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HscSource
-> String -> LRuleDecls GhcRn -> TcRnIf TcGblEnv TcLclEnv ()
forall decl.
HscSource -> String -> Located decl -> TcRnIf TcGblEnv TcLclEnv ()
badBootDecl HscSource
hsc_src String
"rule") [LRuleDecls GhcRn]
rule_decls
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc2 (boot)" SDoc
empty
; (TcGblEnv
tcg_env, [InstInfo GhcRn]
inst_infos, HsValBindsLR GhcRn GhcRn
_deriv_binds)
<- [TyClGroup GhcRn]
-> [LDerivDecl GhcRn]
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
tcTyClsInstDecls [TyClGroup GhcRn]
tycl_decls [LDerivDecl GhcRn]
deriv_decls [(RecFlag, LHsBinds GhcRn)]
val_binds
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {
; TcGblEnv
tcg_env <- TcM TcGblEnv
mkTypeableBinds
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc5" SDoc
empty
; [Id]
val_ids <- [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
tcHsBootSigs [(RecFlag, LHsBinds GhcRn)]
val_binds [LSig GhcRn]
val_sigs
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc7a" SDoc
empty
; TcGblEnv
gbl_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let { type_env0 :: TypeEnv
type_env0 = TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
gbl_env
; type_env1 :: TypeEnv
type_env1 = TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds TypeEnv
type_env0 [Id]
val_ids
; type_env2 :: TypeEnv
type_env2 = TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds TypeEnv
type_env1 [Id]
dfun_ids
; dfun_ids :: [Id]
dfun_ids = (InstInfo GhcRn -> Id) -> [InstInfo GhcRn] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map InstInfo GhcRn -> Id
forall a. InstInfo a -> Id
iDFunId [InstInfo GhcRn]
inst_infos
}
; TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv TcGblEnv
gbl_env TypeEnv
type_env2
}}}
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"boot" (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie); TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
gbl_env }
badBootDecl :: HscSource -> String -> Located decl -> TcM ()
badBootDecl :: HscSource -> String -> Located decl -> TcRnIf TcGblEnv TcLclEnv ()
badBootDecl HscSource
hsc_src String
what (Located decl -> Located (SrcSpanLess (Located decl))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located decl)
_)
= SrcSpan -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrAt SrcSpan
loc (Char -> SDoc
char Char
'A' SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
what
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"declaration is not (currently) allowed in a"
SDoc -> SDoc -> SDoc
<+> (case HscSource
hsc_src of
HscSource
HsBootFile -> String -> SDoc
text String
"hs-boot"
HscSource
HsigFile -> String -> SDoc
text String
"hsig"
HscSource
_ -> String -> SDoc
forall a. String -> a
panic String
"badBootDecl: should be an hsig or hs-boot file")
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"file")
checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
checkHiBootIface TcGblEnv
tcg_env SelfBootInfo
boot_info
| SelfBootInfo
NoSelfBoot <- SelfBootInfo
boot_info
= TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
| HscSource
HsBootFile <- TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env
= TcGblEnv -> TcM TcGblEnv
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 {
; [(Id, Id)]
dfun_prs <- [ClsInst] -> TypeEnv -> [AvailInfo] -> ModDetails -> TcM [(Id, Id)]
checkHiBootIface' [ClsInst]
local_insts TypeEnv
local_type_env
[AvailInfo]
local_exports ModDetails
boot_details
; let boot_dfuns :: [Id]
boot_dfuns = ((Id, Id) -> Id) -> [(Id, Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Id) -> Id
forall a b. (a, b) -> a
fst [(Id, Id)]
dfun_prs
type_env' :: TypeEnv
type_env' = TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds TypeEnv
local_type_env [Id]
boot_dfuns
dfun_binds :: LHsBinds GhcTc
dfun_binds = [LHsBind GhcTc] -> LHsBinds 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 Id
IdP GhcTc
boot_dfun (IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
dfun)
| (Id
boot_dfun, Id
dfun) <- [(Id, Id)]
dfun_prs ]
tcg_env_w_binds :: TcGblEnv
tcg_env_w_binds
= TcGblEnv
tcg_env { tcg_binds :: LHsBinds GhcTc
tcg_binds = LHsBinds GhcTc
binds LHsBinds GhcTc -> LHsBinds GhcTc -> LHsBinds GhcTc
forall a. Bag a -> Bag a -> Bag a
`unionBags` LHsBinds GhcTc
dfun_binds }
; TypeEnv
type_env' TypeEnv -> TcM TcGblEnv -> TcM TcGblEnv
`seq`
TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv TcGblEnv
tcg_env_w_binds TypeEnv
type_env' }
| Bool
otherwise = String -> TcM TcGblEnv
forall a. String -> a
panic String
"checkHiBootIface: unreachable code"
checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
-> ModDetails -> TcM [(Id, Id)]
checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] -> ModDetails -> TcM [(Id, Id)]
checkHiBootIface'
[ClsInst]
local_insts TypeEnv
local_type_env [AvailInfo]
local_exports
(ModDetails { md_types :: ModDetails -> TypeEnv
md_types = TypeEnv
boot_type_env
, md_fam_insts :: ModDetails -> [FamInst]
md_fam_insts = [FamInst]
boot_fam_insts
, md_exports :: ModDetails -> [AvailInfo]
md_exports = [AvailInfo]
boot_exports })
= do { String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"checkHiBootIface" (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeEnv
boot_type_env, [AvailInfo] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AvailInfo]
boot_exports]
; (AvailInfo -> TcRnIf TcGblEnv TcLclEnv ())
-> [AvailInfo] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ AvailInfo -> TcRnIf TcGblEnv TcLclEnv ()
check_export [AvailInfo]
boot_exports
; Bool -> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FamInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FamInst]
boot_fam_insts) (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
String -> TcRnIf TcGblEnv TcLclEnv ()
forall a. String -> a
panic (String
"TcRnDriver.checkHiBootIface: Cannot handle family " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"instances in boot files yet...")
; [Maybe (Id, Id)]
mb_dfun_prs <- (Id -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Id, Id)))
-> [Id] -> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (Id, Id)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Id, Id))
check_cls_inst [Id]
boot_dfuns
; TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM
; [(Id, Id)] -> TcM [(Id, Id)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe (Id, Id)] -> [(Id, Id)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Id, Id)]
mb_dfun_prs) }
where
boot_dfun_names :: [Name]
boot_dfun_names = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
boot_dfuns
boot_dfuns :: [Id]
boot_dfuns = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isDFunId ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ TypeEnv -> [Id]
typeEnvIds TypeEnv
boot_type_env
check_export :: AvailInfo -> TcRnIf TcGblEnv TcLclEnv ()
check_export AvailInfo
boot_avail
| Name
name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
boot_dfun_names = () -> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Name -> Bool
isWiredInName Name
name = () -> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool -> Bool
not ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
missing_names)
= SrcSpan -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrAt (Name -> SrcSpan
nameSrcSpan ([Name] -> Name
forall a. [a] -> a
head [Name]
missing_names))
(Bool -> Name -> String -> SDoc
missingBootThing Bool
True ([Name] -> Name
forall a. [a] -> a
head [Name]
missing_names) String
"exported by")
| Maybe TyThing -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TyThing
mb_boot_thing = () -> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| 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 -> TcRnIf TcGblEnv TcLclEnv ()
checkBootDeclM Bool
True TyThing
boot_thing TyThing
real_thing
| Bool
otherwise
= SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrTc (Bool -> Name -> String -> SDoc
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))
check_cls_inst :: Id -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Id, Id))
check_cls_inst Id
boot_dfun
| (Id
real_dfun : [Id]
_) <- Id -> [Id]
find_real_dfun Id
boot_dfun
, let local_boot_dfun :: Id
local_boot_dfun = Name -> Type -> Id
Id.mkExportedVanillaId
(Id -> Name
idName Id
boot_dfun) (Id -> Type
idType Id
real_dfun)
= Maybe (Id, Id) -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Id, Id))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Id, Id) -> Maybe (Id, Id)
forall a. a -> Maybe a
Just (Id
local_boot_dfun, Id
real_dfun))
| Bool
otherwise
= SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Id, Id))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Id, Id))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
boot_dfun)) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Id, Id))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Id, Id)))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Id, Id))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Id, Id))
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"check_cls_inst" (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"local_insts" SDoc -> SDoc -> SDoc
<+>
[SDoc] -> SDoc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> (ClsInst -> Type) -> ClsInst -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType (Id -> Type) -> (ClsInst -> Id) -> ClsInst -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Id
instanceDFunId) [ClsInst]
local_insts)
, String -> SDoc
text String
"boot_dfun_ty" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
boot_dfun) ]
; SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrTc (Id -> SDoc
instMisMatch Id
boot_dfun)
; Maybe (Id, Id) -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Id, Id))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Id, Id)
forall a. Maybe a
Nothing }
find_real_dfun :: DFunId -> [DFunId]
find_real_dfun :: Id -> [Id]
find_real_dfun Id
boot_dfun
= [Id
dfun | ClsInst
inst <- [ClsInst]
local_insts
, let dfun :: Id
dfun = ClsInst -> Id
instanceDFunId ClsInst
inst
, Id -> Type
idType Id
dfun Type -> Type -> Bool
`eqType` Type
boot_dfun_ty ]
where
boot_dfun_ty :: Type
boot_dfun_ty = Id -> Type
idType Id
boot_dfun
checkBootDeclM :: Bool
-> TyThing -> TyThing -> TcM ()
checkBootDeclM :: Bool -> TyThing -> TyThing -> TcRnIf TcGblEnv TcLclEnv ()
checkBootDeclM Bool
is_boot TyThing
boot_thing TyThing
real_thing
= Maybe SDoc
-> (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Bool -> TyThing -> TyThing -> Maybe SDoc
checkBootDecl Bool
is_boot TyThing
boot_thing TyThing
real_thing) ((SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv ())
-> (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ \ SDoc
err ->
SrcSpan -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrAt SrcSpan
span
(Bool -> SDoc -> TyThing -> TyThing -> SDoc
bootMisMatch Bool
is_boot SDoc
err TyThing
real_thing TyThing
boot_thing)
where
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)
checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc
checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc
checkBootDecl Bool
_ (AnId Id
id1) (AnId Id
id2)
= ASSERT(id1 == id2)
Bool -> SDoc -> Maybe SDoc
check (Id -> Type
idType Id
id1 Type -> Type -> Bool
`eqType` Id -> Type
idType Id
id2)
(String -> SDoc
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
empty
andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
Maybe SDoc
Nothing andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck` Maybe SDoc
msg = Maybe SDoc
msg
Maybe SDoc
msg `andThenCheck` Maybe SDoc
Nothing = Maybe SDoc
msg
Just SDoc
d1 `andThenCheck` Just SDoc
d2 = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc
d1 SDoc -> SDoc -> SDoc
$$ SDoc
d2)
infixr 0 `andThenCheck`
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
checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
-> Maybe SDoc
checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc -> Maybe SDoc
checkListBy a -> a -> Maybe SDoc
check_fun [a]
as [a]
bs SDoc
whats = [SDoc] -> [a] -> [a] -> Maybe SDoc
go [] [a]
as [a]
bs
where
herald :: SDoc
herald = String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> SDoc
whats SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"do not match"
go :: [SDoc] -> [a] -> [a] -> Maybe SDoc
go [] [] [] = Maybe SDoc
forall a. Maybe a
Nothing
go [SDoc]
docs [] [] = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Int -> SDoc -> SDoc
hang (SDoc
herald SDoc -> SDoc -> SDoc
<> SDoc
colon) Int
2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse [SDoc]
docs))
go [SDoc]
docs (a
x:[a]
xs) (a
y:[a]
ys) = case a -> a -> Maybe SDoc
check_fun a
x a
y of
Just SDoc
doc -> [SDoc] -> [a] -> [a] -> Maybe SDoc
go (SDoc
docSDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:[SDoc]
docs) [a]
xs [a]
ys
Maybe SDoc
Nothing -> [SDoc] -> [a] -> [a] -> Maybe SDoc
go [SDoc]
docs [a]
xs [a]
ys
go [SDoc]
_ [a]
_ [a]
_ = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Int -> SDoc -> SDoc
hang (SDoc
herald SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 (String -> SDoc
text String
"There are different numbers of" SDoc -> SDoc -> SDoc
<+> SDoc
whats))
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
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
text String
"The types have different kinds"
| Just Class
c1 <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc1
, Just Class
c2 <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc2
, let ([Id]
clas_tvs1, [FunDep Id]
clas_fds1, [Type]
sc_theta1, [Id]
_, [ClassATItem]
ats1, [ClassOpItem]
op_stuff1)
= Class
-> ([Id], [FunDep Id], [Type], [Id], [ClassATItem], [ClassOpItem])
classExtraBigSig Class
c1
([Id]
clas_tvs2, [FunDep Id]
clas_fds2, [Type]
sc_theta2, [Id]
_, [ClassATItem]
ats2, [ClassOpItem]
op_stuff2)
= Class
-> ([Id], [FunDep Id], [Type], [Id], [ClassATItem], [ClassOpItem])
classExtraBigSig Class
c2
, Just RnEnv2
env <- RnEnv2 -> [Id] -> [Id] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 [Id]
clas_tvs1 [Id]
clas_tvs2
= let
eqSig :: ClassOpItem -> ClassOpItem -> Maybe SDoc
eqSig (Id
id1, Maybe (Name, DefMethSpec Type)
def_meth1) (Id
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
text String
"The names" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> SDoc
pname2 SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"are different") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
op_ty1 Type
op_ty2)
(String -> SDoc
text String
"The types of" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"are different") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
if 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. (a -> a -> Bool) -> Maybe a -> Maybe a -> Bool
eqMaybeBy (Name, DefMethSpec Type) -> (Name, DefMethSpec Type) -> Bool
eqDM Maybe (Name, DefMethSpec Type)
def_meth1 Maybe (Name, DefMethSpec Type)
def_meth2)
(String -> SDoc
text String
"The default methods associated with" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"are different")
else 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
text String
"The default methods associated with" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"are not compatible")
where
name1 :: Name
name1 = Id -> Name
idName Id
id1
name2 :: Name
name2 = Id -> Name
idName Id
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)
([Id]
_, Type
rho_ty1) = Type -> ([Id], Type)
splitForAllTys (Id -> Type
idType Id
id1)
op_ty1 :: Type
op_ty1 = Type -> Type
funResultTy Type
rho_ty1
([Id]
_, Type
rho_ty2) = Type -> ([Id], Type)
splitForAllTys (Id -> Type
idType Id
id2)
op_ty2 :: Type
op_ty2 = Type -> Type
funResultTy Type
rho_ty2
eqAT :: ClassATItem -> ClassATItem -> Maybe SDoc
eqAT (ATI TyCon
tc1 Maybe (Type, SrcSpan)
def_ats1) (ATI TyCon
tc2 Maybe (Type, SrcSpan)
def_ats2)
= 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, SrcSpan) -> Maybe (Type, SrcSpan) -> Bool
eqATDef Maybe (Type, SrcSpan)
def_ats1 Maybe (Type, SrcSpan)
def_ats2)
(String -> SDoc
text String
"The associated type defaults differ")
eqDM :: (Name, DefMethSpec Type) -> (Name, DefMethSpec Type) -> 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
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
subDM Type
t1 (Just (Name
_, GenericDM Type
t2)) (Just (Name
_, DefMethSpec Type
VanillaDM))
= RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
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
eqATDef :: Maybe (Type, SrcSpan) -> Maybe (Type, SrcSpan) -> Bool
eqATDef Maybe (Type, SrcSpan)
Nothing Maybe (Type, SrcSpan)
Nothing = Bool
True
eqATDef (Just (Type
ty1, SrcSpan
_loc1)) (Just (Type
ty2, SrcSpan
_loc2)) = RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
ty1 Type
ty2
eqATDef Maybe (Type, SrcSpan)
_ Maybe (Type, SrcSpan)
_ = Bool
False
eqFD :: FunDep Id -> FunDep Id -> Bool
eqFD ([Id]
as1,[Id]
bs1) ([Id]
as2,[Id]
bs2) =
(Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListBy (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env) ([Id] -> [Type]
mkTyVarTys [Id]
as1) ([Id] -> [Type]
mkTyVarTys [Id]
as2) Bool -> Bool -> Bool
&&
(Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListBy (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env) ([Id] -> [Type]
mkTyVarTys [Id]
bs1) ([Id] -> [Type]
mkTyVarTys [Id]
bs2)
in
[Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 [Role]
roles2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check ((FunDep Id -> FunDep Id -> Bool)
-> [FunDep Id] -> [FunDep Id] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListBy FunDep Id -> FunDep Id -> Bool
eqFD [FunDep Id]
clas_fds1 [FunDep Id]
clas_fds2)
(String -> SDoc
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. (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListBy (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env) [Type]
sc_theta1 [Type]
sc_theta2)
(String -> SDoc
text String
"The class constraints do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
(ClassOpItem -> ClassOpItem -> Maybe SDoc)
-> [ClassOpItem] -> [ClassOpItem] -> SDoc -> Maybe SDoc
forall a.
(a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc -> Maybe SDoc
checkListBy ClassOpItem -> ClassOpItem -> Maybe SDoc
eqSig [ClassOpItem]
op_stuff1 [ClassOpItem]
op_stuff2 (String -> SDoc
text String
"methods") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
(ClassATItem -> ClassATItem -> Maybe SDoc)
-> [ClassATItem] -> [ClassATItem] -> SDoc -> Maybe SDoc
forall a.
(a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc -> Maybe SDoc
checkListBy ClassATItem -> ClassATItem -> Maybe SDoc
eqAT [ClassATItem]
ats1 [ClassATItem]
ats2 (String -> SDoc
text String
"associated types") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
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
text String
"The MINIMAL pragmas are not compatible")
| Just Type
syn_rhs1 <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tc1
, Just Type
syn_rhs2 <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tc2
, Just RnEnv2
env <- RnEnv2 -> [Id] -> [Id] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 (TyCon -> [Id]
tyConTyVars TyCon
tc1) (TyCon -> [Id]
tyConTyVars TyCon
tc2)
= ASSERT(tc1 == tc2)
[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
empty
| Bool -> Bool
not Bool
is_boot
, TyCon -> Bool
isAbstractTyCon TyCon
tc1
, Just ([Id]
tvs, Type
ty) <- TyCon -> Maybe ([Id], Type)
synTyConDefn_maybe TyCon
tc2
, Just (TyCon
tc2', [Type]
args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
= [Id] -> Type -> TyCon -> [Type] -> Maybe SDoc
checkSynAbsData [Id]
tvs Type
ty TyCon
tc2' [Type]
args
| Bool -> Bool
not Bool
is_boot
, TyCon -> Bool
isAbstractTyCon TyCon
tc1
, Just ([Id]
_,Type
ty2) <- TyCon -> Maybe ([Id], 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
= ASSERT(tc1 == tc2)
let eqFamFlav :: FamTyConFlav -> FamTyConFlav -> Bool
eqFamFlav FamTyConFlav
OpenSynFamilyTyCon FamTyConFlav
OpenSynFamilyTyCon = Bool
True
eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = Bool
True
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
[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
whenPprDebug (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Family flavours" SDoc -> SDoc -> SDoc
<+> FamTyConFlav -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamTyConFlav
fam_flav1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> FamTyConFlav -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamTyConFlav
fam_flav2 SDoc -> SDoc -> SDoc
<+>
String -> SDoc
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
text String
"Injectivities do not match")
| TyCon -> Bool
isAlgTyCon TyCon
tc1 Bool -> Bool -> Bool
&& TyCon -> Bool
isAlgTyCon TyCon
tc2
, Just RnEnv2
env <- RnEnv2 -> [Id] -> [Id] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 (TyCon -> [Id]
tyConTyVars TyCon
tc1) (TyCon -> [Id]
tyConTyVars TyCon
tc2)
= ASSERT(tc1 == tc2)
[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. (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListBy (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env)
(TyCon -> [Type]
tyConStupidTheta TyCon
tc1) (TyCon -> [Type]
tyConStupidTheta TyCon
tc2))
(String -> SDoc
text String
"The datatype contexts do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
TyCon -> AlgTyConRhs -> AlgTyConRhs -> Maybe SDoc
forall p. p -> AlgTyConRhs -> AlgTyConRhs -> Maybe SDoc
eqAlgRhs TyCon
tc1 (TyCon -> AlgTyConRhs
algTyConRhs TyCon
tc1) (TyCon -> AlgTyConRhs
algTyConRhs TyCon
tc2)
| Bool
otherwise = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
empty
where
roles1 :: [Role]
roles1 = TyCon -> [Role]
tyConRoles TyCon
tc1
roles2 :: [Role]
roles2 = TyCon -> [Role]
tyConRoles TyCon
tc2
roles_msg :: SDoc
roles_msg = String -> SDoc
text String
"The roles do not match." SDoc -> SDoc -> SDoc
$$
(String -> SDoc
text String
"Roles on abstract types default to" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (String -> SDoc
text String
"representational") SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in boot files.")
roles_subtype_msg :: SDoc
roles_subtype_msg = String -> SDoc
text String
"The roles are not compatible:" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Main module:" SDoc -> SDoc -> SDoc
<+> [Role] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Role]
roles2 SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Hsig file:" SDoc -> SDoc -> SDoc
<+> [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
= 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
rolesSubtypeOf :: [a] -> [a] -> Bool
rolesSubtypeOf [] [] = Bool
True
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
checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc
checkSynAbsData :: [Id] -> Type -> TyCon -> [Type] -> Maybe SDoc
checkSynAbsData [Id]
tvs Type
ty TyCon
tc2' [Type]
args =
Bool -> SDoc -> Maybe SDoc
check ([(TyCon, [Type])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [(TyCon, [Type])]
tcTyFamInsts Type
ty))
(String -> SDoc
text String
"Illegal type family application in implementation of abstract data.")
Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
tvs)
(String -> SDoc
text String
"Illegal parameterized type synonym in implementation of abstract data." SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"(Try eta reducing your type synonym so that it is nullary.)")
Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> Maybe SDoc -> Maybe SDoc
checkUnless (Bool -> Bool
not ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
tvs)) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
ASSERT( null roles2 )
[Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 (Int -> [Role] -> [Role]
forall a. Int -> [a] -> [a]
drop ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args) (TyCon -> [Role]
tyConRoles TyCon
tc2'))
eqAlgRhs :: p -> AlgTyConRhs -> AlgTyConRhs -> Maybe SDoc
eqAlgRhs p
_ AlgTyConRhs
AbstractTyCon AlgTyConRhs
_rhs2
= Maybe SDoc
checkSuccess
eqAlgRhs p
_ tc1 :: AlgTyConRhs
tc1@DataTyCon{} tc2 :: AlgTyConRhs
tc2@DataTyCon{} =
(DataCon -> DataCon -> Maybe SDoc)
-> [DataCon] -> [DataCon] -> SDoc -> Maybe SDoc
forall a.
(a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc -> Maybe SDoc
checkListBy DataCon -> DataCon -> Maybe SDoc
eqCon (AlgTyConRhs -> [DataCon]
data_cons AlgTyConRhs
tc1) (AlgTyConRhs -> [DataCon]
data_cons AlgTyConRhs
tc2) (String -> SDoc
text String
"constructors")
eqAlgRhs p
_ tc1 :: AlgTyConRhs
tc1@NewTyCon{} tc2 :: AlgTyConRhs
tc2@NewTyCon{} =
DataCon -> DataCon -> Maybe SDoc
eqCon (AlgTyConRhs -> DataCon
data_con AlgTyConRhs
tc1) (AlgTyConRhs -> DataCon
data_con AlgTyConRhs
tc2)
eqAlgRhs p
_ AlgTyConRhs
_ AlgTyConRhs
_ = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
"Cannot match a" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"data") SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"definition with a" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"newtype") SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"definition")
eqCon :: DataCon -> DataCon -> Maybe SDoc
eqCon DataCon
c1 DataCon
c2
= Bool -> SDoc -> Maybe SDoc
check (Name
name1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name2)
(String -> SDoc
text String
"The names" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> SDoc
pname2 SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
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
text String
"The fixities of" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check ((HsImplBang -> HsImplBang -> Bool)
-> [HsImplBang] -> [HsImplBang] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListBy HsImplBang -> HsImplBang -> Bool
eqHsBang (DataCon -> [HsImplBang]
dataConImplBangs DataCon
c1) (DataCon -> [HsImplBang]
dataConImplBangs DataCon
c2))
(String -> SDoc
text String
"The strictness annotations for" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check ((FieldLbl Name -> Name) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector (DataCon -> [FieldLbl Name]
dataConFieldLabels DataCon
c1) [Name] -> [Name] -> Bool
forall a. Eq a => a -> a -> Bool
== (FieldLbl Name -> Name) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector (DataCon -> [FieldLbl Name]
dataConFieldLabels DataCon
c2))
(String -> SDoc
text String
"The record label lists for" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check (Type -> Type -> Bool
eqType (DataCon -> Type
dataConUserType DataCon
c1) (DataCon -> Type
dataConUserType DataCon
c2))
(String -> SDoc
text String
"The types for" SDoc -> SDoc -> SDoc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"differ")
where
name1 :: Name
name1 = DataCon -> Name
dataConName DataCon
c1
name2 :: Name
name2 = DataCon -> Name
dataConName DataCon
c2
pname1 :: SDoc
pname1 = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
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 -> Int
forall (br :: BranchFlag). Branches br -> Int
numBranches Branches br
branches1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Branches br -> Int
forall (br :: BranchFlag). Branches br -> Int
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 -> [Id]
cab_tvs = [Id]
tvs1, cab_cvs :: CoAxBranch -> [Id]
cab_cvs = [Id]
cvs1
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs1, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs1 })
(CoAxBranch { cab_tvs :: CoAxBranch -> [Id]
cab_tvs = [Id]
tvs2, cab_cvs :: CoAxBranch -> [Id]
cab_cvs = [Id]
cvs2
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs2, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs2 })
| Just RnEnv2
env1 <- RnEnv2 -> [Id] -> [Id] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 [Id]
tvs1 [Id]
tvs2
, Just RnEnv2
env <- RnEnv2 -> [Id] -> [Id] -> Maybe RnEnv2
eqVarBndrs RnEnv2
env1 [Id]
cvs1 [Id]
cvs2
= (Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListBy (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 -> SDoc
missingBootThing :: Bool -> Name -> String -> SDoc
missingBootThing Bool
is_boot Name
name String
what
= SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is exported by the"
SDoc -> SDoc -> SDoc
<+> (if Bool
is_boot then String -> SDoc
text String
"hs-boot" else String -> SDoc
text String
"hsig")
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"file, but not"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"the module"
badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc
badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc
badReexportedBootThing DynFlags
dflags Bool
is_boot Name
name Name
name'
= PprStyle -> SDoc -> SDoc
withPprStyle (DynFlags -> PrintUnqualified -> Depth -> PprStyle
mkUserStyle DynFlags
dflags PrintUnqualified
alwaysQualify Depth
AllTheWay) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> (if Bool
is_boot then String -> SDoc
text String
"hs-boot" else String -> SDoc
text String
"hsig")
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"file (re)exports" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
, String -> SDoc
text String
"but the implementing module exports a different identifier" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name')
]
bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc
bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc
bootMisMatch Bool
is_boot SDoc
extra_info TyThing
real_thing TyThing
boot_thing
= 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 :: ShowForAllFlag
ss_forall =
if Bool
is_boot
then ShowForAllFlag
ShowForAllMust
else ShowForAllFlag
ShowForAllWhen }
real_doc :: SDoc
real_doc = TyThing -> SDoc
to_doc TyThing
real_thing
boot_doc :: SDoc
boot_doc = TyThing -> SDoc
to_doc TyThing
boot_thing
pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
pprBootMisMatch Bool
is_boot SDoc
extra_info TyThing
real_thing SDoc
real_doc SDoc
boot_doc
= [SDoc] -> SDoc
vcat
[ TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
real_thing SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"has conflicting definitions in the module",
String -> SDoc
text String
"and its" SDoc -> SDoc -> SDoc
<+>
(if Bool
is_boot
then String -> SDoc
text String
"hs-boot file"
else String -> SDoc
text String
"hsig file"),
String -> SDoc
text String
"Main module:" SDoc -> SDoc -> SDoc
<+> SDoc
real_doc,
(if Bool
is_boot
then String -> SDoc
text String
"Boot file: "
else String -> SDoc
text String
"Hsig file: ")
SDoc -> SDoc -> SDoc
<+> SDoc
boot_doc,
SDoc
extra_info
]
instMisMatch :: DFunId -> SDoc
instMisMatch :: Id -> SDoc
instMisMatch Id
dfun
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"instance" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
dfun))
Int
2 (String -> SDoc
text String
"is defined in the hs-boot file, but not in the module itself")
rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
rnTopSrcDecls HsGroup GhcPs
group
= do {
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn12" SDoc
empty ;
(TcGblEnv
tcg_env, HsGroup GhcRn
rn_decls) <- TcM (TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn)
forall r. TcM r -> TcM r
checkNoErrs (TcM (TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn))
-> TcM (TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn)
forall a b. (a -> b) -> a -> b
$ HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
rnSrcDecls HsGroup GhcPs
group ;
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn13" SDoc
empty ;
(TcGblEnv
tcg_env, HsGroup GhcRn
rn_decls) <- TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
runRenamerPlugin TcGblEnv
tcg_env HsGroup GhcRn
rn_decls ;
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"rn13-plugin" SDoc
empty ;
let { tcg_env' :: TcGblEnv
tcg_env'
| Just HsGroup GhcRn
grp <- TcGblEnv -> Maybe (HsGroup GhcRn)
tcg_rn_decls TcGblEnv
tcg_env
= TcGblEnv
tcg_env{ tcg_rn_decls :: Maybe (HsGroup GhcRn)
tcg_rn_decls = HsGroup GhcRn -> Maybe (HsGroup GhcRn)
forall a. a -> Maybe a
Just (HsGroup GhcRn -> HsGroup GhcRn -> HsGroup GhcRn
forall (p :: Pass).
HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p)
appendGroups HsGroup GhcRn
grp HsGroup GhcRn
rn_decls) }
| Bool
otherwise
= TcGblEnv
tcg_env };
HsGroup GhcRn -> TcRnIf TcGblEnv TcLclEnv ()
forall a.
(Outputable a, Data a) =>
a -> TcRnIf TcGblEnv TcLclEnv ()
rnDump HsGroup GhcRn
rn_decls ;
(TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env', HsGroup GhcRn
rn_decls)
}
tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls :: HsGroup GhcRn -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopSrcDecls (HsGroup { hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup GhcRn]
tycl_decls,
hs_derivds :: forall p. HsGroup p -> [LDerivDecl p]
hs_derivds = [LDerivDecl GhcRn]
deriv_decls,
hs_fords :: forall p. HsGroup p -> [LForeignDecl p]
hs_fords = [LForeignDecl GhcRn]
foreign_decls,
hs_defds :: forall p. HsGroup p -> [LDefaultDecl p]
hs_defds = [LDefaultDecl GhcRn]
default_decls,
hs_annds :: forall p. HsGroup p -> [LAnnDecl p]
hs_annds = [LAnnDecl GhcRn]
annotation_decls,
hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds = [LRuleDecls GhcRn]
rule_decls,
hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds = hs_val_binds :: HsValBindsLR GhcRn GhcRn
hs_val_binds@(XValBindsLR
(NValBinds val_binds val_sigs)) })
= do {
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc2 (src)" SDoc
empty ;
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc3" SDoc
empty ;
(TcGblEnv
tcg_env, [InstInfo GhcRn]
inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))
<- [TyClGroup GhcRn]
-> [LDerivDecl GhcRn]
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
tcTyClsInstDecls [TyClGroup GhcRn]
tycl_decls [LDerivDecl GhcRn]
deriv_decls [(RecFlag, LHsBinds GhcRn)]
val_binds ;
TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc3b" SDoc
empty ;
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc3c" SDoc
empty ;
TcRnIf TcGblEnv TcLclEnv ()
tcSemigroupWarnings ;
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc4" SDoc
empty ;
([Id]
fi_ids, [LForeignDecl GhcTc]
fi_decls, Bag GlobalRdrElt
fi_gres) <- [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports [LForeignDecl GhcRn]
foreign_decls ;
[Id]
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id]
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 {
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc4a" SDoc
empty ;
Maybe [Type]
default_tys <- [LDefaultDecl GhcRn] -> TcM (Maybe [Type])
tcDefaults [LDefaultDecl GhcRn]
default_decls ;
(TcGblEnv -> TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
gbl -> TcGblEnv
gbl { tcg_default :: Maybe [Type]
tcg_default = Maybe [Type]
default_tys }) (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc5" SDoc
empty ;
(TcGblEnv, TcLclEnv)
tc_envs <- [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn] -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopBinds [(RecFlag, LHsBinds GhcRn)]
val_binds [LSig GhcRn]
val_sigs;
(TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
tc_envs (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {
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 GhcRn)]
-> [LSig GhcRn] -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopBinds [(RecFlag, LHsBinds GhcRn)]
deriv_binds [LSig GhcRn]
deriv_sigs) ;
(TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
tc_envs (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc6" SDoc
empty ;
LHsBinds GhcTc
inst_binds <- [LTyClDecl GhcRn] -> [InstInfo GhcRn] -> TcM (LHsBinds GhcTc)
tcInstDecls2 ([TyClGroup GhcRn] -> [LTyClDecl GhcRn]
forall pass. [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls [TyClGroup GhcRn]
tycl_decls) [InstInfo GhcRn]
inst_infos ;
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc7" SDoc
empty ;
(LHsBinds GhcTc
foe_binds, [LForeignDecl GhcTc]
foe_decls, Bag GlobalRdrElt
foe_gres) <- [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports [LForeignDecl GhcRn]
foreign_decls ;
[Annotation]
annotations <- [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations [LAnnDecl GhcRn]
annotation_decls ;
[LRuleDecls GhcTc]
rules <- [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc]
tcRules [LRuleDecls GhcRn]
rule_decls ;
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"Tc7a" SDoc
empty ;
let { all_binds :: LHsBinds GhcTc
all_binds = LHsBinds GhcTc
inst_binds LHsBinds GhcTc -> LHsBinds GhcTc -> LHsBinds GhcTc
forall a. Bag a -> Bag a -> Bag a
`unionBags`
LHsBinds GhcTc
foe_binds
; fo_gres :: Bag GlobalRdrElt
fo_gres = Bag GlobalRdrElt
fi_gres Bag GlobalRdrElt -> Bag GlobalRdrElt -> Bag GlobalRdrElt
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag GlobalRdrElt
foe_gres
; fo_fvs :: FreeVars
fo_fvs = (GlobalRdrElt -> FreeVars -> FreeVars)
-> FreeVars -> Bag GlobalRdrElt -> FreeVars
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\GlobalRdrElt
gre FreeVars
fvs -> FreeVars
fvs FreeVars -> Name -> FreeVars
`addOneFV` GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre)
FreeVars
emptyFVs Bag GlobalRdrElt
fo_gres
; sig_names :: FreeVars
sig_names = [Name] -> FreeVars
mkNameSet (HsValBindsLR GhcRn GhcRn -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass).
HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectHsValBinders HsValBindsLR GhcRn GhcRn
hs_val_binds)
FreeVars -> FreeVars -> FreeVars
`minusNameSet` [LSig GhcRn] -> FreeVars
getTypeSigNames [LSig GhcRn]
val_sigs
; tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env { tcg_binds :: LHsBinds GhcTc
tcg_binds = TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
tcg_env LHsBinds GhcTc -> LHsBinds GhcTc -> LHsBinds GhcTc
forall a. Bag a -> Bag a -> Bag a
`unionBags` LHsBinds GhcTc
all_binds
, tcg_sigs :: FreeVars
tcg_sigs = TcGblEnv -> FreeVars
tcg_sigs TcGblEnv
tcg_env FreeVars -> FreeVars -> FreeVars
`unionNameSet` FreeVars
sig_names
, tcg_rules :: [LRuleDecl GhcTc]
tcg_rules = TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env
[LRuleDecl GhcTc] -> [LRuleDecl GhcTc] -> [LRuleDecl GhcTc]
forall a. [a] -> [a] -> [a]
++ [LRuleDecls GhcTc] -> [LRuleDecl GhcTc]
forall pass. [LRuleDecls pass] -> [LRuleDecl pass]
flattenRuleDecls [LRuleDecls GhcTc]
rules
, tcg_anns :: [Annotation]
tcg_anns = TcGblEnv -> [Annotation]
tcg_anns TcGblEnv
tcg_env [Annotation] -> [Annotation] -> [Annotation]
forall a. [a] -> [a] -> [a]
++ [Annotation]
annotations
, tcg_ann_env :: AnnEnv
tcg_ann_env = AnnEnv -> [Annotation] -> AnnEnv
extendAnnEnvList (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
tcg_env) [Annotation]
annotations
, tcg_fords :: [LForeignDecl GhcTc]
tcg_fords = TcGblEnv -> [LForeignDecl GhcTc]
tcg_fords TcGblEnv
tcg_env [LForeignDecl GhcTc]
-> [LForeignDecl GhcTc] -> [LForeignDecl GhcTc]
forall a. [a] -> [a] -> [a]
++ [LForeignDecl GhcTc]
foe_decls [LForeignDecl GhcTc]
-> [LForeignDecl GhcTc] -> [LForeignDecl GhcTc]
forall a. [a] -> [a] -> [a]
++ [LForeignDecl GhcTc]
fi_decls
, tcg_dus :: DefUses
tcg_dus = TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env DefUses -> DefUses -> DefUses
`plusDU` FreeVars -> DefUses
usesOnly FreeVars
fo_fvs } } ;
[GlobalRdrElt] -> TcRnIf TcGblEnv TcLclEnv ()
addUsedGREs (Bag GlobalRdrElt -> [GlobalRdrElt]
forall a. Bag a -> [a]
bagToList Bag GlobalRdrElt
fo_gres) ;
(TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env', TcLclEnv
tcl_env)
}}}}}}
tcTopSrcDecls HsGroup GhcRn
_ = String -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. String -> a
panic String
"tcTopSrcDecls: ValBindsIn"
tcSemigroupWarnings :: TcM ()
tcSemigroupWarnings :: TcRnIf TcGblEnv TcLclEnv ()
tcSemigroupWarnings = do
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcSemigroupWarnings" SDoc
empty
let warnFlag :: WarningFlag
warnFlag = WarningFlag
Opt_WarnSemigroup
WarningFlag -> Name -> TcRnIf TcGblEnv TcLclEnv ()
tcPreludeClashWarn WarningFlag
warnFlag Name
sappendName
WarningFlag -> Name -> Name -> TcRnIf TcGblEnv TcLclEnv ()
tcMissingParentClassWarn WarningFlag
warnFlag Name
monoidClassName Name
semigroupClassName
tcPreludeClashWarn :: WarningFlag
-> Name
-> TcM ()
tcPreludeClashWarn :: WarningFlag -> Name -> TcRnIf 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 -> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ do
{ String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcPreludeClashWarn/wouldBeImported" SDoc
empty
; [ImportDecl GhcRn]
rnImports <- (TcGblEnv -> [ImportDecl GhcRn])
-> TcM TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) [ImportDecl GhcRn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LImportDecl GhcRn -> ImportDecl GhcRn)
-> [LImportDecl GhcRn] -> [ImportDecl GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map LImportDecl GhcRn -> ImportDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc ([LImportDecl GhcRn] -> [ImportDecl GhcRn])
-> (TcGblEnv -> [LImportDecl GhcRn])
-> TcGblEnv
-> [ImportDecl GhcRn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> [LImportDecl GhcRn]
tcg_rn_imports) TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; Bool -> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> [ImportDecl GhcRn] -> Bool
importedViaPrelude Name
name [ImportDecl GhcRn]
rnImports) (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ do
{ [GlobalRdrElt]
rdrElts <- (TcGblEnv -> [GlobalRdrElt])
-> TcM TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrElt]
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]
occEnvElts (GlobalRdrEnv -> [[GlobalRdrElt]])
-> (TcGblEnv -> GlobalRdrEnv) -> TcGblEnv -> [[GlobalRdrElt]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> GlobalRdrEnv
tcg_rdr_env) TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let clashes :: GlobalRdrElt -> Bool
clashes :: GlobalRdrElt -> 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
nameClashes :: Bool
nameClashes = Name -> OccName
nameOccName (GlobalRdrElt -> Name
gre_name GlobalRdrElt
x) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> OccName
nameOccName Name
name
isNotInProperModule :: Bool
isNotInProperModule = GlobalRdrElt -> Name
gre_name GlobalRdrElt
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
name
clashingElts :: [GlobalRdrElt]
clashingElts :: [GlobalRdrElt]
clashingElts = (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
clashes [GlobalRdrElt]
rdrElts
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcPreludeClashWarn/prelude_functions"
(SDoc -> Int -> SDoc -> SDoc
hang (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) Int
4 ([SDoc] -> SDoc
sep [[GlobalRdrElt] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GlobalRdrElt]
clashingElts]))
; let warn_msg :: GlobalRdrElt -> TcRnIf TcGblEnv TcLclEnv ()
warn_msg GlobalRdrElt
x = WarnReason -> SrcSpan -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
warnFlag) (Name -> SrcSpan
nameSrcSpan (GlobalRdrElt -> Name
gre_name GlobalRdrElt
x)) ([SDoc] -> SDoc
hsep
[ String -> SDoc
text String
"Local definition of"
, (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (GlobalRdrElt -> SDoc) -> GlobalRdrElt -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc)
-> (GlobalRdrElt -> OccName) -> GlobalRdrElt -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName)
-> (GlobalRdrElt -> Name) -> GlobalRdrElt -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrElt -> Name
gre_name) GlobalRdrElt
x
, String -> SDoc
text String
"clashes with a future Prelude name." ]
SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"This will become an error in a future release." )
; (GlobalRdrElt -> TcRnIf TcGblEnv TcLclEnv ())
-> [GlobalRdrElt] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GlobalRdrElt -> TcRnIf TcGblEnv TcLclEnv ()
warn_msg [GlobalRdrElt]
clashingElts
}}}
where
importedViaPrelude :: Name
-> [ImportDecl GhcRn]
-> Bool
importedViaPrelude :: Name -> [ImportDecl GhcRn] -> Bool
importedViaPrelude Name
name = (ImportDecl GhcRn -> Bool) -> [ImportDecl GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ImportDecl GhcRn -> Bool
importViaPrelude
where
isPrelude :: ImportDecl GhcRn -> Bool
isPrelude :: ImportDecl GhcRn -> Bool
isPrelude ImportDecl GhcRn
imp = Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl GhcRn -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcRn
imp) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME
isImplicit :: ImportDecl GhcRn -> Bool
isImplicit :: ImportDecl GhcRn -> Bool
isImplicit = ImportDecl GhcRn -> Bool
forall pass. ImportDecl pass -> Bool
ideclImplicit
isUnqualified :: ImportDecl GhcRn -> Bool
isUnqualified :: ImportDecl GhcRn -> Bool
isUnqualified = Bool -> Bool
not (Bool -> Bool)
-> (ImportDecl GhcRn -> Bool) -> ImportDecl GhcRn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDeclQualifiedStyle -> Bool
isImportDeclQualified (ImportDeclQualifiedStyle -> Bool)
-> (ImportDecl GhcRn -> ImportDeclQualifiedStyle)
-> ImportDecl GhcRn
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcRn -> ImportDeclQualifiedStyle
forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified
importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name])
importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name])
importListOf = ((Bool, Located [LIE GhcRn]) -> (Bool, [Name]))
-> Maybe (Bool, Located [LIE GhcRn]) -> Maybe (Bool, [Name])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, Located [LIE GhcRn]) -> (Bool, [Name])
forall a a (p :: Pass) a.
(HasSrcSpan a, HasSrcSpan a, SrcSpanLess a ~ IE (GhcPass p),
SrcSpanLess a ~ [a]) =>
(a, a) -> (a, [IdP (GhcPass p)])
toImportList (Maybe (Bool, Located [LIE GhcRn]) -> Maybe (Bool, [Name]))
-> (ImportDecl GhcRn -> Maybe (Bool, Located [LIE GhcRn]))
-> ImportDecl GhcRn
-> Maybe (Bool, [Name])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcRn -> Maybe (Bool, Located [LIE GhcRn])
forall pass. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
ideclHiding
where
toImportList :: (a, a) -> (a, [IdP (GhcPass p)])
toImportList (a
h, a
loc) = (a
h, (a -> IdP (GhcPass p)) -> [a] -> [IdP (GhcPass p)]
forall a b. (a -> b) -> [a] -> [b]
map (IE (GhcPass p) -> IdP (GhcPass p)
forall (p :: Pass). IE (GhcPass p) -> IdP (GhcPass p)
ieName (IE (GhcPass p) -> IdP (GhcPass p))
-> (a -> IE (GhcPass p)) -> a -> IdP (GhcPass p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IE (GhcPass p)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) (a -> SrcSpanLess a
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc a
loc))
isExplicit :: ImportDecl GhcRn -> Bool
isExplicit :: ImportDecl GhcRn -> Bool
isExplicit ImportDecl GhcRn
x = case ImportDecl GhcRn -> Maybe (Bool, [Name])
importListOf ImportDecl GhcRn
x of
Maybe (Bool, [Name])
Nothing -> Bool
False
Just (Bool
False, [Name]
explicit)
-> Name -> OccName
nameOccName Name
name OccName -> [OccName] -> 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 (Bool
True, [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
importViaPrelude :: ImportDecl GhcRn -> Bool
importViaPrelude :: ImportDecl GhcRn -> Bool
importViaPrelude ImportDecl GhcRn
x = ImportDecl GhcRn -> Bool
isPrelude ImportDecl GhcRn
x
Bool -> Bool -> Bool
&& ImportDecl GhcRn -> Bool
isUnqualified ImportDecl GhcRn
x
Bool -> Bool -> Bool
&& (ImportDecl GhcRn -> Bool
isImplicit ImportDecl GhcRn
x Bool -> Bool -> Bool
|| ImportDecl GhcRn -> Bool
isExplicit ImportDecl GhcRn
x)
tcMissingParentClassWarn :: WarningFlag
-> Name
-> Name
-> TcM ()
tcMissingParentClassWarn :: WarningFlag -> Name -> Name -> TcRnIf 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 -> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$ do
{ String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcMissingParentClassWarn" SDoc
empty
; Maybe Class
isClass' <- Name -> TcM (Maybe Class)
tcLookupClass_maybe Name
isName
; Maybe Class
shouldClass' <- Name -> TcM (Maybe Class)
tcLookupClass_maybe Name
shouldName
; case (Maybe Class
isClass', Maybe Class
shouldClass') of
(Just Class
isClass, Just Class
shouldClass) -> do
{ [ClsInst]
localInstances <- TcM [ClsInst]
tcGetInsts
; let isInstance :: ClsInst -> 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 -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcMissingParentClassWarn/isInsts" ([ClsInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ClsInst]
isInsts)
; [ClsInst]
-> (ClsInst -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ClsInst]
isInsts (Class -> Class -> ClsInst -> TcRnIf TcGblEnv TcLclEnv ()
checkShouldInst Class
isClass Class
shouldClass)
}
(Maybe Class
is',Maybe Class
should') ->
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcMissingParentClassWarn/notIsShould"
(SDoc -> Int -> SDoc -> SDoc
hang (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
isName SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"/" SDoc -> SDoc -> SDoc
<> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
shouldName) Int
2 (
([SDoc] -> SDoc
hsep [ SDoc -> SDoc
quotes (String -> SDoc
text String
"Is"), String -> SDoc
text String
"lookup for"
, Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
isName
, String -> SDoc
text String
"resulted in", Maybe Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Class
is' ])
SDoc -> SDoc -> SDoc
$$
([SDoc] -> SDoc
hsep [ SDoc -> SDoc
quotes (String -> SDoc
text String
"Should"), String -> SDoc
text String
"lookup for"
, Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
shouldName
, String -> SDoc
text String
"resulted in", Maybe Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Class
should' ])))
}}
where
checkShouldInst :: Class
-> Class
-> ClsInst
-> TcM ()
checkShouldInst :: Class -> Class -> ClsInst -> TcRnIf TcGblEnv TcLclEnv ()
checkShouldInst Class
isClass Class
shouldClass ClsInst
isInst
= do { InstEnvs
instEnv <- TcM InstEnvs
tcGetInstEnvs
; let ([InstMatch]
instanceMatches, [ClsInst]
shouldInsts, [InstMatch]
_)
= Bool
-> InstEnvs
-> Class
-> [Type]
-> ([InstMatch], [ClsInst], [InstMatch])
lookupInstEnv Bool
False InstEnvs
instEnv Class
shouldClass (ClsInst -> [Type]
is_tys ClsInst
isInst)
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcMissingParentClassWarn/checkShouldInst"
(SDoc -> Int -> SDoc -> SDoc
hang (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
isInst) Int
4
([SDoc] -> SDoc
sep [[InstMatch] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstMatch]
instanceMatches, [ClsInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ClsInst]
shouldInsts]))
; 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 :: [Maybe Name] -> TcRnIf TcGblEnv TcLclEnv ()
warnMsg (Just Name
name:[Maybe Name]
_) =
WarnReason -> SrcSpan -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
warnFlag) SrcSpan
instLoc (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
hsep [ (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (Name -> SDoc) -> Name -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc) -> (Name -> OccName) -> Name -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) Name
name
, String -> SDoc
text String
"is an instance of"
, (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc) -> (Class -> OccName) -> Class -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (Class -> Name) -> Class -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Name
className) Class
isClass
, String -> SDoc
text String
"but not"
, (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc) -> (Class -> OccName) -> Class -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (Class -> Name) -> Class -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Name
className) Class
shouldClass ]
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"."
SDoc -> SDoc -> SDoc
$$
[SDoc] -> SDoc
hsep [ String -> SDoc
text String
"This will become an error in"
, String -> SDoc
text String
"a future release." ]
warnMsg [Maybe Name]
_ = () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
; Bool -> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
shouldInsts Bool -> Bool -> Bool
&& [InstMatch] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstMatch]
instanceMatches) (TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ())
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
[Maybe Name] -> TcRnIf TcGblEnv TcLclEnv ()
warnMsg (ClsInst -> [Maybe Name]
is_tcs ClsInst
isInst)
}
tcLookupClass_maybe :: Name -> TcM (Maybe Class)
tcLookupClass_maybe :: Name -> TcM (Maybe Class)
tcLookupClass_maybe Name
name = Name -> TcM (MaybeErr SDoc TyThing)
tcLookupImported_maybe Name
name TcM (MaybeErr SDoc TyThing)
-> (MaybeErr SDoc TyThing -> TcM (Maybe Class))
-> TcM (Maybe Class)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Succeeded (ATyCon TyCon
tc) | cls :: Maybe Class
cls@(Just Class
_) <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc -> Maybe Class -> TcM (Maybe Class)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Class
cls
MaybeErr SDoc TyThing
_else -> Maybe Class -> TcM (Maybe Class)
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,
[InstInfo GhcRn],
HsValBinds GhcRn)
tcTyClsInstDecls :: [TyClGroup GhcRn]
-> [LDerivDecl GhcRn]
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
tcTyClsInstDecls [TyClGroup GhcRn]
tycl_decls [LDerivDecl GhcRn]
deriv_decls [(RecFlag, LHsBinds GhcRn)]
binds
= [LInstDecl GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
forall a. [LInstDecl GhcRn] -> TcM a -> TcM a
tcAddDataFamConPlaceholders ([TyClGroup GhcRn]
tycl_decls [TyClGroup GhcRn]
-> (TyClGroup GhcRn -> [LInstDecl GhcRn]) -> [LInstDecl GhcRn]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TyClGroup GhcRn -> [LInstDecl GhcRn]
forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds) (TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn))
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
forall a b. (a -> b) -> a -> b
$
[PatSynBind GhcRn GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
forall a. [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
tcAddPatSynPlaceholders ([(RecFlag, LHsBinds GhcRn)] -> [PatSynBind GhcRn GhcRn]
forall id. [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds [(RecFlag, LHsBinds GhcRn)]
binds) (TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn))
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
forall a b. (a -> b) -> a -> b
$
do { (TcGblEnv
tcg_env, [InstInfo GhcRn]
inst_info, [DerivInfo]
deriv_info)
<- [TyClGroup GhcRn] -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
tcTyAndClassDecls [TyClGroup GhcRn]
tycl_decls ;
; TcGblEnv
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn))
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
forall a b. (a -> b) -> a -> b
$ do {
; TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM
; (TcGblEnv
tcg_env', [InstInfo GhcRn]
inst_info', HsValBindsLR GhcRn GhcRn
val_binds)
<- [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
tcInstDeclsDeriv [DerivInfo]
deriv_info [LDerivDecl GhcRn]
deriv_decls
; TcGblEnv
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env' (TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn))
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
forall a b. (a -> b) -> a -> b
$ do {
TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM
; (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBindsLR GhcRn GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcGblEnv
tcg_env', [InstInfo GhcRn]
inst_info' [InstInfo GhcRn] -> [InstInfo GhcRn] -> [InstInfo GhcRn]
forall a. [a] -> [a] -> [a]
++ [InstInfo GhcRn]
inst_info, HsValBindsLR GhcRn GhcRn
val_binds)
}}}
checkMain :: Bool
-> TcM TcGblEnv
checkMain :: Bool -> TcM TcGblEnv
checkMain Bool
explicit_mod_hdr
= do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; TcGblEnv
tcg_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv
check_main DynFlags
dflags TcGblEnv
tcg_env Bool
explicit_mod_hdr }
check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv
check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv
check_main DynFlags
dflags TcGblEnv
tcg_env Bool
explicit_mod_hdr
| Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
main_mod
= String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"checkMain not" (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
main_mod SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod) TcRnIf TcGblEnv TcLclEnv () -> TcM TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
| Bool
otherwise
= do { Maybe Name
mb_main <- RdrName -> RnM (Maybe Name)
lookupGlobalOccRn_maybe RdrName
main_fn
; case Maybe Name
mb_main of {
Maybe Name
Nothing -> do { String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"checkMain fail" (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
main_mod SDoc -> SDoc -> SDoc
<+> RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
main_fn)
; TcRnIf TcGblEnv TcLclEnv ()
complain_no_main
; TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env } ;
Just Name
main_name -> do
{ String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"checkMain found" (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
main_mod SDoc -> SDoc -> SDoc
<+> RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
main_fn)
; let loc :: SrcSpan
loc = SrcLoc -> SrcSpan
srcLocSpan (Name -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
main_name)
; TyCon
ioTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
ioTyConName
; Type
res_ty <- Type -> TcM Type
newFlexiTyVarTy Type
liftedTypeKind
; let io_ty :: Type
io_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
ioTyCon [Type
res_ty]
skol_info :: SkolemInfo
skol_info = UserTypeCtxt -> Type -> [(Name, Id)] -> SkolemInfo
SigSkol (Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
main_name Bool
False) Type
io_ty []
; (TcEvBinds
ev_binds, LHsExpr GhcTc
main_expr)
<- SkolemInfo
-> [Id]
-> [Id]
-> TcM (LHsExpr GhcTc)
-> TcM (TcEvBinds, LHsExpr GhcTc)
forall result.
SkolemInfo -> [Id] -> [Id] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints SkolemInfo
skol_info [] [] (TcM (LHsExpr GhcTc) -> TcM (TcEvBinds, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (TcEvBinds, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
mainCtxt (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr (SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc Name
SrcSpanLess (Located Name)
main_name)))
(Type -> ExpRhoType
mkCheckExpType Type
io_ty)
; Id
run_main_id <- Name -> TcM Id
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 :: Id
root_main_id = Name -> Type -> Id
Id.mkExportedVanillaId Name
root_main_name
(TyCon -> [Type] -> Type
mkTyConApp TyCon
ioTyCon [Type
res_ty])
; co :: HsWrapper
co = [Type] -> HsWrapper
mkWpTyApps [Type
res_ty]
; rhs :: LHsExpr GhcTc
rhs = LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
co (IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
run_main_id)) (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet TcEvBinds
ev_binds LHsExpr GhcTc
main_expr
; main_bind :: LHsBind GhcTc
main_bind = IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Id
IdP GhcTc
root_main_id LHsExpr GhcTc
rhs }
; TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env { tcg_main :: Maybe Name
tcg_main = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
main_name,
tcg_binds :: LHsBinds GhcTc
tcg_binds = TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
tcg_env
LHsBinds GhcTc -> LHsBind GhcTc -> LHsBinds GhcTc
forall a. Bag a -> a -> Bag a
`snocBag` LHsBind GhcTc
main_bind,
tcg_dus :: DefUses
tcg_dus = TcGblEnv -> DefUses
tcg_dus TcGblEnv
tcg_env
DefUses -> DefUses -> DefUses
`plusDU` FreeVars -> DefUses
usesOnly (Name -> FreeVars
unitFV Name
main_name)
})
}}}
where
mod :: Module
mod = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
main_mod :: Module
main_mod = DynFlags -> Module
mainModIs DynFlags
dflags
main_fn :: RdrName
main_fn = DynFlags -> RdrName
getMainFun DynFlags
dflags
interactive :: Bool
interactive = DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkInMemory
complain_no_main :: TcRnIf TcGblEnv TcLclEnv ()
complain_no_main = Bool -> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
interactive Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
explicit_mod_hdr)
(SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErrTc SDoc
noMainMsg)
mainCtxt :: SDoc
mainCtxt = String -> SDoc
text String
"When checking the type of the" SDoc -> SDoc -> SDoc
<+> SDoc
pp_main_fn
noMainMsg :: SDoc
noMainMsg = String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> SDoc
pp_main_fn
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not defined in module" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
main_mod)
pp_main_fn :: SDoc
pp_main_fn = RdrName -> SDoc
ppMainFn RdrName
main_fn
getMainFun :: DynFlags -> RdrName
getMainFun :: DynFlags -> RdrName
getMainFun DynFlags
dflags = case DynFlags -> Maybe String
mainFunIs DynFlags
dflags of
Just String
fn -> OccName -> RdrName
mkRdrUnqual (FastString -> OccName
mkVarOccFS (String -> FastString
mkFastString String
fn))
Maybe String
Nothing -> RdrName
main_RDR_Unqual
checkMainExported :: TcGblEnv -> TcM ()
checkMainExported :: TcGblEnv -> TcRnIf TcGblEnv TcLclEnv ()
checkMainExported TcGblEnv
tcg_env
= case TcGblEnv -> Maybe Name
tcg_main TcGblEnv
tcg_env of
Maybe Name
Nothing -> () -> TcRnIf TcGblEnv TcLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Name
main_name ->
do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let main_mod :: Module
main_mod = DynFlags -> Module
mainModIs DynFlags
dflags
; Bool -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
checkTc (Name
main_name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
(AvailInfo -> [Name]) -> [AvailInfo] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNames (TcGblEnv -> [AvailInfo]
tcg_exports TcGblEnv
tcg_env)) (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> RdrName -> SDoc
ppMainFn (Name -> RdrName
nameRdrName Name
main_name) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"is not exported by module" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
main_mod) }
ppMainFn :: RdrName -> SDoc
ppMainFn :: RdrName -> SDoc
ppMainFn RdrName
main_fn
| RdrName -> OccName
rdrNameOcc RdrName
main_fn OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
mainOcc
= String -> SDoc
text String
"IO action" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
main_fn)
| Bool
otherwise
= String -> SDoc
text String
"main IO action" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
main_fn)
mainOcc :: OccName
mainOcc :: OccName
mainOcc = FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"main")
runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env TcRn a
thing_inside
= HscEnv -> TcRn a -> IO (Messages, Maybe a)
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
initTcInteractive HscEnv
hsc_env (TcRn a -> IO (Messages, Maybe a))
-> TcRn a -> IO (Messages, Maybe a)
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcRn a -> TcRn a
forall a. HscEnv -> TcM a -> TcM a
withTcPlugins HscEnv
hsc_env (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcRn a -> TcRn a
forall a. HscEnv -> TcM a -> TcM a
withHoleFitPlugins HscEnv
hsc_env (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"setInteractiveContext" (SDoc -> TcRnIf TcGblEnv TcLclEnv ())
-> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"ic_tythings:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((TyThing -> SDoc) -> [TyThing] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
icxt))
, String -> SDoc
text String
"ic_insts:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> Id -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind (Id -> SDoc) -> (ClsInst -> Id) -> ClsInst -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Id
instanceDFunId) [ClsInst]
ic_insts)
, String -> SDoc
text String
"ic_rn_gbl_env (LocalDef)" SDoc -> SDoc -> SDoc
<+>
[SDoc] -> SDoc
vcat (([GlobalRdrElt] -> SDoc) -> [[GlobalRdrElt]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map [GlobalRdrElt] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ [GlobalRdrElt]
local_gres | [GlobalRdrElt]
gres <- GlobalRdrEnv -> [[GlobalRdrElt]]
forall a. OccEnv a -> [a]
occEnvElts (InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
icxt)
, let local_gres :: [GlobalRdrElt]
local_gres = (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
isLocalGRE [GlobalRdrElt]
gres
, Bool -> Bool
not ([GlobalRdrElt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GlobalRdrElt]
local_gres) ]) ]
; let getOrphans :: ModuleName
-> Maybe FastString -> IOEnv (Env TcGblEnv TcLclEnv) [Module]
getOrphans ModuleName
m Maybe FastString
mb_pkg = (ModIface_ 'ModIfaceFinal -> [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
-> IOEnv (Env TcGblEnv TcLclEnv) [Module]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ModIface_ 'ModIfaceFinal
iface -> ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface_ 'ModIfaceFinal
iface
Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: Dependencies -> [Module]
dep_orphs (ModIface_ 'ModIfaceFinal -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface_ 'ModIfaceFinal
iface))
(SDoc
-> ModuleName
-> Bool
-> Maybe FastString
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
loadSrcInterface (String -> SDoc
text String
"runTcInteractive") ModuleName
m
Bool
False Maybe FastString
mb_pkg)
; ![Module]
orphs <- ([[Module]] -> [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) [[Module]]
-> IOEnv (Env TcGblEnv TcLclEnv) [Module]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Module] -> [Module]
forall a. NFData a => a -> a
force ([Module] -> [Module])
-> ([[Module]] -> [Module]) -> [[Module]] -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Module]] -> [Module]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (IOEnv (Env TcGblEnv TcLclEnv) [[Module]]
-> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> ((InteractiveImport -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) [[Module]])
-> (InteractiveImport -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InteractiveImport]
-> (InteractiveImport -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) [[Module]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (InteractiveContext -> [InteractiveImport]
ic_imports InteractiveContext
icxt) ((InteractiveImport -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> (InteractiveImport -> IOEnv (Env TcGblEnv TcLclEnv) [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) [Module]
forall a b. (a -> b) -> a -> b
$ \InteractiveImport
i ->
case InteractiveImport
i of
IIModule ModuleName
n -> ModuleName
-> Maybe FastString -> IOEnv (Env TcGblEnv TcLclEnv) [Module]
getOrphans ModuleName
n Maybe FastString
forall a. Maybe a
Nothing
IIDecl ImportDecl GhcPs
i ->
let mb_pkg :: Maybe FastString
mb_pkg = StringLiteral -> FastString
sl_fs (StringLiteral -> FastString)
-> Maybe StringLiteral -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImportDecl GhcPs -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl GhcPs
i in
ModuleName
-> Maybe FastString -> IOEnv (Env TcGblEnv TcLclEnv) [Module]
getOrphans (Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcPs
i)) Maybe FastString
mb_pkg
; let imports :: ImportAvails
imports = ImportAvails
emptyImportAvails {
imp_orphs :: [Module]
imp_orphs = [Module]
orphs
}
; (TcGblEnv
gbl_env, TcLclEnv
lcl_env) <- TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs
; let gbl_env' :: TcGblEnv
gbl_env' = TcGblEnv
gbl_env {
tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env = InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env InteractiveContext
icxt
, tcg_type_env :: TypeEnv
tcg_type_env = TypeEnv
type_env
, tcg_inst_env :: InstEnv
tcg_inst_env = InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList
(InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList (TcGblEnv -> InstEnv
tcg_inst_env TcGblEnv
gbl_env) [ClsInst]
ic_insts)
[ClsInst]
home_insts
, tcg_fam_inst_env :: FamInstEnv
tcg_fam_inst_env = FamInstEnv -> [FamInst] -> FamInstEnv
extendFamInstEnvList
(FamInstEnv -> [FamInst] -> FamInstEnv
extendFamInstEnvList (TcGblEnv -> FamInstEnv
tcg_fam_inst_env TcGblEnv
gbl_env)
[FamInst]
ic_finsts)
[FamInst]
home_fam_insts
, tcg_field_env :: RecFieldEnv
tcg_field_env = [(Name, [FieldLbl Name])] -> RecFieldEnv
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name, [FieldLbl Name])]
con_fields
, tcg_fix_env :: FixityEnv
tcg_fix_env = InteractiveContext -> FixityEnv
ic_fix_env InteractiveContext
icxt
, tcg_default :: Maybe [Type]
tcg_default = InteractiveContext -> Maybe [Type]
ic_default InteractiveContext
icxt
, tcg_imports :: ImportAvails
tcg_imports = ImportAvails
imports
}
lcl_env' :: TcLclEnv
lcl_env' = TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv
tcExtendLocalTypeEnv TcLclEnv
lcl_env [(Name, TcTyThing)]
lcl_ids
; (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
gbl_env', TcLclEnv
lcl_env') TcRn a
thing_inside }
where
([ClsInst]
home_insts, [FamInst]
home_fam_insts) = HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])
hptInstances HscEnv
hsc_env (\ModuleName
_ -> Bool
True)
icxt :: InteractiveContext
icxt = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
([ClsInst]
ic_insts, [FamInst]
ic_finsts) = InteractiveContext -> ([ClsInst], [FamInst])
ic_instances InteractiveContext
icxt
([(Name, TcTyThing)]
lcl_ids, [TyThing]
top_ty_things) = (TyThing -> Either (Name, TcTyThing) TyThing)
-> [TyThing] -> ([(Name, TcTyThing)], [TyThing])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith TyThing -> Either (Name, TcTyThing) TyThing
is_closed (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
icxt)
is_closed :: TyThing -> Either (Name, TcTyThing) TyThing
is_closed :: TyThing -> Either (Name, TcTyThing) TyThing
is_closed TyThing
thing
| AnId Id
id <- TyThing
thing
, Bool -> Bool
not (Id -> Bool
isTypeClosedLetBndr Id
id)
= (Name, TcTyThing) -> Either (Name, TcTyThing) TyThing
forall a b. a -> Either a b
Left (Id -> Name
idName Id
id, ATcId :: Id -> IdBindingInfo -> TcTyThing
ATcId { tct_id :: Id
tct_id = Id
id
, tct_info :: IdBindingInfo
tct_info = IdBindingInfo
NotLetBound })
| Bool
otherwise
= TyThing -> Either (Name, TcTyThing) TyThing
forall a b. b -> Either a b
Right TyThing
thing
type_env1 :: TypeEnv
type_env1 = [TyThing] -> TypeEnv
mkTypeEnvWithImplicits [TyThing]
top_ty_things
type_env :: TypeEnv
type_env = TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds TypeEnv
type_env1 ((ClsInst -> Id) -> [ClsInst] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> Id
instanceDFunId [ClsInst]
ic_insts)
con_fields :: [(Name, [FieldLbl Name])]
con_fields = [ (DataCon -> Name
dataConName DataCon
c, DataCon -> [FieldLbl Name]
dataConFieldLabels DataCon
c)
| ATyCon TyCon
t <- [TyThing]
top_ty_things
, DataCon
c <- TyCon -> [DataCon]
tyConDataCons TyCon
t ]
tcRnStmt :: HscEnv -> GhciLStmt GhcPs
-> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
tcRnStmt :: HscEnv
-> GhciLStmt GhcPs
-> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
tcRnStmt HscEnv
hsc_env GhciLStmt GhcPs
rdr_stmt
= HscEnv
-> TcRn ([Id], LHsExpr GhcTc, FixityEnv)
-> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn ([Id], LHsExpr GhcTc, FixityEnv)
-> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv)))
-> TcRn ([Id], LHsExpr GhcTc, FixityEnv)
-> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
forall a b. (a -> b) -> a -> b
$ do {
(([Id]
bound_ids, LHsExpr GhcTc
tc_expr), FixityEnv
fix_env) <- GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
tcUserStmt GhciLStmt GhcPs
rdr_stmt ;
LHsExpr GhcTc
zonked_expr <- LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkTopLExpr LHsExpr GhcTc
tc_expr ;
[Id]
zonked_ids <- [Id] -> TcM [Id]
zonkTopBndrs [Id]
bound_ids ;
TcRnIf TcGblEnv TcLclEnv ()
failIfErrsM ;
(Id -> TcRnIf TcGblEnv TcLclEnv ())
-> [Id] -> TcRnIf TcGblEnv TcLclEnv ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Id -> TcRnIf TcGblEnv TcLclEnv ()
bad_unboxed ((Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [Id]
zonked_ids) ;
String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceTc String
"tcs 1" SDoc
empty ;
Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule ;
[Id]
global_ids <- (Id -> TcM Id) -> [Id] -> TcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Module -> Id -> TcM Id
externaliseAndTidyId Module
this_mod) [Id]
zonked_ids ;
DumpFlag -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceOptTcRn DumpFlag
Opt_D_dump_tc
([SDoc] -> SDoc
vcat [String -> SDoc
text String
"Bound Ids" SDoc -> SDoc -> SDoc
<+> (Id -> SDoc) -> [Id] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
global_ids,
String -> SDoc
text String
"Typechecked expr" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcTc
zonked_expr]) ;
([Id], LHsExpr GhcTc, FixityEnv)
-> TcRn ([Id], LHsExpr GhcTc, FixityEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
global_ids, LHsExpr GhcTc
zonked_expr, FixityEnv
fix_env)
}
where
bad_unboxed :: Id -> TcRnIf TcGblEnv TcLclEnv ()
bad_unboxed Id
id = SDoc -> TcRnIf TcGblEnv TcLclEnv ()
addErr ([SDoc] -> SDoc
sep [String -> SDoc
text String
"GHCi can't bind a variable of unlifted type:",
Int -> SDoc -> SDoc
nest Int
2 (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
id))])
type PlanResult = ([Id], LHsExpr GhcTc)
type Plan = TcM PlanResult
runPlans :: [Plan] -> TcM PlanResult
runPlans :: [Plan] -> Plan
runPlans [] = String -> Plan
forall a. String -> a
panic String
"runPlans"
runPlans [Plan
p] = Plan
p
runPlans (Plan
p:[Plan]
ps) = Plan -> Plan -> Plan
forall r. TcM r -> TcM r -> TcM r
tryTcDiscardingErrs ([Plan] -> Plan
runPlans [Plan]
ps) Plan
p
tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
tcUserStmt (GhciLStmt GhcPs -> Located (SrcSpanLess (GhciLStmt GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (BodyStmt _ expr _ _))
= do { (LHsExpr GhcRn
rn_expr, FreeVars
fvs) <- TcM (LHsExpr GhcRn, FreeVars) -> TcM (LHsExpr GhcRn, FreeVars)
forall r. TcM r -> TcM r
checkNoErrs (LHsExpr GhcPs -> TcM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr)
; LHsExpr GhcRn
ghciStep <- TcM (LHsExpr GhcRn)
getGhciStepIO
; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; Name
interPrintName <- TcRn Name
getInteractivePrintName
; let fresh_it :: Name
fresh_it = Unique -> SrcSpan -> Name
itName Unique
uniq SrcSpan
loc
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches = [HsMatchContext (NameOrRdrName (IdP GhcRn))
-> [LPat GhcRn]
-> LHsExpr GhcRn
-> Located (HsLocalBinds GhcRn)
-> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass).
HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (Located Name -> HsMatchContext Name
forall id. Located id -> HsMatchContext id
mkPrefixFunRhs (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc Name
SrcSpanLess (Located Name)
fresh_it)) [] LHsExpr GhcRn
rn_expr
(SrcSpanLess (Located (HsLocalBinds GhcRn))
-> Located (HsLocalBinds GhcRn)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located (HsLocalBinds GhcRn))
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)]
the_bind :: LHsBindLR GhcRn GhcRn
the_bind = SrcSpan
-> SrcSpanLess (LHsBindLR GhcRn GhcRn) -> LHsBindLR GhcRn GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (LHsBindLR GhcRn GhcRn) -> LHsBindLR GhcRn GhcRn)
-> SrcSpanLess (LHsBindLR GhcRn GhcRn) -> LHsBindLR GhcRn GhcRn
forall a b. (a -> b) -> a -> b
$ (Origin
-> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn
mkTopFunBind Origin
FromSource
(SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc Name
SrcSpanLess (Located Name)
fresh_it) [LMatch GhcRn (LHsExpr GhcRn)]
matches)
{ fun_ext :: XFunBind GhcRn GhcRn
fun_ext = FreeVars
XFunBind GhcRn GhcRn
fvs }
let_stmt :: GhciLStmt GhcRn
let_stmt = SrcSpan -> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn)
-> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a b. (a -> b) -> a -> b
$ XLetStmt GhcRn GhcRn (LHsExpr GhcRn)
-> Located (HsLocalBinds GhcRn)
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcRn GhcRn (LHsExpr GhcRn)
NoExtField
noExtField (Located (HsLocalBinds GhcRn)
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn))
-> Located (HsLocalBinds GhcRn)
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (Located (HsLocalBinds GhcRn))
-> Located (HsLocalBinds GhcRn)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located (HsLocalBinds GhcRn))
-> Located (HsLocalBinds GhcRn))
-> SrcSpanLess (Located (HsLocalBinds GhcRn))
-> Located (HsLocalBinds GhcRn)
forall a b. (a -> b) -> a -> b
$ XHsValBinds GhcRn GhcRn
-> HsValBindsLR GhcRn GhcRn -> HsLocalBinds GhcRn
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcRn GhcRn
NoExtField
noExtField
(HsValBindsLR GhcRn GhcRn -> HsLocalBinds GhcRn)
-> HsValBindsLR GhcRn GhcRn -> HsLocalBinds GhcRn
forall a b. (a -> b) -> a -> b
$ XXValBindsLR GhcRn GhcRn -> HsValBindsLR GhcRn GhcRn
forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR
([(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> NHsValBindsLR GhcRn
forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
NValBinds [(RecFlag
NonRecursive,LHsBindLR GhcRn GhcRn -> LHsBinds GhcRn
forall a. a -> Bag a
unitBag LHsBindLR GhcRn GhcRn
the_bind)] [])
bind_stmt :: GhciLStmt GhcRn
bind_stmt = SrcSpan -> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn)
-> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a b. (a -> b) -> a -> b
$ XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
-> LPat GhcRn
-> LHsExpr GhcRn
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
NoExtField
noExtField
(SrcSpan -> SrcSpanLess (Located (Pat GhcRn)) -> Located (Pat GhcRn)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XVarPat GhcRn -> Located (IdP GhcRn) -> Pat GhcRn
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat XVarPat GhcRn
NoExtField
noExtField (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc Name
SrcSpanLess (Located Name)
fresh_it)))
(LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcRn
ghciStep LHsExpr GhcRn
rn_expr)
(Name -> SyntaxExpr GhcRn
mkRnSyntaxExpr Name
bindIOName)
SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
print_it :: GhciLStmt GhcRn
print_it = SrcSpan -> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn)
-> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
-> LHsExpr GhcRn
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
NoExtField
noExtField
(LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP GhcRn
interPrintName)
(IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP GhcRn
fresh_it))
(Name -> SyntaxExpr GhcRn
mkRnSyntaxExpr Name
thenIOName)
SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
no_it_a :: GhciLStmt GhcRn
no_it_a = SrcSpan -> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn)
-> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
-> LHsExpr GhcRn
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
NoExtField
noExtField (IdP GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn
forall (id :: Pass).
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps Name
IdP GhcRn
bindIOName
[LHsExpr GhcRn
rn_expr , IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP GhcRn
interPrintName])
(Name -> SyntaxExpr GhcRn
mkRnSyntaxExpr Name
thenIOName)
SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
no_it_b :: GhciLStmt GhcRn
no_it_b = SrcSpan -> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn)
-> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
-> LHsExpr GhcRn
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
NoExtField
noExtField (LHsExpr GhcRn
rn_expr)
(Name -> SyntaxExpr GhcRn
mkRnSyntaxExpr Name
thenIOName)
SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
no_it_c :: GhciLStmt GhcRn
no_it_c = SrcSpan -> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn)
-> SrcSpanLess (GhciLStmt GhcRn) -> GhciLStmt GhcRn
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
-> LHsExpr GhcRn
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
NoExtField
noExtField
(LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Name
IdP GhcRn
interPrintName) LHsExpr GhcRn
rn_expr)
(Name -> SyntaxExpr GhcRn
mkRnSyntaxExpr Name
thenIOName)
SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
it_plans :: [Plan]
it_plans = [
do { stuff :: PlanResult
stuff@([Id
it_id], LHsExpr GhcTc
_) <- [GhciLStmt GhcRn] -> Plan
tcGhciStmts [GhciLStmt GhcRn
bind_stmt, GhciLStmt GhcRn
print_it]
; Type
it_ty <- Type -> TcM Type
zonkTcType (Id -> Type
idType Id
it_id)
; Bool -> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Type -> Bool
isUnitTy (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ Type
it_ty) TcRnIf TcGblEnv TcLclEnv ()
forall env a. IOEnv env a
failM
; PlanResult -> Plan
forall (m :: * -> *) a. Monad m => a -> m a
return PlanResult
stuff },
[GhciLStmt GhcRn] -> Plan
tcGhciStmts [GhciLStmt GhcRn
bind_stmt],
do { PlanResult
_ <- Plan -> Plan
forall r. TcM r -> TcM r
checkNoErrs ([GhciLStmt GhcRn] -> Plan
tcGhciStmts [GhciLStmt GhcRn
let_stmt])
; [GhciLStmt GhcRn] -> Plan
tcGhciStmts [GhciLStmt GhcRn
let_stmt, GhciLStmt GhcRn
print_it] } ]
no_it_plans :: [Plan]
no_it_plans = [
[GhciLStmt GhcRn] -> Plan
tcGhciStmts [GhciLStmt GhcRn
no_it_a] ,
[GhciLStmt GhcRn] -> Plan
tcGhciStmts [GhciLStmt GhcRn
no_it_b] ,
[GhciLStmt GhcRn] -> Plan
tcGhciStmts [GhciLStmt GhcRn
no_it_c] ]
; Bool
generate_it <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_NoIt
; PlanResult
plan <- GeneralFlag -> Plan -> Plan
forall gbl lcl a.
GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM GeneralFlag
Opt_DeferTypeErrors (Plan -> Plan) -> Plan -> Plan
forall a b. (a -> b) -> a -> b
$
GeneralFlag -> Plan -> Plan
forall gbl lcl a.
GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM GeneralFlag
Opt_DeferTypedHoles (Plan -> Plan) -> Plan -> Plan
forall a b. (a -> b) -> a -> b
$
GeneralFlag -> Plan -> Plan
forall gbl lcl a.
GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM GeneralFlag
Opt_DeferOutOfScopeVariables (Plan -> Plan) -> Plan -> Plan
forall a b. (a -> b) -> a -> b
$
[Plan] -> Plan
runPlans ([Plan] -> Plan) -> [Plan] -> Plan
forall a b. (a -> b) -> a -> b
$ if Bool
generate_it
then [Plan]
no_it_plans
else [Plan]
it_plans
; FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv
; (PlanResult, FixityEnv) -> TcM (PlanResult, FixityEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (PlanResult
plan, FixityEnv
fix_env) }
tcUserStmt rdr_stmt :: GhciLStmt GhcPs
rdr_stmt@(GhciLStmt GhcPs -> Located (SrcSpanLess (GhciLStmt GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (GhciLStmt GhcPs)
_)
= do { (([GhciLStmt GhcRn
rn_stmt], FixityEnv
fix_env), FreeVars
fvs) <- TcM (([GhciLStmt GhcRn], FixityEnv), FreeVars)
-> TcM (([GhciLStmt GhcRn], FixityEnv), FreeVars)
forall r. TcM r -> TcM r
checkNoErrs (TcM (([GhciLStmt GhcRn], FixityEnv), FreeVars)
-> TcM (([GhciLStmt GhcRn], FixityEnv), FreeVars))
-> TcM (([GhciLStmt GhcRn], FixityEnv), FreeVars)
-> TcM (([GhciLStmt GhcRn], FixityEnv), FreeVars)
forall a b. (a -> b) -> a -> b
$
HsStmtContext Name
-> (LHsExpr GhcPs -> TcM (LHsExpr GhcRn, FreeVars))
-> [GhciLStmt GhcPs]
-> ([Name] -> RnM (FixityEnv, FreeVars))
-> TcM (([GhciLStmt GhcRn], FixityEnv), FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmts HsStmtContext Name
forall id. HsStmtContext id
GhciStmtCtxt LHsExpr GhcPs -> TcM (LHsExpr GhcRn, FreeVars)
rnLExpr [GhciLStmt GhcPs
rdr_stmt] (([Name] -> RnM (FixityEnv, FreeVars))
-> TcM (([GhciLStmt GhcRn], FixityEnv), FreeVars))
-> ([Name] -> RnM (FixityEnv, FreeVars))
-> TcM (([GhciLStmt GhcRn], FixityEnv), FreeVars)
forall a b. (a -> b) -> a -> b
$ \[Name]
_ -> do
FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv
(FixityEnv, FreeVars) -> RnM (FixityEnv, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv
fix_env, FreeVars
emptyFVs)
; String -> SDoc -> TcRnIf TcGblEnv TcLclEnv ()
traceRn String
"tcRnStmt" ([SDoc] -> SDoc
vcat [GhciLStmt GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr GhciLStmt GhcPs
rdr_stmt, GhciLStmt GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr GhciLStmt GhcRn
rn_stmt, FreeVars -> SDoc
forall a. Outputable a => a -> SDoc
ppr FreeVars
fvs])
; GhciLStmt GhcRn -> TcRnIf TcGblEnv TcLclEnv ()
forall a.
(Outputable a, Data a) =>
a -> TcRnIf TcGblEnv TcLclEnv ()