{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.Module (
tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
tcRnImportDecls,
tcRnLookupRdrName,
getModuleInterface,
tcRnDeclsi,
isGHCiMonad,
runTcInteractive,
withTcPlugins,
withHoleFitPlugins,
tcRnLookupName,
tcRnGetInfo,
tcRnModule, tcRnModuleTcRnM,
tcTopSrcDecls,
rnTopSrcDecls,
checkBootDecl, checkHiBootIface',
findExtraSigImports,
implicitRequirements,
checkUnit,
mergeSignatures,
tcRnMergeSignatures,
instantiateSignature,
tcRnInstantiateSignature,
loadUnqualIfaces,
badReexportedBootThing,
checkBootDeclM,
missingBootThing,
getRenamedStuff, RenamedStuff
) where
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Config.Diagnostic
import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )
import GHC.Tc.Errors.Types
import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers )
import GHC.Tc.Gen.HsType
import GHC.Tc.Validity( checkValidType )
import GHC.Tc.Gen.Match
import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma )
import GHC.Tc.Utils.Zonk
import GHC.Tc.Gen.Expr
import GHC.Tc.Gen.App( tcInferSigma )
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.Export
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Tc.Instance.Family
import GHC.Tc.Gen.Annotation
import GHC.Tc.Gen.Bind
import GHC.Tc.Gen.Default
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Rule
import GHC.Tc.Gen.Foreign
import GHC.Tc.TyCl.Instance
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Instantiate (tcGetInsts)
import GHC.Tc.Solver
import GHC.Tc.TyCl
import GHC.Tc.Instance.Typeable ( mkTypeableBinds )
import GHC.Tc.Utils.Backpack
import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
import GHC.Rename.HsType
import GHC.Rename.Expr
import GHC.Rename.Fixity ( lookupFixityRn )
import GHC.Rename.Names
import GHC.Rename.Env
import GHC.Rename.Module
import GHC.Rename.Doc
import GHC.Iface.Syntax ( ShowSub(..), showToHeader )
import GHC.Iface.Type ( ShowForAllFlag(..) )
import GHC.Iface.Env ( externaliseName )
import GHC.Iface.Make ( coAxiomToIfaceDecl )
import GHC.Iface.Load
import GHC.Builtin.Types ( unitTy, mkListTy )
import GHC.Builtin.Names
import GHC.Builtin.Utils
import GHC.Hs
import GHC.Hs.Dump
import GHC.Core.PatSyn ( pprPatSynType )
import GHC.Core.Predicate ( classMethodTy )
import GHC.Core.InstEnv
import GHC.Core.TyCon
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Core.Class
import GHC.Core.Coercion.Axiom
import GHC.Core.Reduction ( Reduction(..) )
import GHC.Core.RoughMap( RoughMatchTc(..) )
import GHC.Core.TyCo.Ppr( debugPprType )
import GHC.Core.FamInstEnv
( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst
, famInstEnvElts, extendFamInstEnvList, normaliseType )
import GHC.Parser.Header ( mkPrelImports )
import GHC.IfaceToCore
import GHC.Runtime.Context
import GHC.Utils.Error
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Types.Error
import GHC.Types.Name.Reader
import GHC.Types.Fixity.Env
import GHC.Types.Id as Id
import GHC.Types.Id.Info( IdDetails(..) )
import GHC.Types.Var.Env
import GHC.Types.TypeEnv
import GHC.Types.Unique.FM
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Avail
import GHC.Types.Basic hiding( SuccessFlag(..) )
import GHC.Types.Annotations
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.TyThing.Ppr ( pprTyThingInContext )
import GHC.Types.PkgQual
import qualified GHC.LanguageExtensions as LangExt
import GHC.Unit.External
import GHC.Unit.Types
import GHC.Unit.State
import GHC.Unit.Home
import GHC.Unit.Module
import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Deps
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.List.SetOps
import GHC.Data.Bag
import qualified GHC.Data.BooleanFormula as BF
import Data.Functor.Classes ( liftEq )
import Data.List ( sortBy, sort )
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Data.Ord
import Data.Data ( Data )
import qualified Data.Set as S
import Control.DeepSeq
import Control.Monad
tcRnModule :: HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnModule :: HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnModule HscEnv
hsc_env ModSummary
mod_sum Bool
save_rn_syntax
parsedModule :: HsParsedModule
parsedModule@HsParsedModule {hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module= L SrcSpan
loc HsModule GhcPs
this_module}
| RealSrcSpan RealSrcSpan
real_loc Maybe BufSpan
_ <- SrcSpan
loc
= Logger
-> SDoc
-> ((Messages TcRnMessage, Maybe TcGblEnv) -> ())
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Renamer/typechecker"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(() -> (Messages TcRnMessage, Maybe TcGblEnv) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM TcGblEnv
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc HscEnv
hsc_env HscSource
hsc_src Bool
save_rn_syntax Module
this_mod RealSrcSpan
real_loc (TcM TcGblEnv -> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> TcM TcGblEnv -> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
HscEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall a. HscEnv -> TcM a -> TcM a
withTcPlugins HscEnv
hsc_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
HscEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall a. HscEnv -> TcM a -> TcM a
withDefaultingPlugins HscEnv
hsc_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
HscEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall a. HscEnv -> TcM a -> TcM a
withHoleFitPlugins HscEnv
hsc_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
HscEnv
-> ModSummary
-> HsParsedModule
-> (Module, SrcSpan)
-> TcM TcGblEnv
tcRnModuleTcRnM HscEnv
hsc_env ModSummary
mod_sum HsParsedModule
parsedModule (Module, SrcSpan)
pair
| Bool
otherwise
= (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MsgEnvelope TcRnMessage
err_msg MsgEnvelope TcRnMessage
-> Messages TcRnMessage -> Messages TcRnMessage
forall e. MsgEnvelope e -> Messages e -> Messages e
`addMessage` Messages TcRnMessage
forall e. Messages e
emptyMessages, Maybe TcGblEnv
forall a. Maybe a
Nothing)
where
hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_sum
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
err_msg :: MsgEnvelope TcRnMessage
err_msg = SrcSpan -> TcRnMessage -> MsgEnvelope TcRnMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (TcRnMessage -> MsgEnvelope TcRnMessage)
-> TcRnMessage -> MsgEnvelope TcRnMessage
forall a b. (a -> b) -> a -> b
$
Module -> TcRnMessage
TcRnModMissingRealSrcSpan Module
this_mod
pair :: (Module, SrcSpan)
pair :: (Module, SrcSpan)
pair@(Module
this_mod,SrcSpan
_)
| Just (L SrcSpanAnnA
mod_loc ModuleName
mod) <- HsModule GhcPs -> Maybe (XRec GhcPs ModuleName)
forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName HsModule GhcPs
this_module
= (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod, SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
mod_loc)
| Bool
otherwise
= (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mAIN_NAME, SrcLoc -> SrcSpan
srcLocSpan (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
loc))
tcRnModuleTcRnM :: HscEnv
-> ModSummary
-> HsParsedModule
-> (Module, SrcSpan)
-> TcRn TcGblEnv
tcRnModuleTcRnM :: HscEnv
-> ModSummary
-> HsParsedModule
-> (Module, SrcSpan)
-> TcM TcGblEnv
tcRnModuleTcRnM HscEnv
hsc_env ModSummary
mod_sum
(HsParsedModule {
hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module =
(L SrcSpan
loc (HsModule (XModulePs EpAnn AnnsModule
_ LayoutInfo GhcPs
_ Maybe (LocatedP (WarningTxt GhcPs))
mod_deprec Maybe (LHsDoc GhcPs)
maybe_doc_hdr)
Maybe (XRec GhcPs ModuleName)
maybe_mod Maybe (XRec GhcPs [XRec GhcPs (IE GhcPs)])
export_ies [LImportDecl GhcPs]
import_decls [LHsDecl GhcPs]
local_decls)),
hpm_src_files :: HsParsedModule -> [String]
hpm_src_files = [String]
src_files
})
(Module
this_mod, SrcSpan
prel_imp_loc)
= SrcSpan -> TcM TcGblEnv -> TcM TcGblEnv
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
do { let { explicit_mod_hdr :: Bool
explicit_mod_hdr = Maybe (GenLocated SrcSpanAnnA ModuleName) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (XRec GhcPs ModuleName)
Maybe (GenLocated SrcSpanAnnA ModuleName)
maybe_mod
; hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_sum }
;
TcGblEnv
tcg_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; SelfBootInfo
boot_info <- HscSource -> Module -> TcRn SelfBootInfo
tcHiBootIface HscSource
hsc_src Module
this_mod
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv (TcGblEnv
tcg_env { tcg_self_boot = boot_info })
(TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do
{
Bool
implicit_prelude <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ImplicitPrelude
; let { prel_imports :: [LImportDecl GhcPs]
prel_imports = ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod) SrcSpan
prel_imp_loc
Bool
implicit_prelude [LImportDecl GhcPs]
import_decls }
; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
prel_imports) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
let msg :: TcRnMessage
msg = DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnImplicitPrelude) [GhcHint]
noHints (SDoc
implicitPreludeWarn)
TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnostic TcRnMessage
msg
;
let { simplifyImport :: GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (PkgQual, Located ModuleName)
simplifyImport (L SrcSpanAnnA
_ ImportDecl GhcPs
idecl) =
( UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
renameRawPkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
idecl) (ImportDecl GhcPs -> ImportDeclPkgQual GhcPs
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl GhcPs
idecl)
, GenLocated SrcSpanAnnA ModuleName -> Located ModuleName
forall a e. LocatedAn a e -> Located e
reLoc (GenLocated SrcSpanAnnA ModuleName -> Located ModuleName)
-> GenLocated SrcSpanAnnA ModuleName -> Located ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
idecl)
}
; [ModuleName]
raw_sig_imports <- IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName]
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName])
-> IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName]
forall a b. (a -> b) -> a -> b
$ HscEnv -> HscSource -> ModuleName -> IO [ModuleName]
findExtraSigImports HscEnv
hsc_env HscSource
hsc_src
(Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod)
; [ModuleName]
raw_req_imports <- IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName]
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName])
-> IO [ModuleName] -> IOEnv (Env TcGblEnv TcLclEnv) [ModuleName]
forall a b. (a -> b) -> a -> b
$ HscEnv -> [(PkgQual, Located ModuleName)] -> IO [ModuleName]
implicitRequirements HscEnv
hsc_env
((GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (PkgQual, Located ModuleName))
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(PkgQual, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (PkgQual, Located ModuleName)
simplifyImport ([LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
prel_imports
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
import_decls))
; let { mkImport :: ModuleName -> LocatedAn an (ImportDecl pass)
mkImport ModuleName
mod_name = ImportDecl pass -> LocatedAn an (ImportDecl pass)
forall a an. a -> LocatedAn an a
noLocA
(ImportDecl pass -> LocatedAn an (ImportDecl pass))
-> ImportDecl pass -> LocatedAn an (ImportDecl pass)
forall a b. (a -> b) -> a -> b
$ (ModuleName -> ImportDecl GhcPs
simpleImportDecl ModuleName
mod_name)
{ ideclImportList = Just (Exactly, noLocA [])}}
; let { withReason :: String -> [a] -> [(a, t)]
withReason String
t [a]
imps = (a -> (a, t)) -> [a] -> [(a, t)]
forall a b. (a -> b) -> [a] -> [b]
map (,String -> t
forall doc. IsLine doc => String -> doc
text String
t) [a]
imps }
; let { all_imports :: [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
all_imports = String
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall {t} {a}. IsLine t => String -> [a] -> [(a, t)]
withReason String
"is implicitly imported" [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
prel_imports
[(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall a. [a] -> [a] -> [a]
++ String
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall {t} {a}. IsLine t => String -> [a] -> [(a, t)]
withReason String
"is directly imported" [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
import_decls
[(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall a. [a] -> [a] -> [a]
++ String
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall {t} {a}. IsLine t => String -> [a] -> [(a, t)]
withReason String
"is an extra sig import" ((ModuleName -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> [ModuleName] -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall {pass} {an} {an}.
(ImportDeclPkgQual pass ~ RawPkgQual,
XCImportDecl pass ~ XImportDeclPass,
XRec pass [XRec pass (IE pass)]
~ LocatedAn an [XRec pass (IE pass)],
XRec pass ModuleName ~ GenLocated SrcSpanAnnA ModuleName) =>
ModuleName -> LocatedAn an (ImportDecl pass)
mkImport [ModuleName]
raw_sig_imports)
[(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall a. [a] -> [a] -> [a]
++ String
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall {t} {a}. IsLine t => String -> [a] -> [(a, t)]
withReason String
"is an implicit req import" ((ModuleName -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> [ModuleName] -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall {pass} {an} {an}.
(ImportDeclPkgQual pass ~ RawPkgQual,
XCImportDecl pass ~ XImportDeclPass,
XRec pass [XRec pass (IE pass)]
~ LocatedAn an [XRec pass (IE pass)],
XRec pass ModuleName ~ GenLocated SrcSpanAnnA ModuleName) =>
ModuleName -> LocatedAn an (ImportDecl pass)
mkImport [ModuleName]
raw_req_imports) }
;
TcGblEnv
tcg_env <- {-# SCC "tcRnImports" #-}
HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv
tcRnImports HscEnv
hsc_env [(LImportDecl GhcPs, SDoc)]
[(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
all_imports
; TcGblEnv
tcg_env <- TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env
{ tcg_doc_hdr = fmap (\(WithHsDocIdentifiers HsDocString
str [Located (IdP GhcPs)]
_) -> HsDocString
-> [Located (IdP (GhcPass 'Renamed))] -> HsDoc (GhcPass 'Renamed)
forall a pass.
a -> [Located (IdP pass)] -> WithHsDocIdentifiers a pass
WithHsDocIdentifiers HsDocString
str [])
<$> maybe_doc_hdr })
;
; TcGblEnv
tcg_env1 <- case Maybe (LocatedP (WarningTxt GhcPs))
mod_deprec of
Just (L SrcSpanAnnP
_ WarningTxt GhcPs
txt) -> do { WarningTxt (GhcPass 'Renamed)
txt' <- WarningTxt GhcPs -> RnM (WarningTxt (GhcPass 'Renamed))
rnWarningTxt WarningTxt GhcPs
txt
; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcGblEnv -> TcM TcGblEnv) -> TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ TcGblEnv
tcg_env {tcg_warns = WarnAll txt'}
}
Maybe (LocatedP (WarningTxt GhcPs))
Nothing -> TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TcGblEnv
tcg_env
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env1
(TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn1a" SDoc
forall doc. IsOutput doc => doc
empty
; TcGblEnv
tcg_env <- if HscSource -> Bool
isHsBootOrSig HscSource
hsc_src
then do {
; TcGblEnv
tcg_env <- HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnHsBootDecls HscSource
hsc_src [LHsDecl GhcPs]
local_decls
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn4a: before exports" SDoc
forall doc. IsOutput doc => doc
empty
; TcGblEnv
tcg_env <- TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> TcM TcGblEnv
rnExports Bool
explicit_mod_hdr Maybe (XRec GhcPs [XRec GhcPs (IE GhcPs)])
Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn4b: after exports" SDoc
forall doc. IsOutput doc => doc
empty
; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
}
else {-# SCC "tcRnSrcDecls" #-}
Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> [LHsDecl GhcPs]
-> TcM TcGblEnv
tcRnSrcDecls Bool
explicit_mod_hdr Maybe (XRec GhcPs [XRec GhcPs (IE GhcPs)])
Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies [LHsDecl GhcPs]
local_decls
; TcRnIf TcGblEnv TcLclEnv Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_DoCoreLinting) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
Logger -> DynFlags -> TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()
lintGblEnv (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) TcGblEnv
tcg_env
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env
(TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {
TcGblEnv
tcg_env <- TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
checkHiBootIface TcGblEnv
tcg_env SelfBootInfo
boot_info
;
;
; TcGblEnv -> HscSource -> IOEnv (Env TcGblEnv TcLclEnv) ()
reportUnusedNames TcGblEnv
tcg_env HscSource
hsc_src
; Maybe (GenLocated SrcSpan (HsDoc (GhcPass 'Renamed)))
maybe_doc_hdr <- (LHsDoc GhcPs
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpan (HsDoc (GhcPass 'Renamed))))
-> Maybe (LHsDoc GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (GenLocated SrcSpan (HsDoc (GhcPass 'Renamed))))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse LHsDoc GhcPs
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpan (HsDoc (GhcPass 'Renamed)))
rnLHsDoc Maybe (LHsDoc GhcPs)
maybe_doc_hdr;
; TcGblEnv
tcg_env <- TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env
{ tcg_doc_hdr = maybe_doc_hdr })
;
[String] -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDependentFiles [String]
src_files
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env
(TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do { TcGblEnv
tcg_env <- ModSummary -> TcGblEnv -> TcM TcGblEnv
runTypecheckerPlugin ModSummary
mod_sum TcGblEnv
tcg_env
;
TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcDump TcGblEnv
tcg_env
; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
}
}
}
}
}
implicitPreludeWarn :: SDoc
implicitPreludeWarn :: SDoc
implicitPreludeWarn
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Module `Prelude' implicitly imported"
tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv
tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv
tcRnImports HscEnv
hsc_env [(LImportDecl GhcPs, SDoc)]
import_decls
= do { ([GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))]
rn_imports, GlobalRdrEnv
rdr_env, ImportAvails
imports, Bool
hpc_info) <- [(LImportDecl GhcPs, SDoc)]
-> RnM
([LImportDecl (GhcPass 'Renamed)], GlobalRdrEnv, ImportAvails,
Bool)
rnImports [(LImportDecl GhcPs, SDoc)]
import_decls ;
; Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; TcGblEnv
gbl_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let {
; (InstEnv
home_insts, [FamInst]
home_fam_insts) =
HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst])
hptInstancesBelow HscEnv
hsc_env (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId (HomeUnit -> UnitId) -> HomeUnit -> UnitId
forall a b. (a -> b) -> a -> b
$ HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod)(HscSource -> IsBootInterface
hscSourceToIsBoot (TcGblEnv -> HscSource
tcg_src TcGblEnv
gbl_env)))
} ;
; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do {
(ExternalPackageState -> ExternalPackageState)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl.
(ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ ((ExternalPackageState -> ExternalPackageState)
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (ExternalPackageState -> ExternalPackageState)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ \ExternalPackageState
eps -> ExternalPackageState
eps { eps_is_boot = imp_boot_mods imports }
}
; (TcGblEnv -> TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv ( \ TcGblEnv
gbl ->
TcGblEnv
gbl {
tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
tcg_imports = tcg_imports gbl `plusImportAvails` imports,
tcg_rn_imports = rn_imports,
tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts,
tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
home_fam_insts,
tcg_hpc = hpc_info
}) (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn1" (InstalledModuleEnv ModuleNameWithIsBoot -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ImportAvails -> InstalledModuleEnv ModuleNameWithIsBoot
imp_direct_dep_mods ImportAvails
imports))
; IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM
; SDoc -> [Module] -> IOEnv (Env TcGblEnv TcLclEnv) ()
loadModuleInterfaces (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Loading orphan modules")
((Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter (Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
this_mod) (ImportAvails -> [Module]
imp_orphs ImportAvails
imports))
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn1: checking family instance consistency {" SDoc
forall doc. IsOutput doc => doc
empty
; let { dir_imp_mods :: [Module]
dir_imp_mods = ModuleEnv [ImportedBy] -> [Module]
forall a. ModuleEnv a -> [Module]
moduleEnvKeys
(ModuleEnv [ImportedBy] -> [Module])
-> (ImportAvails -> ModuleEnv [ImportedBy])
-> ImportAvails
-> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportAvails -> ModuleEnv [ImportedBy]
imp_mods
(ImportAvails -> [Module]) -> ImportAvails -> [Module]
forall a b. (a -> b) -> a -> b
$ ImportAvails
imports }
; [Module] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkFamInstConsistency [Module]
dir_imp_mods
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn1: } checking family instance consistency" SDoc
forall doc. IsOutput doc => doc
empty
; TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv } }
tcRnSrcDecls :: Bool
-> Maybe (LocatedL [LIE GhcPs])
-> [LHsDecl GhcPs]
-> TcM TcGblEnv
tcRnSrcDecls :: Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> [LHsDecl GhcPs]
-> TcM TcGblEnv
tcRnSrcDecls Bool
explicit_mod_hdr Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies [LHsDecl GhcPs]
decls
= do {
; (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie) <- [LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls [LHsDecl GhcPs]
decls
; Bag EvBind
new_ev_binds <- {-# SCC "simplifyTop" #-}
(TcGblEnv, TcLclEnv) -> TcRn (Bag EvBind) -> TcRn (Bag EvBind)
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRn (Bag EvBind) -> TcRn (Bag EvBind))
-> TcRn (Bag EvBind) -> TcRn (Bag EvBind)
forall a b. (a -> b) -> a -> b
$
do { WantedConstraints
lie_main <- TcGblEnv -> TcRn WantedConstraints
checkMainType TcGblEnv
tcg_env
; WantedConstraints -> TcRn (Bag EvBind)
simplifyTop (WantedConstraints
lie WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
lie_main) }
; TcGblEnv
tcg_env <- TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
TcM TcGblEnv
mkTypeableBinds
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc9" SDoc
forall doc. IsOutput doc => doc
empty
; IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM
; (TypeEnv
id_env, Bag EvBind
ev_binds', Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
fords', [LTcSpecPrag]
imp_specs', [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules')
<- Bag EvBind
-> TcGblEnv
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv Bag EvBind
new_ev_binds TcGblEnv
tcg_env
; let
init_tcg_env :: TcGblEnv
init_tcg_env = TcGblEnv
tcg_env { tcg_binds = emptyBag
, tcg_ev_binds = emptyBag
, tcg_imp_specs = []
, tcg_rules = []
, tcg_fords = []
, tcg_type_env = tcg_type_env tcg_env
`plusTypeEnv` id_env }
; (TcGblEnv
tcg_env, TcLclEnv
tcl_env) <- TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
init_tcg_env
TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
run_th_modfinalizers
; IOEnv (Env TcGblEnv TcLclEnv) ()
finishTH
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc11" SDoc
forall doc. IsOutput doc => doc
empty
; TcGblEnv
tcg_env <- (TcGblEnv, TcLclEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> TcM TcGblEnv
rnExports Bool
explicit_mod_hdr Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies
; (TcGblEnv
tcg_env, Bag EvBind
main_ev_binds)
<- (TcGblEnv, TcLclEnv)
-> TcRn (TcGblEnv, Bag EvBind) -> TcRn (TcGblEnv, Bag EvBind)
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRn (TcGblEnv, Bag EvBind) -> TcRn (TcGblEnv, Bag EvBind))
-> TcRn (TcGblEnv, Bag EvBind) -> TcRn (TcGblEnv, Bag EvBind)
forall a b. (a -> b) -> a -> b
$
do { (TcGblEnv
tcg_env, WantedConstraints
lie) <- TcM TcGblEnv -> TcM (TcGblEnv, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM TcGblEnv -> TcM (TcGblEnv, WantedConstraints))
-> TcM TcGblEnv -> TcM (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> TcM TcGblEnv
checkMain Bool
explicit_mod_hdr Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies
; Bag EvBind
ev_binds <- WantedConstraints -> TcRn (Bag EvBind)
simplifyTop WantedConstraints
lie
; (TcGblEnv, Bag EvBind) -> TcRn (TcGblEnv, Bag EvBind)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, Bag EvBind
ev_binds) }
; IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM
; (TypeEnv
id_env_mf, Bag EvBind
ev_binds_mf, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds_mf, [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
fords_mf, [LTcSpecPrag]
imp_specs_mf, [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules_mf)
<- Bag EvBind
-> TcGblEnv
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv Bag EvBind
main_ev_binds TcGblEnv
tcg_env
; let { !final_type_env :: TypeEnv
final_type_env = TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
tcg_env
TypeEnv -> TypeEnv -> TypeEnv
`plusTypeEnv` TypeEnv
id_env_mf
; tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env
{ tcg_binds = binds' `unionBags` binds_mf
, tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf
, tcg_imp_specs = imp_specs' ++ imp_specs_mf
, tcg_rules = rules' ++ rules_mf
, tcg_fords = fords' ++ fords_mf } } ;
; TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv TcGblEnv
tcg_env' TypeEnv
final_type_env
}
zonkTcGblEnv :: Bag EvBind -> TcGblEnv
-> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
[LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv :: Bag EvBind
-> TcGblEnv
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv Bag EvBind
ev_binds tcg_env :: TcGblEnv
tcg_env@(TcGblEnv { tcg_binds :: TcGblEnv -> LHsBinds GhcTc
tcg_binds = LHsBinds GhcTc
binds
, tcg_ev_binds :: TcGblEnv -> Bag EvBind
tcg_ev_binds = Bag EvBind
cur_ev_binds
, tcg_imp_specs :: TcGblEnv -> [LTcSpecPrag]
tcg_imp_specs = [LTcSpecPrag]
imp_specs
, tcg_rules :: TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules = [LRuleDecl GhcTc]
rules
, tcg_fords :: TcGblEnv -> [LForeignDecl GhcTc]
tcg_fords = [LForeignDecl GhcTc]
fords })
= {-# SCC "zonkTopDecls" #-}
TcGblEnv
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc]))
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
forall a b. (a -> b) -> a -> b
$
do { let all_ev_binds :: Bag EvBind
all_ev_binds = Bag EvBind
cur_ev_binds Bag EvBind -> Bag EvBind -> Bag EvBind
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag EvBind
ev_binds
; Bag EvBind
-> LHsBinds GhcTc
-> [LRuleDecl GhcTc]
-> [LTcSpecPrag]
-> [LForeignDecl GhcTc]
-> TcM
(TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc],
[LTcSpecPrag], [LRuleDecl GhcTc])
zonkTopDecls Bag EvBind
all_ev_binds LHsBinds GhcTc
binds [LRuleDecl GhcTc]
rules [LTcSpecPrag]
imp_specs [LForeignDecl GhcTc]
fords }
run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
run_th_modfinalizers :: TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
run_th_modfinalizers = do
TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- (TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)])
-> TcM TcGblEnv
-> IOEnv
(Env TcGblEnv TcLclEnv) (TcRef [(TcLclEnv, ThModFinalizers)])
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)]
tcg_th_modfinalizers TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
[(TcLclEnv, ThModFinalizers)]
th_modfinalizers <- TcRef [(TcLclEnv, ThModFinalizers)]
-> TcRnIf TcGblEnv TcLclEnv [(TcLclEnv, ThModFinalizers)]
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var
if [(TcLclEnv, ThModFinalizers)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TcLclEnv, ThModFinalizers)]
th_modfinalizers
then TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs
else do
TcRef [(TcLclEnv, ThModFinalizers)]
-> [(TcLclEnv, ThModFinalizers)]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var []
let run_finalizer :: (TcLclEnv, ThModFinalizers) -> IOEnv (Env TcGblEnv TcLclEnv) ()
run_finalizer (TcLclEnv
lcl_env, ThModFinalizers
f) =
TcLclEnv
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl a.
TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
restoreLclEnv TcLclEnv
lcl_env (ThModFinalizers -> IOEnv (Env TcGblEnv TcLclEnv) ()
runRemoteModFinalizers ThModFinalizers
f)
(()
_, WantedConstraints
lie_th) <- IOEnv (Env TcGblEnv TcLclEnv) () -> TcM ((), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (IOEnv (Env TcGblEnv TcLclEnv) () -> TcM ((), WantedConstraints))
-> IOEnv (Env TcGblEnv TcLclEnv) () -> TcM ((), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
((TcLclEnv, ThModFinalizers) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [(TcLclEnv, ThModFinalizers)]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcLclEnv, ThModFinalizers) -> IOEnv (Env TcGblEnv TcLclEnv) ()
run_finalizer [(TcLclEnv, ThModFinalizers)]
th_modfinalizers
(TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie_top_decls) <- [LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls []
(TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do
Bag EvBind
new_ev_binds <- {-# SCC "simplifyTop2" #-}
WantedConstraints -> TcRn (Bag EvBind)
simplifyTop (WantedConstraints
lie_th WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
lie_top_decls)
Bag EvBind
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. Bag EvBind -> TcM a -> TcM a
addTopEvBinds Bag EvBind
new_ev_binds TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
run_th_modfinalizers
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, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
group_tail) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
ds
; (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls) <- HsGroup GhcPs -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
rnTopSrcDecls HsGroup GhcPs
first_group
; TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_topdecls_var <- (TcGblEnv -> TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> TcM TcGblEnv
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> TcRef [LHsDecl GhcPs]
TcGblEnv -> TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
tcg_th_topdecls TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_ds <- TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> TcRnIf TcGblEnv TcLclEnv [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_topdecls_var
; TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_topdecls_var []
; (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls) <-
if [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_ds
then (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls)
else do { (HsGroup GhcPs
th_group, Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
th_group_tail) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_ds
; case Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
th_group_tail of
{ Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
Nothing -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; Just (SpliceDecl XSpliceDecl GhcPs
_ (L SrcSpanAnnA
loc HsUntypedSplice GhcPs
_) SpliceDecoration
_, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
_) ->
SrcSpanAnnA
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc
(IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text
(String
"Declaration splices are not "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"permitted inside top-level "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"declarations added with addTopDecls"))
}
; (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
th_rn_decls) <- TcGblEnv
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env
(TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed)))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ HsGroup GhcPs -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
rnTopSrcDecls HsGroup GhcPs
th_group
; let msg :: String
msg = String
"top-level declarations added with addTopDecls"
; SpliceInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceSplice
(SpliceInfo -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SpliceInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ SpliceInfo { spliceDescription :: String
spliceDescription = String
msg
, spliceIsDecl :: Bool
spliceIsDecl = Bool
True
, spliceSource :: Maybe (LHsExpr (GhcPass 'Renamed))
spliceSource = Maybe (LHsExpr (GhcPass 'Renamed))
Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall a. Maybe a
Nothing
, spliceGenerated :: SDoc
spliceGenerated = HsGroup (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsGroup (GhcPass 'Renamed)
th_rn_decls }
; (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
-> HsGroup (GhcPass 'Renamed) -> HsGroup (GhcPass 'Renamed)
forall (p :: Pass).
HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p)
appendGroups HsGroup (GhcPass 'Renamed)
rn_decls HsGroup (GhcPass 'Renamed)
th_rn_decls)
}
; ((TcGblEnv
tcg_env, TcLclEnv
tcl_env), WantedConstraints
lie1) <- TcGblEnv
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcRnIf TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints))
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf
TcGblEnv TcLclEnv ((TcGblEnv, TcLclEnv), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
HsGroup (GhcPass 'Renamed)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopSrcDecls HsGroup (GhcPass 'Renamed)
rn_decls
; (TcGblEnv, TcLclEnv)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints))
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
case Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
group_tail of
{ Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
Nothing -> (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env, TcLclEnv
tcl_env, WantedConstraints
lie1)
; Just (SpliceDecl XSpliceDecl GhcPs
_ (L SrcSpanAnnA
_ HsUntypedSplice GhcPs
splice) SpliceDecoration
_, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
rest_ds) ->
do {
; Bag EvBind
ev_binds1 <- WantedConstraints -> TcRn (Bag EvBind)
simplifyTop WantedConstraints
lie1
; ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
spliced_decls, FreeVars
splice_fvs) <- HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls HsUntypedSplice GhcPs
splice
; TcGblEnv
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv (TcGblEnv
tcg_env TcGblEnv -> DefUses -> TcGblEnv
`addTcgDUs` FreeVars -> DefUses
usesOnly FreeVars
splice_fvs) (TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints))
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
Bag EvBind
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a. Bag EvBind -> TcM a -> TcM a
addTopEvBinds Bag EvBind
ev_binds1 (TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints))
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
-> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
[LHsDecl GhcPs] -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
tc_rn_src_decls ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
spliced_decls [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
rest_ds)
}
}
}
tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
tcRnHsBootDecls HscSource
hsc_src [LHsDecl GhcPs]
decls
= do { (HsGroup GhcPs
first_group, Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
group_tail) <- [LHsDecl GhcPs]
-> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
findSplice [LHsDecl GhcPs]
decls
; (TcGblEnv
tcg_env, HsGroup { hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup (GhcPass 'Renamed)]
tycl_decls
, hs_derivds :: forall p. HsGroup p -> [LDerivDecl p]
hs_derivds = [LDerivDecl (GhcPass 'Renamed)]
deriv_decls
, hs_fords :: forall p. HsGroup p -> [LForeignDecl p]
hs_fords = [LForeignDecl (GhcPass 'Renamed)]
for_decls
, hs_defds :: forall p. HsGroup p -> [LDefaultDecl p]
hs_defds = [LDefaultDecl (GhcPass 'Renamed)]
def_decls
, hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds = [LRuleDecls (GhcPass 'Renamed)]
rule_decls
, hs_annds :: forall p. HsGroup p -> [LAnnDecl p]
hs_annds = [LAnnDecl (GhcPass 'Renamed)]
_
, hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds = XValBindsLR (NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds [LSig (GhcPass 'Renamed)]
val_sigs) })
<- HsGroup GhcPs -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
rnTopSrcDecls HsGroup GhcPs
first_group
; (TcGblEnv
gbl_env, WantedConstraints
lie) <- TcGblEnv
-> TcM (TcGblEnv, WantedConstraints)
-> TcM (TcGblEnv, WantedConstraints)
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM (TcGblEnv, WantedConstraints)
-> TcM (TcGblEnv, WantedConstraints))
-> TcM (TcGblEnv, WantedConstraints)
-> TcM (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$ TcM TcGblEnv -> TcM (TcGblEnv, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM TcGblEnv -> TcM (TcGblEnv, WantedConstraints))
-> TcM TcGblEnv -> TcM (TcGblEnv, WantedConstraints)
forall a b. (a -> b) -> a -> b
$ do {
; case Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
group_tail of
Just (SpliceDecl XSpliceDecl GhcPs
_ XRec GhcPs (HsUntypedSplice GhcPs)
d SpliceDecoration
_, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
_) -> HscSource
-> String
-> GenLocated SrcSpanAnnA (HsUntypedSplice GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall decl.
HscSource
-> String -> LocatedA decl -> IOEnv (Env TcGblEnv TcLclEnv) ()
badBootDecl HscSource
hsc_src String
"splice" XRec GhcPs (HsUntypedSplice GhcPs)
GenLocated SrcSpanAnnA (HsUntypedSplice GhcPs)
d
Maybe (SpliceDecl GhcPs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
Nothing -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; (LocatedA (ForeignDecl (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [LocatedA (ForeignDecl (GhcPass 'Renamed))]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HscSource
-> String
-> LocatedA (ForeignDecl (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall decl.
HscSource
-> String -> LocatedA decl -> IOEnv (Env TcGblEnv TcLclEnv) ()
badBootDecl HscSource
hsc_src String
"foreign") [LForeignDecl (GhcPass 'Renamed)]
[LocatedA (ForeignDecl (GhcPass 'Renamed))]
for_decls
; (LocatedA (DefaultDecl (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [LocatedA (DefaultDecl (GhcPass 'Renamed))]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HscSource
-> String
-> LocatedA (DefaultDecl (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall decl.
HscSource
-> String -> LocatedA decl -> IOEnv (Env TcGblEnv TcLclEnv) ()
badBootDecl HscSource
hsc_src String
"default") [LDefaultDecl (GhcPass 'Renamed)]
[LocatedA (DefaultDecl (GhcPass 'Renamed))]
def_decls
; (LocatedA (RuleDecls (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [LocatedA (RuleDecls (GhcPass 'Renamed))]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HscSource
-> String
-> LocatedA (RuleDecls (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall decl.
HscSource
-> String -> LocatedA decl -> IOEnv (Env TcGblEnv TcLclEnv) ()
badBootDecl HscSource
hsc_src String
"rule") [LRuleDecls (GhcPass 'Renamed)]
[LocatedA (RuleDecls (GhcPass 'Renamed))]
rule_decls
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc2 (boot)" SDoc
forall doc. IsOutput doc => doc
empty
; (TcGblEnv
tcg_env, [InstInfo (GhcPass 'Renamed)]
inst_infos, ThBindEnv
_deriv_binds, HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
_th_bndrs)
<- [TyClGroup (GhcPass 'Renamed)]
-> [LDerivDecl (GhcPass 'Renamed)]
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
tcTyClsInstDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls [LDerivDecl (GhcPass 'Renamed)]
deriv_decls [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {
; TcGblEnv
tcg_env <- TcM TcGblEnv
mkTypeableBinds
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ do {
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc5" SDoc
forall doc. IsOutput doc => doc
empty
; [Var]
val_ids <- [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)] -> TcM [Var]
tcHsBootSigs [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds [LSig (GhcPass 'Renamed)]
val_sigs
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc7a" SDoc
forall doc. IsOutput doc => doc
empty
; TcGblEnv
gbl_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let { type_env0 :: TypeEnv
type_env0 = TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
gbl_env
; type_env1 :: TypeEnv
type_env1 = TypeEnv -> [Var] -> TypeEnv
extendTypeEnvWithIds TypeEnv
type_env0 [Var]
val_ids
; type_env2 :: TypeEnv
type_env2 = TypeEnv -> [Var] -> TypeEnv
extendTypeEnvWithIds TypeEnv
type_env1 [Var]
dfun_ids
; dfun_ids :: [Var]
dfun_ids = (InstInfo (GhcPass 'Renamed) -> Var)
-> [InstInfo (GhcPass 'Renamed)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map InstInfo (GhcPass 'Renamed) -> Var
forall a. InstInfo a -> Var
iDFunId [InstInfo (GhcPass 'Renamed)]
inst_infos
}
; TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv TcGblEnv
gbl_env TypeEnv
type_env2
}}}
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"boot" (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie); TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
gbl_env }
badBootDecl :: HscSource -> String -> LocatedA decl -> TcM ()
badBootDecl :: forall decl.
HscSource
-> String -> LocatedA decl -> IOEnv (Env TcGblEnv TcLclEnv) ()
badBootDecl HscSource
hsc_src String
what (L SrcSpanAnnA
loc decl
_)
= SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
(Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'A' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
what
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"declaration is not (currently) allowed in a"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (case HscSource
hsc_src of
HscSource
HsBootFile -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs-boot"
HscSource
HsigFile -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hsig"
HscSource
_ -> String -> SDoc
forall a. HasCallStack => String -> a
panic String
"badBootDecl: should be an hsig or hs-boot file")
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"file")
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
| HscSource
HsBootFile <- TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env
= TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
| SelfBoot { sb_mds :: SelfBootInfo -> ModDetails
sb_mds = ModDetails
boot_details } <- SelfBootInfo
boot_info
, TcGblEnv { tcg_binds :: TcGblEnv -> LHsBinds GhcTc
tcg_binds = LHsBinds GhcTc
binds
, tcg_insts :: TcGblEnv -> [ClsInst]
tcg_insts = [ClsInst]
local_insts
, tcg_type_env :: TcGblEnv -> TypeEnv
tcg_type_env = TypeEnv
local_type_env
, tcg_exports :: TcGblEnv -> [AvailInfo]
tcg_exports = [AvailInfo]
local_exports } <- TcGblEnv
tcg_env
= do {
; [(Var, Var)]
dfun_prs <- [ClsInst]
-> TypeEnv -> [AvailInfo] -> ModDetails -> TcM [(Var, Var)]
checkHiBootIface' [ClsInst]
local_insts TypeEnv
local_type_env
[AvailInfo]
local_exports ModDetails
boot_details
; let boot_dfuns :: [Var]
boot_dfuns = ((Var, Var) -> Var) -> [(Var, Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Var) -> Var
forall a b. (a, b) -> a
fst [(Var, Var)]
dfun_prs
type_env' :: TypeEnv
type_env' = TypeEnv -> [Var] -> TypeEnv
extendTypeEnvWithIds TypeEnv
local_type_env [Var]
boot_dfuns
dfun_binds :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
dfun_binds = [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [a] -> Bag a
listToBag [ IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP GhcTc
Var
boot_dfun (IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Var
dfun)
| (Var
boot_dfun, Var
dfun) <- [(Var, Var)]
dfun_prs ]
tcg_env_w_binds :: TcGblEnv
tcg_env_w_binds
= TcGblEnv
tcg_env { tcg_binds = binds `unionBags` dfun_binds }
; TypeEnv
type_env' TypeEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. a -> b -> b
`seq`
TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv TcGblEnv
tcg_env_w_binds TypeEnv
type_env' }
#if __GLASGOW_HASKELL__ <= 810
| otherwise = panic "checkHiBootIface: unreachable code"
#endif
checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
-> ModDetails -> TcM [(Id, Id)]
checkHiBootIface' :: [ClsInst]
-> TypeEnv -> [AvailInfo] -> ModDetails -> TcM [(Var, Var)]
checkHiBootIface'
[ClsInst]
local_insts TypeEnv
local_type_env [AvailInfo]
local_exports
(ModDetails { md_types :: ModDetails -> TypeEnv
md_types = TypeEnv
boot_type_env
, md_fam_insts :: ModDetails -> [FamInst]
md_fam_insts = [FamInst]
boot_fam_insts
, md_exports :: ModDetails -> [AvailInfo]
md_exports = [AvailInfo]
boot_exports })
= do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"checkHiBootIface" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeEnv
boot_type_env, [AvailInfo] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AvailInfo]
boot_exports]
; (AvailInfo -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [AvailInfo] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ AvailInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_export [AvailInfo]
boot_exports
; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FamInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FamInst]
boot_fam_insts) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
String -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. HasCallStack => String -> a
panic (String
"GHC.Tc.Module.checkHiBootIface: Cannot handle family " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"instances in boot files yet...")
; [Maybe (Var, Var)]
mb_dfun_prs <- (Var -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var)))
-> [Var] -> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (Var, Var)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Var -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
check_cls_inst [Var]
boot_dfuns
; IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM
; [(Var, Var)] -> TcM [(Var, Var)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe (Var, Var)] -> [(Var, Var)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Var, Var)]
mb_dfun_prs) }
where
boot_dfun_names :: [Name]
boot_dfun_names = (Var -> Name) -> [Var] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Name
idName [Var]
boot_dfuns
boot_dfuns :: [Var]
boot_dfuns = (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
isDFunId ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ TypeEnv -> [Var]
typeEnvIds TypeEnv
boot_type_env
check_export :: AvailInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_export AvailInfo
boot_avail
| Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
boot_dfun_names = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Name
missing_name:[Name]
_ <- [Name]
missing_names
= SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt (Name -> SrcSpan
nameSrcSpan Name
missing_name)
(Bool -> Name -> String -> TcRnMessage
missingBootThing Bool
True Name
missing_name String
"exported by")
| Maybe TyThing -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TyThing
mb_boot_thing = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just TyThing
real_thing <- TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
local_type_env Name
name,
Just TyThing
boot_thing <- Maybe TyThing
mb_boot_thing
= Bool -> TyThing -> TyThing -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkBootDeclM Bool
True TyThing
boot_thing TyThing
real_thing
| Bool
otherwise
= TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (Bool -> Name -> String -> TcRnMessage
missingBootThing Bool
True Name
name String
"defined in")
where
name :: Name
name = AvailInfo -> Name
availName AvailInfo
boot_avail
mb_boot_thing :: Maybe TyThing
mb_boot_thing = TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
boot_type_env Name
name
missing_names :: [Name]
missing_names = case NameEnv AvailInfo -> Name -> Maybe AvailInfo
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv AvailInfo
local_export_env Name
name of
Maybe AvailInfo
Nothing -> [Name
name]
Just AvailInfo
avail -> AvailInfo -> [Name]
availNames AvailInfo
boot_avail [Name] -> [Name] -> [Name]
forall a. Ord a => [a] -> [a] -> [a]
`minusList` AvailInfo -> [Name]
availNames AvailInfo
avail
local_export_env :: NameEnv AvailInfo
local_export_env :: NameEnv AvailInfo
local_export_env = [AvailInfo] -> NameEnv AvailInfo
availsToNameEnv [AvailInfo]
local_exports
check_cls_inst :: DFunId -> TcM (Maybe (Id, Id))
check_cls_inst :: Var -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
check_cls_inst Var
boot_dfun
| (Var
real_dfun : [Var]
_) <- Var -> [Var]
find_real_dfun Var
boot_dfun
, let local_boot_dfun :: Var
local_boot_dfun = Name -> Type -> Var
Id.mkExportedVanillaId
(Var -> Name
idName Var
boot_dfun) (Var -> Type
idType Var
real_dfun)
= Maybe (Var, Var)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Var, Var) -> Maybe (Var, Var)
forall a. a -> Maybe a
Just (Var
local_boot_dfun, Var
real_dfun))
| Bool
otherwise
= SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
nameSrcSpan (Var -> Name
forall a. NamedThing a => a -> Name
getName Var
boot_dfun)) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var)))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"check_cls_inst" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"local_insts" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> (ClsInst -> Type) -> ClsInst -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Type
idType (Var -> Type) -> (ClsInst -> Var) -> ClsInst -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Var
instanceDFunId) [ClsInst]
local_insts)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"boot_dfun_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
idType Var
boot_dfun) ]
; TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (Var -> TcRnMessage
instMisMatch Var
boot_dfun)
; Maybe (Var, Var)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (Var, Var))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Var, Var)
forall a. Maybe a
Nothing }
find_real_dfun :: DFunId -> [DFunId]
find_real_dfun :: Var -> [Var]
find_real_dfun Var
boot_dfun
= [Var
dfun | ClsInst
inst <- [ClsInst]
local_insts
, let dfun :: Var
dfun = ClsInst -> Var
instanceDFunId ClsInst
inst
, Var -> Type
idType Var
dfun Type -> Type -> Bool
`eqType` Type
boot_dfun_ty ]
where
boot_dfun_ty :: Type
boot_dfun_ty = Var -> Type
idType Var
boot_dfun
checkBootDeclM :: Bool
-> TyThing -> TyThing -> TcM ()
checkBootDeclM :: Bool -> TyThing -> TyThing -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkBootDeclM Bool
is_boot TyThing
boot_thing TyThing
real_thing
= Maybe SDoc
-> (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Bool -> TyThing -> TyThing -> Maybe SDoc
checkBootDecl Bool
is_boot TyThing
boot_thing TyThing
real_thing) ((SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ \ SDoc
err ->
SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
span
(Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage
bootMisMatch Bool
is_boot SDoc
err TyThing
real_thing TyThing
boot_thing)
where
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 Var
id1) (AnId Var
id2)
= Bool -> Maybe SDoc -> Maybe SDoc
forall a. HasCallStack => Bool -> a -> a
assert (Var
id1 Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
id2) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> Maybe SDoc
check (Var -> Type
idType Var
id1 Type -> Type -> Bool
`eqType` Var -> Type
idType Var
id2)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The two types are different")
checkBootDecl Bool
is_boot (ATyCon TyCon
tc1) (ATyCon TyCon
tc2)
= Bool -> TyCon -> TyCon -> Maybe SDoc
checkBootTyCon Bool
is_boot TyCon
tc1 TyCon
tc2
checkBootDecl Bool
_ (AConLike (RealDataCon DataCon
dc1)) (AConLike (RealDataCon DataCon
_))
= String -> SDoc -> Maybe SDoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"checkBootDecl" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc1)
checkBootDecl Bool
_ TyThing
_ TyThing
_ = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
forall doc. IsOutput doc => doc
empty
andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
Maybe SDoc
Nothing andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck` Maybe SDoc
msg = Maybe SDoc
msg
Maybe SDoc
msg `andThenCheck` Maybe SDoc
Nothing = Maybe SDoc
msg
Just SDoc
d1 `andThenCheck` Just SDoc
d2 = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc
d1 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
d2)
infixr 0 `andThenCheck`
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 :: forall a.
(a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc -> Maybe SDoc
checkListBy a -> a -> Maybe SDoc
check_fun [a]
as [a]
bs SDoc
whats = [SDoc] -> [a] -> [a] -> Maybe SDoc
go [] [a]
as [a]
bs
where
herald :: SDoc
herald = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
whats SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"do not match"
go :: [SDoc] -> [a] -> [a] -> Maybe SDoc
go [] [] [] = Maybe SDoc
forall a. Maybe a
Nothing
go [SDoc]
docs [] [] = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Arity -> SDoc -> SDoc
hang (SDoc
herald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon) Arity
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse [SDoc]
docs))
go [SDoc]
docs (a
x:[a]
xs) (a
y:[a]
ys) = case a -> a -> Maybe SDoc
check_fun a
x a
y of
Just SDoc
doc -> [SDoc] -> [a] -> [a] -> Maybe SDoc
go (SDoc
docSDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:[SDoc]
docs) [a]
xs [a]
ys
Maybe SDoc
Nothing -> [SDoc] -> [a] -> [a] -> Maybe SDoc
go [SDoc]
docs [a]
xs [a]
ys
go [SDoc]
_ [a]
_ [a]
_ = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Arity -> SDoc -> SDoc
hang (SDoc
herald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)
Arity
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"There are different numbers of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
whats))
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
forall doc. IsLine doc => String -> doc
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 ([Var]
clas_tvs1, [FunDep Var]
clas_fds1, [Type]
sc_theta1, [Var]
_, [ClassATItem]
ats1, [ClassOpItem]
op_stuff1)
= Class
-> ([Var], [FunDep Var], [Type], [Var], [ClassATItem],
[ClassOpItem])
classExtraBigSig Class
c1
([Var]
clas_tvs2, [FunDep Var]
clas_fds2, [Type]
sc_theta2, [Var]
_, [ClassATItem]
ats2, [ClassOpItem]
op_stuff2)
= Class
-> ([Var], [FunDep Var], [Type], [Var], [ClassATItem],
[ClassOpItem])
classExtraBigSig Class
c2
, Just RnEnv2
env <- RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 [Var]
clas_tvs1 [Var]
clas_tvs2
= let
eqSig :: ClassOpItem -> ClassOpItem -> Maybe SDoc
eqSig (Var
id1, Maybe (Name, DefMethSpec Type)
def_meth1) (Var
id2, Maybe (Name, DefMethSpec Type)
def_meth2)
= Bool -> SDoc -> Maybe SDoc
check (Name
name1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name2)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The names" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"are different") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
op_ty1 Type
op_ty2)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The types of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"are different") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
if Bool
is_boot
then Bool -> SDoc -> Maybe SDoc
check (((Name, DefMethSpec Type) -> (Name, DefMethSpec Type) -> Bool)
-> Maybe (Name, DefMethSpec Type)
-> Maybe (Name, DefMethSpec Type)
-> Bool
forall a b. (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (Name, DefMethSpec Type) -> (Name, DefMethSpec Type) -> Bool
eqDM Maybe (Name, DefMethSpec Type)
def_meth1 Maybe (Name, DefMethSpec Type)
def_meth2)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The default methods associated with" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"are different")
else Bool -> SDoc -> Maybe SDoc
check (Type
-> Maybe (Name, DefMethSpec Type)
-> Maybe (Name, DefMethSpec Type)
-> Bool
subDM Type
op_ty1 Maybe (Name, DefMethSpec Type)
def_meth1 Maybe (Name, DefMethSpec Type)
def_meth2)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The default methods associated with" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"are not compatible")
where
name1 :: Name
name1 = Var -> Name
idName Var
id1
name2 :: Name
name2 = Var -> Name
idName Var
id2
pname1 :: SDoc
pname1 = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name1)
pname2 :: SDoc
pname2 = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name2)
op_ty1 :: Type
op_ty1 = Var -> Type
classMethodTy Var
id1
op_ty2 :: Type
op_ty2 = Var -> Type
classMethodTy Var
id2
eqAT :: ClassATItem -> ClassATItem -> Maybe SDoc
eqAT (ATI TyCon
tc1 Maybe (Type, ATValidityInfo)
def_ats1) (ATI TyCon
tc2 Maybe (Type, ATValidityInfo)
def_ats2)
= Bool -> TyCon -> TyCon -> Maybe SDoc
checkBootTyCon Bool
is_boot TyCon
tc1 TyCon
tc2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check (Maybe (Type, ATValidityInfo)
-> Maybe (Type, ATValidityInfo) -> Bool
eqATDef Maybe (Type, ATValidityInfo)
def_ats1 Maybe (Type, ATValidityInfo)
def_ats2)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The associated type defaults differ")
eqDM :: (Name, DefMethSpec Type) -> (Name, DefMethSpec Type) -> Bool
eqDM (Name
_, DefMethSpec Type
VanillaDM) (Name
_, DefMethSpec Type
VanillaDM) = Bool
True
eqDM (Name
_, GenericDM Type
t1) (Name
_, GenericDM Type
t2) = RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
eqDM (Name, DefMethSpec Type)
_ (Name, DefMethSpec Type)
_ = Bool
False
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
gdm_t1)) (Just (Name
_, DefMethSpec Type
VanillaDM))
= Type -> Type -> Bool
eqType Type
t1 Type
gdm_t1
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, ATValidityInfo)
-> Maybe (Type, ATValidityInfo) -> Bool
eqATDef Maybe (Type, ATValidityInfo)
Nothing Maybe (Type, ATValidityInfo)
Nothing = Bool
True
eqATDef (Just (Type
ty1, ATValidityInfo
_loc1)) (Just (Type
ty2, ATValidityInfo
_loc2)) = RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
ty1 Type
ty2
eqATDef Maybe (Type, ATValidityInfo)
_ Maybe (Type, ATValidityInfo)
_ = Bool
False
eqFD :: FunDep Var -> FunDep Var -> Bool
eqFD ([Var]
as1,[Var]
bs1) ([Var]
as2,[Var]
bs2) =
(Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env) ([Var] -> [Type]
mkTyVarTys [Var]
as1) ([Var] -> [Type]
mkTyVarTys [Var]
as2) Bool -> Bool -> Bool
&&
(Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env) ([Var] -> [Type]
mkTyVarTys [Var]
bs1) ([Var] -> [Type]
mkTyVarTys [Var]
bs2)
in
[Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 [Role]
roles2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check ((FunDep Var -> FunDep Var -> Bool)
-> [FunDep Var] -> [FunDep Var] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq FunDep Var -> FunDep Var -> Bool
eqFD [FunDep Var]
clas_fds1 [FunDep Var]
clas_fds2)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The functional dependencies do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> Maybe SDoc -> Maybe SDoc
checkUnless (TyCon -> Bool
isAbstractTyCon TyCon
tc1) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> Maybe SDoc
check ((Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env) [Type]
sc_theta1 [Type]
sc_theta2)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The class constraints do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
(ClassOpItem -> ClassOpItem -> Maybe SDoc)
-> [ClassOpItem] -> [ClassOpItem] -> SDoc -> Maybe SDoc
forall a.
(a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc -> Maybe SDoc
checkListBy ClassOpItem -> ClassOpItem -> Maybe SDoc
eqSig [ClassOpItem]
op_stuff1 [ClassOpItem]
op_stuff2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"methods") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
(ClassATItem -> ClassATItem -> Maybe SDoc)
-> [ClassATItem] -> [ClassATItem] -> SDoc -> Maybe SDoc
forall a.
(a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc -> Maybe SDoc
checkListBy ClassATItem -> ClassATItem -> Maybe SDoc
eqAT [ClassATItem]
ats1 [ClassATItem]
ats2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"associated types") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check (Class -> ClassMinimalDef
classMinimalDef Class
c1 ClassMinimalDef -> ClassMinimalDef -> Bool
forall a.
Uniquable a =>
BooleanFormula a -> BooleanFormula a -> Bool
`BF.implies` Class -> ClassMinimalDef
classMinimalDef Class
c2)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The MINIMAL pragmas are not compatible")
| Just Type
syn_rhs1 <- TyCon -> DFunInstType
synTyConRhs_maybe TyCon
tc1
, Just Type
syn_rhs2 <- TyCon -> DFunInstType
synTyConRhs_maybe TyCon
tc2
, Just RnEnv2
env <- RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 (TyCon -> [Var]
tyConTyVars TyCon
tc1) (TyCon -> [Var]
tyConTyVars TyCon
tc2)
= Bool -> Maybe SDoc -> Maybe SDoc
forall a. HasCallStack => Bool -> a -> a
assert (TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
[Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 [Role]
roles2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
syn_rhs1 Type
syn_rhs2) SDoc
forall doc. IsOutput doc => doc
empty
| Bool -> Bool
not Bool
is_boot
, TyCon -> Bool
isAbstractTyCon TyCon
tc1
, Just ([Var]
tvs, Type
ty) <- TyCon -> Maybe ([Var], Type)
synTyConDefn_maybe TyCon
tc2
, Just (TyCon
tc2', [Type]
args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
= [Var] -> Type -> TyCon -> [Type] -> Maybe SDoc
checkSynAbsData [Var]
tvs Type
ty TyCon
tc2' [Type]
args
| Bool -> Bool
not Bool
is_boot
, TyCon -> Bool
isAbstractTyCon TyCon
tc1
, Just ([Var]
_,Type
ty2) <- TyCon -> Maybe ([Var], Type)
synTyConDefn_maybe TyCon
tc2
, Maybe TyLit -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe TyLit
isLitTy Type
ty2)
= Maybe SDoc
forall a. Maybe a
Nothing
| Just FamTyConFlav
fam_flav1 <- TyCon -> Maybe FamTyConFlav
famTyConFlav_maybe TyCon
tc1
, Just FamTyConFlav
fam_flav2 <- TyCon -> Maybe FamTyConFlav
famTyConFlav_maybe TyCon
tc2
= Bool -> Maybe SDoc -> Maybe SDoc
forall a. HasCallStack => Bool -> a -> a
assert (TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
let eqFamFlav :: FamTyConFlav -> FamTyConFlav -> Bool
eqFamFlav FamTyConFlav
OpenSynFamilyTyCon FamTyConFlav
OpenSynFamilyTyCon = Bool
True
eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = Bool
True
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
forall doc. IsOutput doc => doc -> doc
whenPprDebug (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Family flavours" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FamTyConFlav -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamTyConFlav
fam_flav1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FamTyConFlav -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamTyConFlav
fam_flav2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check (Injectivity
injInfo1 Injectivity -> Injectivity -> Bool
forall a. Eq a => a -> a -> Bool
== Injectivity
injInfo2) (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Injectivities do not match")
| TyCon -> Bool
isAlgTyCon TyCon
tc1 Bool -> Bool -> Bool
&& TyCon -> Bool
isAlgTyCon TyCon
tc2
, Just RnEnv2
env <- RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 (TyCon -> [Var]
tyConTyVars TyCon
tc1) (TyCon -> [Var]
tyConTyVars TyCon
tc2)
= Bool -> Maybe SDoc -> Maybe SDoc
forall a. HasCallStack => Bool -> a -> a
assert (TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
[Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 [Role]
roles2 Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check ((Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env)
(TyCon -> [Type]
tyConStupidTheta TyCon
tc1) (TyCon -> [Type]
tyConStupidTheta TyCon
tc2))
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The datatype contexts do not match") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
TyCon -> AlgTyConRhs -> AlgTyConRhs -> Maybe SDoc
forall {p}. p -> AlgTyConRhs -> AlgTyConRhs -> Maybe SDoc
eqAlgRhs TyCon
tc1 (TyCon -> AlgTyConRhs
algTyConRhs TyCon
tc1) (TyCon -> AlgTyConRhs
algTyConRhs TyCon
tc2)
| Bool
otherwise = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
forall doc. IsOutput doc => doc
empty
where
roles1 :: [Role]
roles1 = TyCon -> [Role]
tyConRoles TyCon
tc1
roles2 :: [Role]
roles2 = TyCon -> [Role]
tyConRoles TyCon
tc2
roles_msg :: SDoc
roles_msg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The roles do not match." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Roles on abstract types default to" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"representational") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in boot files.")
roles_subtype_msg :: SDoc
roles_subtype_msg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The roles are not compatible:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Main module:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Role] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Role]
roles2 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Hsig file:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Role] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Role]
roles1
checkRoles :: [Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
r1 [Role]
r2
| Bool
is_boot Bool -> Bool -> Bool
|| TyCon -> Role -> Bool
isInjectiveTyCon TyCon
tc1 Role
Representational
= 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 :: [Var] -> Type -> TyCon -> [Type] -> Maybe SDoc
checkSynAbsData [Var]
tvs Type
ty TyCon
tc2' [Type]
args =
Bool -> SDoc -> Maybe SDoc
check ([(TyCon, [Type])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [(TyCon, [Type])]
tcTyFamInsts Type
ty))
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Illegal type family application in implementation of abstract data.")
Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check ([Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
tvs)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Illegal parameterized type synonym in implementation of abstract data." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(Try eta reducing your type synonym so that it is nullary.)")
Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> Maybe SDoc -> Maybe SDoc
checkUnless (Bool -> Bool
not ([Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
tvs)) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
Bool -> Maybe SDoc -> Maybe SDoc
forall a. HasCallStack => Bool -> a -> a
assert ([Role] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Role]
roles2) (Maybe SDoc -> Maybe SDoc) -> Maybe SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
[Role] -> [Role] -> Maybe SDoc
checkRoles [Role]
roles1 (Arity -> [Role] -> [Role]
forall a. Arity -> [a] -> [a]
drop ([Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
args) (TyCon -> [Role]
tyConRoles TyCon
tc2'))
eqAlgRhs :: p -> AlgTyConRhs -> AlgTyConRhs -> Maybe SDoc
eqAlgRhs p
_ (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
forall doc. IsLine doc => String -> doc
text String
"constructors")
eqAlgRhs p
_ tc1 :: AlgTyConRhs
tc1@NewTyCon{} tc2 :: AlgTyConRhs
tc2@NewTyCon{} =
DataCon -> DataCon -> Maybe SDoc
eqCon (AlgTyConRhs -> DataCon
data_con AlgTyConRhs
tc1) (AlgTyConRhs -> DataCon
data_con AlgTyConRhs
tc2)
eqAlgRhs p
_ AlgTyConRhs
_ AlgTyConRhs
_ = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Cannot match a" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"data") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"definition with a" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"newtype") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"definition")
eqCon :: DataCon -> DataCon -> Maybe SDoc
eqCon DataCon
c1 DataCon
c2
= Bool -> SDoc -> Maybe SDoc
check (Name
name1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name2)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The names" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check (DataCon -> Bool
dataConIsInfix DataCon
c1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Bool
dataConIsInfix DataCon
c2)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The fixities of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check ((HsImplBang -> HsImplBang -> Bool)
-> [HsImplBang] -> [HsImplBang] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq HsImplBang -> HsImplBang -> Bool
eqHsBang (DataCon -> [HsImplBang]
dataConImplBangs DataCon
c1) (DataCon -> [HsImplBang]
dataConImplBangs DataCon
c2))
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The strictness annotations for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check ((FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
c1) [Name] -> [Name] -> Bool
forall a. Eq a => a -> a -> Bool
== (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
c2))
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The record label lists for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"differ") Maybe SDoc -> Maybe SDoc -> Maybe SDoc
`andThenCheck`
Bool -> SDoc -> Maybe SDoc
check (Type -> Type -> Bool
eqType (DataCon -> Type
dataConWrapperType DataCon
c1) (DataCon -> Type
dataConWrapperType DataCon
c2))
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The types for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pname1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"differ")
where
name1 :: Name
name1 = DataCon -> Name
dataConName DataCon
c1
name2 :: Name
name2 = DataCon -> Name
dataConName DataCon
c2
pname1 :: SDoc
pname1 = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name1)
pname2 :: SDoc
pname2 = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name2)
eqClosedFamilyAx :: Maybe (CoAxiom br) -> Maybe (CoAxiom br) -> Bool
eqClosedFamilyAx Maybe (CoAxiom br)
Nothing Maybe (CoAxiom br)
Nothing = Bool
True
eqClosedFamilyAx Maybe (CoAxiom br)
Nothing (Just CoAxiom br
_) = Bool
False
eqClosedFamilyAx (Just CoAxiom br
_) Maybe (CoAxiom br)
Nothing = Bool
False
eqClosedFamilyAx (Just (CoAxiom { co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
co_ax_branches = Branches br
branches1 }))
(Just (CoAxiom { co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
co_ax_branches = Branches br
branches2 }))
= Branches br -> Arity
forall (br :: BranchFlag). Branches br -> Arity
numBranches Branches br
branches1 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Branches br -> Arity
forall (br :: BranchFlag). Branches br -> Arity
numBranches Branches br
branches2
Bool -> Bool -> Bool
&& ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (CoAxBranch -> CoAxBranch -> Bool)
-> [CoAxBranch] -> [CoAxBranch] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CoAxBranch -> CoAxBranch -> Bool
eqClosedFamilyBranch [CoAxBranch]
branch_list1 [CoAxBranch]
branch_list2)
where
branch_list1 :: [CoAxBranch]
branch_list1 = Branches br -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches Branches br
branches1
branch_list2 :: [CoAxBranch]
branch_list2 = Branches br -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches Branches br
branches2
eqClosedFamilyBranch :: CoAxBranch -> CoAxBranch -> Bool
eqClosedFamilyBranch (CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs1, cab_cvs :: CoAxBranch -> [Var]
cab_cvs = [Var]
cvs1
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs1, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs1 })
(CoAxBranch { cab_tvs :: CoAxBranch -> [Var]
cab_tvs = [Var]
tvs2, cab_cvs :: CoAxBranch -> [Var]
cab_cvs = [Var]
cvs2
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs2, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs2 })
| Just RnEnv2
env1 <- RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
eqVarBndrs RnEnv2
emptyRnEnv2 [Var]
tvs1 [Var]
tvs2
, Just RnEnv2
env <- RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
eqVarBndrs RnEnv2
env1 [Var]
cvs1 [Var]
cvs2
= (Type -> Type -> Bool) -> [Type] -> [Type] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env) [Type]
lhs1 [Type]
lhs2 Bool -> Bool -> Bool
&&
RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
rhs1 Type
rhs2
| Bool
otherwise = Bool
False
emptyRnEnv2 :: RnEnv2
emptyRnEnv2 :: RnEnv2
emptyRnEnv2 = InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
emptyInScopeSet
missingBootThing :: Bool -> Name -> String -> TcRnMessage
missingBootThing :: Bool -> Name -> String -> TcRnMessage
missingBootThing Bool
is_boot Name
name String
what
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is exported by the"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (if Bool
is_boot then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs-boot" else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hsig")
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"file, but not"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the module"
badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage
badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage
badReexportedBootThing Bool
is_boot Name
name Name
name'
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
NamePprCtx -> Depth -> SDoc -> SDoc
withUserStyle NamePprCtx
alwaysQualify Depth
AllTheWay (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (if Bool
is_boot then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs-boot" else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hsig")
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"file (re)exports" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"but the implementing module exports a different identifier" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name')
]
bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage
bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage
bootMisMatch Bool
is_boot SDoc
extra_info TyThing
real_thing TyThing
boot_thing
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
pprBootMisMatch Bool
is_boot SDoc
extra_info TyThing
real_thing SDoc
real_doc SDoc
boot_doc
where
to_doc :: TyThing -> SDoc
to_doc
= ShowSub -> TyThing -> SDoc
pprTyThingInContext (ShowSub -> TyThing -> SDoc) -> ShowSub -> TyThing -> SDoc
forall a b. (a -> b) -> a -> b
$ ShowSub
showToHeader { ss_forall =
if is_boot
then ShowForAllMust
else ShowForAllWhen }
real_doc :: SDoc
real_doc = TyThing -> SDoc
to_doc TyThing
real_thing
boot_doc :: SDoc
boot_doc = TyThing -> SDoc
to_doc TyThing
boot_thing
pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
pprBootMisMatch Bool
is_boot SDoc
extra_info TyThing
real_thing SDoc
real_doc SDoc
boot_doc
= [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
real_thing SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has conflicting definitions in the module",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and its" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
(if Bool
is_boot
then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs-boot file"
else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hsig file"),
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Main module:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
real_doc,
(if Bool
is_boot
then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Boot file: "
else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Hsig file: ")
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
boot_doc,
SDoc
extra_info
]
instMisMatch :: DFunId -> TcRnMessage
instMisMatch :: Var -> TcRnMessage
instMisMatch Var
dfun
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"instance" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
idType Var
dfun))
Arity
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is defined in the hs-boot file, but not in the module itself")
rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
rnTopSrcDecls HsGroup GhcPs
group
= do {
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn12" SDoc
forall doc. IsOutput doc => doc
empty ;
(TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls) <- TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall r. TcM r -> TcM r
checkNoErrs (TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed)))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ HsGroup GhcPs -> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
rnSrcDecls HsGroup GhcPs
group ;
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn13" SDoc
forall doc. IsOutput doc => doc
empty ;
(TcGblEnv
tcg_env, HsGroup (GhcPass 'Renamed)
rn_decls) <- TcGblEnv
-> HsGroup (GhcPass 'Renamed)
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
runRenamerPlugin TcGblEnv
tcg_env HsGroup (GhcPass 'Renamed)
rn_decls ;
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rn13-plugin" SDoc
forall doc. IsOutput doc => doc
empty ;
let { tcg_env' :: TcGblEnv
tcg_env'
| Just HsGroup (GhcPass 'Renamed)
grp <- TcGblEnv -> Maybe (HsGroup (GhcPass 'Renamed))
tcg_rn_decls TcGblEnv
tcg_env
= TcGblEnv
tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
| Bool
otherwise
= TcGblEnv
tcg_env };
HsGroup (GhcPass 'Renamed) -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a.
(Outputable a, Data a) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) ()
rnDump HsGroup (GhcPass 'Renamed)
rn_decls ;
(TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env', HsGroup (GhcPass 'Renamed)
rn_decls)
}
tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls :: HsGroup (GhcPass 'Renamed)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopSrcDecls (HsGroup { hs_tyclds :: forall p. HsGroup p -> [TyClGroup p]
hs_tyclds = [TyClGroup (GhcPass 'Renamed)]
tycl_decls,
hs_derivds :: forall p. HsGroup p -> [LDerivDecl p]
hs_derivds = [LDerivDecl (GhcPass 'Renamed)]
deriv_decls,
hs_fords :: forall p. HsGroup p -> [LForeignDecl p]
hs_fords = [LForeignDecl (GhcPass 'Renamed)]
foreign_decls,
hs_defds :: forall p. HsGroup p -> [LDefaultDecl p]
hs_defds = [LDefaultDecl (GhcPass 'Renamed)]
default_decls,
hs_annds :: forall p. HsGroup p -> [LAnnDecl p]
hs_annds = [LAnnDecl (GhcPass 'Renamed)]
annotation_decls,
hs_ruleds :: forall p. HsGroup p -> [LRuleDecls p]
hs_ruleds = [LRuleDecls (GhcPass 'Renamed)]
rule_decls,
hs_valds :: forall p. HsGroup p -> HsValBinds p
hs_valds = hs_val_binds :: HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
hs_val_binds@(XValBindsLR
(NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds [LSig (GhcPass 'Renamed)]
val_sigs)) })
= do {
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc2 (src)" SDoc
forall doc. IsOutput doc => doc
empty ;
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc3" SDoc
forall doc. IsOutput doc => doc
empty ;
(TcGblEnv
tcg_env, [InstInfo (GhcPass 'Renamed)]
inst_infos, ThBindEnv
th_bndrs,
XValBindsLR (NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
deriv_binds [LSig (GhcPass 'Renamed)]
deriv_sigs))
<- [TyClGroup (GhcPass 'Renamed)]
-> [LDerivDecl (GhcPass 'Renamed)]
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
tcTyClsInstDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls [LDerivDecl (GhcPass 'Renamed)]
deriv_decls [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds ;
(TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
tcl_env -> TcLclEnv
tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$
TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc3b" SDoc
forall doc. IsOutput doc => doc
empty ;
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc3c" SDoc
forall doc. IsOutput doc => doc
empty ;
IOEnv (Env TcGblEnv TcLclEnv) ()
tcSemigroupWarnings ;
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc4" SDoc
forall doc. IsOutput doc => doc
empty ;
([Var]
fi_ids, [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
fi_decls, Bag GlobalRdrElt
fi_gres) <- [LForeignDecl (GhcPass 'Renamed)]
-> TcM ([Var], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports [LForeignDecl (GhcPass 'Renamed)]
foreign_decls ;
[Var]
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv [Var]
fi_ids (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc4a" SDoc
forall doc. IsOutput doc => doc
empty ;
Maybe [Type]
default_tys <- [LDefaultDecl (GhcPass 'Renamed)] -> TcM (Maybe [Type])
tcDefaults [LDefaultDecl (GhcPass 'Renamed)]
default_decls ;
(TcGblEnv -> TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
gbl -> TcGblEnv
gbl { tcg_default = default_tys }) (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc5" SDoc
forall doc. IsOutput doc => doc
empty ;
(TcGblEnv, TcLclEnv)
tc_envs <- [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)]
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
val_binds [LSig (GhcPass 'Renamed)]
val_sigs;
(TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv, TcLclEnv)
tc_envs (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {
tc_envs :: (TcGblEnv, TcLclEnv)
tc_envs@(TcGblEnv
tcg_env, TcLclEnv
tcl_env)
<- TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall r. TcM r -> TcM r
discardWarnings ([(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)]
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
tcTopBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
deriv_binds [LSig (GhcPass 'Renamed)]
deriv_sigs) ;
(TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv, TcLclEnv)
tc_envs (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv))
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a b. (a -> b) -> a -> b
$ do {
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc6" SDoc
forall doc. IsOutput doc => doc
empty ;
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
inst_binds <- [LTyClDecl (GhcPass 'Renamed)]
-> [InstInfo (GhcPass 'Renamed)] -> TcM (LHsBinds GhcTc)
tcInstDecls2 ([TyClGroup (GhcPass 'Renamed)] -> [LTyClDecl (GhcPass 'Renamed)]
forall pass. [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls) [InstInfo (GhcPass 'Renamed)]
inst_infos ;
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc7" SDoc
forall doc. IsOutput doc => doc
empty ;
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
foe_binds, [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
foe_decls, Bag GlobalRdrElt
foe_gres) <- [LForeignDecl (GhcPass 'Renamed)]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports [LForeignDecl (GhcPass 'Renamed)]
foreign_decls ;
[Annotation]
annotations <- [LAnnDecl (GhcPass 'Renamed)] -> TcM [Annotation]
tcAnnotations [LAnnDecl (GhcPass 'Renamed)]
annotation_decls ;
[GenLocated SrcSpanAnnA (RuleDecls GhcTc)]
rules <- [LRuleDecls (GhcPass 'Renamed)] -> TcM [LRuleDecls GhcTc]
tcRules [LRuleDecls (GhcPass 'Renamed)]
rule_decls ;
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Tc7a" SDoc
forall doc. IsOutput doc => doc
empty ;
let { all_binds :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
all_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
inst_binds Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a -> Bag a -> Bag a
`unionBags`
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
foe_binds
; fo_gres :: Bag GlobalRdrElt
fo_gres = Bag GlobalRdrElt
fi_gres Bag GlobalRdrElt -> Bag GlobalRdrElt -> Bag GlobalRdrElt
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag GlobalRdrElt
foe_gres
; fo_fvs :: FreeVars
fo_fvs = (GlobalRdrElt -> FreeVars -> FreeVars)
-> FreeVars -> Bag GlobalRdrElt -> FreeVars
forall a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\GlobalRdrElt
gre FreeVars
fvs -> FreeVars
fvs FreeVars -> Name -> FreeVars
`addOneFV` GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)
FreeVars
emptyFVs Bag GlobalRdrElt
fo_gres
; sig_names :: FreeVars
sig_names = [Name] -> FreeVars
mkNameSet (CollectFlag (GhcPass 'Renamed)
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> [IdP (GhcPass 'Renamed)]
forall (idL :: Pass) idR.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)]
collectHsValBinders CollectFlag (GhcPass 'Renamed)
forall p. CollectFlag p
CollNoDictBinders HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
hs_val_binds)
FreeVars -> FreeVars -> FreeVars
`minusNameSet` [LSig (GhcPass 'Renamed)] -> FreeVars
getTypeSigNames [LSig (GhcPass 'Renamed)]
val_sigs
; tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
, tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names
, tcg_rules = tcg_rules tcg_env
++ flattenRuleDecls rules
, tcg_anns = tcg_anns tcg_env ++ annotations
, tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
, tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls
, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
[GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
addUsedGREs (Bag GlobalRdrElt -> [GlobalRdrElt]
forall a. Bag a -> [a]
bagToList Bag GlobalRdrElt
fo_gres) ;
(TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env', TcLclEnv
tcl_env)
}}}}}}
tcTopSrcDecls HsGroup (GhcPass 'Renamed)
_ = String -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall a. HasCallStack => String -> a
panic String
"tcTopSrcDecls: ValBindsIn"
tcSemigroupWarnings :: TcM ()
tcSemigroupWarnings :: IOEnv (Env TcGblEnv TcLclEnv) ()
tcSemigroupWarnings = do
Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
primUnit) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcSemigroupWarnings" SDoc
forall doc. IsOutput doc => doc
empty
let warnFlag :: WarningFlag
warnFlag = WarningFlag
Opt_WarnSemigroup
WarningFlag -> Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcPreludeClashWarn WarningFlag
warnFlag Name
sappendName
WarningFlag -> Name -> Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcMissingParentClassWarn WarningFlag
warnFlag Name
monoidClassName Name
semigroupClassName
tcPreludeClashWarn :: WarningFlag
-> Name
-> TcM ()
tcPreludeClashWarn :: WarningFlag -> Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcPreludeClashWarn WarningFlag
warnFlag Name
name = do
{ Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
warnFlag
; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
{ String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcPreludeClashWarn/wouldBeImported" SDoc
forall doc. IsOutput doc => doc
empty
; [ImportDecl (GhcPass 'Renamed)]
rnImports <- (TcGblEnv -> [ImportDecl (GhcPass 'Renamed)])
-> TcM TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) [ImportDecl (GhcPass 'Renamed)]
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))
-> ImportDecl (GhcPass 'Renamed))
-> [GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))]
-> [ImportDecl (GhcPass 'Renamed)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))
-> ImportDecl (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc ([GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))]
-> [ImportDecl (GhcPass 'Renamed)])
-> (TcGblEnv
-> [GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))])
-> TcGblEnv
-> [ImportDecl (GhcPass 'Renamed)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> [LImportDecl (GhcPass 'Renamed)]
TcGblEnv
-> [GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))]
tcg_rn_imports) TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> [ImportDecl (GhcPass 'Renamed)] -> Bool
importedViaPrelude Name
name [ImportDecl (GhcPass 'Renamed)]
rnImports) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
{ [GlobalRdrElt]
rdrElts <- (TcGblEnv -> [GlobalRdrElt])
-> TcM TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) [GlobalRdrElt]
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([[GlobalRdrElt]] -> [GlobalRdrElt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[GlobalRdrElt]] -> [GlobalRdrElt])
-> (TcGblEnv -> [[GlobalRdrElt]]) -> TcGblEnv -> [GlobalRdrElt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrEnv -> [[GlobalRdrElt]]
forall a. OccEnv a -> [a]
nonDetOccEnvElts (GlobalRdrEnv -> [[GlobalRdrElt]])
-> (TcGblEnv -> GlobalRdrEnv) -> TcGblEnv -> [[GlobalRdrElt]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> GlobalRdrEnv
tcg_rdr_env) TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let clashes :: GlobalRdrElt -> Bool
clashes :: GlobalRdrElt -> Bool
clashes GlobalRdrElt
x = Bool
isLocalDef Bool -> Bool -> Bool
&& Bool
nameClashes Bool -> Bool -> Bool
&& Bool
isNotInProperModule
where
isLocalDef :: Bool
isLocalDef = GlobalRdrElt -> Bool
gre_lcl GlobalRdrElt
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True
nameClashes :: Bool
nameClashes = Name -> OccName
nameOccName (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
x) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> OccName
nameOccName Name
name
isNotInProperModule :: Bool
isNotInProperModule = GlobalRdrElt -> Name
greMangledName 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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcPreludeClashWarn/prelude_functions"
(SDoc -> Arity -> SDoc -> SDoc
hang (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) Arity
4 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [[GlobalRdrElt] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GlobalRdrElt]
clashingElts]))
; let warn_msg :: GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn_msg GlobalRdrElt
x = SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticAt (Name -> SrcSpan
nameSrcSpan (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
x)) (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
warnFlag) [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Local definition of"
, (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (GlobalRdrElt -> SDoc) -> GlobalRdrElt -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc)
-> (GlobalRdrElt -> OccName) -> GlobalRdrElt -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName)
-> (GlobalRdrElt -> Name) -> GlobalRdrElt -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrElt -> Name
greMangledName) GlobalRdrElt
x
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"clashes with a future Prelude name." ]
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"This will become an error in a future release." )
; (GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [GlobalRdrElt] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GlobalRdrElt -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn_msg [GlobalRdrElt]
clashingElts
}}}
where
importedViaPrelude :: Name
-> [ImportDecl GhcRn]
-> Bool
importedViaPrelude :: Name -> [ImportDecl (GhcPass 'Renamed)] -> Bool
importedViaPrelude Name
name = (ImportDecl (GhcPass 'Renamed) -> Bool)
-> [ImportDecl (GhcPass 'Renamed)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ImportDecl (GhcPass 'Renamed) -> Bool
importViaPrelude
where
isPrelude :: ImportDecl GhcRn -> Bool
isPrelude :: ImportDecl (GhcPass 'Renamed) -> Bool
isPrelude ImportDecl (GhcPass 'Renamed)
imp = GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl (GhcPass 'Renamed) -> XRec (GhcPass 'Renamed) ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl (GhcPass 'Renamed)
imp) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME
isImplicit :: ImportDecl GhcRn -> Bool
isImplicit :: ImportDecl (GhcPass 'Renamed) -> Bool
isImplicit = XImportDeclPass -> Bool
ideclImplicit (XImportDeclPass -> Bool)
-> (ImportDecl (GhcPass 'Renamed) -> XImportDeclPass)
-> ImportDecl (GhcPass 'Renamed)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl (GhcPass 'Renamed) -> XCImportDecl (GhcPass 'Renamed)
ImportDecl (GhcPass 'Renamed) -> XImportDeclPass
forall pass. ImportDecl pass -> XCImportDecl pass
ideclExt
isUnqualified :: ImportDecl GhcRn -> Bool
isUnqualified :: ImportDecl (GhcPass 'Renamed) -> Bool
isUnqualified = Bool -> Bool
not (Bool -> Bool)
-> (ImportDecl (GhcPass 'Renamed) -> Bool)
-> ImportDecl (GhcPass 'Renamed)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDeclQualifiedStyle -> Bool
isImportDeclQualified (ImportDeclQualifiedStyle -> Bool)
-> (ImportDecl (GhcPass 'Renamed) -> ImportDeclQualifiedStyle)
-> ImportDecl (GhcPass 'Renamed)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl (GhcPass 'Renamed) -> ImportDeclQualifiedStyle
forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified
importListOf :: ImportDecl GhcRn -> Maybe (ImportListInterpretation, [Name])
importListOf :: ImportDecl (GhcPass 'Renamed)
-> Maybe (ImportListInterpretation, [Name])
importListOf = ((ImportListInterpretation,
GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
-> (ImportListInterpretation, [Name]))
-> Maybe
(ImportListInterpretation,
GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
-> Maybe (ImportListInterpretation, [Name])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ImportListInterpretation,
GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
-> (ImportListInterpretation, [Name])
(ImportListInterpretation,
GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
-> (ImportListInterpretation, [IdGhcP 'Renamed])
forall {a} {l} {l} {p :: Pass}.
(a, GenLocated l [GenLocated l (IE (GhcPass p))])
-> (a, [IdGhcP p])
toImportList (Maybe
(ImportListInterpretation,
GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
-> Maybe (ImportListInterpretation, [Name]))
-> (ImportDecl (GhcPass 'Renamed)
-> Maybe
(ImportListInterpretation,
GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))]))
-> ImportDecl (GhcPass 'Renamed)
-> Maybe (ImportListInterpretation, [Name])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl (GhcPass 'Renamed)
-> Maybe
(ImportListInterpretation,
XRec (GhcPass 'Renamed) [LIE (GhcPass 'Renamed)])
ImportDecl (GhcPass 'Renamed)
-> Maybe
(ImportListInterpretation,
GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed))])
forall pass.
ImportDecl pass
-> Maybe (ImportListInterpretation, XRec pass [LIE pass])
ideclImportList
where
toImportList :: (a, GenLocated l [GenLocated l (IE (GhcPass p))])
-> (a, [IdGhcP p])
toImportList (a
h, GenLocated l [GenLocated l (IE (GhcPass p))]
loc) = (a
h, (GenLocated l (IE (GhcPass p)) -> IdGhcP p)
-> [GenLocated l (IE (GhcPass p))] -> [IdGhcP p]
forall a b. (a -> b) -> [a] -> [b]
map (IE (GhcPass p) -> IdP (GhcPass p)
IE (GhcPass p) -> IdGhcP p
forall (p :: Pass). IE (GhcPass p) -> IdP (GhcPass p)
ieName (IE (GhcPass p) -> IdGhcP p)
-> (GenLocated l (IE (GhcPass p)) -> IE (GhcPass p))
-> GenLocated l (IE (GhcPass p))
-> IdGhcP p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated l (IE (GhcPass p)) -> IE (GhcPass p)
forall l e. GenLocated l e -> e
unLoc) (GenLocated l [GenLocated l (IE (GhcPass p))]
-> [GenLocated l (IE (GhcPass p))]
forall l e. GenLocated l e -> e
unLoc GenLocated l [GenLocated l (IE (GhcPass p))]
loc))
isExplicit :: ImportDecl GhcRn -> Bool
isExplicit :: ImportDecl (GhcPass 'Renamed) -> Bool
isExplicit ImportDecl (GhcPass 'Renamed)
x = case ImportDecl (GhcPass 'Renamed)
-> Maybe (ImportListInterpretation, [Name])
importListOf ImportDecl (GhcPass 'Renamed)
x of
Maybe (ImportListInterpretation, [Name])
Nothing -> Bool
False
Just (ImportListInterpretation
Exactly, [Name]
explicit)
-> Name -> OccName
nameOccName Name
name OccName -> [OccName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Name -> OccName) -> [Name] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Name -> OccName
nameOccName [Name]
explicit
Just (ImportListInterpretation
EverythingBut, [Name]
hidden)
-> Name -> OccName
nameOccName Name
name OccName -> [OccName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Name -> OccName) -> [Name] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map Name -> OccName
nameOccName [Name]
hidden
importViaPrelude :: ImportDecl GhcRn -> Bool
importViaPrelude :: ImportDecl (GhcPass 'Renamed) -> Bool
importViaPrelude ImportDecl (GhcPass 'Renamed)
x = ImportDecl (GhcPass 'Renamed) -> Bool
isPrelude ImportDecl (GhcPass 'Renamed)
x
Bool -> Bool -> Bool
&& ImportDecl (GhcPass 'Renamed) -> Bool
isUnqualified ImportDecl (GhcPass 'Renamed)
x
Bool -> Bool -> Bool
&& (ImportDecl (GhcPass 'Renamed) -> Bool
isImplicit ImportDecl (GhcPass 'Renamed)
x Bool -> Bool -> Bool
|| ImportDecl (GhcPass 'Renamed) -> Bool
isExplicit ImportDecl (GhcPass 'Renamed)
x)
tcMissingParentClassWarn :: WarningFlag
-> Name
-> Name
-> TcM ()
tcMissingParentClassWarn :: WarningFlag -> Name -> Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcMissingParentClassWarn WarningFlag
warnFlag Name
isName Name
shouldName
= do { Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
warnFlag
; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
{ String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcMissingParentClassWarn" SDoc
forall doc. IsOutput doc => doc
empty
; Maybe Class
isClass' <- Name -> TcM (Maybe Class)
tcLookupClass_maybe Name
isName
; Maybe Class
shouldClass' <- Name -> TcM (Maybe Class)
tcLookupClass_maybe Name
shouldName
; case (Maybe Class
isClass', Maybe Class
shouldClass') of
(Just Class
isClass, Just Class
shouldClass) -> do
{ [ClsInst]
localInstances <- TcM [ClsInst]
tcGetInsts
; let isInstance :: ClsInst -> Bool
isInstance ClsInst
m = ClsInst -> Class
is_cls ClsInst
m Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
isClass
isInsts :: [ClsInst]
isInsts = (ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filter ClsInst -> Bool
isInstance [ClsInst]
localInstances
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcMissingParentClassWarn/isInsts" ([ClsInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ClsInst]
isInsts)
; [ClsInst]
-> (ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ClsInst]
isInsts (Class -> Class -> ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShouldInst Class
isClass Class
shouldClass)
}
(Maybe Class
is',Maybe Class
should') ->
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcMissingParentClassWarn/notIsShould"
(SDoc -> Arity -> SDoc -> SDoc
hang (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
isName SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"/" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
shouldName) Arity
2 (
([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Is"), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"lookup for"
, Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
isName
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"resulted in", Maybe Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Class
is' ])
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Should"), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"lookup for"
, Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
shouldName
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"resulted in", Maybe Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Class
should' ])))
}}
where
checkShouldInst :: Class
-> Class
-> ClsInst
-> TcM ()
checkShouldInst :: Class -> Class -> ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkShouldInst Class
isClass Class
shouldClass ClsInst
isInst
= do { InstEnvs
instEnv <- TcM InstEnvs
tcGetInstEnvs
; let ([InstMatch]
instanceMatches, PotentialUnifiers
shouldInsts, [InstMatch]
_)
= Bool
-> InstEnvs
-> Class
-> [Type]
-> ([InstMatch], PotentialUnifiers, [InstMatch])
lookupInstEnv Bool
False InstEnvs
instEnv Class
shouldClass (ClsInst -> [Type]
is_tys ClsInst
isInst)
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcMissingParentClassWarn/checkShouldInst"
(SDoc -> Arity -> SDoc -> SDoc
hang (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
isInst) Arity
4
([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [[InstMatch] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstMatch]
instanceMatches, PotentialUnifiers -> SDoc
forall a. Outputable a => a -> SDoc
ppr PotentialUnifiers
shouldInsts]))
; let instLoc :: SrcSpan
instLoc = SrcLoc -> SrcSpan
srcLocSpan (SrcLoc -> SrcSpan) -> (Name -> SrcLoc) -> Name -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SrcLoc
nameSrcLoc (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ ClsInst -> Name
forall a. NamedThing a => a -> Name
getName ClsInst
isInst
warnMsg :: [RoughMatchTc] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnMsg (RM_KnownTc Name
name:[RoughMatchTc]
_) =
SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticAt SrcSpan
instLoc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
warnFlag) [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (Name -> SDoc) -> Name -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc) -> (Name -> OccName) -> Name -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) Name
name
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is an instance of"
, (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc) -> (Class -> OccName) -> Class -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (Class -> Name) -> Class -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Name
className) Class
isClass
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"but not"
, (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc) -> (Class -> OccName) -> Class -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (Class -> Name) -> Class -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Name
className) Class
shouldClass ]
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"."
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"This will become an error in"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a future release." ]
warnMsg [RoughMatchTc]
_ = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PotentialUnifiers -> Bool
nullUnifiers PotentialUnifiers
shouldInsts Bool -> Bool -> Bool
&& [InstMatch] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstMatch]
instanceMatches) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
[RoughMatchTc] -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnMsg (ClsInst -> [RoughMatchTc]
is_tcs ClsInst
isInst)
}
tcLookupClass_maybe :: Name -> TcM (Maybe Class)
tcLookupClass_maybe :: Name -> TcM (Maybe Class)
tcLookupClass_maybe Name
name = Name -> TcM (MaybeErr SDoc TyThing)
tcLookupImported_maybe Name
name TcM (MaybeErr SDoc TyThing)
-> (MaybeErr SDoc TyThing -> TcM (Maybe Class))
-> TcM (Maybe Class)
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Succeeded (ATyCon TyCon
tc) | cls :: Maybe Class
cls@(Just Class
_) <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc -> Maybe Class -> TcM (Maybe Class)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Class
cls
MaybeErr SDoc TyThing
_else -> Maybe Class -> TcM (Maybe Class)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Class
forall a. Maybe a
Nothing
tcTyClsInstDecls :: [TyClGroup GhcRn]
-> [LDerivDecl GhcRn]
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM (TcGblEnv,
[InstInfo GhcRn],
ThBindEnv,
HsValBinds GhcRn)
tcTyClsInstDecls :: [TyClGroup (GhcPass 'Renamed)]
-> [LDerivDecl (GhcPass 'Renamed)]
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
tcTyClsInstDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls [LDerivDecl (GhcPass 'Renamed)]
deriv_decls [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds
= [LInstDecl (GhcPass 'Renamed)]
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a. [LInstDecl (GhcPass 'Renamed)] -> TcM a -> TcM a
tcAddDataFamConPlaceholders ([TyClGroup (GhcPass 'Renamed)]
tycl_decls [TyClGroup (GhcPass 'Renamed)]
-> (TyClGroup (GhcPass 'Renamed)
-> [GenLocated SrcSpanAnnA (InstDecl (GhcPass 'Renamed))])
-> [GenLocated SrcSpanAnnA (InstDecl (GhcPass 'Renamed))]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TyClGroup (GhcPass 'Renamed) -> [LInstDecl (GhcPass 'Renamed)]
TyClGroup (GhcPass 'Renamed)
-> [GenLocated SrcSpanAnnA (InstDecl (GhcPass 'Renamed))]
forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds) (TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$
[PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a.
[PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
-> TcM a -> TcM a
tcAddPatSynPlaceholders ([(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
forall id.
UnXRec id =>
[(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds) (TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$
do { (TcGblEnv
tcg_env, [InstInfo (GhcPass 'Renamed)]
inst_info, [DerivInfo]
deriv_info, ThBindEnv
th_bndrs)
<- [TyClGroup (GhcPass 'Renamed)]
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], [DerivInfo], ThBindEnv)
tcTyAndClassDecls [TyClGroup (GhcPass 'Renamed)]
tycl_decls ;
; TcGblEnv
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ do {
; IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM
; (TcGblEnv
tcg_env', [InstInfo (GhcPass 'Renamed)]
inst_info', HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
val_binds)
<- [DerivInfo]
-> [LDerivDecl (GhcPass 'Renamed)]
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)],
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
tcInstDeclsDeriv [DerivInfo]
deriv_info [LDerivDecl (GhcPass 'Renamed)]
deriv_decls
; TcGblEnv
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env' (TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ do {
IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM
; (TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], ThBindEnv,
HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( TcGblEnv
tcg_env', [InstInfo (GhcPass 'Renamed)]
inst_info' [InstInfo (GhcPass 'Renamed)]
-> [InstInfo (GhcPass 'Renamed)] -> [InstInfo (GhcPass 'Renamed)]
forall a. [a] -> [a] -> [a]
++ [InstInfo (GhcPass 'Renamed)]
inst_info, ThBindEnv
th_bndrs, HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
val_binds )
}}}
checkMainType :: TcGblEnv -> TcRn WantedConstraints
checkMainType :: TcGblEnv -> TcRn WantedConstraints
checkMainType TcGblEnv
tcg_env
= do { HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; if TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= HomeUnitEnv -> Module
mainModIs (HscEnv -> HomeUnitEnv
hsc_HUE HscEnv
hsc_env)
then WantedConstraints -> TcRn WantedConstraints
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
emptyWC else
do { GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
main_occ :: OccName
main_occ = DynFlags -> OccName
getMainOcc DynFlags
dflags
main_gres :: [GlobalRdrElt]
main_gres = GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
rdr_env OccName
main_occ
; case (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
isLocalGRE [GlobalRdrElt]
main_gres of {
[] -> WantedConstraints -> TcRn WantedConstraints
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
emptyWC ;
(GlobalRdrElt
_:GlobalRdrElt
_:[GlobalRdrElt]
_) -> WantedConstraints -> TcRn WantedConstraints
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
emptyWC ;
[GlobalRdrElt
main_gre] ->
do { let main_name :: Name
main_name = GlobalRdrElt -> Name
greMangledName GlobalRdrElt
main_gre
ctxt :: UserTypeCtxt
ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
main_name ReportRedundantConstraints
NoRRC
; Var
main_id <- Name -> TcM Var
tcLookupId Name
main_name
; (Type
io_ty,Type
_) <- TcM (Type, Type)
getIOType
; let main_ty :: Type
main_ty = Var -> Type
idType Var
main_id
eq_orig :: CtOrigin
eq_orig = TypeEqOrigin { uo_actual :: Type
uo_actual = Type
main_ty
, uo_expected :: Type
uo_expected = Type
io_ty
, uo_thing :: Maybe TypedThing
uo_thing = Maybe TypedThing
forall a. Maybe a
Nothing
, uo_visible :: Bool
uo_visible = Bool
True }
; ((TcEvBinds, HsWrapper)
_, WantedConstraints
lie) <- TcM (TcEvBinds, HsWrapper)
-> TcM ((TcEvBinds, HsWrapper), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM (TcEvBinds, HsWrapper)
-> TcM ((TcEvBinds, HsWrapper), WantedConstraints))
-> TcM (TcEvBinds, HsWrapper)
-> TcM ((TcEvBinds, HsWrapper), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
Name -> Type -> TcM HsWrapper -> TcM (TcEvBinds, HsWrapper)
forall a. Name -> Type -> TcM a -> TcM (TcEvBinds, a)
setMainCtxt Name
main_name Type
io_ty (TcM HsWrapper -> TcM (TcEvBinds, HsWrapper))
-> TcM HsWrapper -> TcM (TcEvBinds, HsWrapper)
forall a b. (a -> b) -> a -> b
$
CtOrigin -> UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSubTypeSigma CtOrigin
eq_orig UserTypeCtxt
ctxt Type
main_ty Type
io_ty
; WantedConstraints -> TcRn WantedConstraints
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
lie } } } }
checkMain :: Bool
-> Maybe (LocatedL [LIE GhcPs])
-> TcM TcGblEnv
checkMain :: Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> TcM TcGblEnv
checkMain Bool
explicit_mod_hdr Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
export_ies
= do { HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; TcGblEnv
tcg_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
main_mod :: Module
main_mod = HomeUnitEnv -> Module
mainModIs (HscEnv -> HomeUnitEnv
hsc_HUE HscEnv
hsc_env)
main_occ :: OccName
main_occ = DynFlags -> OccName
getMainOcc DynFlags
dflags
exported_mains :: [Name]
exported_mains :: [Name]
exported_mains = [ Name
name | AvailInfo
avail <- TcGblEnv -> [AvailInfo]
tcg_exports TcGblEnv
tcg_env
, Name
name <- AvailInfo -> [Name]
availNames AvailInfo
avail
, Name -> OccName
nameOccName Name
name OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
main_occ ]
; if | TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
main_mod
->
TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
| [Name
main_name] <- [Name]
exported_mains
->
TcGblEnv -> Name -> TcM TcGblEnv
generateMainBinding TcGblEnv
tcg_env Name
main_name
| Bool
otherwise
-> Bool -> TcM TcGblEnv -> TcM TcGblEnv
forall a. HasCallStack => Bool -> a -> a
assert ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
exported_mains) (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
do { DynFlags -> Module -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain_no_main DynFlags
dflags Module
main_mod OccName
main_occ
; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env } }
where
complain_no_main :: DynFlags -> Module -> OccName -> IOEnv (Env TcGblEnv TcLclEnv) ()
complain_no_main DynFlags
dflags Module
main_mod OccName
main_occ
= Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
interactive Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
explicit_mod_hdr) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (Module -> OccName -> TcRnMessage
noMainMsg Module
main_mod OccName
main_occ)
where
interactive :: Bool
interactive = DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkInMemory
noMainMsg :: Module -> OccName -> TcRnMessage
noMainMsg Module
main_mod OccName
main_occ
= DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OccName -> SDoc
ppMainFn OccName
main_occ
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is not" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
defOrExp SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"module"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
main_mod)
defOrExp :: String
defOrExp | Bool
explicit_export_list = String
"exported by"
| Bool
otherwise = String
"defined in"
explicit_export_list :: Bool
explicit_export_list = Bool
explicit_mod_hdr Bool -> Bool -> Bool
&& Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Bool
forall a. Maybe a -> Bool
isJust Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
export_ies
getMainOcc :: DynFlags -> OccName
getMainOcc :: DynFlags -> OccName
getMainOcc DynFlags
dflags = case DynFlags -> Maybe String
mainFunIs DynFlags
dflags of
Just String
fn -> FastString -> OccName
mkVarOccFS (String -> FastString
mkFastString String
fn)
Maybe String
Nothing -> OccName
mainOcc
ppMainFn :: OccName -> SDoc
ppMainFn :: OccName -> SDoc
ppMainFn OccName
main_occ
| OccName
main_occ OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
mainOcc
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"IO action" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
main_occ)
| Bool
otherwise
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"main IO action" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
main_occ)
mainOcc :: OccName
mainOcc :: OccName
mainOcc = FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"main")
generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv
generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv
generateMainBinding TcGblEnv
tcg_env Name
main_name = do
{ String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"checkMain found" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
main_name)
; (Type
io_ty, Type
res_ty) <- TcM (Type, Type)
getIOType
; let loc :: SrcSpan
loc = Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
main_name
main_expr_rn :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
main_expr_rn = SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (XVar (GhcPass 'Renamed)
-> LIdP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) Name
main_name))
; (TcEvBinds
ev_binds, GenLocated SrcSpanAnnA (HsExpr GhcTc)
main_expr) <- Name
-> Type -> TcM (LHsExpr GhcTc) -> TcM (TcEvBinds, LHsExpr GhcTc)
forall a. Name -> Type -> TcM a -> TcM (TcEvBinds, a)
setMainCtxt Name
main_name Type
io_ty (TcM (LHsExpr GhcTc) -> TcM (TcEvBinds, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (TcEvBinds, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
LHsExpr (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
main_expr_rn Type
io_ty
; Var
run_main_id <- Name -> TcM Var
tcLookupId Name
runMainIOName
; let { root_main_name :: Name
root_main_name = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
rootMainKey Module
rOOT_MAIN
(FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"main"))
(Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
main_name)
; root_main_id :: Var
root_main_id = Name -> Type -> Var
Id.mkExportedVanillaId Name
root_main_name Type
io_ty
; co :: HsWrapper
co = [Type] -> HsWrapper
mkWpTyApps [Type
res_ty]
; rhs :: LHsExpr GhcTc
rhs = LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
co (IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Var
run_main_id)) (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet TcEvBinds
ev_binds LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
main_expr
; main_bind :: LHsBind GhcTc
main_bind = IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP GhcTc
Var
root_main_id LHsExpr GhcTc
rhs }
; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env { tcg_main = Just main_name
, tcg_binds = tcg_binds tcg_env
`snocBag` main_bind
, tcg_dus = tcg_dus tcg_env
`plusDU` usesOnly (unitFV main_name) })
}
getIOType :: TcM (TcType, TcType)
getIOType :: TcM (Type, Type)
getIOType = do { TyCon
ioTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
ioTyConName
; Type
res_ty <- Type -> TcM Type
newFlexiTyVarTy Type
liftedTypeKind
; (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> [Type] -> Type
mkTyConApp TyCon
ioTyCon [Type
res_ty], Type
res_ty) }
setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a)
setMainCtxt :: forall a. Name -> Type -> TcM a -> TcM (TcEvBinds, a)
setMainCtxt Name
main_name Type
io_ty TcM a
thing_inside
= SrcSpan -> TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
main_name) (TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a))
-> TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a)
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
main_ctxt (TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a))
-> TcRn (TcEvBinds, a) -> TcRn (TcEvBinds, a)
forall a b. (a -> b) -> a -> b
$
SkolemInfoAnon -> [Var] -> [Var] -> TcM a -> TcRn (TcEvBinds, a)
forall result.
SkolemInfoAnon
-> [Var] -> [Var] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints SkolemInfoAnon
skol_info [] [] (TcM a -> TcRn (TcEvBinds, a)) -> TcM a -> TcRn (TcEvBinds, a)
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
where
skol_info :: SkolemInfoAnon
skol_info = UserTypeCtxt -> Type -> [(Name, Var)] -> SkolemInfoAnon
SigSkol (Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
main_name ReportRedundantConstraints
NoRRC) Type
io_ty []
main_ctxt :: SDoc
main_ctxt = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"When checking the type of the"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OccName -> SDoc
ppMainFn (Name -> OccName
nameOccName Name
main_name)
runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive :: forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env TcRn a
thing_inside
= HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
initTcInteractive HscEnv
hsc_env (TcRn a -> IO (Messages TcRnMessage, Maybe a))
-> TcRn a -> IO (Messages TcRnMessage, Maybe a)
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcRn a -> TcRn a
forall a. HscEnv -> TcM a -> TcM a
withTcPlugins HscEnv
hsc_env (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall a b. (a -> b) -> a -> b
$
HscEnv -> TcRn a -> TcRn a
forall a. HscEnv -> TcM a -> TcM a
withDefaultingPlugins HscEnv
hsc_env (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcRn a -> TcRn a
forall a. HscEnv -> TcM a -> TcM a
withHoleFitPlugins HscEnv
hsc_env (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"setInteractiveContext" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ic_tythings:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((TyThing -> SDoc) -> [TyThing] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr (InteractiveContext -> [TyThing]
ic_tythings InteractiveContext
icxt))
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ic_insts:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> Var -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind (Var -> SDoc) -> (ClsInst -> Var) -> ClsInst -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClsInst -> Var
instanceDFunId) (InstEnv -> [ClsInst]
instEnvElts InstEnv
ic_insts))
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"icReaderEnv (LocalDef)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (([GlobalRdrElt] -> SDoc) -> [[GlobalRdrElt]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map [GlobalRdrElt] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ [GlobalRdrElt]
local_gres | [GlobalRdrElt]
gres <- GlobalRdrEnv -> [[GlobalRdrElt]]
forall a. OccEnv a -> [a]
nonDetOccEnvElts (InteractiveContext -> GlobalRdrEnv
icReaderEnv 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GlobalRdrElt]
local_gres) ]) ]
; let getOrphans :: ModuleName -> PkgQual -> IOEnv (Env TcGblEnv TcLclEnv) [Module]
getOrphans ModuleName
m PkgQual
mb_pkg = (ModIface_ 'ModIfaceFinal -> [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
-> IOEnv (Env TcGblEnv TcLclEnv) [Module]
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ModIface_ 'ModIfaceFinal
iface -> ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface_ 'ModIfaceFinal
iface
Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: Dependencies -> [Module]
dep_orphs (ModIface_ 'ModIfaceFinal -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface_ 'ModIfaceFinal
iface))
(SDoc
-> ModuleName
-> IsBootInterface
-> PkgQual
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
loadSrcInterface (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"runTcInteractive") ModuleName
m
IsBootInterface
NotBoot PkgQual
mb_pkg)
; ![Module]
orphs <- ([[Module]] -> [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) [[Module]]
-> IOEnv (Env TcGblEnv TcLclEnv) [Module]
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([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 -> PkgQual -> IOEnv (Env TcGblEnv TcLclEnv) [Module]
getOrphans ModuleName
n PkgQual
NoPkgQual
IIDecl ImportDecl GhcPs
i -> ModuleName -> PkgQual -> IOEnv (Env TcGblEnv TcLclEnv) [Module]
getOrphans (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
i))
(UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
renameRawPkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
i) (ImportDecl GhcPs -> ImportDeclPkgQual GhcPs
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl GhcPs
i))
; let imports :: ImportAvails
imports = ImportAvails
emptyImportAvails { imp_orphs = orphs }
upd_envs :: (TcGblEnv, TcLclEnv) -> (TcGblEnv, TcLclEnv)
upd_envs (TcGblEnv
gbl_env, TcLclEnv
lcl_env) = (TcGblEnv
gbl_env', TcLclEnv
lcl_env')
where
gbl_env' :: TcGblEnv
gbl_env' = TcGblEnv
gbl_env { tcg_rdr_env = icReaderEnv icxt
, tcg_type_env = type_env
, tcg_inst_env = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts
, tcg_fam_inst_env = extendFamInstEnvList
(extendFamInstEnvList (tcg_fam_inst_env gbl_env)
ic_finsts)
home_fam_insts
, tcg_field_env = mkNameEnv con_fields
, tcg_fix_env = ic_fix_env icxt
, tcg_default = ic_default icxt
, tcg_imports = imports }
lcl_env' :: TcLclEnv
lcl_env' = TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv
tcExtendLocalTypeEnv TcLclEnv
lcl_env [(Name, TcTyThing)]
lcl_ids
; ((TcGblEnv, TcLclEnv) -> (TcGblEnv, TcLclEnv)) -> TcRn a -> TcRn a
forall gbl lcl a.
((gbl, lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updEnvs (TcGblEnv, TcLclEnv) -> (TcGblEnv, TcLclEnv)
upd_envs TcRn a
thing_inside }
where
(InstEnv
home_insts, [FamInst]
home_fam_insts) = HscEnv -> (InstEnv, [FamInst])
hptAllInstances HscEnv
hsc_env
icxt :: InteractiveContext
icxt = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
(InstEnv
ic_insts, [FamInst]
ic_finsts) = InteractiveContext -> (InstEnv, [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 Var
id <- TyThing
thing
, Bool -> Bool
not (Var -> Bool
isTypeClosedLetBndr Var
id)
= (Name, TcTyThing) -> Either (Name, TcTyThing) TyThing
forall a b. a -> Either a b
Left (Var -> Name
idName Var
id, ATcId { tct_id :: Var
tct_id = Var
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 -> [Var] -> TypeEnv
extendTypeEnvWithIds TypeEnv
type_env1 ((ClsInst -> Var) -> [ClsInst] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> Var
instanceDFunId (InstEnv -> [ClsInst]
instEnvElts InstEnv
ic_insts))
con_fields :: [(Name, [FieldLabel])]
con_fields = [ (DataCon -> Name
dataConName DataCon
c, DataCon -> [FieldLabel]
dataConFieldLabels DataCon
c)
| ATyCon TyCon
t <- [TyThing]
top_ty_things
, DataCon
c <- TyCon -> [DataCon]
tyConDataCons TyCon
t ]
tcRnStmt :: HscEnv -> GhciLStmt GhcPs
-> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
tcRnStmt :: HscEnv
-> GhciLStmt GhcPs
-> IO
(Messages TcRnMessage, Maybe ([Var], LHsExpr GhcTc, FixityEnv))
tcRnStmt HscEnv
hsc_env GhciLStmt GhcPs
rdr_stmt
= HscEnv
-> TcRn ([Var], LHsExpr GhcTc, FixityEnv)
-> IO
(Messages TcRnMessage, Maybe ([Var], LHsExpr GhcTc, FixityEnv))
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn ([Var], LHsExpr GhcTc, FixityEnv)
-> IO
(Messages TcRnMessage, Maybe ([Var], LHsExpr GhcTc, FixityEnv)))
-> TcRn ([Var], LHsExpr GhcTc, FixityEnv)
-> IO
(Messages TcRnMessage, Maybe ([Var], LHsExpr GhcTc, FixityEnv))
forall a b. (a -> b) -> a -> b
$ do {
(([Var]
bound_ids, GenLocated SrcSpanAnnA (HsExpr GhcTc)
tc_expr), FixityEnv
fix_env) <- GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
tcUserStmt GhciLStmt GhcPs
rdr_stmt ;
GenLocated SrcSpanAnnA (HsExpr GhcTc)
zonked_expr <- LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
zonkTopLExpr LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
tc_expr ;
[Var]
zonked_ids <- [Var] -> TcM [Var]
zonkTopBndrs [Var]
bound_ids ;
IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM ;
(Var -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [Var] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Var -> IOEnv (Env TcGblEnv TcLclEnv) ()
bad_unboxed ((Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter (Type -> Bool
mightBeUnliftedType (Type -> Bool) -> (Var -> Type) -> Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Type
idType) [Var]
zonked_ids) ;
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcs 1" SDoc
forall doc. IsOutput doc => doc
empty ;
Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule ;
[Var]
global_ids <- (Var -> TcM Var) -> [Var] -> TcM [Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Module -> Var -> TcM Var
externaliseAndTidyId Module
this_mod) [Var]
zonked_ids ;
DumpFlag -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceOptTcRn DumpFlag
Opt_D_dump_tc
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Bound Ids" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (Var -> SDoc) -> [Var] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
global_ids,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Typechecked expr" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsExpr GhcTc)
zonked_expr]) ;
([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Var]
global_ids, GenLocated SrcSpanAnnA (HsExpr GhcTc)
zonked_expr, FixityEnv
fix_env)
}
where
bad_unboxed :: Var -> IOEnv (Env TcGblEnv TcLclEnv) ()
bad_unboxed Var
id = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GHCi can't bind a variable of unlifted type:",
Arity -> SDoc -> SDoc
nest Arity
2 (Var -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Var
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
idType Var
id))])
type PlanResult = ([Id], LHsExpr GhcTc)
type Plan = TcM PlanResult
runPlans :: NonEmpty Plan -> Plan
runPlans :: NonEmpty Plan -> Plan
runPlans = (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 ((TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b c. (a -> b -> c) -> b -> a -> c
flip TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall r. TcM r -> TcM r -> TcM r
tryTcDiscardingErrs)
tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
tcUserStmt (L SrcSpanAnnA
loc (BodyStmt XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_))
= do { (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
rn_expr, FreeVars
fvs) <- TcM (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)), FreeVars)
-> TcM
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)), FreeVars)
forall r. TcM r -> TcM r
checkNoErrs (LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), FreeVars)
rnLExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr)
; DumpFlag
-> String -> DumpFormat -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
dumpOptTcRn DumpFlag
Opt_D_dump_rn_ast String
"Renamer" DumpFormat
FormatHaskell
(BlankSrcSpan
-> BlankEpAnnotations
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> SDoc
forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
rn_expr)
; GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
ghciStep <- TcM (LHsExpr (GhcPass 'Renamed))
IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
getGhciStepIO
; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; let loc' :: SrcSpanAnnN
loc' = SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan (SrcSpan -> SrcSpanAnnN) -> SrcSpan -> SrcSpanAnnN
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc
; Name
interPrintName <- TcRn Name
getInteractivePrintName
; let fresh_it :: Name
fresh_it = Unique -> SrcSpan -> Name
itName Unique
uniq (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
matches :: [GenLocated
SrcSpanAnnA
(Match
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))]
matches = [HsMatchContext (GhcPass 'Renamed)
-> [LPat (GhcPass 'Renamed)]
-> LHsExpr (GhcPass 'Renamed)
-> HsLocalBinds (GhcPass 'Renamed)
-> LMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP (NoGhcTc (GhcPass 'Renamed))
-> HsMatchContext (GhcPass 'Renamed)
forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' Name
fresh_it)) [] LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
rn_expr
HsLocalBinds (GhcPass 'Renamed)
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds]
the_bind :: GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
the_bind = SrcSpanAnnA
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ (Origin
-> GenLocated SrcSpanAnnN Name
-> [LMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
mkTopFunBind Origin
FromSource
(SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' Name
fresh_it) [LMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
[GenLocated
SrcSpanAnnA
(Match
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))]
matches)
{ fun_ext = fvs }
let_stmt :: GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
let_stmt = SrcSpanAnnA
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall a b. (a -> b) -> a -> b
$ XLetStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> HsLocalBinds (GhcPass 'Renamed)
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn (HsLocalBinds (GhcPass 'Renamed)
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
-> HsLocalBinds (GhcPass 'Renamed)
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ XHsValBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsLocalBinds (GhcPass 'Renamed)
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
EpAnn AnnList
forall a. EpAnn a
noAnn
(HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsLocalBinds (GhcPass 'Renamed))
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsLocalBinds (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$ XXValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR
([(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR (GhcPass 'Renamed)
forall idL.
[(RecFlag, LHsBinds idL)]
-> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR idL
NValBinds [(RecFlag
NonRecursive,GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
forall a. a -> Bag a
unitBag GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
the_bind)] [])
bind_stmt :: GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
bind_stmt = SrcSpanAnnA
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall a b. (a -> b) -> a -> b
$ XBindStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> LPat (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt
(XBindStmtRn
{ xbsrn_bindOp :: SyntaxExpr (GhcPass 'Renamed)
xbsrn_bindOp = Name -> SyntaxExprRn
mkRnSyntaxExpr Name
bindIOName
, xbsrn_failOp :: FailOperator (GhcPass 'Renamed)
xbsrn_failOp = FailOperator (GhcPass 'Renamed)
Maybe SyntaxExprRn
forall a. Maybe a
Nothing
})
(SrcSpanAnnA
-> Pat (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XVarPat (GhcPass 'Renamed)
-> LIdP (GhcPass 'Renamed) -> Pat (GhcPass 'Renamed)
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat (GhcPass 'Renamed)
NoExtField
noExtField (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' Name
fresh_it)))
(LHsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
ghciStep LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
rn_expr)
print_it :: GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
print_it = SrcSpanAnnA
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall a b. (a -> b) -> a -> b
$ XBodyStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> SyntaxExpr (GhcPass 'Renamed)
-> SyntaxExpr (GhcPass 'Renamed)
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField
(LHsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Renamed)
Name
interPrintName)
(IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Renamed)
Name
fresh_it))
(Name -> SyntaxExprRn
mkRnSyntaxExpr Name
thenIOName)
SyntaxExpr (GhcPass 'Renamed)
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr
no_it_a :: GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
no_it_a = SrcSpanAnnA
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall a b. (a -> b) -> a -> b
$ XBodyStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> SyntaxExpr (GhcPass 'Renamed)
-> SyntaxExpr (GhcPass 'Renamed)
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField (IdP (GhcPass 'Renamed)
-> [LHsExpr (GhcPass 'Renamed)] -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Renamed)
Name
bindIOName
[LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
rn_expr , IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Renamed)
Name
interPrintName])
(Name -> SyntaxExprRn
mkRnSyntaxExpr Name
thenIOName)
SyntaxExpr (GhcPass 'Renamed)
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr
no_it_b :: GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
no_it_b = SrcSpanAnnA
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall a b. (a -> b) -> a -> b
$ XBodyStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> SyntaxExpr (GhcPass 'Renamed)
-> SyntaxExpr (GhcPass 'Renamed)
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
rn_expr)
(Name -> SyntaxExprRn
mkRnSyntaxExpr Name
thenIOName)
SyntaxExpr (GhcPass 'Renamed)
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr
no_it_c :: GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
no_it_c = SrcSpanAnnA
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall a b. (a -> b) -> a -> b
$ XBodyStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> SyntaxExpr (GhcPass 'Renamed)
-> SyntaxExpr (GhcPass 'Renamed)
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField
(LHsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Renamed)
Name
interPrintName) LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
rn_expr)
(Name -> SyntaxExprRn
mkRnSyntaxExpr Name
thenIOName)
SyntaxExpr (GhcPass 'Renamed)
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr
it_plans :: NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
it_plans =
do { stuff :: ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
stuff@([Var
it_id], GenLocated SrcSpanAnnA (HsExpr GhcTc)
_) <- [GhciLStmt (GhcPass 'Renamed)] -> Plan
tcGhciStmts [GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
bind_stmt, GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
print_it]
; Type
it_ty <- Type -> TcM Type
zonkTcType (Var -> Type
idType Var
it_id)
; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Type -> Bool
isUnitTy Type
it_ty) IOEnv (Env TcGblEnv TcLclEnv) ()
forall env a. IOEnv env a
failM
; ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
stuff } TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> [a] -> NonEmpty a
:|
[ [GhciLStmt (GhcPass 'Renamed)] -> Plan
tcGhciStmts [GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
bind_stmt]
, do { ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
_ <- TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall r. TcM r -> TcM r
checkNoErrs ([GhciLStmt (GhcPass 'Renamed)] -> Plan
tcGhciStmts [GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
let_stmt])
; [GhciLStmt (GhcPass 'Renamed)] -> Plan
tcGhciStmts [GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
let_stmt, GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
print_it] } ]
no_it_plans :: NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
no_it_plans =
[GhciLStmt (GhcPass 'Renamed)] -> Plan
tcGhciStmts [GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
no_it_a] TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> [a] -> NonEmpty a
:|
[GhciLStmt (GhcPass 'Renamed)] -> Plan
tcGhciStmts [GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
no_it_b] TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> [TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall a. a -> [a] -> [a]
:
[GhciLStmt (GhcPass 'Renamed)] -> Plan
tcGhciStmts [GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
no_it_c] TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> [TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall a. a -> [a] -> [a]
:
[]
; Bool
generate_it <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_NoIt
; ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
plan <- GeneralFlag
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall gbl lcl a.
GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM GeneralFlag
Opt_DeferTypeErrors (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
GeneralFlag
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall gbl lcl a.
GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM GeneralFlag
Opt_DeferTypedHoles (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
GeneralFlag
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall gbl lcl a.
GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM GeneralFlag
Opt_DeferOutOfScopeVariables (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
NonEmpty Plan -> Plan
runPlans (NonEmpty Plan -> Plan) -> NonEmpty Plan -> Plan
forall a b. (a -> b) -> a -> b
$ if Bool
generate_it
then NonEmpty Plan
NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
no_it_plans
else NonEmpty Plan
NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
it_plans
; DumpFlag
-> String -> DumpFormat -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
dumpOptTcRn DumpFlag
Opt_D_dump_tc_ast String
"Typechecker AST" DumpFormat
FormatHaskell
(BlankSrcSpan
-> BlankEpAnnotations
-> ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> SDoc
forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
plan)
; FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv
; (([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)), FixityEnv)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)), FixityEnv)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
plan, FixityEnv
fix_env) }
tcUserStmt rdr_stmt :: GhciLStmt GhcPs
rdr_stmt@(L SrcSpanAnnA
loc StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_)
= do { (([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
rn_stmt], FixityEnv
fix_env), FreeVars
fvs) <- TcM
(([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))],
FixityEnv),
FreeVars)
-> TcM
(([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))],
FixityEnv),
FreeVars)
forall r. TcM r -> TcM r
checkNoErrs (TcM
(([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))],
FixityEnv),
FreeVars)
-> TcM
(([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))],
FixityEnv),
FreeVars))
-> TcM
(([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))],
FixityEnv),
FreeVars)
-> TcM
(([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))],
FixityEnv),
FreeVars)
forall a b. (a -> b) -> a -> b
$
HsStmtContext (GhcPass 'Renamed)
-> (HsExpr GhcPs -> RnM (HsExpr (GhcPass 'Renamed), FreeVars))
-> [LStmt GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> ([Name] -> RnM (FixityEnv, FreeVars))
-> RnM
(([LStmt
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))],
FixityEnv),
FreeVars)
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext (GhcPass 'Renamed)
-> (body GhcPs -> RnM (body (GhcPass 'Renamed), FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
(([LStmt (GhcPass 'Renamed) (LocatedA (body (GhcPass 'Renamed)))],
thing),
FreeVars)
rnStmts (HsDoFlavour -> HsStmtContext (GhcPass 'Renamed)
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
GhciStmtCtxt) HsExpr GhcPs -> RnM (HsExpr (GhcPass 'Renamed), FreeVars)
rnExpr [GhciLStmt GhcPs
LStmt GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rdr_stmt] (([Name] -> RnM (FixityEnv, FreeVars))
-> RnM
(([LStmt
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))],
FixityEnv),
FreeVars))
-> ([Name] -> RnM (FixityEnv, FreeVars))
-> RnM
(([LStmt
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))],
FixityEnv),
FreeVars)
forall a b. (a -> b) -> a -> b
$ \[Name]
_ -> do
FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv
(FixityEnv, FreeVars) -> RnM (FixityEnv, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv
fix_env, FreeVars
emptyFVs)
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"tcRnStmt" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr GhciLStmt GhcPs
GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
rdr_stmt, GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
rn_stmt, FreeVars -> SDoc
forall a. Outputable a => a -> SDoc
ppr FreeVars
fvs])
; GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a.
(Outputable a, Data a) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) ()
rnDump GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
rn_stmt ;
; GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
ghciStep <- TcM (LHsExpr (GhcPass 'Renamed))
IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
getGhciStepIO
; let gi_stmt :: GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
gi_stmt
| (L SrcSpanAnnA
loc (BindStmt XBindStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
x LPat (GhcPass 'Renamed)
pat GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr)) <- GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
rn_stmt
= SrcSpanAnnA
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall a b. (a -> b) -> a -> b
$ XBindStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> LPat (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
x LPat (GhcPass 'Renamed)
pat (LHsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
ghciStep LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr)
| Bool
otherwise = GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
rn_stmt
; Bool
opt_pr_flag <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_PrintBindResult
; let print_result_plan :: Maybe (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
print_result_plan
| Bool
opt_pr_flag
, [IdP (GhcPass 'Renamed)
v] <- CollectFlag (GhcPass 'Renamed)
-> LStmt
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> [IdP (GhcPass 'Renamed)]
forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
collectLStmtBinders CollectFlag (GhcPass 'Renamed)
forall p. CollectFlag p
CollNoDictBinders LStmt
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
gi_stmt
= TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> Maybe (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> Maybe a
Just (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> Maybe (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> Maybe (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
-> Name -> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
mk_print_result_plan GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
gi_stmt IdP (GhcPass 'Renamed)
Name
v
| Bool
otherwise = Maybe (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. Maybe a
Nothing
; ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
plan <- NonEmpty Plan -> Plan
runPlans (NonEmpty Plan -> Plan) -> NonEmpty Plan -> Plan
forall a b. (a -> b) -> a -> b
$ (NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> NonEmpty Plan)
-> (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> NonEmpty Plan)
-> Maybe (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> NonEmpty Plan
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> NonEmpty Plan
NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> a
id TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> NonEmpty Plan
TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. a -> NonEmpty a -> NonEmpty a
(NE.<|) Maybe (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
print_result_plan (NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> NonEmpty Plan)
-> NonEmpty (TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> NonEmpty Plan
forall a b. (a -> b) -> a -> b
$ Plan -> NonEmpty Plan
forall a. a -> NonEmpty a
NE.singleton (Plan -> NonEmpty Plan) -> Plan -> NonEmpty Plan
forall a b. (a -> b) -> a -> b
$ [GhciLStmt (GhcPass 'Renamed)] -> Plan
tcGhciStmts [GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
gi_stmt]
; (([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)), FixityEnv)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc)), FixityEnv)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
plan, FixityEnv
fix_env) }
where
mk_print_result_plan :: GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
-> Name -> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
mk_print_result_plan GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
stmt Name
v
= do { stuff :: ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
stuff@([Var
v_id], GenLocated SrcSpanAnnA (HsExpr GhcTc)
_) <- [GhciLStmt (GhcPass 'Renamed)] -> Plan
tcGhciStmts [GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
stmt, GhciLStmt (GhcPass 'Renamed)
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
print_v]
; Type
v_ty <- Type -> TcM Type
zonkTcType (Var -> Type
idType Var
v_id)
; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Type -> Bool
isUnitTy Type
v_ty Bool -> Bool -> Bool
|| Bool -> Bool
not (Type -> Bool
isTauTy Type
v_ty)) IOEnv (Env TcGblEnv TcLclEnv) ()
forall env a. IOEnv env a
failM
; ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
stuff }
where
print_v :: GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
print_v = SrcSpanAnnA
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))
forall a b. (a -> b) -> a -> b
$ XBodyStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> SyntaxExpr (GhcPass 'Renamed)
-> SyntaxExpr (GhcPass 'Renamed)
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
NoExtField
noExtField (LHsExpr (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Renamed)
Name
printName)
(IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Renamed)
Name
v))
(Name -> SyntaxExprRn
mkRnSyntaxExpr Name
thenIOName) SyntaxExpr (GhcPass 'Renamed)
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr
tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult
tcGhciStmts :: [GhciLStmt (GhcPass 'Renamed)] -> Plan
tcGhciStmts [GhciLStmt (GhcPass 'Renamed)]
stmts
= do { TyCon
ioTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
ioTyConName
; Var
ret_id <- Name -> TcM Var
tcLookupId Name
returnIOName
; let ret_ty :: Type
ret_ty = Type -> Type
mkListTy Type
unitTy
io_ret_ty :: Type
io_ret_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
ioTyCon [Type
ret_ty]
tc_io_stmts :: (ExpType -> TcM [Var])
-> TcM
([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))], [Var])
tc_io_stmts = HsStmtContext GhcTc
-> TcStmtChecker HsExpr ExpType
-> [LStmt
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))]
-> ExpType
-> (ExpType -> TcM [Var])
-> TcM
([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))], [Var])
forall (body :: * -> *) rho_type thing.
AnnoBody body =>
HsStmtContext GhcTc
-> TcStmtChecker body rho_type
-> [LStmt (GhcPass 'Renamed) (LocatedA (body (GhcPass 'Renamed)))]
-> rho_type
-> (rho_type -> TcM thing)
-> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
tcStmtsAndThen (HsDoFlavour -> HsStmtContext GhcTc
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
GhciStmtCtxt) HsStmtContext GhcTc
-> StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> ExpType
-> (ExpType -> TcM thing)
-> TcM (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), thing)
TcStmtChecker HsExpr ExpType
tcDoStmt [GhciLStmt (GhcPass 'Renamed)]
[LStmt
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))]
stmts
(Type -> ExpType
mkCheckExpType Type
io_ret_ty)
names :: [IdP (GhcPass 'Renamed)]
names = CollectFlag (GhcPass 'Renamed)
-> [LStmt
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))]
-> [IdP (GhcPass 'Renamed)]
forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders CollectFlag (GhcPass 'Renamed)
forall p. CollectFlag p
CollNoDictBinders [GhciLStmt (GhcPass 'Renamed)]
[LStmt
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))]
stmts
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"GHC.Tc.Module.tcGhciStmts: tc stmts" SDoc
forall doc. IsOutput doc => doc
empty
; (([LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
tc_stmts, [Var]
ids), WantedConstraints
lie) <- TcM
([LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
[Var])
-> TcM
(([LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
[Var]),
WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM
([LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
[Var])
-> TcM
(([LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
[Var]),
WantedConstraints))
-> TcM
([LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
[Var])
-> TcM
(([LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))],
[Var]),
WantedConstraints)
forall a b. (a -> b) -> a -> b
$
(ExpType -> TcM [Var])
-> TcM
([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))], [Var])
tc_io_stmts ((ExpType -> TcM [Var])
-> TcM
([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))], [Var]))
-> (ExpType -> TcM [Var])
-> TcM
([LStmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))], [Var])
forall a b. (a -> b) -> a -> b
$ \ ExpType
_ ->
(Name -> TcM Var) -> [Name] -> TcM [Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> TcM Var
tcLookupId [IdP (GhcPass 'Renamed)]
[Name]
names
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"GHC.Tc.Module.tcGhciStmts: simplify ctxt" SDoc
forall doc. IsOutput doc => doc
empty
; Bag EvBind
const_binds <- TcRn (Bag EvBind) -> TcRn (Bag EvBind)
forall r. TcM r -> TcM r
checkNoErrs (WantedConstraints -> TcRn (Bag EvBind)
simplifyInteractive WantedConstraints
lie)
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"GHC.Tc.Module.tcGhciStmts: done" SDoc
forall doc. IsOutput doc => doc
empty
; AnId Var
unsafe_coerce_id <- Name -> TcM TyThing
tcLookupGlobal Name
unsafeCoercePrimName
; let ret_expr :: LHsExpr GhcTc
ret_expr = LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (Var -> [Type] -> LHsExpr GhcTc
nlHsTyApp Var
ret_id [Type
ret_ty]) (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTc -> [LHsExpr GhcTc] -> HsExpr GhcTc
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcTc
Type
unitTy ([LHsExpr GhcTc] -> HsExpr GhcTc)
-> [LHsExpr GhcTc] -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
(Var -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [Var] -> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map Var -> LHsExpr GhcTc
Var -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
mk_item [Var]
ids
mk_item :: Var -> LHsExpr GhcTc
mk_item Var
id = Var
unsafe_coerce_id Var -> [Type] -> LHsExpr GhcTc
`nlHsTyApp` [ (() :: Constraint) => Type -> Type
Type -> Type
getRuntimeRep (Var -> Type
idType Var
id)
, (() :: Constraint) => Type -> Type
Type -> Type
getRuntimeRep Type
unitTy
, Var -> Type
idType Var
id, Type
unitTy]
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Var
id
stmts :: [LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts = [LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
tc_stmts [LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a an. a -> LocatedAn an a
noLocA (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
(GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
ret_expr)]
; ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM ([Var], GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Var]
ids, TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet (Bag EvBind -> TcEvBinds
EvBinds Bag EvBind
const_binds) (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA (XDo GhcTc
-> HsDoFlavour -> XRec GhcTc [ExprLStmt GhcTc] -> HsExpr GhcTc
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
Type
io_ret_ty HsDoFlavour
GhciStmtCtxt ([LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> LocatedAn
AnnList
[LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a an. a -> LocatedAn an a
noLocA [LocatedAn
AnnListItem (Stmt GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)))
}
getGhciStepIO :: TcM (LHsExpr GhcRn)
getGhciStepIO :: TcM (LHsExpr (GhcPass 'Renamed))
getGhciStepIO = do
Name
ghciTy <- TcRn Name
getGHCiMonad
Name
a_tv <- OccName -> TcRn Name
newName (FastString -> OccName
mkTyVarOccFS (String -> FastString
fsLit String
"a"))
let ghciM :: LHsType (GhcPass 'Renamed)
ghciM = LHsType (GhcPass 'Renamed)
-> LHsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsAppTy (PromotionFlag
-> IdP (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted IdP (GhcPass 'Renamed)
Name
ghciTy) (PromotionFlag
-> IdP (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted IdP (GhcPass 'Renamed)
Name
a_tv)
ioM :: LHsType (GhcPass 'Renamed)
ioM = LHsType (GhcPass 'Renamed)
-> LHsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsAppTy (PromotionFlag
-> IdP (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted IdP (GhcPass 'Renamed)
Name
ioTyConName) (PromotionFlag
-> IdP (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted IdP (GhcPass 'Renamed)
Name
a_tv)
step_ty :: LHsSigType GhcRn
step_ty :: LHsSigType (GhcPass 'Renamed)
step_ty = HsSigType (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
forall a an. a -> LocatedAn an a
noLocA (HsSigType (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> HsSigType (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ HsSig
{ sig_bndrs :: HsOuterSigTyVarBndrs (GhcPass 'Renamed)
sig_bndrs = HsOuterImplicit{hso_ximplicit :: XHsOuterImplicit (GhcPass 'Renamed)
hso_ximplicit = [Name
a_tv]}
, sig_ext :: XHsSig (GhcPass 'Renamed)
sig_ext = XHsSig (GhcPass 'Renamed)
NoExtField
noExtField
, sig_body :: LHsType (GhcPass 'Renamed)
sig_body = LHsType (GhcPass 'Renamed)
-> LHsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsFunTy LHsType (GhcPass 'Renamed)
ghciM LHsType (GhcPass 'Renamed)
ioM }
stepTy :: LHsSigWcType GhcRn
stepTy :: LHsSigWcType (GhcPass 'Renamed)
stepTy = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
-> HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall thing. thing -> HsWildCardBndrs (GhcPass 'Renamed) thing
mkEmptyWildCardBndrs LHsSigType (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
step_ty
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall a an. a -> LocatedAn an a
noLocA (HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ XExprWithTySig (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig (GhcPass 'Renamed)
NoExtField
noExtField (IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Renamed)
Name
ghciStepIoMName) LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
stepTy)
isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name)
isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name)
isGHCiMonad HscEnv
hsc_env String
ty
= HscEnv -> TcRn Name -> IO (Messages TcRnMessage, Maybe Name)
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn Name -> IO (Messages TcRnMessage, Maybe Name))
-> TcRn Name -> IO (Messages TcRnMessage, Maybe Name)
forall a b. (a -> b) -> a -> b
$ do
GlobalRdrEnv
rdrEnv <- TcRn GlobalRdrEnv
getGlobalRdrEnv
let occIO :: Maybe [GlobalRdrElt]
occIO = GlobalRdrEnv -> OccName -> Maybe [GlobalRdrElt]
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv GlobalRdrEnv
rdrEnv (NameSpace -> String -> OccName
mkOccName NameSpace
tcName String
ty)
case Maybe [GlobalRdrElt]
occIO of
Just [GlobalRdrElt
n] -> do
let name :: Name
name = GlobalRdrElt -> Name
greMangledName GlobalRdrElt
n
Class
ghciClass <- Name -> TcM Class
tcLookupClass Name
ghciIoClassName
TyCon
userTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
name
let userTy :: Type
userTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
userTyCon []
ClsInst
_ <- Class -> [Type] -> TcM ClsInst
tcLookupInstance Class
ghciClass [Type
userTy]
Name -> TcRn Name
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
Just [GlobalRdrElt]
_ -> TcRnMessage -> TcRn Name
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcRn Name) -> TcRnMessage -> TcRn Name
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Ambiguous type!"
Maybe [GlobalRdrElt]
Nothing -> TcRnMessage -> TcRn Name
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcRn Name) -> TcRnMessage -> TcRn Name
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"Can't find type:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty)
data TcRnExprMode = TM_Inst
| TM_Default
tcRnExpr :: HscEnv
-> TcRnExprMode
-> LHsExpr GhcPs
-> IO (Messages TcRnMessage, Maybe Type)
tcRnExpr :: HscEnv
-> TcRnExprMode
-> LHsExpr GhcPs
-> IO (Messages TcRnMessage, DFunInstType)
tcRnExpr HscEnv
hsc_env TcRnExprMode
mode LHsExpr GhcPs
rdr_expr
= HscEnv -> TcM Type -> IO (Messages TcRnMessage, DFunInstType)
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcM Type -> IO (Messages TcRnMessage, DFunInstType))
-> TcM Type -> IO (Messages TcRnMessage, DFunInstType)
forall a b. (a -> b) -> a -> b
$
do {
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
rn_expr, FreeVars
_fvs) <- LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), FreeVars)
rnLExpr LHsExpr GhcPs
rdr_expr ;
IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM ;
((TcLevel
tclvl, Type
res_ty), WantedConstraints
lie)
<- TcM (TcLevel, Type) -> TcM ((TcLevel, Type), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM (TcLevel, Type) -> TcM ((TcLevel, Type), WantedConstraints))
-> TcM (TcLevel, Type) -> TcM ((TcLevel, Type), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
TcM Type -> TcM (TcLevel, Type)
forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM (TcM Type -> TcM (TcLevel, Type))
-> TcM Type -> TcM (TcLevel, Type)
forall a b. (a -> b) -> a -> b
$
Bool -> LHsExpr (GhcPass 'Renamed) -> TcM Type
tcInferSigma Bool
inst LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
rn_expr ;
Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique ;
let { fresh_it :: Name
fresh_it = Unique -> SrcSpan -> Name
itName Unique
uniq (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
rdr_expr) } ;
(([Var]
qtvs, [Var]
dicts, TcEvBinds
_, Bool
_), WantedConstraints
residual)
<- TcM ([Var], [Var], TcEvBinds, Bool)
-> TcM (([Var], [Var], TcEvBinds, Bool), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM ([Var], [Var], TcEvBinds, Bool)
-> TcM (([Var], [Var], TcEvBinds, Bool), WantedConstraints))
-> TcM ([Var], [Var], TcEvBinds, Bool)
-> TcM (([Var], [Var], TcEvBinds, Bool), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, Type)]
-> WantedConstraints
-> TcM ([Var], [Var], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
infer_mode
[]
[(Name
fresh_it, Type
res_ty)]
WantedConstraints
lie ;
Bag EvBind
_ <- TcRn (Bag EvBind) -> TcRn (Bag EvBind)
perhaps_disable_default_warnings (TcRn (Bag EvBind) -> TcRn (Bag EvBind))
-> TcRn (Bag EvBind) -> TcRn (Bag EvBind)
forall a b. (a -> b) -> a -> b
$
WantedConstraints -> TcRn (Bag EvBind)
simplifyInteractive WantedConstraints
residual ;
let { all_expr_ty :: Type
all_expr_ty = [Var] -> Type -> Type
mkInfForAllTys [Var]
qtvs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
(() :: Constraint) => [Type] -> Type -> Type
mkPhiTy ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
idType [Var]
dicts) Type
res_ty } ;
Type
ty <- Type -> TcM Type
zonkTcType Type
all_expr_ty ;
FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs ;
let { normalised_type :: Type
normalised_type = Reduction -> Type
reductionReducedType (Reduction -> Type) -> Reduction -> Type
forall a b. (a -> b) -> a -> b
$ FamInstEnvs -> Role -> Type -> Reduction
normaliseType FamInstEnvs
fam_envs Role
Nominal Type
ty
; final_type :: Type
final_type = if Type -> Bool
isSigmaTy Type
res_ty then Type
ty else Type
normalised_type } ;
Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
final_type }
where
(Bool
inst, InferMode
infer_mode, TcRn (Bag EvBind) -> TcRn (Bag EvBind)
perhaps_disable_default_warnings) = case TcRnExprMode
mode of
TcRnExprMode
TM_Inst -> (Bool
False, InferMode
NoRestrictions, TcRn (Bag EvBind) -> TcRn (Bag EvBind)
forall a. a -> a
id)
TcRnExprMode
TM_Default -> (Bool
True, InferMode
EagerDefaulting, WarningFlag -> TcRn (Bag EvBind) -> TcRn (Bag EvBind)
forall gbl lcl a.
WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM WarningFlag
Opt_WarnTypeDefaults)
tcRnImportDecls :: HscEnv
-> [LImportDecl GhcPs]
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
tcRnImportDecls :: HscEnv
-> [LImportDecl GhcPs]
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
tcRnImportDecls HscEnv
hsc_env [LImportDecl GhcPs]
import_decls
= HscEnv
-> TcRn GlobalRdrEnv
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn GlobalRdrEnv
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv))
-> TcRn GlobalRdrEnv
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$
do { TcGblEnv
gbl_env <- (TcGblEnv -> TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv TcGblEnv -> TcGblEnv
zap_rdr_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv
tcRnImports HscEnv
hsc_env ([(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv)
-> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc))
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(GenLocated SrcSpanAnnA (ImportDecl GhcPs), SDoc)]
forall a b. (a -> b) -> [a] -> [b]
map (,String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is directly imported") [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
import_decls
; GlobalRdrEnv -> TcRn GlobalRdrEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
gbl_env) }
where
zap_rdr_env :: TcGblEnv -> TcGblEnv
zap_rdr_env TcGblEnv
gbl_env = TcGblEnv
gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
tcRnType :: HscEnv
-> ZonkFlexi
-> Bool
-> LHsType GhcPs
-> IO (Messages TcRnMessage, Maybe (Type, Kind))
tcRnType :: HscEnv
-> ZonkFlexi
-> Bool
-> LHsType GhcPs
-> IO (Messages TcRnMessage, Maybe (Type, Type))
tcRnType HscEnv
hsc_env ZonkFlexi
flexi Bool
normalise LHsType GhcPs
rdr_type
= HscEnv
-> TcM (Type, Type)
-> IO (Messages TcRnMessage, Maybe (Type, Type))
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcM (Type, Type) -> IO (Messages TcRnMessage, Maybe (Type, Type)))
-> TcM (Type, Type)
-> IO (Messages TcRnMessage, Maybe (Type, Type))
forall a b. (a -> b) -> a -> b
$
Extension -> TcM (Type, Type) -> TcM (Type, Type)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.PolyKinds (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
do { (HsWC { hswc_ext :: forall pass thing. HsWildCardBndrs pass thing -> XHsWC pass thing
hswc_ext = XHsWC
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
wcs, hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = rn_sig_type :: GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
rn_sig_type@(L SrcSpanAnnA
_ (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs (GhcPass 'Renamed)
outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType (GhcPass 'Renamed)
body })) }, FreeVars
_fvs)
<- HsDocContext
-> LHsSigWcType GhcPs
-> RnM (LHsSigWcType (GhcPass 'Renamed), FreeVars)
rnHsSigWcType HsDocContext
GHCiCtx (LHsSigType GhcPs -> LHsSigWcType GhcPs
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs (LHsSigType GhcPs -> LHsSigWcType GhcPs)
-> LHsSigType GhcPs -> LHsSigWcType GhcPs
forall a b. (a -> b) -> a -> b
$ HsSigType GhcPs -> LocatedAn AnnListItem (HsSigType GhcPs)
forall a an. a -> LocatedAn an a
noLocA (LHsType GhcPs -> HsSigType GhcPs
mkHsImplicitSigType LHsType GhcPs
rdr_type))
; IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcRnType" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [[Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
XHsWC
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
wcs, GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
rn_sig_type])
; SkolemInfo
si <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo)
-> SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall a b. (a -> b) -> a -> b
$ UserTypeCtxt -> SkolemInfoAnon
SigTypeSkol (Bool -> UserTypeCtxt
GhciCtxt Bool
True)
; ((HsOuterTyVarBndrs Specificity GhcTc
_, (Type
ty, Type
kind)), WantedConstraints
wanted)
<- TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
-> TcM
((HsOuterTyVarBndrs Specificity GhcTc, (Type, Type)),
WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints (TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
-> TcM
((HsOuterTyVarBndrs Specificity GhcTc, (Type, Type)),
WantedConstraints))
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
-> TcM
((HsOuterTyVarBndrs Specificity GhcTc, (Type, Type)),
WantedConstraints)
forall a b. (a -> b) -> a -> b
$
TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
forall r. TcM r -> TcM r
pushTcLevelM_ (TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type)))
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
forall a b. (a -> b) -> a -> b
$
[Name]
-> ([(Name, Var)]
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type)))
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
forall a. [Name] -> ([(Name, Var)] -> TcM a) -> TcM a
bindNamedWildCardBinders [Name]
XHsWC
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
wcs (([(Name, Var)]
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type)))
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type)))
-> ([(Name, Var)]
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type)))
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
forall a b. (a -> b) -> a -> b
$ \ [(Name, Var)]
wcs' ->
do { ((Name, Var) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [(Name, Var)] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, Var) -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitNamedTypeHole [(Name, Var)]
wcs'
; SkolemInfo
-> HsOuterSigTyVarBndrs (GhcPass 'Renamed)
-> TcM (Type, Type)
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> HsOuterTyVarBndrs flag (GhcPass 'Renamed)
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrs SkolemInfo
si HsOuterSigTyVarBndrs (GhcPass 'Renamed)
outer_bndrs (TcM (Type, Type)
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type)))
-> TcM (Type, Type)
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, (Type, Type))
forall a b. (a -> b) -> a -> b
$ LHsType (GhcPass 'Renamed) -> TcM (Type, Type)
tcInferLHsTypeUnsaturated LHsType (GhcPass 'Renamed)
body }
; Bag EvBind
empty_binds <- WantedConstraints -> TcRn (Bag EvBind)
simplifyTop WantedConstraints
wanted
; Bool -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (Bag EvBind -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag EvBind
empty_binds) (Bag EvBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag EvBind
empty_binds)
; [Var]
kvs <- SkolemInfo -> Type -> TcM [Var]
kindGeneralizeAll SkolemInfo
HasCallStack => SkolemInfo
unkSkol Type
kind
; ZonkEnv
e <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
flexi
; Type
ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
e Type
ty
; UserTypeCtxt -> Type -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkValidType (Bool -> UserTypeCtxt
GhciCtxt Bool
True) Type
ty
; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; let ty' :: Type
ty' | Bool
normalise = Type -> Type
expandTypeSynonyms (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Reduction -> Type
reductionReducedType (Reduction -> Type) -> Reduction -> Type
forall a b. (a -> b) -> a -> b
$
FamInstEnvs -> Role -> Type -> Reduction
normaliseType FamInstEnvs
fam_envs Role
Nominal Type
ty
| Bool
otherwise = Type
ty
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcRnExpr" (Type -> SDoc
debugPprType Type
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
debugPprType Type
ty')
; (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty', [Var] -> Type -> Type
mkInfForAllTys [Var]
kvs ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty')) }
tcRnDeclsi :: HscEnv
-> [LHsDecl GhcPs]
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnDeclsi :: HscEnv
-> [LHsDecl GhcPs] -> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnDeclsi HscEnv
hsc_env [LHsDecl GhcPs]
local_decls
= HscEnv -> TcM TcGblEnv -> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcM TcGblEnv -> IO (Messages TcRnMessage, Maybe TcGblEnv))
-> TcM TcGblEnv -> IO (Messages TcRnMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
Bool
-> Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
-> [LHsDecl GhcPs]
-> TcM TcGblEnv
tcRnSrcDecls Bool
False Maybe (LocatedAn AnnList [XRec GhcPs (IE GhcPs)])
Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a. Maybe a
Nothing [LHsDecl GhcPs]
local_decls
externaliseAndTidyId :: Module -> Id -> TcM Id
externaliseAndTidyId :: Module -> Var -> TcM Var
externaliseAndTidyId Module
this_mod Var
id
= do { Name
name' <- Module -> Name -> TcRn Name
forall m n. Module -> Name -> TcRnIf m n Name
externaliseName Module
this_mod (Var -> Name
idName Var
id)
; Var -> TcM Var
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> TcM Var) -> Var -> TcM Var
forall a b. (a -> b) -> a -> b
$ Var -> Var
globaliseId Var
id
Var -> Name -> Var
`setIdName` Name
name'
Var -> Type -> Var
`setIdType` Type -> Type
tidyTopType (Var -> Type
idType Var
id) }
getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
getModuleInterface :: HscEnv
-> Module
-> IO (Messages TcRnMessage, Maybe (ModIface_ 'ModIfaceFinal))
getModuleInterface HscEnv
hsc_env Module
mod
= HscEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
-> IO (Messages TcRnMessage, Maybe (ModIface_ 'ModIfaceFinal))
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
-> IO (Messages TcRnMessage, Maybe (ModIface_ 'ModIfaceFinal)))
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
-> IO (Messages TcRnMessage, Maybe (ModIface_ 'ModIfaceFinal))
forall a b. (a -> b) -> a -> b
$
SDoc
-> Module
-> IOEnv (Env TcGblEnv TcLclEnv) (ModIface_ 'ModIfaceFinal)
loadModuleInterface (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"getModuleInterface") Module
mod
tcRnLookupRdrName :: HscEnv -> LocatedN RdrName
-> IO (Messages TcRnMessage, Maybe [Name])
tcRnLookupRdrName :: HscEnv
-> GenLocated SrcSpanAnnN RdrName
-> IO (Messages TcRnMessage, Maybe [Name])
tcRnLookupRdrName HscEnv
hsc_env (L SrcSpanAnnN
loc RdrName
rdr_name)
= HscEnv -> TcRn [Name] -> IO (Messages TcRnMessage, Maybe [Name])
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn [Name] -> IO (Messages TcRnMessage, Maybe [Name]))
-> TcRn [Name] -> IO (Messages TcRnMessage, Maybe [Name])
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnN -> TcRn [Name] -> TcRn [Name]
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnN
loc (TcRn [Name] -> TcRn [Name]) -> TcRn [Name] -> TcRn [Name]
forall a b. (a -> b) -> a -> b
$
do {
let rdr_names :: [RdrName]
rdr_names = RdrName -> [RdrName]
dataTcOccs RdrName
rdr_name
; [[Name]]
names_s <- (RdrName -> TcRn [Name])
-> [RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM RdrName -> TcRn [Name]
lookupInfoOccRn [RdrName]
rdr_names
; let names :: [Name]
names = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
names_s
; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
names) (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Not in scope:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name)))
; [Name] -> TcRn [Name]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name]
names }
tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing)
tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing)
tcRnLookupName HscEnv
hsc_env Name
name
= HscEnv -> TcM TyThing -> IO (Messages TcRnMessage, Maybe TyThing)
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcM TyThing -> IO (Messages TcRnMessage, Maybe TyThing))
-> TcM TyThing -> IO (Messages TcRnMessage, Maybe TyThing)
forall a b. (a -> b) -> a -> b
$
Name -> TcM TyThing
tcRnLookupName' Name
name
tcRnLookupName' :: Name -> TcRn TyThing
tcRnLookupName' :: Name -> TcM TyThing
tcRnLookupName' Name
name = do
TcTyThing
tcthing <- Name -> TcM TcTyThing
tcLookup Name
name
case TcTyThing
tcthing of
AGlobal TyThing
thing -> TyThing -> TcM TyThing
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
ATcId{tct_id :: TcTyThing -> Var
tct_id=Var
id} -> TyThing -> TcM TyThing
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> TyThing
AnId Var
id)
TcTyThing
_ -> String -> TcM TyThing
forall a. HasCallStack => String -> a
panic String
"tcRnLookupName'"
tcRnGetInfo :: HscEnv
-> Name
-> IO ( Messages TcRnMessage
, Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
tcRnGetInfo :: HscEnv
-> Name
-> IO
(Messages TcRnMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
tcRnGetInfo HscEnv
hsc_env Name
name
= HscEnv
-> TcRn (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> IO
(Messages TcRnMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> IO
(Messages TcRnMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> TcRn (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> IO
(Messages TcRnMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a b. (a -> b) -> a -> b
$
do { HscEnv -> InteractiveContext -> IOEnv (Env TcGblEnv TcLclEnv) ()
loadUnqualIfaces HscEnv
hsc_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
; TyThing
thing <- Name -> TcM TyThing
tcRnLookupName' Name
name
; Fixity
fixity <- Name -> RnM Fixity
lookupFixityRn Name
name
; ([ClsInst]
cls_insts, [FamInst]
fam_insts) <- TyThing -> TcM ([ClsInst], [FamInst])
lookupInsts TyThing
thing
; let info :: SDoc
info = Name -> SDoc
lookupKnownNameInfo Name
name
; (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> TcRn (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing
thing, Fixity
fixity, [ClsInst]
cls_insts, [FamInst]
fam_insts, SDoc
info) }
lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
lookupInsts :: TyThing -> TcM ([ClsInst], [FamInst])
lookupInsts (ATyCon TyCon
tc)
= do { InstEnvs { ie_global :: InstEnvs -> InstEnv
ie_global = InstEnv
pkg_ie, ie_local :: InstEnvs -> InstEnv
ie_local = InstEnv
home_ie, ie_visible :: InstEnvs -> VisibleOrphanModules
ie_visible = VisibleOrphanModules
vis_mods } <- TcM InstEnvs
tcGetInstEnvs
; (FamInstEnv
pkg_fie, FamInstEnv
home_fie) <- TcM FamInstEnvs
tcGetFamInstEnvs
; let cls_insts :: [ClsInst]
cls_insts =
[ ClsInst
ispec
| ClsInst
ispec <- InstEnv -> [ClsInst]
instEnvElts InstEnv
home_ie [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ InstEnv -> [ClsInst]
instEnvElts InstEnv
pkg_ie
, VisibleOrphanModules -> ClsInst -> Bool
instIsVisible VisibleOrphanModules
vis_mods ClsInst
ispec
, Name
tc_name Name -> FreeVars -> Bool
`elemNameSet` ClsInst -> FreeVars
orphNamesOfClsInst ClsInst
ispec ]
; let fam_insts :: [FamInst]
fam_insts =
[ FamInst
fispec
| FamInst
fispec <- FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
home_fie [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
pkg_fie
, Name
tc_name Name -> FreeVars -> Bool
`elemNameSet` FamInst -> FreeVars
orphNamesOfFamInst FamInst
fispec ]
; ([ClsInst], [FamInst]) -> TcM ([ClsInst], [FamInst])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ClsInst]
cls_insts, [FamInst]
fam_insts) }
where
tc_name :: Name
tc_name = TyCon -> Name
tyConName TyCon
tc
lookupInsts TyThing
_ = ([ClsInst], [FamInst]) -> TcM ([ClsInst], [FamInst])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],[])
loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
loadUnqualIfaces :: HscEnv -> InteractiveContext -> IOEnv (Env TcGblEnv TcLclEnv) ()
loadUnqualIfaces HscEnv
hsc_env InteractiveContext
ictxt
= IfG () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IfG () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
(Module -> IOEnv (Env IfGblEnv ()) (ModIface_ 'ModIfaceFinal))
-> [Module] -> IfG ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc
-> Module -> IOEnv (Env IfGblEnv ()) (ModIface_ 'ModIfaceFinal)
forall lcl. SDoc -> Module -> IfM lcl (ModIface_ 'ModIfaceFinal)
loadSysInterface SDoc
doc) (VisibleOrphanModules -> [Module]
moduleSetElts ([Module] -> VisibleOrphanModules
mkModuleSet [Module]
unqual_mods))
where
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
unqual_mods :: [Module]
unqual_mods = [ (() :: Constraint) => Name -> Module
Name -> Module
nameModule Name
name
| GlobalRdrElt
gre <- GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts (InteractiveContext -> GlobalRdrEnv
icReaderEnv InteractiveContext
ictxt)
, let name :: Name
name = GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre
, HomeUnit -> Name -> Bool
nameIsFromExternalPackage HomeUnit
home_unit Name
name
, OccName -> Bool
isTcOcc (Name -> OccName
nameOccName Name
name)
, GlobalRdrElt -> Bool
unQualOK GlobalRdrElt
gre ]
doc :: SDoc
doc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Need interface for module whose export(s) are in scope unqualified"
rnDump :: (Outputable a, Data a) => a -> TcRn ()
rnDump :: forall a.
(Outputable a, Data a) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) ()
rnDump a
rn = DumpFlag
-> String -> DumpFormat -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
dumpOptTcRn DumpFlag
Opt_D_dump_rn String
"Renamer" DumpFormat
FormatHaskell (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
rn)
tcDump :: TcGblEnv -> TcRn ()
tcDump :: TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcDump TcGblEnv
env
= do { UnitState
unit_state <- (() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units (HscEnv -> UnitState)
-> TcRnIf TcGblEnv TcLclEnv HscEnv
-> IOEnv (Env TcGblEnv TcLclEnv) UnitState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv ;
Logger
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger ;
Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_types Bool -> Bool -> Bool
|| Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_tc)
(Bool
-> DumpFlag
-> String
-> DumpFormat
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) ()
dumpTcRn Bool
True DumpFlag
Opt_D_dump_types
String
"" DumpFormat
FormatText (UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state SDoc
short_dump)) ;
DumpFlag
-> String -> DumpFormat -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
dumpOptTcRn DumpFlag
Opt_D_dump_tc String
"Typechecker" DumpFormat
FormatHaskell SDoc
full_dump;
DumpFlag
-> String -> DumpFormat -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
dumpOptTcRn DumpFlag
Opt_D_dump_tc_ast String
"Typechecker AST" DumpFormat
FormatHaskell SDoc
ast_dump
}
where
short_dump :: SDoc
short_dump = TcGblEnv -> SDoc
pprTcGblEnv TcGblEnv
env
full_dump :: SDoc
full_dump = LHsBinds GhcTc -> SDoc
forall (idL :: Pass) (idR :: Pass).
(OutputableBndrId idL, OutputableBndrId idR) =>
LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds (TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
env)
ast_dump :: SDoc
ast_dump = BlankSrcSpan
-> BlankEpAnnotations
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> SDoc
forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations (TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
env)
pprTcGblEnv :: TcGblEnv -> SDoc
pprTcGblEnv :: TcGblEnv -> SDoc
pprTcGblEnv (TcGblEnv { tcg_type_env :: TcGblEnv -> TypeEnv
tcg_type_env = TypeEnv
type_env,
tcg_insts :: TcGblEnv -> [ClsInst]
tcg_insts = [ClsInst]
insts,
tcg_fam_insts :: TcGblEnv -> [FamInst]
tcg_fam_insts = [FamInst]
fam_insts,
tcg_rules :: TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules = [LRuleDecl GhcTc]
rules,
tcg_imports :: TcGblEnv -> ImportAvails
tcg_imports = ImportAvails
imports })
= (Bool -> SDoc) -> SDoc
forall doc. IsOutput doc => (Bool -> doc) -> doc
getPprDebug ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \Bool
debug ->
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Bool -> TypeEnv -> SDoc
ppr_types Bool
debug TypeEnv
type_env
, Bool -> [FamInst] -> TypeEnv -> SDoc
ppr_tycons Bool
debug [FamInst]
fam_insts TypeEnv
type_env
, Bool -> TypeEnv -> SDoc
ppr_datacons Bool
debug TypeEnv
type_env
, TypeEnv -> SDoc
ppr_patsyns TypeEnv
type_env
, [ClsInst] -> SDoc
ppr_insts [ClsInst]
insts
, [FamInst] -> SDoc
ppr_fam_insts [FamInst]
fam_insts
, [LRuleDecl GhcTc] -> SDoc
ppr_rules [LRuleDecl GhcTc]
rules
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Dependent modules:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
([(InstalledModule, ModuleNameWithIsBoot)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([(InstalledModule, ModuleNameWithIsBoot)] -> SDoc)
-> (InstalledModuleEnv ModuleNameWithIsBoot
-> [(InstalledModule, ModuleNameWithIsBoot)])
-> InstalledModuleEnv ModuleNameWithIsBoot
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(InstalledModule, ModuleNameWithIsBoot)]
-> [(InstalledModule, ModuleNameWithIsBoot)]
forall a. Ord a => [a] -> [a]
sort ([(InstalledModule, ModuleNameWithIsBoot)]
-> [(InstalledModule, ModuleNameWithIsBoot)])
-> (InstalledModuleEnv ModuleNameWithIsBoot
-> [(InstalledModule, ModuleNameWithIsBoot)])
-> InstalledModuleEnv ModuleNameWithIsBoot
-> [(InstalledModule, ModuleNameWithIsBoot)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledModuleEnv ModuleNameWithIsBoot
-> [(InstalledModule, ModuleNameWithIsBoot)]
forall a. InstalledModuleEnv a -> [(InstalledModule, a)]
installedModuleEnvElts (InstalledModuleEnv ModuleNameWithIsBoot -> SDoc)
-> InstalledModuleEnv ModuleNameWithIsBoot -> SDoc
forall a b. (a -> b) -> a -> b
$ ImportAvails -> InstalledModuleEnv ModuleNameWithIsBoot
imp_direct_dep_mods ImportAvails
imports)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Dependent packages:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
[UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Set UnitId -> [UnitId]
forall a. Set a -> [a]
S.toList (Set UnitId -> [UnitId]) -> Set UnitId -> [UnitId]
forall a b. (a -> b) -> a -> b
$ ImportAvails -> Set UnitId
imp_dep_direct_pkgs ImportAvails
imports)]
ppr_rules :: [LRuleDecl GhcTc] -> SDoc
ppr_rules :: [LRuleDecl GhcTc] -> SDoc
ppr_rules [LRuleDecl GhcTc]
rules
= Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppUnless ([GenLocated SrcSpanAnnA (RuleDecl GhcTc)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LRuleDecl GhcTc]
[GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RULES")
Arity
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((GenLocated SrcSpanAnnA (RuleDecl GhcTc) -> SDoc)
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (RuleDecl GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LRuleDecl GhcTc]
[GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules))
ppr_types :: Bool -> TypeEnv -> SDoc
ppr_types :: Bool -> TypeEnv -> SDoc
ppr_types Bool
debug TypeEnv
type_env
= String -> (Var -> SDoc) -> [Var] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"TYPE SIGNATURES" Var -> SDoc
ppr_sig
((Var -> Var -> Ordering) -> [Var] -> [Var]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Var -> OccName) -> Var -> Var -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Var -> OccName
forall a. NamedThing a => a -> OccName
getOccName) [Var]
ids)
where
ids :: [Var]
ids = [Var
id | Var
id <- TypeEnv -> [Var]
typeEnvIds TypeEnv
type_env, Var -> Bool
want_sig Var
id]
want_sig :: Var -> Bool
want_sig Var
id
| Bool
debug = Bool
True
| Bool
otherwise = Var -> Bool
forall x. NamedThing x => x -> Bool
hasTopUserName Var
id
Bool -> Bool -> Bool
&& case Var -> IdDetails
idDetails Var
id of
IdDetails
VanillaId -> Bool
True
WorkerLikeId{} -> Bool
True
RecSelId {} -> Bool
True
ClassOpId {} -> Bool
True
FCallId {} -> Bool
True
IdDetails
_ -> Bool
False
ppr_sig :: Var -> SDoc
ppr_sig Var
id = SDoc -> Arity -> SDoc -> SDoc
hang (Var -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Var
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon) Arity
2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> Type
tidyTopType (Var -> Type
idType Var
id)))
ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc
ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc
ppr_tycons Bool
debug [FamInst]
fam_insts TypeEnv
type_env
= [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> (TyCon -> SDoc) -> [TyCon] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"TYPE CONSTRUCTORS" TyCon -> SDoc
ppr_tc [TyCon]
tycons
, String -> (CoAxiom Branched -> SDoc) -> [CoAxiom Branched] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"COERCION AXIOMS" CoAxiom Branched -> SDoc
forall {br :: BranchFlag}. CoAxiom br -> SDoc
ppr_ax
(TypeEnv -> [CoAxiom Branched]
typeEnvCoAxioms TypeEnv
type_env) ]
where
fi_tycons :: [TyCon]
fi_tycons = [FamInst] -> [TyCon]
famInstsRepTyCons [FamInst]
fam_insts
tycons :: [TyCon]
tycons = (TyCon -> TyCon -> Ordering) -> [TyCon] -> [TyCon]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((TyCon -> OccName) -> TyCon -> TyCon -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName) ([TyCon] -> [TyCon]) -> [TyCon] -> [TyCon]
forall a b. (a -> b) -> a -> b
$
[TyCon
tycon | TyCon
tycon <- TypeEnv -> [TyCon]
typeEnvTyCons TypeEnv
type_env
, TyCon -> Bool
want_tycon TyCon
tycon]
want_tycon :: TyCon -> Bool
want_tycon TyCon
tycon | Bool
debug = Bool
True
| Bool
otherwise = Name -> Bool
isExternalName (TyCon -> Name
tyConName TyCon
tycon) Bool -> Bool -> Bool
&&
Bool -> Bool
not (TyCon
tycon TyCon -> [TyCon] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyCon]
fi_tycons)
ppr_tc :: TyCon -> SDoc
ppr_tc TyCon
tc
= [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> Arity -> SDoc -> SDoc
hang (TyConFlavour -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> TyConFlavour
tyConFlavour TyCon
tc) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc (TyCon -> Name
tyConName TyCon
tc)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Arity
tyConArity TyCon
tc)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon)
Arity
2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> Type
tidyTopType (TyCon -> Type
tyConKind TyCon
tc)))
, Arity -> SDoc -> SDoc
nest Arity
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppWhen Bool
show_roles (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"roles" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep ((Role -> SDoc) -> [Role] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Role]
roles)) ]
where
show_roles :: Bool
show_roles = Bool
debug Bool -> Bool -> Bool
|| Bool -> Bool
not ((Role -> Bool) -> [Role] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
boring_role) [Role]
roles)
roles :: [Role]
roles = TyCon -> [Role]
tyConRoles TyCon
tc
boring_role :: Role
boring_role | TyCon -> Bool
isClassTyCon TyCon
tc = Role
Nominal
| Bool
otherwise = Role
Representational
ppr_ax :: CoAxiom br -> SDoc
ppr_ax CoAxiom br
ax = IfaceDecl -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoAxiom br -> IfaceDecl
forall (br :: BranchFlag). CoAxiom br -> IfaceDecl
coAxiomToIfaceDecl CoAxiom br
ax)
ppr_datacons :: Bool -> TypeEnv -> SDoc
ppr_datacons :: Bool -> TypeEnv -> SDoc
ppr_datacons Bool
debug TypeEnv
type_env
= String -> (DataCon -> SDoc) -> [DataCon] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"DATA CONSTRUCTORS" DataCon -> SDoc
ppr_dc [DataCon]
wanted_dcs
where
ppr_dc :: DataCon -> SDoc
ppr_dc DataCon
dc = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocLinearTypes (\Bool
show_linear_types ->
DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Bool -> DataCon -> Type
dataConDisplayType Bool
show_linear_types DataCon
dc))
all_dcs :: [DataCon]
all_dcs = TypeEnv -> [DataCon]
typeEnvDataCons TypeEnv
type_env
wanted_dcs :: [DataCon]
wanted_dcs | Bool
debug = [DataCon]
all_dcs
| Bool
otherwise = (DataCon -> Bool) -> [DataCon] -> [DataCon]
forall a. (a -> Bool) -> [a] -> [a]
filterOut DataCon -> Bool
is_cls_dc [DataCon]
all_dcs
is_cls_dc :: DataCon -> Bool
is_cls_dc DataCon
dc = TyCon -> Bool
isClassTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)
ppr_patsyns :: TypeEnv -> SDoc
ppr_patsyns :: TypeEnv -> SDoc
ppr_patsyns TypeEnv
type_env
= String -> (PatSyn -> SDoc) -> [PatSyn] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"PATTERN SYNONYMS" PatSyn -> SDoc
ppr_ps
(TypeEnv -> [PatSyn]
typeEnvPatSyns TypeEnv
type_env)
where
ppr_ps :: PatSyn -> SDoc
ppr_ps PatSyn
ps = PatSyn -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc PatSyn
ps SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PatSyn -> SDoc
pprPatSynType PatSyn
ps
ppr_insts :: [ClsInst] -> SDoc
ppr_insts :: [ClsInst] -> SDoc
ppr_insts [ClsInst]
ispecs
= String -> (ClsInst -> SDoc) -> [ClsInst] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"CLASS INSTANCES" ClsInst -> SDoc
pprInstance [ClsInst]
ispecs
ppr_fam_insts :: [FamInst] -> SDoc
ppr_fam_insts :: [FamInst] -> SDoc
ppr_fam_insts [FamInst]
fam_insts
= String -> (FamInst -> SDoc) -> [FamInst] -> SDoc
forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
"FAMILY INSTANCES" FamInst -> SDoc
pprFamInst [FamInst]
fam_insts
ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc
ppr_things :: forall a. String -> (a -> SDoc) -> [a] -> SDoc
ppr_things String
herald a -> SDoc
ppr_one [a]
things
| [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
things = SDoc
forall doc. IsOutput doc => doc
empty
| Bool
otherwise = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
herald SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Arity -> SDoc -> SDoc
nest Arity
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((a -> SDoc) -> [a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map a -> SDoc
ppr_one [a]
things))
hasTopUserName :: NamedThing x => x -> Bool
hasTopUserName :: forall x. NamedThing x => x -> Bool
hasTopUserName x
x
= Name -> Bool
isExternalName Name
name Bool -> Bool -> Bool
&& Bool -> Bool
not (OccName -> Bool
isDerivedOccName (Name -> OccName
nameOccName Name
name))
where
name :: Name
name = x -> Name
forall a. NamedThing a => a -> Name
getName x
x
withTcPlugins :: HscEnv -> TcM a -> TcM a
withTcPlugins :: forall a. HscEnv -> TcM a -> TcM a
withTcPlugins HscEnv
hsc_env TcM a
m =
case [Maybe TcPlugin] -> [TcPlugin]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TcPlugin] -> [TcPlugin]) -> [Maybe TcPlugin] -> [TcPlugin]
forall a b. (a -> b) -> a -> b
$ Plugins
-> (Plugin -> [String] -> Maybe TcPlugin) -> [Maybe TcPlugin]
forall a. Plugins -> (Plugin -> [String] -> a) -> [a]
mapPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) Plugin -> [String] -> Maybe TcPlugin
tcPlugin of
[] -> TcM a
m
[TcPlugin]
plugins -> do
([TcPluginSolver]
solvers, [UniqFM TyCon TcPluginRewriter]
rewriters, [TcPluginM ()]
stops) <-
[(TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ())]
-> ([TcPluginSolver], [UniqFM TyCon TcPluginRewriter],
[TcPluginM ()])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ())]
-> ([TcPluginSolver], [UniqFM TyCon TcPluginRewriter],
[TcPluginM ()]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ())]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TcPluginSolver], [UniqFM TyCon TcPluginRewriter], [TcPluginM ()])
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (TcPlugin
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ()))
-> [TcPlugin]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TcPlugin
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ())
start_plugin [TcPlugin]
plugins
let
rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter]
!rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter]
rewritersUniqFM = [UniqFM TyCon TcPluginRewriter] -> UniqFM TyCon [TcPluginRewriter]
forall key elt. [UniqFM key elt] -> UniqFM key [elt]
sequenceUFMList [UniqFM TyCon TcPluginRewriter]
rewriters
Either IOEnvFailure a
eitherRes <- TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM (TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a))
-> TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$
(TcGblEnv -> TcGblEnv) -> TcM a -> TcM a
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
e -> TcGblEnv
e { tcg_tc_plugin_solvers = solvers
, tcg_tc_plugin_rewriters = rewritersUniqFM }) TcM a
m
(TcPluginM () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [TcPluginM ()] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TcPluginM () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcPluginM a -> TcM a
runTcPluginM [TcPluginM ()]
stops
case Either IOEnvFailure a
eitherRes of
Left IOEnvFailure
_ -> TcM a
forall env a. IOEnv env a
failM
Right a
res -> a -> TcM a
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
where
start_plugin :: TcPlugin
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ())
start_plugin (TcPlugin TcPluginM s
start s -> TcPluginSolver
solve s -> UniqFM TyCon TcPluginRewriter
rewrite s -> TcPluginM ()
stop) =
do s
s <- TcPluginM s -> TcM s
forall a. TcPluginM a -> TcM a
runTcPluginM TcPluginM s
start
(TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ())
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ())
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> TcPluginSolver
solve s
s, s -> UniqFM TyCon TcPluginRewriter
rewrite s
s, s -> TcPluginM ()
stop s
s)
withDefaultingPlugins :: HscEnv -> TcM a -> TcM a
withDefaultingPlugins :: forall a. HscEnv -> TcM a -> TcM a
withDefaultingPlugins HscEnv
hsc_env TcM a
m =
do case [Maybe DefaultingPlugin] -> [DefaultingPlugin]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DefaultingPlugin] -> [DefaultingPlugin])
-> [Maybe DefaultingPlugin] -> [DefaultingPlugin]
forall a b. (a -> b) -> a -> b
$ Plugins
-> (Plugin -> [String] -> Maybe DefaultingPlugin)
-> [Maybe DefaultingPlugin]
forall a. Plugins -> (Plugin -> [String] -> a) -> [a]
mapPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) Plugin -> [String] -> Maybe DefaultingPlugin
defaultingPlugin of
[] -> TcM a
m
[DefaultingPlugin]
plugins -> do ([FillDefaulting]
plugins,[TcPluginM ()]
stops) <- (DefaultingPlugin
-> IOEnv (Env TcGblEnv TcLclEnv) (FillDefaulting, TcPluginM ()))
-> [DefaultingPlugin]
-> IOEnv (Env TcGblEnv TcLclEnv) ([FillDefaulting], [TcPluginM ()])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM DefaultingPlugin
-> IOEnv (Env TcGblEnv TcLclEnv) (FillDefaulting, TcPluginM ())
start_plugin [DefaultingPlugin]
plugins
Either IOEnvFailure a
eitherRes <- TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM (TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a))
-> TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$ do
(TcGblEnv -> TcGblEnv) -> TcM a -> TcM a
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
e -> TcGblEnv
e { tcg_defaulting_plugins = plugins }) TcM a
m
(TcPluginM () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [TcPluginM ()] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TcPluginM () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcPluginM a -> TcM a
runTcPluginM [TcPluginM ()]
stops
case Either IOEnvFailure a
eitherRes of
Left IOEnvFailure
_ -> TcM a
forall env a. IOEnv env a
failM
Right a
res -> a -> TcM a
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
where
start_plugin :: DefaultingPlugin
-> IOEnv (Env TcGblEnv TcLclEnv) (FillDefaulting, TcPluginM ())
start_plugin (DefaultingPlugin TcPluginM s
start s -> FillDefaulting
fill s -> TcPluginM ()
stop) =
do s
s <- TcPluginM s -> TcM s
forall a. TcPluginM a -> TcM a
runTcPluginM TcPluginM s
start
(FillDefaulting, TcPluginM ())
-> IOEnv (Env TcGblEnv TcLclEnv) (FillDefaulting, TcPluginM ())
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> FillDefaulting
fill s
s, s -> TcPluginM ()
stop s
s)
withHoleFitPlugins :: HscEnv -> TcM a -> TcM a
withHoleFitPlugins :: forall a. HscEnv -> TcM a -> TcM a
withHoleFitPlugins HscEnv
hsc_env TcM a
m =
case [Maybe HoleFitPluginR] -> [HoleFitPluginR]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe HoleFitPluginR] -> [HoleFitPluginR])
-> [Maybe HoleFitPluginR] -> [HoleFitPluginR]
forall a b. (a -> b) -> a -> b
$ Plugins
-> (Plugin -> [String] -> Maybe HoleFitPluginR)
-> [Maybe HoleFitPluginR]
forall a. Plugins -> (Plugin -> [String] -> a) -> [a]
mapPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) Plugin -> [String] -> Maybe HoleFitPluginR
holeFitPlugin of
[] -> TcM a
m
[HoleFitPluginR]
plugins -> do ([HoleFitPlugin]
plugins,[IOEnv (Env TcGblEnv TcLclEnv) ()]
stops) <- (HoleFitPluginR
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HoleFitPlugin, IOEnv (Env TcGblEnv TcLclEnv) ()))
-> [HoleFitPluginR]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([HoleFitPlugin], [IOEnv (Env TcGblEnv TcLclEnv) ()])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM HoleFitPluginR
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HoleFitPlugin, IOEnv (Env TcGblEnv TcLclEnv) ())
start_plugin [HoleFitPluginR]
plugins
Either IOEnvFailure a
eitherRes <- TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM (TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a))
-> TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$
(TcGblEnv -> TcGblEnv) -> TcM a -> TcM a
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\TcGblEnv
e -> TcGblEnv
e { tcg_hf_plugins = plugins }) TcM a
m
[IOEnv (Env TcGblEnv TcLclEnv) ()]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IOEnv (Env TcGblEnv TcLclEnv) ()]
stops
case Either IOEnvFailure a
eitherRes of
Left IOEnvFailure
_ -> TcM a
forall env a. IOEnv env a
failM
Right a
res -> a -> TcM a
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
where
start_plugin :: HoleFitPluginR
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HoleFitPlugin, IOEnv (Env TcGblEnv TcLclEnv) ())
start_plugin (HoleFitPluginR TcM (TcRef s)
init TcRef s -> HoleFitPlugin
plugin TcRef s -> IOEnv (Env TcGblEnv TcLclEnv) ()
stop) =
do TcRef s
ref <- TcM (TcRef s)
init
(HoleFitPlugin, IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HoleFitPlugin, IOEnv (Env TcGblEnv TcLclEnv) ())
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcRef s -> HoleFitPlugin
plugin TcRef s
ref, TcRef s -> IOEnv (Env TcGblEnv TcLclEnv) ()
stop TcRef s
ref)
runRenamerPlugin :: TcGblEnv
-> HsGroup GhcRn
-> TcM (TcGblEnv, HsGroup GhcRn)
runRenamerPlugin :: TcGblEnv
-> HsGroup (GhcPass 'Renamed)
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
runRenamerPlugin TcGblEnv
gbl_env HsGroup (GhcPass 'Renamed)
hs_group = do
HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
Plugins
-> PluginOperation
(IOEnv (Env TcGblEnv TcLclEnv))
(TcGblEnv, HsGroup (GhcPass 'Renamed))
-> (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall (m :: * -> *) a.
Monad m =>
Plugins -> PluginOperation m a -> a -> m a
withPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env)
(\Plugin
p [String]
opts (TcGblEnv
e, HsGroup (GhcPass 'Renamed)
g) -> ( DynFlags -> IOEnv (Env TcGblEnv TcLclEnv) ()
mark_plugin_unsafe (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
IOEnv (Env TcGblEnv TcLclEnv) ()
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Plugin
-> [String]
-> TcGblEnv
-> HsGroup (GhcPass 'Renamed)
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
renamedResultAction Plugin
p [String]
opts TcGblEnv
e HsGroup (GhcPass 'Renamed)
g))
(TcGblEnv
gbl_env, HsGroup (GhcPass 'Renamed)
hs_group)
type RenamedStuff =
(Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
Maybe (LHsDoc GhcRn)))
getRenamedStuff :: TcGblEnv -> RenamedStuff
getRenamedStuff :: TcGblEnv -> RenamedStuff
getRenamedStuff TcGblEnv
tc_result
= (HsGroup (GhcPass 'Renamed)
-> (HsGroup (GhcPass 'Renamed),
[GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))],
Maybe
[(GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)), [AvailInfo])],
Maybe (GenLocated SrcSpan (HsDoc (GhcPass 'Renamed)))))
-> Maybe (HsGroup (GhcPass 'Renamed))
-> Maybe
(HsGroup (GhcPass 'Renamed),
[GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Renamed))],
Maybe
[(GenLocated SrcSpanAnnA (IE (GhcPass 'Renamed)), [AvailInfo])],
Maybe (GenLocated SrcSpan (HsDoc (GhcPass 'Renamed))))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HsGroup (GhcPass 'Renamed)
decls -> ( HsGroup (GhcPass 'Renamed)
decls, TcGblEnv -> [LImportDecl (GhcPass 'Renamed)]
tcg_rn_imports TcGblEnv
tc_result
, TcGblEnv -> Maybe [(LIE (GhcPass 'Renamed), [AvailInfo])]
tcg_rn_exports TcGblEnv
tc_result, TcGblEnv -> Maybe (GenLocated SrcSpan (HsDoc (GhcPass 'Renamed)))
tcg_doc_hdr TcGblEnv
tc_result ) )
(TcGblEnv -> Maybe (HsGroup (GhcPass 'Renamed))
tcg_rn_decls TcGblEnv
tc_result)
runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv
runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv
runTypecheckerPlugin ModSummary
sum TcGblEnv
gbl_env = do
HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
Plugins
-> PluginOperation (IOEnv (Env TcGblEnv TcLclEnv)) TcGblEnv
-> TcGblEnv
-> TcM TcGblEnv
forall (m :: * -> *) a.
Monad m =>
Plugins -> PluginOperation m a -> a -> m a
withPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env)
(\Plugin
p [String]
opts TcGblEnv
env -> DynFlags -> IOEnv (Env TcGblEnv TcLclEnv) ()
mark_plugin_unsafe (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
IOEnv (Env TcGblEnv TcLclEnv) () -> TcM TcGblEnv -> TcM TcGblEnv
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Plugin -> [String] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typeCheckResultAction Plugin
p [String]
opts ModSummary
sum TcGblEnv
env)
TcGblEnv
gbl_env
mark_plugin_unsafe :: DynFlags -> TcM ()
mark_plugin_unsafe :: DynFlags -> IOEnv (Env TcGblEnv TcLclEnv) ()
mark_plugin_unsafe DynFlags
dflags = Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PluginTrustworthy DynFlags
dflags) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
Messages TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
recordUnsafeInfer Messages TcRnMessage
pluginUnsafe
where
!diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
pluginUnsafe :: Messages TcRnMessage
pluginUnsafe =
MsgEnvelope TcRnMessage -> Messages TcRnMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope TcRnMessage -> Messages TcRnMessage)
-> MsgEnvelope TcRnMessage -> Messages TcRnMessage
forall a b. (a -> b) -> a -> b
$
DiagOpts -> SrcSpan -> TcRnMessage -> MsgEnvelope TcRnMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan TcRnMessage
TcRnUnsafeDueToPlugin