{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
module GHC.Driver.Main
(
newHscEnv
, Messager, batchMsg
, HscBackendAction (..), HscRecompStatus (..)
, initModDetails
, hscMaybeWriteIface
, hscCompileCmmFile
, hscGenHardCode
, hscInteractive
, hscRecompStatus
, hscParse
, hscTypecheckRename
, hscTypecheckAndGetWarnings
, hscDesugar
, makeSimpleDetails
, hscSimplify
, hscDesugarAndSimplify
, hscCheckSafe
, hscGetSafe
, hscParseIdentifier
, hscTcRcLookupName
, hscTcRnGetInfo
, hscIsGHCiMonad
, hscGetModuleInterface
, hscRnImportDecls
, hscTcRnLookupRdrName
, hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
, hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
, hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
, hscParseExpr
, hscParseType
, hscCompileCoreExpr
, hscCompileCoreExpr'
, hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen
, getHscEnv
, hscSimpleIface'
, oneShotMsg
, dumpIfaceStats
, ioMsgMaybe
, showModuleIndex
, hscAddSptEntries
) where
import GHC.Prelude
import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.CodeOutput
import GHC.Driver.Config
import GHC.Driver.Hooks
import GHC.Runtime.Context
import GHC.Runtime.Interpreter ( addSptEntry )
import GHC.Runtime.Loader ( initializePlugins )
import GHCi.RemoteTypes ( ForeignHValue )
import GHC.ByteCode.Types
import GHC.Linker.Loader
import GHC.Linker.Types
import GHC.Hs
import GHC.Hs.Dump
import GHC.Hs.Stats ( ppSourceStats )
import GHC.HsToCore
import GHC.StgToByteCode ( byteCodeGen, stgExprToBCOs )
import GHC.IfaceToCore ( typecheckIface )
import GHC.Iface.Load ( ifaceStats, writeIface )
import GHC.Iface.Make
import GHC.Iface.Recomp
import GHC.Iface.Tidy
import GHC.Iface.Ext.Ast ( mkHieFile )
import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
import GHC.Core
import GHC.Core.Tidy ( tidyExpr )
import GHC.Core.Type ( Type, Kind )
import GHC.Core.Lint ( lintInteractiveExpr )
import GHC.Core.Multiplicity
import GHC.Core.Utils ( exprType )
import GHC.Core.ConLike
import GHC.Core.Opt.Pipeline
import GHC.Core.TyCon
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.CoreToStg.Prep
import GHC.CoreToStg ( coreToStg )
import GHC.Parser.Errors.Types
import GHC.Parser
import GHC.Parser.Lexer as Lexer
import GHC.Tc.Module
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) )
import GHC.Stg.Syntax
import GHC.Stg.FVs ( annTopBindingsFreeVars )
import GHC.Stg.Pipeline ( stg2stg )
import GHC.Builtin.Utils
import GHC.Builtin.Names
import GHC.Builtin.Uniques ( mkPseudoUniqueE )
import qualified GHC.StgToCmm as StgToCmm ( codeGen )
import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)
import GHC.Cmm
import GHC.Cmm.Parser ( parseCmmFile )
import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Info
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.External
import GHC.Unit.State
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Unit.Module.Status
import GHC.Unit.Home.ModInfo
import GHC.Types.Id
import GHC.Types.SourceError
import GHC.Types.SafeHaskell
import GHC.Types.ForeignStubs
import GHC.Types.Var.Env ( emptyTidyEnv )
import GHC.Types.Error hiding ( getMessages )
import qualified GHC.Types.Error as Error.Types
import GHC.Types.Fixity.Env
import GHC.Types.CostCentre
import GHC.Types.IPE
import GHC.Types.SourceFile
import GHC.Types.SrcLoc
import GHC.Types.Name
import GHC.Types.Name.Cache ( initNameCache )
import GHC.Types.Name.Reader
import GHC.Types.Name.Ppr
import GHC.Types.TyThing
import GHC.Types.HpcInfo
import GHC.Utils.Fingerprint ( Fingerprint )
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Data.StringBuffer
import qualified GHC.Data.Stream as Stream
import GHC.Data.Stream (Stream)
import Data.Data hiding (Fixity, TyCon)
import Data.Maybe ( fromJust )
import Data.List ( nub, isPrefixOf, partition )
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
import System.Directory
import System.IO (fixIO)
import qualified Data.Set as S
import Data.Set (Set)
import Data.Functor
import Control.DeepSeq (force)
import Data.Bifunctor (first)
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags = do
NameCache
nc_var <- Char -> [Name] -> IO NameCache
initNameCache Char
'r' [Name]
knownKeyNames
FinderCache
fc_var <- IO FinderCache
initFinderCache
Logger
logger <- IO Logger
initLogger
TmpFs
tmpfs <- IO TmpFs
initTmpFs
UnitEnv
unit_env <- GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv (DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags) (DynFlags -> Platform
targetPlatform DynFlags
dflags)
HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv :: DynFlags
-> [Target]
-> ModuleGraph
-> InteractiveContext
-> NameCache
-> FinderCache
-> Maybe (Module, IORef TypeEnv)
-> Maybe Interp
-> [LoadedPlugin]
-> [StaticPlugin]
-> UnitEnv
-> Logger
-> Hooks
-> TmpFs
-> HscEnv
HscEnv { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags
, hsc_logger :: Logger
hsc_logger = Logger
logger
, hsc_targets :: [Target]
hsc_targets = []
, hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
emptyMG
, hsc_IC :: InteractiveContext
hsc_IC = DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
, hsc_NC :: NameCache
hsc_NC = NameCache
nc_var
, hsc_FC :: FinderCache
hsc_FC = FinderCache
fc_var
, hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
hsc_type_env_var = Maybe (Module, IORef TypeEnv)
forall a. Maybe a
Nothing
, hsc_interp :: Maybe Interp
hsc_interp = Maybe Interp
forall a. Maybe a
Nothing
, hsc_unit_env :: UnitEnv
hsc_unit_env = UnitEnv
unit_env
, hsc_plugins :: [LoadedPlugin]
hsc_plugins = []
, hsc_static_plugins :: [StaticPlugin]
hsc_static_plugins = []
, hsc_hooks :: Hooks
hsc_hooks = Hooks
emptyHooks
, hsc_tmpfs :: TmpFs
hsc_tmpfs = TmpFs
tmpfs
}
getDiagnostics :: Hsc (Messages GhcMessage)
getDiagnostics :: Hsc (Messages GhcMessage)
getDiagnostics = (HscEnv
-> Messages GhcMessage
-> IO (Messages GhcMessage, Messages GhcMessage))
-> Hsc (Messages GhcMessage)
forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc ((HscEnv
-> Messages GhcMessage
-> IO (Messages GhcMessage, Messages GhcMessage))
-> Hsc (Messages GhcMessage))
-> (HscEnv
-> Messages GhcMessage
-> IO (Messages GhcMessage, Messages GhcMessage))
-> Hsc (Messages GhcMessage)
forall a b. (a -> b) -> a -> b
$ \HscEnv
_ Messages GhcMessage
w -> (Messages GhcMessage, Messages GhcMessage)
-> IO (Messages GhcMessage, Messages GhcMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages GhcMessage
w, Messages GhcMessage
w)
clearDiagnostics :: Hsc ()
clearDiagnostics :: Hsc ()
clearDiagnostics = (HscEnv -> Messages GhcMessage -> IO ((), Messages GhcMessage))
-> Hsc ()
forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc ((HscEnv -> Messages GhcMessage -> IO ((), Messages GhcMessage))
-> Hsc ())
-> (HscEnv -> Messages GhcMessage -> IO ((), Messages GhcMessage))
-> Hsc ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
_ Messages GhcMessage
_ -> ((), Messages GhcMessage) -> IO ((), Messages GhcMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Messages GhcMessage
forall e. Messages e
emptyMessages)
logDiagnostics :: Messages GhcMessage -> Hsc ()
logDiagnostics :: Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
w = (HscEnv -> Messages GhcMessage -> IO ((), Messages GhcMessage))
-> Hsc ()
forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc ((HscEnv -> Messages GhcMessage -> IO ((), Messages GhcMessage))
-> Hsc ())
-> (HscEnv -> Messages GhcMessage -> IO ((), Messages GhcMessage))
-> Hsc ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
_ Messages GhcMessage
w0 -> ((), Messages GhcMessage) -> IO ((), Messages GhcMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Messages GhcMessage
w0 Messages GhcMessage -> Messages GhcMessage -> Messages GhcMessage
forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages GhcMessage
w)
getHscEnv :: Hsc HscEnv
getHscEnv :: Hsc HscEnv
getHscEnv = (HscEnv -> Messages GhcMessage -> IO (HscEnv, Messages GhcMessage))
-> Hsc HscEnv
forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc ((HscEnv
-> Messages GhcMessage -> IO (HscEnv, Messages GhcMessage))
-> Hsc HscEnv)
-> (HscEnv
-> Messages GhcMessage -> IO (HscEnv, Messages GhcMessage))
-> Hsc HscEnv
forall a b. (a -> b) -> a -> b
$ \HscEnv
e Messages GhcMessage
w -> (HscEnv, Messages GhcMessage) -> IO (HscEnv, Messages GhcMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, Messages GhcMessage
w)
handleWarnings :: Hsc ()
handleWarnings :: Hsc ()
handleWarnings = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- Hsc Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
Messages GhcMessage
w <- Hsc (Messages GhcMessage)
getDiagnostics
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger DynFlags
dflags Messages GhcMessage
w
Hsc ()
clearDiagnostics
logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc ()
logWarningsReportErrors :: (Messages PsWarning, Messages PsWarning) -> Hsc ()
logWarningsReportErrors (Messages PsWarning
warnings,Messages PsWarning
errors) = do
Messages GhcMessage -> Hsc ()
logDiagnostics (PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage)
-> Messages PsWarning -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
warnings)
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Messages PsWarning -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages PsWarning
errors) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> Hsc ()
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage)
-> Messages PsWarning -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
errors)
handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a
handleWarningsThrowErrors :: (Messages PsWarning, Messages PsWarning) -> Hsc a
handleWarningsThrowErrors (Messages PsWarning
warnings, Messages PsWarning
errors) = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Messages GhcMessage -> Hsc ()
logDiagnostics (PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage)
-> Messages PsWarning -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
warnings)
Logger
logger <- Hsc Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
let (Messages PsWarning
wWarns, Messages PsWarning
wErrs) = Messages PsWarning -> (Messages PsWarning, Messages PsWarning)
forall e. Diagnostic e => Messages e -> (Messages e, Messages e)
partitionMessages Messages PsWarning
warnings
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Messages PsWarning -> IO ()
forall a. Diagnostic a => Logger -> DynFlags -> Messages a -> IO ()
printMessages Logger
logger DynFlags
dflags Messages PsWarning
wWarns
Messages GhcMessage -> Hsc a
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (Messages GhcMessage -> Hsc a) -> Messages GhcMessage -> Hsc a
forall a b. (a -> b) -> a -> b
$ (PsWarning -> GhcMessage)
-> Messages PsWarning -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsWarning -> GhcMessage
GhcPsMessage (Messages PsWarning -> Messages GhcMessage)
-> Messages PsWarning -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ Messages PsWarning
errors Messages PsWarning -> Messages PsWarning -> Messages PsWarning
forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages PsWarning
wErrs
ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe IO (Messages GhcMessage, Maybe a)
ioA = do
(Messages GhcMessage
msgs, Maybe a
mb_r) <- IO (Messages GhcMessage, Maybe a)
-> Hsc (Messages GhcMessage, Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Messages GhcMessage, Maybe a)
ioA
let (Messages GhcMessage
warns, Messages GhcMessage
errs) = Messages GhcMessage -> (Messages GhcMessage, Messages GhcMessage)
forall e. Diagnostic e => Messages e -> (Messages e, Messages e)
partitionMessages Messages GhcMessage
msgs
Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
warns
case Maybe a
mb_r of
Maybe a
Nothing -> Messages GhcMessage -> Hsc a
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors Messages GhcMessage
errs
Just a
r -> Bool -> (a -> Hsc a) -> a -> Hsc a
forall a. HasCallStack => Bool -> a -> a
assert (Messages GhcMessage -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
errs ) a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' IO (Messages GhcMessage, Maybe a)
ioA = do
(Messages GhcMessage
msgs, Maybe a
mb_r) <- IO (Messages GhcMessage, Maybe a)
-> Hsc (Messages GhcMessage, Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages GhcMessage, Maybe a)
-> Hsc (Messages GhcMessage, Maybe a))
-> IO (Messages GhcMessage, Maybe a)
-> Hsc (Messages GhcMessage, Maybe a)
forall a b. (a -> b) -> a -> b
$ IO (Messages GhcMessage, Maybe a)
ioA
Messages GhcMessage -> Hsc ()
logDiagnostics (Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage)
-> Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getWarningMessages Messages GhcMessage
msgs)
Maybe a -> Hsc (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mb_r
hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
hscTcRnLookupRdrName HscEnv
hsc_env0 LocatedN RdrName
rdr_name
= HscEnv -> Hsc [Name] -> IO [Name]
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc [Name] -> IO [Name]) -> Hsc [Name] -> IO [Name]
forall a b. (a -> b) -> a -> b
$
do { HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
; IO (Messages GhcMessage, Maybe [Name]) -> Hsc [Name]
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe [Name]) -> Hsc [Name])
-> IO (Messages GhcMessage, Maybe [Name]) -> Hsc [Name]
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe [Name])
-> IO (Messages GhcMessage, Maybe [Name])
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe [Name])
-> IO (Messages GhcMessage, Maybe [Name]))
-> IO (Messages TcRnMessage, Maybe [Name])
-> IO (Messages GhcMessage, Maybe [Name])
forall a b. (a -> b) -> a -> b
$ HscEnv
-> LocatedN RdrName -> IO (Messages TcRnMessage, Maybe [Name])
tcRnLookupRdrName HscEnv
hsc_env LocatedN RdrName
rdr_name }
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName HscEnv
hsc_env0 Name
name = HscEnv -> Hsc (Maybe TyThing) -> IO (Maybe TyThing)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Maybe TyThing) -> IO (Maybe TyThing))
-> Hsc (Maybe TyThing) -> IO (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
IO (Messages GhcMessage, Maybe TyThing) -> Hsc (Maybe TyThing)
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' (IO (Messages GhcMessage, Maybe TyThing) -> Hsc (Maybe TyThing))
-> IO (Messages GhcMessage, Maybe TyThing) -> Hsc (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe TyThing)
-> IO (Messages GhcMessage, Maybe TyThing)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe TyThing)
-> IO (Messages GhcMessage, Maybe TyThing))
-> IO (Messages TcRnMessage, Maybe TyThing)
-> IO (Messages GhcMessage, Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing)
tcRnLookupName HscEnv
hsc_env Name
name
hscTcRnGetInfo :: HscEnv -> Name
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo :: HscEnv
-> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo HscEnv
hsc_env0 Name
name
= HscEnv
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a b. (a -> b) -> a -> b
$
do { HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
; IO
(Messages GhcMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' (IO
(Messages GhcMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> IO
(Messages GhcMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a b. (a -> b) -> a -> b
$ IO
(Messages TcRnMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> IO
(Messages GhcMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO
(Messages TcRnMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> IO
(Messages GhcMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> IO
(Messages TcRnMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> IO
(Messages GhcMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name
-> IO
(Messages TcRnMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
tcRnGetInfo HscEnv
hsc_env Name
name }
hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad HscEnv
hsc_env String
name
= HscEnv -> Hsc Name -> IO Name
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc Name -> IO Name) -> Hsc Name -> IO Name
forall a b. (a -> b) -> a -> b
$ IO (Messages GhcMessage, Maybe Name) -> Hsc Name
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe Name) -> Hsc Name)
-> IO (Messages GhcMessage, Maybe Name) -> Hsc Name
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe Name)
-> IO (Messages GhcMessage, Maybe Name)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe Name)
-> IO (Messages GhcMessage, Maybe Name))
-> IO (Messages TcRnMessage, Maybe Name)
-> IO (Messages GhcMessage, Maybe Name)
forall a b. (a -> b) -> a -> b
$ HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name)
isGHCiMonad HscEnv
hsc_env String
name
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface HscEnv
hsc_env0 Module
mod = HscEnv -> Hsc ModIface -> IO ModIface
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc ModIface -> IO ModIface) -> Hsc ModIface -> IO ModIface
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
IO (Messages GhcMessage, Maybe ModIface) -> Hsc ModIface
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe ModIface) -> Hsc ModIface)
-> IO (Messages GhcMessage, Maybe ModIface) -> Hsc ModIface
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe ModIface)
-> IO (Messages GhcMessage, Maybe ModIface)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe ModIface)
-> IO (Messages GhcMessage, Maybe ModIface))
-> IO (Messages TcRnMessage, Maybe ModIface)
-> IO (Messages GhcMessage, Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
getModuleInterface HscEnv
hsc_env Module
mod
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls HscEnv
hsc_env0 [LImportDecl GhcPs]
import_decls = HscEnv -> Hsc GlobalRdrEnv -> IO GlobalRdrEnv
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc GlobalRdrEnv -> IO GlobalRdrEnv)
-> Hsc GlobalRdrEnv -> IO GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
IO (Messages GhcMessage, Maybe GlobalRdrEnv) -> Hsc GlobalRdrEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe GlobalRdrEnv) -> Hsc GlobalRdrEnv)
-> IO (Messages GhcMessage, Maybe GlobalRdrEnv) -> Hsc GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
-> IO (Messages GhcMessage, Maybe GlobalRdrEnv)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
-> IO (Messages GhcMessage, Maybe GlobalRdrEnv))
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
-> IO (Messages GhcMessage, Maybe GlobalRdrEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LImportDecl GhcPs]
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
tcRnImportDecls HscEnv
hsc_env [LImportDecl GhcPs]
import_decls
hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
hscParse HscEnv
hsc_env ModSummary
mod_summary = HscEnv -> Hsc HsParsedModule -> IO HsParsedModule
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc HsParsedModule -> IO HsParsedModule)
-> Hsc HsParsedModule -> IO HsParsedModule
forall a b. (a -> b) -> a -> b
$ ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary
| Just HsParsedModule
r <- ModSummary -> Maybe HsParsedModule
ms_parsed_mod ModSummary
mod_summary = HsParsedModule -> Hsc HsParsedModule
forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
r
| Bool
otherwise = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- Hsc Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
{-# SCC "Parser" #-} Logger
-> DynFlags
-> SDoc
-> (HsParsedModule -> ())
-> Hsc HsParsedModule
-> Hsc HsParsedModule
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
(String -> SDoc
text String
"Parser"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> SDoc) -> Module -> SDoc
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
mod_summary))
(() -> HsParsedModule -> ()
forall a b. a -> b -> a
const ()) (Hsc HsParsedModule -> Hsc HsParsedModule)
-> Hsc HsParsedModule -> Hsc HsParsedModule
forall a b. (a -> b) -> a -> b
$ do
let src_filename :: String
src_filename = ModSummary -> String
ms_hspp_file ModSummary
mod_summary
maybe_src_buf :: Maybe StringBuffer
maybe_src_buf = ModSummary -> Maybe StringBuffer
ms_hspp_buf ModSummary
mod_summary
StringBuffer
buf <- case Maybe StringBuffer
maybe_src_buf of
Just StringBuffer
b -> StringBuffer -> Hsc StringBuffer
forall (m :: * -> *) a. Monad m => a -> m a
return StringBuffer
b
Maybe StringBuffer
Nothing -> IO StringBuffer -> Hsc StringBuffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StringBuffer -> Hsc StringBuffer)
-> IO StringBuffer -> Hsc StringBuffer
forall a b. (a -> b) -> a -> b
$ String -> IO StringBuffer
hGetStringBuffer String
src_filename
let loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
src_filename) Int
1 Int
1
let parseMod :: P (Located HsModule)
parseMod | HscSource
HsigFile HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
= P (Located HsModule)
parseSignature
| Bool
otherwise = P (Located HsModule)
parseModule
case P (Located HsModule) -> PState -> ParseResult (Located HsModule)
forall a. P a -> PState -> ParseResult a
unP P (Located HsModule)
parseMod (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) StringBuffer
buf RealSrcLoc
loc) of
PFailed PState
pst ->
(Messages PsWarning, Messages PsWarning) -> Hsc HsParsedModule
forall a. (Messages PsWarning, Messages PsWarning) -> Hsc a
handleWarningsThrowErrors (PState -> (Messages PsWarning, Messages PsWarning)
getMessages PState
pst)
POk PState
pst Located HsModule
rdr_module -> do
let (Messages PsWarning
warns, Messages PsWarning
errs) = PState -> (Messages PsWarning, Messages PsWarning)
getMessages PState
pst
Messages GhcMessage -> Hsc ()
logDiagnostics (PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage)
-> Messages PsWarning -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
warns)
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_parsed String
"Parser"
DumpFormat
FormatHaskell (Located HsModule -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located HsModule
rdr_module)
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_parsed_ast String
"Parser AST"
DumpFormat
FormatHaskell (BlankSrcSpan -> BlankEpAnnotations -> Located HsModule -> SDoc
forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan
BlankEpAnnotations
NoBlankEpAnnotations
Located HsModule
rdr_module)
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_source_stats String
"Source Statistics"
DumpFormat
FormatText (Bool -> Located HsModule -> SDoc
ppSourceStats Bool
False Located HsModule
rdr_module)
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Messages PsWarning -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages PsWarning
errs) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> Hsc ()
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage)
-> Messages PsWarning -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
errs)
let n_hspp :: String
n_hspp = String -> String
FilePath.normalise String
src_filename
srcs0 :: [String]
srcs0 = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> String
tmpDir DynFlags
dflags String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n_hspp))
([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
FilePath.normalise
([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"<")
([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (FastString -> String) -> [FastString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> String
unpackFS
([FastString] -> [String]) -> [FastString] -> [String]
forall a b. (a -> b) -> a -> b
$ PState -> [FastString]
srcfiles PState
pst
srcs1 :: [String]
srcs1 = case ModLocation -> Maybe String
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod_summary) of
Just String
f -> (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> String
FilePath.normalise String
f) [String]
srcs0
Maybe String
Nothing -> [String]
srcs0
[String]
srcs2 <- IO [String] -> Hsc [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Hsc [String]) -> IO [String] -> Hsc [String]
forall a b. (a -> b) -> a -> b
$ (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
srcs1
let res :: HsParsedModule
res = HsParsedModule :: Located HsModule -> [String] -> HsParsedModule
HsParsedModule {
hpm_module :: Located HsModule
hpm_module = Located HsModule
rdr_module,
hpm_src_files :: [String]
hpm_src_files = [String]
srcs2
}
let applyPluginAction :: Plugin -> [String] -> HsParsedModule -> Hsc HsParsedModule
applyPluginAction Plugin
p [String]
opts
= Plugin
-> [String] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction Plugin
p [String]
opts ModSummary
mod_summary
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
HscEnv
-> (Plugin -> [String] -> HsParsedModule -> Hsc HsParsedModule)
-> HsParsedModule
-> Hsc HsParsedModule
forall (m :: * -> *) a.
Monad m =>
HscEnv -> PluginOperation m a -> a -> m a
withPlugins HscEnv
hsc_env Plugin -> [String] -> HsParsedModule -> Hsc HsParsedModule
applyPluginAction HsParsedModule
res
extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
ModSummary
mod_summary TcGblEnv
tc_result = do
let rn_info :: RenamedStuff
rn_info = TcGblEnv -> RenamedStuff
getRenamedStuff TcGblEnv
tc_result
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- Hsc Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_rn_ast String
"Renamer"
DumpFormat
FormatHaskell (BlankSrcSpan
-> BlankEpAnnotations
-> Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString)
-> SDoc
forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString)
RenamedStuff
rn_info)
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
HieFile
hieFile <- ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile
mkHieFile ModSummary
mod_summary TcGblEnv
tc_result (Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString)
-> (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString)
RenamedStuff
rn_info)
let out_file :: String
out_file = ModLocation -> String
ml_hie_file (ModLocation -> String) -> ModLocation -> String
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
mod_summary
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ String -> HieFile -> IO ()
writeHieFile String
out_file HieFile
hieFile
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_hie String
"HIE AST" DumpFormat
FormatHaskell (HieASTs Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HieASTs Int -> SDoc) -> HieASTs Int -> SDoc
forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs Int
hie_asts HieFile
hieFile)
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ValidateHie DynFlags
dflags) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hs_env <- (HscEnv -> Messages GhcMessage -> IO (HscEnv, Messages GhcMessage))
-> Hsc HscEnv
forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc ((HscEnv
-> Messages GhcMessage -> IO (HscEnv, Messages GhcMessage))
-> Hsc HscEnv)
-> (HscEnv
-> Messages GhcMessage -> IO (HscEnv, Messages GhcMessage))
-> Hsc HscEnv
forall a b. (a -> b) -> a -> b
$ \HscEnv
e Messages GhcMessage
w -> (HscEnv, Messages GhcMessage) -> IO (HscEnv, Messages GhcMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, Messages GhcMessage
w)
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
case Module -> Map HiePath (HieAST Int) -> [SDoc]
forall a. Module -> Map HiePath (HieAST a) -> [SDoc]
validateScopes (HieFile -> Module
hie_module HieFile
hieFile) (Map HiePath (HieAST Int) -> [SDoc])
-> Map HiePath (HieAST Int) -> [SDoc]
forall a b. (a -> b) -> a -> b
$ HieASTs Int -> Map HiePath (HieAST Int)
forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts (HieASTs Int -> Map HiePath (HieAST Int))
-> HieASTs Int -> Map HiePath (HieAST Int)
forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs Int
hie_asts HieFile
hieFile of
[] -> Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Got valid scopes"
[SDoc]
xs -> do
Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Got invalid scopes"
(SDoc -> IO ()) -> [SDoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags) [SDoc]
xs
HieFileResult
file' <- NameCache -> String -> IO HieFileResult
readHieFile (HscEnv -> NameCache
hsc_NC HscEnv
hs_env) String
out_file
case Diff HieFile
diffFile HieFile
hieFile (HieFileResult -> HieFile
hie_file_result HieFileResult
file') of
[] ->
Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Got no roundtrip errors"
[SDoc]
xs -> do
Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Got roundtrip errors"
(SDoc -> IO ()) -> [SDoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger (DynFlags -> DumpFlag -> DynFlags
dopt_set DynFlags
dflags DumpFlag
Opt_D_ppr_debug)) [SDoc]
xs
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString)
-> Hsc
(Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString)
RenamedStuff
rn_info
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename :: HscEnv
-> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename HscEnv
hsc_env ModSummary
mod_summary HsParsedModule
rdr_module = HscEnv
-> Hsc
(TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
-> IO
(TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc
(TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
-> IO
(TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString)))
-> Hsc
(TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
-> IO
(TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
forall a b. (a -> b) -> a -> b
$
Bool
-> ModSummary
-> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck Bool
True ModSummary
mod_summary (HsParsedModule -> Maybe HsParsedModule
forall a. a -> Maybe a
Just HsParsedModule
rdr_module)
hscTypecheckAndGetWarnings :: HscEnv -> ModSummary -> IO (FrontendResult, WarningMessages)
hscTypecheckAndGetWarnings :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage)
hscTypecheckAndGetWarnings HscEnv
hsc_env ModSummary
summary = HscEnv
-> Hsc FrontendResult -> IO (FrontendResult, Messages GhcMessage)
forall a. HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
runHsc' HscEnv
hsc_env (Hsc FrontendResult -> IO (FrontendResult, Messages GhcMessage))
-> Hsc FrontendResult -> IO (FrontendResult, Messages GhcMessage)
forall a b. (a -> b) -> a -> b
$ do
case Hooks -> Maybe (ModSummary -> Hsc FrontendResult)
hscFrontendHook (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) of
Maybe (ModSummary -> Hsc FrontendResult)
Nothing -> TcGblEnv -> FrontendResult
FrontendTypecheck (TcGblEnv -> FrontendResult)
-> ((TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
-> TcGblEnv)
-> (TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
-> FrontendResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
-> TcGblEnv
forall a b. (a, b) -> a
fst ((TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
-> FrontendResult)
-> Hsc
(TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
-> Hsc FrontendResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> ModSummary
-> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck Bool
False ModSummary
summary Maybe HsParsedModule
forall a. Maybe a
Nothing
Just ModSummary -> Hsc FrontendResult
h -> ModSummary -> Hsc FrontendResult
h ModSummary
summary
hsc_typecheck :: Bool
-> ModSummary -> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck :: Bool
-> ModSummary
-> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck Bool
keep_rn ModSummary
mod_summary Maybe HsParsedModule
mb_rdr_module = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
let hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
outer_mod :: Module
outer_mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
mod_name :: ModuleName
mod_name = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
outer_mod
outer_mod' :: Module
outer_mod' = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name
inner_mod :: Module
inner_mod = HomeUnit -> ModuleName -> Module
homeModuleNameInstantiation HomeUnit
home_unit ModuleName
mod_name
src_filename :: String
src_filename = ModSummary -> String
ms_hspp_file ModSummary
mod_summary
real_loc :: RealSrcSpan
real_loc = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
src_filename) Int
1 Int
1
keep_rn' :: Bool
keep_rn' = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags Bool -> Bool -> Bool
|| Bool
keep_rn
Bool -> Hsc ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
outer_mod)
TcGblEnv
tc_result <- if HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& Bool -> Bool
not (Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
inner_mod)
then IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> RealSrcSpan
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnInstantiateSignature HscEnv
hsc_env Module
outer_mod' RealSrcSpan
real_loc
else
do HsParsedModule
hpm <- case Maybe HsParsedModule
mb_rdr_module of
Just HsParsedModule
hpm -> HsParsedModule -> Hsc HsParsedModule
forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
hpm
Maybe HsParsedModule
Nothing -> ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary
TcGblEnv
tc_result0 <- ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv
tcRnModule' ModSummary
mod_summary Bool
keep_rn' HsParsedModule
hpm
if HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
then do (ModIface
iface, Maybe Fingerprint
_, ModDetails
_) <- IO (ModIface, Maybe Fingerprint, ModDetails)
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Maybe Fingerprint, ModDetails)
-> Hsc (ModIface, Maybe Fingerprint, ModDetails))
-> IO (ModIface, Maybe Fingerprint, ModDetails)
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcGblEnv
-> Maybe Fingerprint
-> IO (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result0 Maybe Fingerprint
forall a. Maybe a
Nothing
IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> HsParsedModule
-> TcGblEnv
-> ModIface
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnMergeSignatures HscEnv
hsc_env HsParsedModule
hpm TcGblEnv
tc_result0 ModIface
iface
else TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tc_result0
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString)
rn_info <- ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff ModSummary
mod_summary TcGblEnv
tc_result
(TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
-> Hsc
(TcGblEnv,
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString))
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tc_result, Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe LHsDocString)
rn_info)
tcRnModule' :: ModSummary -> Bool -> HsParsedModule
-> Hsc TcGblEnv
tcRnModule' :: ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv
tcRnModule' ModSummary
sum Bool
save_rn_syntax HsParsedModule
mod = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let reason :: DiagnosticReason
reason = WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingSafeHaskellMode
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (DynFlags -> Bool
safeHaskellModeEnabled DynFlags
dflags)
Bool -> Bool -> Bool
&& WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingSafeHaskellMode DynFlags
dflags) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$
Messages GhcMessage -> Hsc ()
logDiagnostics (Messages GhcMessage -> Hsc ()) -> Messages GhcMessage -> Hsc ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$
DynFlags -> SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => DynFlags -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DynFlags
dflags (Located HsModule -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (HsParsedModule -> Located HsModule
hpm_module HsParsedModule
mod)) (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage (DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
reason [GhcHint]
noHints SDoc
warnMissingSafeHaskellMode
TcGblEnv
tcg_res <- {-# SCC "Typecheck-Rename" #-}
IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnModule HscEnv
hsc_env ModSummary
sum
Bool
save_rn_syntax HsParsedModule
mod
Bool
tcSafeOK <- IO Bool -> Hsc Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Hsc Bool) -> IO Bool -> Hsc Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef Bool
tcg_safe_infer TcGblEnv
tcg_res)
Messages TcRnMessage
whyUnsafe <- IO (Messages TcRnMessage) -> Hsc (Messages TcRnMessage)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages TcRnMessage) -> Hsc (Messages TcRnMessage))
-> IO (Messages TcRnMessage) -> Hsc (Messages TcRnMessage)
forall a b. (a -> b) -> a -> b
$ IORef (Messages TcRnMessage) -> IO (Messages TcRnMessage)
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef (Messages TcRnMessage)
tcg_safe_infer_reasons TcGblEnv
tcg_res)
let allSafeOK :: Bool
allSafeOK = DynFlags -> Bool
safeInferred DynFlags
dflags Bool -> Bool -> Bool
&& Bool
tcSafeOK
if Bool -> Bool
not (DynFlags -> Bool
safeHaskellOn DynFlags
dflags)
Bool -> Bool -> Bool
|| (DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
allSafeOK)
then TcGblEnv -> Messages TcRnMessage -> Hsc TcGblEnv
forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_res Messages TcRnMessage
whyUnsafe
else do
TcGblEnv
tcg_res' <- TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports TcGblEnv
tcg_res
Bool
safe <- IO Bool -> Hsc Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Hsc Bool) -> IO Bool -> Hsc Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef Bool
tcg_safe_infer TcGblEnv
tcg_res')
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
safe (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$
case WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnSafe DynFlags
dflags of
Bool
True
| DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Safe -> () -> Hsc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> (Messages GhcMessage -> Hsc ()
logDiagnostics (Messages GhcMessage -> Hsc ()) -> Messages GhcMessage -> Hsc ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$
DynFlags -> SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => DynFlags -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DynFlags
dflags (DynFlags -> SrcSpan
warnSafeOnLoc DynFlags
dflags) (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage (DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnSafe) [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
TcGblEnv -> SDoc
errSafe TcGblEnv
tcg_res')
Bool
False | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Trustworthy Bool -> Bool -> Bool
&&
WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnTrustworthySafe DynFlags
dflags ->
(Messages GhcMessage -> Hsc ()
logDiagnostics (Messages GhcMessage -> Hsc ()) -> Messages GhcMessage -> Hsc ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$
DynFlags -> SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => DynFlags -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DynFlags
dflags (DynFlags -> SrcSpan
trustworthyOnLoc DynFlags
dflags) (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage (DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnTrustworthySafe) [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
TcGblEnv -> SDoc
errTwthySafe TcGblEnv
tcg_res')
Bool
False -> () -> Hsc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_res'
where
pprMod :: TcGblEnv -> SDoc
pprMod TcGblEnv
t = ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleName -> SDoc) -> ModuleName -> SDoc
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> Module
tcg_mod TcGblEnv
t
errSafe :: TcGblEnv -> SDoc
errSafe TcGblEnv
t = SDoc -> SDoc
quotes (TcGblEnv -> SDoc
pprMod TcGblEnv
t) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has been inferred as safe!"
errTwthySafe :: TcGblEnv -> SDoc
errTwthySafe TcGblEnv
t = SDoc -> SDoc
quotes (TcGblEnv -> SDoc
pprMod TcGblEnv
t)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is marked as Trustworthy but has been inferred as safe!"
warnMissingSafeHaskellMode :: SDoc
warnMissingSafeHaskellMode = ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
sum))
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is missing Safe Haskell mode"
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar HscEnv
hsc_env ModSummary
mod_summary TcGblEnv
tc_result =
HscEnv -> Hsc ModGuts -> IO ModGuts
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc ModGuts -> IO ModGuts) -> Hsc ModGuts -> IO ModGuts
forall a b. (a -> b) -> a -> b
$ ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' (ModSummary -> ModLocation
ms_location ModSummary
mod_summary) TcGblEnv
tc_result
hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' ModLocation
mod_location TcGblEnv
tc_result = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
IO (Messages GhcMessage, Maybe ModGuts) -> Hsc ModGuts
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe ModGuts) -> Hsc ModGuts)
-> IO (Messages GhcMessage, Maybe ModGuts) -> Hsc ModGuts
forall a b. (a -> b) -> a -> b
$ IO (Messages DsMessage, Maybe ModGuts)
-> IO (Messages GhcMessage, Maybe ModGuts)
forall (m :: * -> *) a.
Monad m =>
m (Messages DsMessage, a) -> m (Messages GhcMessage, a)
hoistDsMessage (IO (Messages DsMessage, Maybe ModGuts)
-> IO (Messages GhcMessage, Maybe ModGuts))
-> IO (Messages DsMessage, Maybe ModGuts)
-> IO (Messages GhcMessage, Maybe ModGuts)
forall a b. (a -> b) -> a -> b
$
{-# SCC "deSugar" #-}
HscEnv
-> ModLocation
-> TcGblEnv
-> IO (Messages DsMessage, Maybe ModGuts)
deSugar HscEnv
hsc_env ModLocation
mod_location TcGblEnv
tc_result
makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails HscEnv
hsc_env TcGblEnv
tc_result = HscEnv -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc HscEnv
hsc_env TcGblEnv
tc_result
type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()
hscRecompStatus :: Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
-> IO HscRecompStatus
hscRecompStatus :: Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO HscRecompStatus
hscRecompStatus
Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
mod_summary SourceModified
source_modified Maybe ModIface
mb_old_iface (Int, Int)
mod_index
= do
let
msg :: RecompileRequired -> IO ()
msg RecompileRequired
what = case Maybe Messager
mHscMessage of
Just Messager
hscMessage -> Messager
hscMessage HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
what (ExtendedModSummary -> ModuleGraphNode
ModuleNode (ModSummary -> ExtendedModSummary
extendModSummaryNoDeps ModSummary
mod_summary))
Maybe Messager
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(RecompileRequired
recomp_reqd, Maybe ModIface
mb_checked_iface)
<- {-# SCC "checkOldIface" #-}
IO (RecompileRequired, Maybe ModIface)
-> IO (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RecompileRequired, Maybe ModIface)
-> IO (RecompileRequired, Maybe ModIface))
-> IO (RecompileRequired, Maybe ModIface)
-> IO (RecompileRequired, Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IO (RecompileRequired, Maybe ModIface)
checkOldIface HscEnv
hsc_env ModSummary
mod_summary
SourceModified
source_modified Maybe ModIface
mb_old_iface
let mb_old_hash :: Maybe Fingerprint
mb_old_hash = (ModIface -> Fingerprint) -> Maybe ModIface -> Maybe Fingerprint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModIfaceBackend -> Fingerprint
mi_iface_hash (ModIfaceBackend -> Fingerprint)
-> (ModIface -> ModIfaceBackend) -> ModIface -> Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> ModIfaceBackend
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts) Maybe ModIface
mb_checked_iface
RecompileRequired -> IO ()
msg RecompileRequired
recomp_reqd
case Maybe ModIface
mb_checked_iface of
Just ModIface
iface | Bool -> Bool
not (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp_reqd) -> do
HscRecompStatus -> IO HscRecompStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (HscRecompStatus -> IO HscRecompStatus)
-> HscRecompStatus -> IO HscRecompStatus
forall a b. (a -> b) -> a -> b
$ ModIface -> HscRecompStatus
HscUpToDate ModIface
iface
Maybe ModIface
_ -> HscRecompStatus -> IO HscRecompStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (HscRecompStatus -> IO HscRecompStatus)
-> HscRecompStatus -> IO HscRecompStatus
forall a b. (a -> b) -> a -> b
$ Maybe Fingerprint -> HscRecompStatus
HscRecompNeeded Maybe Fingerprint
mb_old_hash
initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails
initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails
initModDetails HscEnv
hsc_env ModSummary
mod_summary ModIface
iface =
(ModDetails -> IO ModDetails) -> IO ModDetails
forall a. (a -> IO a) -> IO a
fixIO ((ModDetails -> IO ModDetails) -> IO ModDetails)
-> (ModDetails -> IO ModDetails) -> IO ModDetails
forall a b. (a -> b) -> a -> b
$ \ModDetails
details' -> do
let act :: HomePackageTable -> HomePackageTable
act HomePackageTable
hpt = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary)
(ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details' Maybe Linkable
forall a. Maybe a
Nothing)
let hsc_env' :: HscEnv
hsc_env' = (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT HomePackageTable -> HomePackageTable
act HscEnv
hsc_env
HscEnv -> ModIface -> IO ModDetails
genModDetails HscEnv
hsc_env' ModIface
iface
hscDesugarAndSimplify :: ModSummary
-> FrontendResult
-> Messages GhcMessage
-> Maybe Fingerprint
-> Hsc HscBackendAction
hscDesugarAndSimplify :: ModSummary
-> FrontendResult
-> Messages GhcMessage
-> Maybe Fingerprint
-> Hsc HscBackendAction
hscDesugarAndSimplify ModSummary
summary (FrontendTypecheck TcGblEnv
tc_result) Messages GhcMessage
tc_warnings Maybe Fingerprint
mb_old_hash = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- Hsc Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
let bcknd :: Backend
bcknd = DynFlags -> Backend
backend DynFlags
dflags
hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
summary
Maybe ModGuts
mb_desugar <-
if ModSummary -> Module
ms_mod ModSummary
summary Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
gHC_PRIM Bool -> Bool -> Bool
&& HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile
then ModGuts -> Maybe ModGuts
forall a. a -> Maybe a
Just (ModGuts -> Maybe ModGuts) -> Hsc ModGuts -> Hsc (Maybe ModGuts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' (ModSummary -> ModLocation
ms_location ModSummary
summary) TcGblEnv
tc_result
else Maybe ModGuts -> Hsc (Maybe ModGuts)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ModGuts
forall a. Maybe a
Nothing
Messages GhcMessage
w <- Hsc (Messages GhcMessage)
getDiagnostics
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger DynFlags
dflags (Messages GhcMessage -> Messages GhcMessage -> Messages GhcMessage
forall e. Messages e -> Messages e -> Messages e
unionMessages Messages GhcMessage
tc_warnings Messages GhcMessage
w)
Hsc ()
clearDiagnostics
case Maybe ModGuts
mb_desugar of
Just ModGuts
desugared_guts | Backend
bcknd Backend -> Backend -> Bool
forall a. Eq a => a -> a -> Bool
/= Backend
NoBackend -> do
[String]
plugins <- IO [String] -> Hsc [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Hsc [String]) -> IO [String] -> Hsc [String]
forall a b. (a -> b) -> a -> b
$ IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef [String]
tcg_th_coreplugins TcGblEnv
tc_result)
ModGuts
simplified_guts <- [String] -> ModGuts -> Hsc ModGuts
hscSimplify' [String]
plugins ModGuts
desugared_guts
(CgGuts
cg_guts, ModDetails
details) <- {-# SCC "CoreTidy" #-}
IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails))
-> IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram HscEnv
hsc_env ModGuts
simplified_guts
let !partial_iface :: PartialModIface
partial_iface =
{-# SCC "GHC.Driver.Main.mkPartialIface" #-}
PartialModIface -> PartialModIface
forall a. NFData a => a -> a
force (HscEnv -> ModDetails -> ModGuts -> PartialModIface
mkPartialIface HscEnv
hsc_env ModDetails
details ModGuts
simplified_guts)
HscBackendAction -> Hsc HscBackendAction
forall (m :: * -> *) a. Monad m => a -> m a
return HscRecomp :: CgGuts
-> ModLocation
-> PartialModIface
-> Maybe Fingerprint
-> HscBackendAction
HscRecomp { hscs_guts :: CgGuts
hscs_guts = CgGuts
cg_guts,
hscs_mod_location :: ModLocation
hscs_mod_location = ModSummary -> ModLocation
ms_location ModSummary
summary,
hscs_partial_iface :: PartialModIface
hscs_partial_iface = PartialModIface
partial_iface,
hscs_old_iface_hash :: Maybe Fingerprint
hscs_old_iface_hash = Maybe Fingerprint
mb_old_hash
}
Maybe ModGuts
_ -> do
(ModIface
iface, Maybe Fingerprint
mb_old_iface_hash, ModDetails
_details) <- IO (ModIface, Maybe Fingerprint, ModDetails)
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Maybe Fingerprint, ModDetails)
-> Hsc (ModIface, Maybe Fingerprint, ModDetails))
-> IO (ModIface, Maybe Fingerprint, ModDetails)
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> TcGblEnv
-> Maybe Fingerprint
-> IO (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result Maybe Fingerprint
mb_old_hash
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Bool
-> ModIface
-> Maybe Fingerprint
-> ModLocation
-> IO ()
hscMaybeWriteIface Logger
logger DynFlags
dflags Bool
True ModIface
iface Maybe Fingerprint
mb_old_iface_hash (ModSummary -> ModLocation
ms_location ModSummary
summary)
HscBackendAction -> Hsc HscBackendAction
forall (m :: * -> *) a. Monad m => a -> m a
return (HscBackendAction -> Hsc HscBackendAction)
-> HscBackendAction -> Hsc HscBackendAction
forall a b. (a -> b) -> a -> b
$ ModIface -> HscBackendAction
HscUpdate ModIface
iface
hscMaybeWriteIface :: Logger -> DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()
hscMaybeWriteIface :: Logger
-> DynFlags
-> Bool
-> ModIface
-> Maybe Fingerprint
-> ModLocation
-> IO ()
hscMaybeWriteIface Logger
logger DynFlags
dflags Bool
is_simple ModIface
iface Maybe Fingerprint
old_iface ModLocation
mod_location = do
let force_write_interface :: Bool
force_write_interface = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
write_interface :: Bool
write_interface = case DynFlags -> Backend
backend DynFlags
dflags of
Backend
NoBackend -> Bool
False
Backend
Interpreter -> Bool
False
Backend
_ -> Bool
True
baseName :: String
baseName = ModLocation -> String
ml_hi_file ModLocation
mod_location
buildIfName :: String -> String
buildIfName String
suffix
| Just String
name <- DynFlags -> Maybe String
outputHi DynFlags
dflags
= String
name
| Bool
otherwise
= let with_hi :: String
with_hi = String -> String -> String
replaceExtension String
baseName String
suffix
in IsBootInterface -> String -> String
addBootSuffix_maybe (ModIface -> IsBootInterface
mi_boot ModIface
iface) String
with_hi
write_iface :: DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags' ModIface
iface =
let !iface_name :: String
iface_name = String -> String
buildIfName (DynFlags -> String
hiSuf DynFlags
dflags')
in
{-# SCC "writeIface" #-}
Logger -> DynFlags -> SDoc -> (() -> ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags'
(String -> SDoc
text String
"WriteIface"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (String -> SDoc
text String
iface_name))
(() -> () -> ()
forall a b. a -> b -> a
const ())
(Logger -> DynFlags -> String -> ModIface -> IO ()
writeIface Logger
logger DynFlags
dflags' String
iface_name ModIface
iface)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
write_interface Bool -> Bool -> Bool
|| Bool
force_write_interface) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let no_change :: Bool
no_change = Maybe Fingerprint
old_iface Maybe Fingerprint -> Maybe Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint -> Maybe Fingerprint
forall a. a -> Maybe a
Just (ModIfaceBackend -> Fingerprint
mi_iface_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface))
DynamicTooState
dt <- DynFlags -> IO DynamicTooState
forall (m :: * -> *). MonadIO m => DynFlags -> m DynamicTooState
dynamicTooState DynFlags
dflags
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_if_trace DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Writing interface(s):") Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"Kind:" SDoc -> SDoc -> SDoc
<+> if Bool
is_simple then String -> SDoc
text String
"simple" else String -> SDoc
text String
"full"
, String -> SDoc
text String
"Hash change:" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Bool -> Bool
not Bool
no_change)
, String -> SDoc
text String
"DynamicToo state:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (DynamicTooState -> String
forall a. Show a => a -> String
show DynamicTooState
dt)
]
if Bool
is_simple
then Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
no_change (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
case DynamicTooState
dt of
DynamicTooState
DT_Dont -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
DynamicTooState
DT_Failed -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
DynamicTooState
DT_Dyn -> String -> IO ()
forall a. String -> a
panic String
"Unexpected DT_Dyn state when writing simple interface"
DynamicTooState
DT_OK -> DynFlags -> ModIface -> IO ()
write_iface (DynFlags -> DynFlags
setDynamicNow DynFlags
dflags) ModIface
iface
else case DynamicTooState
dt of
DynamicTooState
DT_Dont | Bool -> Bool
not Bool
no_change -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
DynamicTooState
DT_OK | Bool -> Bool
not Bool
no_change -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
DynamicTooState
DT_Dyn -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
DynamicTooState
DT_Failed | Bool -> Bool
not (DynFlags -> Bool
dynamicNow DynFlags
dflags) -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
DynamicTooState
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
genModDetails :: HscEnv -> ModIface -> IO ModDetails
genModDetails :: HscEnv -> ModIface -> IO ModDetails
genModDetails HscEnv
hsc_env ModIface
old_iface
= do
ModDetails
new_details <- {-# SCC "tcRnIface" #-}
HscEnv -> IfG ModDetails -> IO ModDetails
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (ModIface -> IfG ModDetails
typecheckIface ModIface
old_iface)
HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env
ModDetails -> IO ModDetails
forall (m :: * -> *) a. Monad m => a -> m a
return ModDetails
new_details
oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
oneShotMsg HscEnv
hsc_env RecompileRequired
recomp =
case RecompileRequired
recomp of
RecompileRequired
UpToDate ->
Logger -> DynFlags -> SDoc -> IO ()
compilationProgressMsg Logger
logger DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"compilation IS NOT required"
RecompileRequired
_ ->
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
batchMsg :: Messager
batchMsg :: Messager
batchMsg HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
recomp ModuleGraphNode
node = case ModuleGraphNode
node of
InstantiationNode InstantiatedUnit
_ ->
case RecompileRequired
recomp of
RecompileRequired
MustCompile -> SDoc -> SDoc -> IO ()
showMsg (String -> SDoc
text String
"Instantiating ") SDoc
empty
RecompileRequired
UpToDate
| DynFlags -> Int
verbosity DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 -> SDoc -> SDoc -> IO ()
showMsg (String -> SDoc
text String
"Skipping ") SDoc
empty
| Bool
otherwise -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
RecompBecause String
reason -> SDoc -> SDoc -> IO ()
showMsg (String -> SDoc
text String
"Instantiating ") (String -> SDoc
text String
" [" SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
reason SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"]")
ModuleNode ExtendedModSummary
_ ->
case RecompileRequired
recomp of
RecompileRequired
MustCompile -> SDoc -> SDoc -> IO ()
showMsg (String -> SDoc
text String
"Compiling ") SDoc
empty
RecompileRequired
UpToDate
| DynFlags -> Int
verbosity DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 -> SDoc -> SDoc -> IO ()
showMsg (String -> SDoc
text String
"Skipping ") SDoc
empty
| Bool
otherwise -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
RecompBecause String
reason -> SDoc -> SDoc -> IO ()
showMsg (String -> SDoc
text String
"Compiling ") (String -> SDoc
text String
" [" SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
reason SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"]")
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
showMsg :: SDoc -> SDoc -> IO ()
showMsg SDoc
msg SDoc
reason =
Logger -> DynFlags -> SDoc -> IO ()
compilationProgressMsg Logger
logger DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
((Int, Int) -> SDoc
showModuleIndex (Int, Int)
mod_index SDoc -> SDoc -> SDoc
<>
SDoc
msg SDoc -> SDoc -> SDoc
<> DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp) ModuleGraphNode
node)
SDoc -> SDoc -> SDoc
<> SDoc
reason
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports TcGblEnv
tcg_env = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
TcGblEnv
tcg_env' <- TcGblEnv -> Hsc TcGblEnv
checkSafeImports TcGblEnv
tcg_env
DynFlags -> TcGblEnv -> Hsc TcGblEnv
checkRULES DynFlags
dflags TcGblEnv
tcg_env'
where
checkRULES :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
checkRULES DynFlags
dflags TcGblEnv
tcg_env' =
case DynFlags -> Bool
safeLanguageOn DynFlags
dflags of
Bool
True -> do
Messages GhcMessage -> Hsc ()
logDiagnostics (Messages GhcMessage -> Hsc ()) -> Messages GhcMessage -> Hsc ()
forall a b. (a -> b) -> a -> b
$ (DriverMessage -> GhcMessage)
-> Messages DriverMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage (Messages DriverMessage -> Messages GhcMessage)
-> Messages DriverMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> Messages DriverMessage
warns DynFlags
dflags (TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env')
TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env' { tcg_rules :: [LRuleDecl GhcTc]
tcg_rules = [] }
Bool
False
| DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not ([GenLocated SrcSpanAnnA (RuleDecl GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GenLocated SrcSpanAnnA (RuleDecl GhcTc)] -> Bool)
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)] -> Bool
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env')
-> TcGblEnv -> Messages DriverMessage -> Hsc TcGblEnv
forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env' (Messages DriverMessage -> Hsc TcGblEnv)
-> Messages DriverMessage -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> Messages DriverMessage
warns DynFlags
dflags (TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env')
| Bool
otherwise
-> TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env'
warns :: DynFlags
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> Messages DriverMessage
warns DynFlags
dflags [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules = Bag (MsgEnvelope DriverMessage) -> Messages DriverMessage
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope DriverMessage) -> Messages DriverMessage)
-> Bag (MsgEnvelope DriverMessage) -> Messages DriverMessage
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope DriverMessage] -> Bag (MsgEnvelope DriverMessage)
forall a. [a] -> Bag a
listToBag ([MsgEnvelope DriverMessage] -> Bag (MsgEnvelope DriverMessage))
-> [MsgEnvelope DriverMessage] -> Bag (MsgEnvelope DriverMessage)
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (RuleDecl GhcTc)
-> MsgEnvelope DriverMessage)
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> [MsgEnvelope DriverMessage]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
warnRules DynFlags
dflags) [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules
warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
warnRules DynFlags
df (L loc (HsRule { rd_name = n })) =
DynFlags -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DynFlags -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DynFlags
df (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage (DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
WarningWithoutFlag [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Rule \"" SDoc -> SDoc -> SDoc
<> FastString -> SDoc
ftext ((SourceText, FastString) -> FastString
forall a b. (a, b) -> b
snd ((SourceText, FastString) -> FastString)
-> (SourceText, FastString) -> FastString
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan (SourceText, FastString)
-> (SourceText, FastString)
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (SourceText, FastString)
XRec GhcTc (SourceText, FastString)
n) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"\" ignored" SDoc -> SDoc -> SDoc
$+$
String -> SDoc
text String
"User defined rules are disabled under Safe Haskell"
checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
checkSafeImports TcGblEnv
tcg_env
= do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
[(Module, SrcSpan, Bool)]
imps <- ((Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, Bool))
-> [(Module, [ImportedModsVal])] -> Hsc [(Module, SrcSpan, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, Bool)
condense [(Module, [ImportedModsVal])]
imports'
let ([(Module, SrcSpan, Bool)]
safeImps, [(Module, SrcSpan, Bool)]
regImps) = ((Module, SrcSpan, Bool) -> Bool)
-> [(Module, SrcSpan, Bool)]
-> ([(Module, SrcSpan, Bool)], [(Module, SrcSpan, Bool)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Module
_,SrcSpan
_,Bool
s) -> Bool
s) [(Module, SrcSpan, Bool)]
imps
Messages GhcMessage
oldErrs <- Hsc (Messages GhcMessage)
getDiagnostics
Hsc ()
clearDiagnostics
Set UnitId
safePkgs <- [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
S.fromList ([UnitId] -> Set UnitId) -> Hsc [UnitId] -> Hsc (Set UnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Module, SrcSpan, Bool) -> Hsc (Maybe UnitId))
-> [(Module, SrcSpan, Bool)] -> Hsc [UnitId]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Module, SrcSpan, Bool) -> Hsc (Maybe UnitId)
forall a. (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe [(Module, SrcSpan, Bool)]
safeImps
Messages GhcMessage
safeErrs <- Hsc (Messages GhcMessage)
getDiagnostics
Hsc ()
clearDiagnostics
(Messages GhcMessage
infErrs, Set UnitId
infPkgs) <- case (DynFlags -> Bool
safeInferOn DynFlags
dflags) of
Bool
False -> (Messages GhcMessage, Set UnitId)
-> Hsc (Messages GhcMessage, Set UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages GhcMessage
forall e. Messages e
emptyMessages, Set UnitId
forall a. Set a
S.empty)
Bool
True -> do Set UnitId
infPkgs <- [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
S.fromList ([UnitId] -> Set UnitId) -> Hsc [UnitId] -> Hsc (Set UnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Module, SrcSpan, Bool) -> Hsc (Maybe UnitId))
-> [(Module, SrcSpan, Bool)] -> Hsc [UnitId]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Module, SrcSpan, Bool) -> Hsc (Maybe UnitId)
forall a. (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe [(Module, SrcSpan, Bool)]
regImps
Messages GhcMessage
infErrs <- Hsc (Messages GhcMessage)
getDiagnostics
Hsc ()
clearDiagnostics
(Messages GhcMessage, Set UnitId)
-> Hsc (Messages GhcMessage, Set UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages GhcMessage
infErrs, Set UnitId
infPkgs)
Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
oldErrs
case (Messages GhcMessage -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
safeErrs) of
Bool
False -> IO TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TcGblEnv -> Hsc TcGblEnv)
-> (Messages GhcMessage -> IO TcGblEnv)
-> Messages GhcMessage
-> Hsc TcGblEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages GhcMessage -> IO TcGblEnv
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (Messages GhcMessage -> Hsc TcGblEnv)
-> Messages GhcMessage -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage
safeErrs
Bool
True -> do
let infPassed :: Bool
infPassed = Messages GhcMessage -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
infErrs
TcGblEnv
tcg_env' <- case (Bool -> Bool
not Bool
infPassed) of
Bool
True -> TcGblEnv -> Messages GhcMessage -> Hsc TcGblEnv
forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env Messages GhcMessage
infErrs
Bool
False -> TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
packageTrustOn DynFlags
dflags) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Set UnitId -> Hsc ()
checkPkgTrust Set UnitId
pkgReqs
let newTrust :: ImportAvails
newTrust = DynFlags -> Set UnitId -> Set UnitId -> Bool -> ImportAvails
pkgTrustReqs DynFlags
dflags Set UnitId
safePkgs Set UnitId
infPkgs Bool
infPassed
TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env' { tcg_imports :: ImportAvails
tcg_imports = ImportAvails
impInfo ImportAvails -> ImportAvails -> ImportAvails
`plusImportAvails` ImportAvails
newTrust }
where
impInfo :: ImportAvails
impInfo = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env
imports :: ImportedMods
imports = ImportAvails -> ImportedMods
imp_mods ImportAvails
impInfo
imports1 :: [(Module, [ImportedBy])]
imports1 = ImportedMods -> [(Module, [ImportedBy])]
forall a. ModuleEnv a -> [(Module, a)]
moduleEnvToList ImportedMods
imports
imports' :: [(Module, [ImportedModsVal])]
imports' = ((Module, [ImportedBy]) -> (Module, [ImportedModsVal]))
-> [(Module, [ImportedBy])] -> [(Module, [ImportedModsVal])]
forall a b. (a -> b) -> [a] -> [b]
map (([ImportedBy] -> [ImportedModsVal])
-> (Module, [ImportedBy]) -> (Module, [ImportedModsVal])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ImportedBy] -> [ImportedModsVal]
importedByUser) [(Module, [ImportedBy])]
imports1
pkgReqs :: Set UnitId
pkgReqs = ImportAvails -> Set UnitId
imp_trust_pkgs ImportAvails
impInfo
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, Bool)
condense (Module
_, []) = String -> Hsc (Module, SrcSpan, Bool)
forall a. String -> a
panic String
"GHC.Driver.Main.condense: Pattern match failure!"
condense (Module
m, ImportedModsVal
x:[ImportedModsVal]
xs) = do ImportedModsVal
imv <- (ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal)
-> ImportedModsVal -> [ImportedModsVal] -> Hsc ImportedModsVal
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' ImportedModsVal
x [ImportedModsVal]
xs
(Module, SrcSpan, Bool) -> Hsc (Module, SrcSpan, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module
m, ImportedModsVal -> SrcSpan
imv_span ImportedModsVal
imv, ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
imv)
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' ImportedModsVal
v1 ImportedModsVal
v2
| ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
v1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
v2
= MsgEnvelope GhcMessage -> Hsc ImportedModsVal
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> Hsc ImportedModsVal)
-> MsgEnvelope GhcMessage -> Hsc ImportedModsVal
forall a b. (a -> b) -> a -> b
$
SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (ImportedModsVal -> SrcSpan
imv_span ImportedModsVal
v1) (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage (DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
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
text String
"Module" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ImportedModsVal -> ModuleName
imv_name ImportedModsVal
v1) SDoc -> SDoc -> SDoc
<+>
(String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"is imported both as a safe and unsafe import!")
| Bool
otherwise
= ImportedModsVal -> Hsc ImportedModsVal
forall (m :: * -> *) a. Monad m => a -> m a
return ImportedModsVal
v1
checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe (Module
m, SrcSpan
l, a
_) = (Maybe UnitId, Set UnitId) -> Maybe UnitId
forall a b. (a, b) -> a
fst ((Maybe UnitId, Set UnitId) -> Maybe UnitId)
-> Hsc (Maybe UnitId, Set UnitId) -> Hsc (Maybe UnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' Module
m SrcSpan
l
pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->
Bool -> ImportAvails
pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> Bool -> ImportAvails
pkgTrustReqs DynFlags
dflags Set UnitId
req Set UnitId
inf Bool
infPassed | DynFlags -> Bool
safeInferOn DynFlags
dflags
Bool -> Bool -> Bool
&& Bool -> Bool
not (DynFlags -> Bool
safeHaskellModeEnabled DynFlags
dflags) Bool -> Bool -> Bool
&& Bool
infPassed
= ImportAvails
emptyImportAvails {
imp_trust_pkgs :: Set UnitId
imp_trust_pkgs = Set UnitId
req Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set UnitId
inf
}
pkgTrustReqs DynFlags
dflags Set UnitId
_ Set UnitId
_ Bool
_ | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Unsafe
= ImportAvails
emptyImportAvails
pkgTrustReqs DynFlags
_ Set UnitId
req Set UnitId
_ Bool
_ = ImportAvails
emptyImportAvails { imp_trust_pkgs :: Set UnitId
imp_trust_pkgs = Set UnitId
req }
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe HscEnv
hsc_env Module
m SrcSpan
l = HscEnv -> Hsc Bool -> IO Bool
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc Bool -> IO Bool) -> Hsc Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Set UnitId
pkgs <- (Maybe UnitId, Set UnitId) -> Set UnitId
forall a b. (a, b) -> b
snd ((Maybe UnitId, Set UnitId) -> Set UnitId)
-> Hsc (Maybe UnitId, Set UnitId) -> Hsc (Set UnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' Module
m SrcSpan
l
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
packageTrustOn DynFlags
dflags) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Set UnitId -> Hsc ()
checkPkgTrust Set UnitId
pkgs
Messages GhcMessage
errs <- Hsc (Messages GhcMessage)
getDiagnostics
Bool -> Hsc Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Hsc Bool) -> Bool -> Hsc Bool
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
errs
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
hscGetSafe HscEnv
hsc_env Module
m SrcSpan
l = HscEnv -> Hsc (Bool, Set UnitId) -> IO (Bool, Set UnitId)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (Bool, Set UnitId) -> IO (Bool, Set UnitId))
-> Hsc (Bool, Set UnitId) -> IO (Bool, Set UnitId)
forall a b. (a -> b) -> a -> b
$ do
(Maybe UnitId
self, Set UnitId
pkgs) <- Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' Module
m SrcSpan
l
Bool
good <- Messages GhcMessage -> Bool
forall e. Messages e -> Bool
isEmptyMessages (Messages GhcMessage -> Bool)
-> Hsc (Messages GhcMessage) -> Hsc Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Hsc (Messages GhcMessage)
getDiagnostics
Hsc ()
clearDiagnostics
let pkgs' :: Set UnitId
pkgs' | Just UnitId
p <- Maybe UnitId
self = UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
S.insert UnitId
p Set UnitId
pkgs
| Bool
otherwise = Set UnitId
pkgs
(Bool, Set UnitId) -> Hsc (Bool, Set UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
good, Set UnitId
pkgs')
hscCheckSafe' :: Module -> SrcSpan
-> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' :: Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' Module
m SrcSpan
l = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
(Bool
tw, Set UnitId
pkgs) <- HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
isModSafe HomeUnit
home_unit Module
m SrcSpan
l
case Bool
tw of
Bool
False -> (Maybe UnitId, Set UnitId) -> Hsc (Maybe UnitId, Set UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UnitId
forall a. Maybe a
Nothing, Set UnitId
pkgs)
Bool
True | HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
m -> (Maybe UnitId, Set UnitId) -> Hsc (Maybe UnitId, Set UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UnitId
forall a. Maybe a
Nothing, Set UnitId
pkgs)
| Bool
otherwise -> (Maybe UnitId, Set UnitId) -> Hsc (Maybe UnitId, Set UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just (UnitId -> Maybe UnitId) -> UnitId -> Maybe UnitId
forall a b. (a -> b) -> a -> b
$ Unit -> UnitId
toUnitId (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
m), Set UnitId
pkgs)
where
isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
isModSafe HomeUnit
home_unit Module
m SrcSpan
l = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Maybe ModIface
iface <- Module -> Hsc (Maybe ModIface)
lookup' Module
m
case Maybe ModIface
iface of
Maybe ModIface
Nothing -> MsgEnvelope GhcMessage -> Hsc (Bool, Set UnitId)
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> Hsc (Bool, Set UnitId))
-> MsgEnvelope GhcMessage -> Hsc (Bool, Set UnitId)
forall a b. (a -> b) -> a -> b
$
SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage (DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
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
text String
"Can't load the interface file for" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
m
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", to check that it can be safely imported"
Just ModIface
iface' ->
let trust :: SafeHaskellMode
trust = IfaceTrustInfo -> SafeHaskellMode
getSafeMode (IfaceTrustInfo -> SafeHaskellMode)
-> IfaceTrustInfo -> SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ ModIface -> IfaceTrustInfo
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust ModIface
iface'
trust_own_pkg :: Bool
trust_own_pkg = ModIface -> Bool
forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_trust_pkg ModIface
iface'
safeM :: Bool
safeM = SafeHaskellMode
trust SafeHaskellMode -> [SafeHaskellMode] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SafeHaskellMode
Sf_Safe, SafeHaskellMode
Sf_SafeInferred, SafeHaskellMode
Sf_Trustworthy]
safeP :: Bool
safeP = DynFlags
-> UnitState
-> HomeUnit
-> SafeHaskellMode
-> Bool
-> Module
-> Bool
packageTrusted DynFlags
dflags (HscEnv -> UnitState
hsc_units HscEnv
hsc_env) HomeUnit
home_unit SafeHaskellMode
trust Bool
trust_own_pkg Module
m
pkgRs :: Set UnitId
pkgRs = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
S.fromList (Dependencies -> [UnitId]
dep_trusted_pkgs (Dependencies -> [UnitId]) -> Dependencies -> [UnitId]
forall a b. (a -> b) -> a -> b
$ ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface')
warns :: Messages GhcMessage
warns = if WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnInferredSafeImports DynFlags
dflags
Bool -> Bool -> Bool
&& DynFlags -> Bool
safeLanguageOn DynFlags
dflags
Bool -> Bool -> Bool
&& SafeHaskellMode
trust SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_SafeInferred
then DynFlags -> Messages GhcMessage
inferredImportWarn DynFlags
dflags
else Messages GhcMessage
forall e. Messages e
emptyMessages
errs :: Messages GhcMessage
errs = case (Bool
safeM, Bool
safeP) of
(Bool
True, Bool
True ) -> Messages GhcMessage
forall e. Messages e
emptyMessages
(Bool
True, Bool
False) -> Messages GhcMessage
pkgTrustErr
(Bool
False, Bool
_ ) -> Messages GhcMessage
modTrustErr
in do
Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
warns
Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
errs
(Bool, Set UnitId) -> Hsc (Bool, Set UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (SafeHaskellMode
trust SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Trustworthy, Set UnitId
pkgRs)
where
state :: UnitState
state = HscEnv -> UnitState
hsc_units HscEnv
hsc_env
inferredImportWarn :: DynFlags -> Messages GhcMessage
inferredImportWarn DynFlags
dflags = MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage
(MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ DynFlags
-> SrcSpan
-> PrintUnqualified
-> GhcMessage
-> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
DynFlags -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkMsgEnvelope DynFlags
dflags SrcSpan
l (UnitState -> PrintUnqualified
pkgQual UnitState
state)
(GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage
(DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnInferredSafeImports) [GhcHint]
noHints
(SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep
[ String -> SDoc
text String
"Importing Safe-Inferred module "
SDoc -> SDoc -> SDoc
<> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m)
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" from explicitly Safe module"
]
pkgTrustErr :: Messages GhcMessage
pkgTrustErr = MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage
(MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PrintUnqualified -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
l (UnitState -> PrintUnqualified
pkgQual UnitState
state)
(GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage
(DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
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
sep [ ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m)
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
": Can't be safely imported!"
, String -> SDoc
text String
"The package ("
SDoc -> SDoc -> SDoc
<> (UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
m))
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
") the module resides in isn't trusted."
]
modTrustErr :: Messages GhcMessage
modTrustErr = MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage
(MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PrintUnqualified -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
l (UnitState -> PrintUnqualified
pkgQual UnitState
state)
(GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage
(DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
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
sep [ ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m)
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
": Can't be safely imported!"
, String -> SDoc
text String
"The module itself isn't safe." ]
packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted :: DynFlags
-> UnitState
-> HomeUnit
-> SafeHaskellMode
-> Bool
-> Module
-> Bool
packageTrusted DynFlags
dflags UnitState
unit_state HomeUnit
home_unit SafeHaskellMode
safe_mode Bool
trust_own_pkg Module
mod =
case SafeHaskellMode
safe_mode of
SafeHaskellMode
Sf_None -> Bool
False
SafeHaskellMode
Sf_Ignore -> Bool
False
SafeHaskellMode
Sf_Unsafe -> Bool
False
SafeHaskellMode
_ | Bool -> Bool
not (DynFlags -> Bool
packageTrustOn DynFlags
dflags) -> Bool
True
SafeHaskellMode
Sf_Safe | Bool -> Bool
not Bool
trust_own_pkg -> Bool
True
SafeHaskellMode
Sf_SafeInferred | Bool -> Bool
not Bool
trust_own_pkg -> Bool
True
SafeHaskellMode
_ | HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
mod -> Bool
True
SafeHaskellMode
_ -> GenericUnitInfo
(Indefinite UnitId) PackageId PackageName UnitId ModuleName Module
-> Bool
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsTrusted (GenericUnitInfo
(Indefinite UnitId) PackageId PackageName UnitId ModuleName Module
-> Bool)
-> GenericUnitInfo
(Indefinite UnitId) PackageId PackageName UnitId ModuleName Module
-> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack =>
UnitState
-> Unit
-> GenericUnitInfo
(Indefinite UnitId) PackageId PackageName UnitId ModuleName Module
UnitState
-> Unit
-> GenericUnitInfo
(Indefinite UnitId) PackageId PackageName UnitId ModuleName Module
unsafeLookupUnit UnitState
unit_state (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
m)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' Module
m = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
ExternalPackageState
hsc_eps <- IO ExternalPackageState -> Hsc ExternalPackageState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> Hsc ExternalPackageState)
-> IO ExternalPackageState -> Hsc ExternalPackageState
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
let pkgIfaceT :: PackageIfaceTable
pkgIfaceT = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
hsc_eps
homePkgT :: HomePackageTable
homePkgT = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
iface :: Maybe ModIface
iface = HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomePackageTable
homePkgT PackageIfaceTable
pkgIfaceT Module
m
case Maybe ModIface
iface of
Just ModIface
_ -> Maybe ModIface -> Hsc (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
iface
Maybe ModIface
Nothing -> (Messages TcRnMessage, Maybe ModIface) -> Maybe ModIface
forall a b. (a, b) -> b
snd ((Messages TcRnMessage, Maybe ModIface) -> Maybe ModIface)
-> Hsc (Messages TcRnMessage, Maybe ModIface)
-> Hsc (Maybe ModIface)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (IO (Messages TcRnMessage, Maybe ModIface)
-> Hsc (Messages TcRnMessage, Maybe ModIface)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages TcRnMessage, Maybe ModIface)
-> Hsc (Messages TcRnMessage, Maybe ModIface))
-> IO (Messages TcRnMessage, Maybe ModIface)
-> Hsc (Messages TcRnMessage, Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
getModuleInterface HscEnv
hsc_env Module
m)
checkPkgTrust :: Set UnitId -> Hsc ()
checkPkgTrust :: Set UnitId -> Hsc ()
checkPkgTrust Set UnitId
pkgs = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
let errors :: Bag (MsgEnvelope GhcMessage)
errors = (UnitId
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage))
-> Bag (MsgEnvelope GhcMessage)
-> Set UnitId
-> Bag (MsgEnvelope GhcMessage)
forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr UnitId
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
go Bag (MsgEnvelope GhcMessage)
forall a. Bag a
emptyBag Set UnitId
pkgs
state :: UnitState
state = HscEnv -> UnitState
hsc_units HscEnv
hsc_env
go :: UnitId
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
go UnitId
pkg Bag (MsgEnvelope GhcMessage)
acc
| GenericUnitInfo
(Indefinite UnitId) PackageId PackageName UnitId ModuleName Module
-> Bool
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsTrusted (GenericUnitInfo
(Indefinite UnitId) PackageId PackageName UnitId ModuleName Module
-> Bool)
-> GenericUnitInfo
(Indefinite UnitId) PackageId PackageName UnitId ModuleName Module
-> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack =>
UnitState
-> UnitId
-> GenericUnitInfo
(Indefinite UnitId) PackageId PackageName UnitId ModuleName Module
UnitState
-> UnitId
-> GenericUnitInfo
(Indefinite UnitId) PackageId PackageName UnitId ModuleName Module
unsafeLookupUnitId UnitState
state UnitId
pkg
= Bag (MsgEnvelope GhcMessage)
acc
| Bool
otherwise
= (MsgEnvelope GhcMessage
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
forall a. a -> Bag a -> Bag a
`consBag` Bag (MsgEnvelope GhcMessage)
acc)
(MsgEnvelope GhcMessage -> Bag (MsgEnvelope GhcMessage))
-> MsgEnvelope GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PrintUnqualified -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
noSrcSpan (UnitState -> PrintUnqualified
pkgQual UnitState
state)
(GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage
(DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage
(DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints
(SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state
(SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"The package ("
SDoc -> SDoc -> SDoc
<> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
pkg
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
") is required to be trusted but it isn't!"
if Bag (MsgEnvelope GhcMessage) -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (MsgEnvelope GhcMessage)
errors
then () -> Hsc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> IO ()
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (Messages GhcMessage -> IO ()) -> Messages GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages Bag (MsgEnvelope GhcMessage)
errors
markUnsafeInfer :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer :: TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env Messages e
whyUnsafe = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let reason :: DiagnosticReason
reason = WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnUnsafe
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnsafe DynFlags
dflags)
(Messages GhcMessage -> Hsc ()
logDiagnostics (Messages GhcMessage -> Hsc ()) -> Messages GhcMessage -> Hsc ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$
DynFlags -> SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => DynFlags -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DynFlags
dflags (DynFlags -> SrcSpan
warnUnsafeOnLoc DynFlags
dflags) (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage (DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
reason [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
DynFlags -> SDoc
whyUnsafe' DynFlags
dflags)
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TcGblEnv -> IORef Bool
tcg_safe_infer TcGblEnv
tcg_env) Bool
False
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ IORef (Messages TcRnMessage) -> Messages TcRnMessage -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TcGblEnv -> IORef (Messages TcRnMessage)
tcg_safe_infer_reasons TcGblEnv
tcg_env) Messages TcRnMessage
forall e. Messages e
emptyMessages
case Bool -> Bool
not (DynFlags -> Bool
safeHaskellModeEnabled DynFlags
dflags) of
Bool
True -> TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> Hsc TcGblEnv) -> TcGblEnv -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ TcGblEnv
tcg_env { tcg_imports :: ImportAvails
tcg_imports = ImportAvails
wiped_trust }
Bool
False -> TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
where
wiped_trust :: ImportAvails
wiped_trust = (TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env) { imp_trust_pkgs :: Set UnitId
imp_trust_pkgs = Set UnitId
forall a. Set a
S.empty }
pprMod :: SDoc
pprMod = ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleName -> SDoc) -> ModuleName -> SDoc
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
whyUnsafe' :: DynFlags -> SDoc
whyUnsafe' DynFlags
df = [SDoc] -> SDoc
vcat [ SDoc -> SDoc
quotes SDoc
pprMod SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has been inferred as unsafe!"
, String -> SDoc
text String
"Reason:"
, Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags -> [SDoc]
badFlags DynFlags
df) SDoc -> SDoc -> SDoc
$+$
([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope e) -> [SDoc]
forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (Messages e -> Bag (MsgEnvelope e)
forall e. Messages e -> Bag (MsgEnvelope e)
Error.Types.getMessages Messages e
whyUnsafe)) SDoc -> SDoc -> SDoc
$+$
([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [ClsInst] -> [SDoc]
forall (t :: * -> *). Foldable t => t ClsInst -> [SDoc]
badInsts ([ClsInst] -> [SDoc]) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [ClsInst]
tcg_insts TcGblEnv
tcg_env)
]
badFlags :: DynFlags -> [SDoc]
badFlags DynFlags
df = ((String, DynFlags -> SrcSpan, DynFlags -> Bool,
DynFlags -> DynFlags)
-> [SDoc])
-> [(String, DynFlags -> SrcSpan, DynFlags -> Bool,
DynFlags -> DynFlags)]
-> [SDoc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DynFlags
-> (String, DynFlags -> SrcSpan, DynFlags -> Bool,
DynFlags -> DynFlags)
-> [SDoc]
forall t d. t -> (String, t -> SrcSpan, t -> Bool, d) -> [SDoc]
badFlag DynFlags
df) [(String, DynFlags -> SrcSpan, DynFlags -> Bool,
DynFlags -> DynFlags)]
unsafeFlagsForInfer
badFlag :: t -> (String, t -> SrcSpan, t -> Bool, d) -> [SDoc]
badFlag t
df (String
str,t -> SrcSpan
loc,t -> Bool
on,d
_)
| t -> Bool
on t
df = [MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
MCOutput (t -> SrcSpan
loc t
df) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not allowed in Safe Haskell"]
| Bool
otherwise = []
badInsts :: t ClsInst -> [SDoc]
badInsts t ClsInst
insts = (ClsInst -> [SDoc]) -> t ClsInst -> [SDoc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ClsInst -> [SDoc]
badInst t ClsInst
insts
checkOverlap :: OverlapMode -> Bool
checkOverlap (NoOverlap SourceText
_) = Bool
False
checkOverlap OverlapMode
_ = Bool
True
badInst :: ClsInst -> [SDoc]
badInst ClsInst
ins | OverlapMode -> Bool
checkOverlap (OverlapFlag -> OverlapMode
overlapMode (ClsInst -> OverlapFlag
is_flag ClsInst
ins))
= [MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
MCOutput (Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ DFunId -> Name
forall a. NamedThing a => a -> Name
getName (DFunId -> Name) -> DFunId -> Name
forall a b. (a -> b) -> a -> b
$ ClsInst -> DFunId
is_dfun ClsInst
ins) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
OverlapMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OverlapFlag -> OverlapMode
overlapMode (OverlapFlag -> OverlapMode) -> OverlapFlag -> OverlapMode
forall a b. (a -> b) -> a -> b
$ ClsInst -> OverlapFlag
is_flag ClsInst
ins) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"overlap mode isn't allowed in Safe Haskell"]
| Bool
otherwise = []
hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode TcGblEnv
tcg_env = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
IO SafeHaskellMode -> Hsc SafeHaskellMode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SafeHaskellMode -> Hsc SafeHaskellMode)
-> IO SafeHaskellMode -> Hsc SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode DynFlags
dflags TcGblEnv
tcg_env
hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify HscEnv
hsc_env [String]
plugins ModGuts
modguts =
HscEnv -> Hsc ModGuts -> IO ModGuts
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc ModGuts -> IO ModGuts) -> Hsc ModGuts -> IO ModGuts
forall a b. (a -> b) -> a -> b
$ [String] -> ModGuts -> Hsc ModGuts
hscSimplify' [String]
plugins ModGuts
modguts
hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
hscSimplify' [String]
plugins ModGuts
ds_result = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
HscEnv
hsc_env_with_plugins <- if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
plugins
then HscEnv -> Hsc HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
else IO HscEnv -> Hsc HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> Hsc HscEnv) -> IO HscEnv -> Hsc HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO HscEnv
initializePlugins (HscEnv -> IO HscEnv) -> HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env
{ hsc_dflags :: DynFlags
hsc_dflags = (String -> DynFlags -> DynFlags)
-> DynFlags -> [String] -> DynFlags
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> DynFlags -> DynFlags
addPluginModuleName (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) [String]
plugins
}
{-# SCC "Core2Core" #-}
IO ModGuts -> Hsc ModGuts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> Hsc ModGuts) -> IO ModGuts -> Hsc ModGuts
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO ModGuts
core2core HscEnv
hsc_env_with_plugins ModGuts
ds_result
hscSimpleIface :: HscEnv
-> TcGblEnv
-> Maybe Fingerprint
-> IO (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface :: HscEnv
-> TcGblEnv
-> Maybe Fingerprint
-> IO (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result Maybe Fingerprint
mb_old_iface
= HscEnv
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
-> IO (ModIface, Maybe Fingerprint, ModDetails)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (ModIface, Maybe Fingerprint, ModDetails)
-> IO (ModIface, Maybe Fingerprint, ModDetails))
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
-> IO (ModIface, Maybe Fingerprint, ModDetails)
forall a b. (a -> b) -> a -> b
$ TcGblEnv
-> Maybe Fingerprint
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface' TcGblEnv
tc_result Maybe Fingerprint
mb_old_iface
hscSimpleIface' :: TcGblEnv
-> Maybe Fingerprint
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface' :: TcGblEnv
-> Maybe Fingerprint
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface' TcGblEnv
tc_result Maybe Fingerprint
mb_old_iface = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
ModDetails
details <- IO ModDetails -> Hsc ModDetails
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModDetails -> Hsc ModDetails)
-> IO ModDetails -> Hsc ModDetails
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc HscEnv
hsc_env TcGblEnv
tc_result
SafeHaskellMode
safe_mode <- TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode TcGblEnv
tc_result
ModIface
new_iface
<- {-# SCC "MkFinalIface" #-}
IO ModIface -> Hsc ModIface
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModIface -> Hsc ModIface) -> IO ModIface -> Hsc ModIface
forall a b. (a -> b) -> a -> b
$
HscEnv -> SafeHaskellMode -> ModDetails -> TcGblEnv -> IO ModIface
mkIfaceTc HscEnv
hsc_env SafeHaskellMode
safe_mode ModDetails
details TcGblEnv
tc_result
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env
(ModIface, Maybe Fingerprint, ModDetails)
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
new_iface, Maybe Fingerprint
mb_old_iface, ModDetails
details)
hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)
hscGenHardCode :: HscEnv
-> CgGuts
-> ModLocation
-> String
-> IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
hscGenHardCode HscEnv
hsc_env CgGuts
cgguts ModLocation
location String
output_filename = do
let CgGuts{
cg_module :: CgGuts -> Module
cg_module = Module
this_mod,
cg_binds :: CgGuts -> CoreProgram
cg_binds = CoreProgram
core_binds,
cg_tycons :: CgGuts -> [TyCon]
cg_tycons = [TyCon]
tycons,
cg_foreign :: CgGuts -> ForeignStubs
cg_foreign = ForeignStubs
foreign_stubs0,
cg_foreign_files :: CgGuts -> [(ForeignSrcLang, String)]
cg_foreign_files = [(ForeignSrcLang, String)]
foreign_files,
cg_dep_pkgs :: CgGuts -> [UnitId]
cg_dep_pkgs = [UnitId]
dependencies,
cg_hpc_info :: CgGuts -> HpcInfo
cg_hpc_info = HpcInfo
hpc_info } = CgGuts
cgguts
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
hooks :: Hooks
hooks = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env
tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
data_tycons :: [TyCon]
data_tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
(CoreProgram
prepd_binds, Set CostCentre
local_ccs) <- {-# SCC "CorePrep" #-}
HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO (CoreProgram, Set CostCentre)
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
location
CoreProgram
core_binds [TyCon]
data_tycons
([StgTopBinding]
stg_binds, InfoTableProvMap
denv, ([CostCentre]
caf_ccs, [CostCentreStack]
caf_cc_stacks))
<- {-# SCC "CoreToStg" #-}
Logger
-> DynFlags
-> SDoc
-> (([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
-> ())
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
(String -> SDoc
text String
"CoreToStg"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(\([StgTopBinding]
a, InfoTableProvMap
b, ([CostCentre]
c,[CostCentreStack]
d)) -> [StgTopBinding]
a [StgTopBinding] -> InfoTableProvMap -> InfoTableProvMap
forall a b. [a] -> b -> b
`seqList` InfoTableProvMap
b InfoTableProvMap -> () -> ()
`seq` [CostCentre]
c [CostCentre] -> [CostCentreStack] -> [CostCentreStack]
forall a b. [a] -> b -> b
`seqList` [CostCentreStack]
d [CostCentreStack] -> () -> ()
forall a b. [a] -> b -> b
`seqList` ())
(Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStg Logger
logger DynFlags
dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) Module
this_mod ModLocation
location CoreProgram
prepd_binds)
let cost_centre_info :: ([CostCentre], [CostCentreStack])
cost_centre_info =
(Set CostCentre -> [CostCentre]
forall a. Set a -> [a]
S.toList Set CostCentre
local_ccs [CostCentre] -> [CostCentre] -> [CostCentre]
forall a. [a] -> [a] -> [a]
++ [CostCentre]
caf_ccs, [CostCentreStack]
caf_cc_stacks)
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
prof_init :: CStub
prof_init
| DynFlags -> Bool
sccProfilingEnabled DynFlags
dflags = Platform -> Module -> ([CostCentre], [CostCentreStack]) -> CStub
profilingInitCode Platform
platform Module
this_mod ([CostCentre], [CostCentreStack])
cost_centre_info
| Bool
otherwise = CStub
forall a. Monoid a => a
mempty
Logger
-> DynFlags
-> SDoc
-> ((String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
-> ())
-> IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
-> IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
(String -> SDoc
text String
"CodeGen"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(()
-> (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
-> ()
forall a b. a -> b -> a
const ()) (IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
-> IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos))
-> IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
-> IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
forall a b. (a -> b) -> a -> b
$ do
Stream IO CmmGroupSRTs CgInfos
cmms <- {-# SCC "StgToCmm" #-}
HscEnv
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroupSRTs CgInfos)
doCodeGen HscEnv
hsc_env Module
this_mod InfoTableProvMap
denv [TyCon]
data_tycons
([CostCentre], [CostCentreStack])
cost_centre_info
[StgTopBinding]
stg_binds HpcInfo
hpc_info
Stream IO RawCmmGroup CgInfos
rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
case Hooks
-> forall a.
Maybe
(DynFlags
-> Maybe Module
-> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a))
cmmToRawCmmHook Hooks
hooks of
Maybe
(DynFlags
-> Maybe Module
-> Stream IO CmmGroupSRTs CgInfos
-> IO (Stream IO RawCmmGroup CgInfos))
Nothing -> Logger
-> DynFlags
-> Stream IO CmmGroupSRTs CgInfos
-> IO (Stream IO RawCmmGroup CgInfos)
forall a.
Logger
-> DynFlags
-> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a)
cmmToRawCmm Logger
logger DynFlags
dflags Stream IO CmmGroupSRTs CgInfos
cmms
Just DynFlags
-> Maybe Module
-> Stream IO CmmGroupSRTs CgInfos
-> IO (Stream IO RawCmmGroup CgInfos)
h -> DynFlags
-> Maybe Module
-> Stream IO CmmGroupSRTs CgInfos
-> IO (Stream IO RawCmmGroup CgInfos)
h DynFlags
dflags (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
this_mod) Stream IO CmmGroupSRTs CgInfos
cmms
let dump :: RawCmmGroup -> IO RawCmmGroup
dump RawCmmGroup
a = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RawCmmGroup -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null RawCmmGroup
a) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cmm_raw String
"Raw Cmm" DumpFormat
FormatCMM (Platform -> RawCmmGroup -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform RawCmmGroup
a)
RawCmmGroup -> IO RawCmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return RawCmmGroup
a
rawcmms1 :: Stream IO RawCmmGroup CgInfos
rawcmms1 = (RawCmmGroup -> IO RawCmmGroup)
-> Stream IO RawCmmGroup CgInfos -> Stream IO RawCmmGroup CgInfos
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM RawCmmGroup -> IO RawCmmGroup
dump Stream IO RawCmmGroup CgInfos
rawcmms0
let foreign_stubs :: CgInfos -> ForeignStubs
foreign_stubs CgInfos
st = ForeignStubs
foreign_stubs0 ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CStub
prof_init
ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CgInfos -> CStub
cgIPEStub CgInfos
st
(String
output_filename, (Bool
_stub_h_exists, Maybe String
stub_c_exists), [(ForeignSrcLang, String)]
foreign_fps, CgInfos
cg_infos)
<- {-# SCC "codeOutput" #-}
Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> String
-> ModLocation
-> (CgInfos -> ForeignStubs)
-> [(ForeignSrcLang, String)]
-> [UnitId]
-> Stream IO RawCmmGroup CgInfos
-> IO
(String, (Bool, Maybe String), [(ForeignSrcLang, String)], CgInfos)
forall a.
Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> String
-> ModLocation
-> (a -> ForeignStubs)
-> [(ForeignSrcLang, String)]
-> [UnitId]
-> Stream IO RawCmmGroup a
-> IO (String, (Bool, Maybe String), [(ForeignSrcLang, String)], a)
codeOutput Logger
logger TmpFs
tmpfs DynFlags
dflags (HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
this_mod String
output_filename ModLocation
location
CgInfos -> ForeignStubs
foreign_stubs [(ForeignSrcLang, String)]
foreign_files [UnitId]
dependencies Stream IO RawCmmGroup CgInfos
rawcmms1
(String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
-> IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
output_filename, Maybe String
stub_c_exists, [(ForeignSrcLang, String)]
foreign_fps, CgInfos
cg_infos)
hscInteractive :: HscEnv
-> CgGuts
-> ModLocation
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive :: HscEnv
-> CgGuts
-> ModLocation
-> IO (Maybe String, CompiledByteCode, [SptEntry])
hscInteractive HscEnv
hsc_env CgGuts
cgguts ModLocation
location = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
let CgGuts{
cg_module :: CgGuts -> Module
cg_module = Module
this_mod,
cg_binds :: CgGuts -> CoreProgram
cg_binds = CoreProgram
core_binds,
cg_tycons :: CgGuts -> [TyCon]
cg_tycons = [TyCon]
tycons,
cg_foreign :: CgGuts -> ForeignStubs
cg_foreign = ForeignStubs
foreign_stubs,
cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_modBreaks = Maybe ModBreaks
mod_breaks,
cg_spt_entries :: CgGuts -> [SptEntry]
cg_spt_entries = [SptEntry]
spt_entries } = CgGuts
cgguts
data_tycons :: [TyCon]
data_tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
(CoreProgram
prepd_binds, Set CostCentre
_) <- {-# SCC "CorePrep" #-}
HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO (CoreProgram, Set CostCentre)
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
location CoreProgram
core_binds [TyCon]
data_tycons
([StgTopBinding]
stg_binds, InfoTableProvMap
_infotable_prov, ([CostCentre], [CostCentreStack])
_caf_ccs__caf_cc_stacks)
<- {-# SCC "CoreToStg" #-}
Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStg Logger
logger DynFlags
dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) Module
this_mod ModLocation
location CoreProgram
prepd_binds
CompiledByteCode
comp_bc <- HscEnv
-> Module
-> [StgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod [StgTopBinding]
stg_binds [TyCon]
data_tycons Maybe ModBreaks
mod_breaks
(Bool
_istub_h_exists, Maybe String
istub_c_exists)
<- Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> ModLocation
-> ForeignStubs
-> IO (Bool, Maybe String)
outputForeignStubs Logger
logger TmpFs
tmpfs DynFlags
dflags (HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
this_mod ModLocation
location ForeignStubs
foreign_stubs
(Maybe String, CompiledByteCode, [SptEntry])
-> IO (Maybe String, CompiledByteCode, [SptEntry])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
istub_c_exists, CompiledByteCode
comp_bc, [SptEntry]
spt_entries)
hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath)
hscCompileCmmFile :: HscEnv -> String -> String -> IO (Maybe String)
hscCompileCmmFile HscEnv
hsc_env String
filename String
output_filename = HscEnv -> Hsc (Maybe String) -> IO (Maybe String)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (Maybe String) -> IO (Maybe String))
-> Hsc (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let hooks :: Hooks
hooks = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
mod_name :: ModuleName
mod_name = String -> ModuleName
mkModuleName (String -> ModuleName) -> String -> ModuleName
forall a b. (a -> b) -> a -> b
$ String
"Cmm$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
FilePath.takeFileName String
filename
cmm_mod :: Module
cmm_mod = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name
(CmmGroup
cmm, [InfoProvEnt]
ents) <- IO (Messages GhcMessage, Maybe (CmmGroup, [InfoProvEnt]))
-> Hsc (CmmGroup, [InfoProvEnt])
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe
(IO (Messages GhcMessage, Maybe (CmmGroup, [InfoProvEnt]))
-> Hsc (CmmGroup, [InfoProvEnt]))
-> IO (Messages GhcMessage, Maybe (CmmGroup, [InfoProvEnt]))
-> Hsc (CmmGroup, [InfoProvEnt])
forall a b. (a -> b) -> a -> b
$ do
(Messages PsWarning
warns,Messages PsWarning
errs,Maybe (CmmGroup, [InfoProvEnt])
cmm) <- Logger
-> DynFlags
-> SDoc
-> ((Messages PsWarning, Messages PsWarning,
Maybe (CmmGroup, [InfoProvEnt]))
-> ())
-> IO
(Messages PsWarning, Messages PsWarning,
Maybe (CmmGroup, [InfoProvEnt]))
-> IO
(Messages PsWarning, Messages PsWarning,
Maybe (CmmGroup, [InfoProvEnt]))
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags (String -> SDoc
text String
"ParseCmm"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (String -> SDoc
text String
filename)) (\(Messages PsWarning, Messages PsWarning,
Maybe (CmmGroup, [InfoProvEnt]))
_ -> ())
(IO
(Messages PsWarning, Messages PsWarning,
Maybe (CmmGroup, [InfoProvEnt]))
-> IO
(Messages PsWarning, Messages PsWarning,
Maybe (CmmGroup, [InfoProvEnt])))
-> IO
(Messages PsWarning, Messages PsWarning,
Maybe (CmmGroup, [InfoProvEnt]))
-> IO
(Messages PsWarning, Messages PsWarning,
Maybe (CmmGroup, [InfoProvEnt]))
forall a b. (a -> b) -> a -> b
$ DynFlags
-> Module
-> HomeUnit
-> String
-> IO
(Messages PsWarning, Messages PsWarning,
Maybe (CmmGroup, [InfoProvEnt]))
parseCmmFile DynFlags
dflags Module
cmm_mod HomeUnit
home_unit String
filename
let msgs :: Messages PsWarning
msgs = Messages PsWarning
warns Messages PsWarning -> Messages PsWarning -> Messages PsWarning
forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages PsWarning
errs
(Messages GhcMessage, Maybe (CmmGroup, [InfoProvEnt]))
-> IO (Messages GhcMessage, Maybe (CmmGroup, [InfoProvEnt]))
forall (m :: * -> *) a. Monad m => a -> m a
return (PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage)
-> Messages PsWarning -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
msgs, Maybe (CmmGroup, [InfoProvEnt])
cmm)
IO (Maybe String) -> Hsc (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> Hsc (Maybe String))
-> IO (Maybe String) -> Hsc (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cmm_verbose_by_proc String
"Parsed Cmm" DumpFormat
FormatCMM (Platform -> CmmGroup -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmGroup
cmm)
CmmGroupSRTs
cmmgroup <-
(GenCmmDecl CmmStatics CmmTopInfo CmmGraph -> IO CmmGroupSRTs)
-> CmmGroup -> IO CmmGroupSRTs
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (\GenCmmDecl CmmStatics CmmTopInfo CmmGraph
cmm -> (ModuleSRTInfo, CmmGroupSRTs) -> CmmGroupSRTs
forall a b. (a, b) -> b
snd ((ModuleSRTInfo, CmmGroupSRTs) -> CmmGroupSRTs)
-> IO (ModuleSRTInfo, CmmGroupSRTs) -> IO CmmGroupSRTs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv
-> ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroupSRTs)
cmmPipeline HscEnv
hsc_env (Module -> ModuleSRTInfo
emptySRT Module
cmm_mod) [GenCmmDecl CmmStatics CmmTopInfo CmmGraph
cmm]) CmmGroup
cmm
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CmmGroupSRTs -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CmmGroupSRTs
cmmgroup) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cmm String
"Output Cmm"
DumpFormat
FormatCMM (Platform -> CmmGroupSRTs -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmGroupSRTs
cmmgroup)
Stream IO RawCmmGroup ()
rawCmms <- case Hooks
-> forall a.
Maybe
(DynFlags
-> Maybe Module
-> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a))
cmmToRawCmmHook Hooks
hooks of
Maybe
(DynFlags
-> Maybe Module
-> Stream IO CmmGroupSRTs ()
-> IO (Stream IO RawCmmGroup ()))
Nothing -> Logger
-> DynFlags
-> Stream IO CmmGroupSRTs ()
-> IO (Stream IO RawCmmGroup ())
forall a.
Logger
-> DynFlags
-> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a)
cmmToRawCmm Logger
logger DynFlags
dflags (CmmGroupSRTs -> Stream IO CmmGroupSRTs ()
forall (m :: * -> *) a. Monad m => a -> Stream m a ()
Stream.yield CmmGroupSRTs
cmmgroup)
Just DynFlags
-> Maybe Module
-> Stream IO CmmGroupSRTs ()
-> IO (Stream IO RawCmmGroup ())
h -> DynFlags
-> Maybe Module
-> Stream IO CmmGroupSRTs ()
-> IO (Stream IO RawCmmGroup ())
h DynFlags
dflags Maybe Module
forall a. Maybe a
Nothing (CmmGroupSRTs -> Stream IO CmmGroupSRTs ()
forall (m :: * -> *) a. Monad m => a -> Stream m a ()
Stream.yield CmmGroupSRTs
cmmgroup)
let foreign_stubs :: () -> ForeignStubs
foreign_stubs ()
_ =
let ip_init :: CStub
ip_init = DynFlags -> Module -> [InfoProvEnt] -> CStub
ipInitCode DynFlags
dflags Module
cmm_mod [InfoProvEnt]
ents
in ForeignStubs
NoStubs ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CStub
ip_init
(String
_output_filename, (Bool
_stub_h_exists, Maybe String
stub_c_exists), [(ForeignSrcLang, String)]
_foreign_fps, ()
_caf_infos)
<- Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> String
-> ModLocation
-> (() -> ForeignStubs)
-> [(ForeignSrcLang, String)]
-> [UnitId]
-> Stream IO RawCmmGroup ()
-> IO
(String, (Bool, Maybe String), [(ForeignSrcLang, String)], ())
forall a.
Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> String
-> ModLocation
-> (a -> ForeignStubs)
-> [(ForeignSrcLang, String)]
-> [UnitId]
-> Stream IO RawCmmGroup a
-> IO (String, (Bool, Maybe String), [(ForeignSrcLang, String)], a)
codeOutput Logger
logger TmpFs
tmpfs DynFlags
dflags (HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
cmm_mod String
output_filename ModLocation
no_loc () -> ForeignStubs
foreign_stubs [] []
Stream IO RawCmmGroup ()
rawCmms
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
stub_c_exists
where
no_loc :: ModLocation
no_loc = ModLocation :: Maybe String -> String -> String -> String -> ModLocation
ModLocation{ ml_hs_file :: Maybe String
ml_hs_file = String -> Maybe String
forall a. a -> Maybe a
Just String
filename,
ml_hi_file :: String
ml_hi_file = String -> String
forall a. String -> a
panic String
"hscCompileCmmFile: no hi file",
ml_obj_file :: String
ml_obj_file = String -> String
forall a. String -> a
panic String
"hscCompileCmmFile: no obj file",
ml_hie_file :: String
ml_hie_file = String -> String
forall a. String -> a
panic String
"hscCompileCmmFile: no hie file"}
doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroupSRTs CgInfos)
doCodeGen :: HscEnv
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroupSRTs CgInfos)
doCodeGen HscEnv
hsc_env Module
this_mod InfoTableProvMap
denv [TyCon]
data_tycons
([CostCentre], [CostCentreStack])
cost_centre_info [StgTopBinding]
stg_binds HpcInfo
hpc_info = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let hooks :: Hooks
hooks = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
let stg_binds_w_fvs :: [CgStgTopBinding]
stg_binds_w_fvs = [StgTopBinding] -> [CgStgTopBinding]
annTopBindingsFreeVars [StgTopBinding]
stg_binds
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_stg_final String
"Final STG:" DumpFormat
FormatSTG (StgPprOpts -> [CgStgTopBinding] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings (DynFlags -> StgPprOpts
initStgPprOpts DynFlags
dflags) [CgStgTopBinding]
stg_binds_w_fvs)
let stg_to_cmm :: DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
stg_to_cmm = case Hooks
-> Maybe
(DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup (CStub, ModuleLFInfos))
stgToCmmHook Hooks
hooks of
Maybe
(DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup (CStub, ModuleLFInfos))
Nothing -> Logger
-> TmpFs
-> DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
StgToCmm.codeGen Logger
logger TmpFs
tmpfs
Just DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
h -> DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
h
let cmm_stream :: Stream IO CmmGroup (CStub, ModuleLFInfos)
cmm_stream :: Stream IO CmmGroup (CStub, ModuleLFInfos)
cmm_stream = [CgStgTopBinding]
stg_binds_w_fvs [CgStgTopBinding]
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
forall a b. [a] -> b -> b
`seqList` {-# SCC "StgToCmm" #-}
DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
stg_to_cmm DynFlags
dflags Module
this_mod InfoTableProvMap
denv [TyCon]
data_tycons ([CostCentre], [CostCentreStack])
cost_centre_info [CgStgTopBinding]
stg_binds_w_fvs HpcInfo
hpc_info
let dump1 :: CmmGroup -> IO CmmGroup
dump1 CmmGroup
a = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CmmGroup -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CmmGroup
a) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cmm_from_stg
String
"Cmm produced by codegen" DumpFormat
FormatCMM (Platform -> CmmGroup -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmGroup
a)
CmmGroup -> IO CmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return CmmGroup
a
ppr_stream1 :: Stream IO CmmGroup (CStub, ModuleLFInfos)
ppr_stream1 = (CmmGroup -> IO CmmGroup)
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM CmmGroup -> IO CmmGroup
dump1 Stream IO CmmGroup (CStub, ModuleLFInfos)
cmm_stream
pipeline_stream :: Stream IO CmmGroupSRTs CgInfos
pipeline_stream :: Stream IO CmmGroupSRTs CgInfos
pipeline_stream = do
(NonCaffySet
non_cafs, (CStub
used_info, ModuleLFInfos
lf_infos)) <-
{-# SCC "cmmPipeline" #-}
(ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroupSRTs))
-> ModuleSRTInfo
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
-> Stream IO CmmGroupSRTs (ModuleSRTInfo, (CStub, ModuleLFInfos))
forall (m :: * -> *) a b c r.
Monad m =>
(c -> a -> m (c, b)) -> c -> Stream m a r -> Stream m b (c, r)
Stream.mapAccumL_ (HscEnv
-> ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroupSRTs)
cmmPipeline HscEnv
hsc_env) (Module -> ModuleSRTInfo
emptySRT Module
this_mod) Stream IO CmmGroup (CStub, ModuleLFInfos)
ppr_stream1
Stream IO CmmGroupSRTs (ModuleSRTInfo, (CStub, ModuleLFInfos))
-> ((ModuleSRTInfo, (CStub, ModuleLFInfos))
-> (NonCaffySet, (CStub, ModuleLFInfos)))
-> Stream IO CmmGroupSRTs (NonCaffySet, (CStub, ModuleLFInfos))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (ModuleSRTInfo -> NonCaffySet)
-> (ModuleSRTInfo, (CStub, ModuleLFInfos))
-> (NonCaffySet, (CStub, ModuleLFInfos))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SRTMap -> NonCaffySet
srtMapNonCAFs (SRTMap -> NonCaffySet)
-> (ModuleSRTInfo -> SRTMap) -> ModuleSRTInfo -> NonCaffySet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleSRTInfo -> SRTMap
moduleSRTMap)
CgInfos -> Stream IO CmmGroupSRTs CgInfos
forall (m :: * -> *) a. Monad m => a -> m a
return CgInfos :: NonCaffySet -> ModuleLFInfos -> CStub -> CgInfos
CgInfos{ cgNonCafs :: NonCaffySet
cgNonCafs = NonCaffySet
non_cafs, cgLFInfos :: ModuleLFInfos
cgLFInfos = ModuleLFInfos
lf_infos, cgIPEStub :: CStub
cgIPEStub = CStub
used_info }
dump2 :: CmmGroupSRTs -> IO CmmGroupSRTs
dump2 CmmGroupSRTs
a = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CmmGroupSRTs -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CmmGroupSRTs
a) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cmm String
"Output Cmm" DumpFormat
FormatCMM (Platform -> CmmGroupSRTs -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmGroupSRTs
a)
CmmGroupSRTs -> IO CmmGroupSRTs
forall (m :: * -> *) a. Monad m => a -> m a
return CmmGroupSRTs
a
Stream IO CmmGroupSRTs CgInfos
-> IO (Stream IO CmmGroupSRTs CgInfos)
forall (m :: * -> *) a. Monad m => a -> m a
return ((CmmGroupSRTs -> IO CmmGroupSRTs)
-> Stream IO CmmGroupSRTs CgInfos -> Stream IO CmmGroupSRTs CgInfos
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM CmmGroupSRTs -> IO CmmGroupSRTs
dump2 Stream IO CmmGroupSRTs CgInfos
pipeline_stream)
myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
-> Module -> ModLocation -> CoreExpr
-> IO ( StgRhs
, InfoTableProvMap
, CollectedCCs )
myCoreToStgExpr :: Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreExpr
-> IO (StgRhs, InfoTableProvMap, ([CostCentre], [CostCentreStack]))
myCoreToStgExpr Logger
logger DynFlags
dflags InteractiveContext
ictxt Module
this_mod ModLocation
ml CoreExpr
prepd_expr = do
let bco_tmp_id :: DFunId
bco_tmp_id = FastString -> Unique -> Mult -> Mult -> DFunId
mkSysLocal (String -> FastString
fsLit String
"BCO_toplevel")
(Int -> Unique
mkPseudoUniqueE Int
0)
Mult
Many
(CoreExpr -> Mult
exprType CoreExpr
prepd_expr)
([StgTopLifted (StgNonRec BinderP 'Vanilla
_ StgRhs
stg_expr)], InfoTableProvMap
prov_map, ([CostCentre], [CostCentreStack])
collected_ccs) <-
Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStg Logger
logger
DynFlags
dflags
InteractiveContext
ictxt
Module
this_mod
ModLocation
ml
[DFunId -> CoreExpr -> Bind DFunId
forall b. b -> Expr b -> Bind b
NonRec DFunId
bco_tmp_id CoreExpr
prepd_expr]
(StgRhs, InfoTableProvMap, ([CostCentre], [CostCentreStack]))
-> IO (StgRhs, InfoTableProvMap, ([CostCentre], [CostCentreStack]))
forall (m :: * -> *) a. Monad m => a -> m a
return (StgRhs
stg_expr, InfoTableProvMap
prov_map, ([CostCentre], [CostCentreStack])
collected_ccs)
myCoreToStg :: Logger -> DynFlags -> InteractiveContext
-> Module -> ModLocation -> CoreProgram
-> IO ( [StgTopBinding]
, InfoTableProvMap
, CollectedCCs )
myCoreToStg :: Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStg Logger
logger DynFlags
dflags InteractiveContext
ictxt Module
this_mod ModLocation
ml CoreProgram
prepd_binds = do
let ([StgTopBinding]
stg_binds, InfoTableProvMap
denv, ([CostCentre], [CostCentreStack])
cost_centre_info)
= {-# SCC "Core2Stg" #-}
DynFlags
-> Module
-> ModLocation
-> CoreProgram
-> ([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
coreToStg DynFlags
dflags Module
this_mod ModLocation
ml CoreProgram
prepd_binds
[StgTopBinding]
stg_binds2
<- {-# SCC "Stg2Stg" #-}
Logger
-> DynFlags
-> InteractiveContext
-> Module
-> [StgTopBinding]
-> IO [StgTopBinding]
stg2stg Logger
logger DynFlags
dflags InteractiveContext
ictxt Module
this_mod [StgTopBinding]
stg_binds
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgTopBinding]
stg_binds2, InfoTableProvMap
denv, ([CostCentre], [CostCentreStack])
cost_centre_info)
hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscStmt :: HscEnv -> String -> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
hscStmt HscEnv
hsc_env String
stmt = HscEnv
-> String
-> String
-> Int
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
hscStmtWithLocation HscEnv
hsc_env String
stmt String
"<interactive>" Int
1
hscStmtWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO ( Maybe ([Id]
, ForeignHValue
, FixityEnv))
hscStmtWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
hscStmtWithLocation HscEnv
hsc_env0 String
stmt String
source Int
linenumber =
HscEnv
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv)))
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ do
Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
maybe_stmt <- String -> Int -> String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation String
source Int
linenumber String
stmt
case Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
maybe_stmt of
Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
Nothing -> Maybe ([DFunId], ForeignHValue, FixityEnv)
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([DFunId], ForeignHValue, FixityEnv)
forall a. Maybe a
Nothing
Just GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
parsed_stmt -> do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv)))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
hscParsedStmt HscEnv
hsc_env GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
GhciLStmt GhcPs
parsed_stmt
hscParsedStmt :: HscEnv
-> GhciLStmt GhcPs
-> IO ( Maybe ([Id]
, ForeignHValue
, FixityEnv))
hscParsedStmt :: HscEnv
-> GhciLStmt GhcPs
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
hscParsedStmt HscEnv
hsc_env GhciLStmt GhcPs
stmt = HscEnv
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv)))
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ do
([DFunId]
ids, GenLocated SrcSpanAnnA (HsExpr GhcTc)
tc_expr, FixityEnv
fix_env) <- IO
(Messages GhcMessage,
Maybe ([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv))
-> Hsc ([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv)
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO
(Messages GhcMessage,
Maybe ([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv))
-> Hsc
([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv))
-> IO
(Messages GhcMessage,
Maybe ([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv))
-> Hsc ([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv)
forall a b. (a -> b) -> a -> b
$ IO
(Messages TcRnMessage,
Maybe ([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv))
-> IO
(Messages GhcMessage,
Maybe ([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv))
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO
(Messages TcRnMessage,
Maybe ([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv))
-> IO
(Messages GhcMessage,
Maybe
([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv)))
-> IO
(Messages TcRnMessage,
Maybe ([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv))
-> IO
(Messages GhcMessage,
Maybe ([DFunId], GenLocated SrcSpanAnnA (HsExpr GhcTc), FixityEnv))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs
-> IO
(Messages TcRnMessage, Maybe ([DFunId], LHsExpr GhcTc, FixityEnv))
tcRnStmt HscEnv
hsc_env GhciLStmt GhcPs
stmt
CoreExpr
ds_expr <- IO (Messages GhcMessage, Maybe CoreExpr) -> Hsc CoreExpr
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe CoreExpr) -> Hsc CoreExpr)
-> IO (Messages GhcMessage, Maybe CoreExpr) -> Hsc CoreExpr
forall a b. (a -> b) -> a -> b
$ IO (Messages DsMessage, Maybe CoreExpr)
-> IO (Messages GhcMessage, Maybe CoreExpr)
forall (m :: * -> *) a.
Monad m =>
m (Messages DsMessage, a) -> m (Messages GhcMessage, a)
hoistDsMessage (IO (Messages DsMessage, Maybe CoreExpr)
-> IO (Messages GhcMessage, Maybe CoreExpr))
-> IO (Messages DsMessage, Maybe CoreExpr)
-> IO (Messages GhcMessage, Maybe CoreExpr)
forall a b. (a -> b) -> a -> b
$ HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr)
deSugarExpr HscEnv
hsc_env GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
tc_expr
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SDoc -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr (String -> SDoc
text String
"desugar expression") HscEnv
hsc_env CoreExpr
ds_expr)
Hsc ()
handleWarnings
let src_span :: SrcSpan
src_span = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc
ForeignHValue
hval <- IO ForeignHValue -> Hsc ForeignHValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ForeignHValue -> Hsc ForeignHValue)
-> IO ForeignHValue -> Hsc ForeignHValue
forall a b. (a -> b) -> a -> b
$ HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr HscEnv
hsc_env SrcSpan
src_span CoreExpr
ds_expr
Maybe ([DFunId], ForeignHValue, FixityEnv)
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([DFunId], ForeignHValue, FixityEnv)
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv)))
-> Maybe ([DFunId], ForeignHValue, FixityEnv)
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ ([DFunId], ForeignHValue, FixityEnv)
-> Maybe ([DFunId], ForeignHValue, FixityEnv)
forall a. a -> Maybe a
Just ([DFunId]
ids, ForeignHValue
hval, FixityEnv
fix_env)
hscDecls :: HscEnv
-> String
-> IO ([TyThing], InteractiveContext)
hscDecls :: HscEnv -> String -> IO ([TyThing], InteractiveContext)
hscDecls HscEnv
hsc_env String
str = HscEnv
-> String -> String -> Int -> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation HscEnv
hsc_env String
str String
"<interactive>" Int
1
hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation HscEnv
hsc_env String
source Int
line_num String
str = do
L SrcSpan
_ (HsModule{ hsmodDecls :: HsModule -> [LHsDecl GhcPs]
hsmodDecls = [LHsDecl GhcPs]
decls }) <-
HscEnv -> Hsc (Located HsModule) -> IO (Located HsModule)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Located HsModule) -> IO (Located HsModule))
-> Hsc (Located HsModule) -> IO (Located HsModule)
forall a b. (a -> b) -> a -> b
$
String
-> Int -> P (Located HsModule) -> String -> Hsc (Located HsModule)
forall thing.
(Outputable thing, Data thing) =>
String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation String
source Int
line_num P (Located HsModule)
parseModule String
str
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> IO [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (m :: * -> *) a. Monad m => a -> m a
return [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
[LHsDecl GhcPs]
decls
hscDeclsWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation :: HscEnv
-> String -> String -> Int -> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation HscEnv
hsc_env String
str String
source Int
linenumber = do
L SrcSpan
_ (HsModule{ hsmodDecls :: HsModule -> [LHsDecl GhcPs]
hsmodDecls = [LHsDecl GhcPs]
decls }) <-
HscEnv -> Hsc (Located HsModule) -> IO (Located HsModule)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Located HsModule) -> IO (Located HsModule))
-> Hsc (Located HsModule) -> IO (Located HsModule)
forall a b. (a -> b) -> a -> b
$
String
-> Int -> P (Located HsModule) -> String -> Hsc (Located HsModule)
forall thing.
(Outputable thing, Data thing) =>
String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation String
source Int
linenumber P (Located HsModule)
parseModule String
str
HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls HscEnv
hsc_env [LHsDecl GhcPs]
decls
hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls HscEnv
hsc_env [LHsDecl GhcPs]
decls = HscEnv
-> Hsc ([TyThing], InteractiveContext)
-> IO ([TyThing], InteractiveContext)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc ([TyThing], InteractiveContext)
-> IO ([TyThing], InteractiveContext))
-> Hsc ([TyThing], InteractiveContext)
-> IO ([TyThing], InteractiveContext)
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
TcGblEnv
tc_gblenv <- IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv) -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv))
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-> IO (Messages GhcMessage, Maybe TcGblEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LHsDecl GhcPs] -> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnDeclsi HscEnv
hsc_env [LHsDecl GhcPs]
decls
let defaults :: Maybe [Mult]
defaults = TcGblEnv -> Maybe [Mult]
tcg_default TcGblEnv
tc_gblenv
let iNTERACTIVELoc :: ModLocation
iNTERACTIVELoc = ModLocation :: Maybe String -> String -> String -> String -> ModLocation
ModLocation{ ml_hs_file :: Maybe String
ml_hs_file = Maybe String
forall a. Maybe a
Nothing,
ml_hi_file :: String
ml_hi_file = String -> String
forall a. String -> a
panic String
"hsDeclsWithLocation:ml_hi_file",
ml_obj_file :: String
ml_obj_file = String -> String
forall a. String -> a
panic String
"hsDeclsWithLocation:ml_obj_file",
ml_hie_file :: String
ml_hie_file = String -> String
forall a. String -> a
panic String
"hsDeclsWithLocation:ml_hie_file" }
ModGuts
ds_result <- ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' ModLocation
iNTERACTIVELoc TcGblEnv
tc_gblenv
ModGuts
simpl_mg <- IO ModGuts -> Hsc ModGuts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> Hsc ModGuts) -> IO ModGuts -> Hsc ModGuts
forall a b. (a -> b) -> a -> b
$ do
[String]
plugins <- IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef [String]
tcg_th_coreplugins TcGblEnv
tc_gblenv)
HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify HscEnv
hsc_env [String]
plugins ModGuts
ds_result
(CgGuts
tidy_cg, ModDetails
mod_details) <- IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails))
-> IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram HscEnv
hsc_env ModGuts
simpl_mg
let !CgGuts{ cg_module :: CgGuts -> Module
cg_module = Module
this_mod,
cg_binds :: CgGuts -> CoreProgram
cg_binds = CoreProgram
core_binds,
cg_tycons :: CgGuts -> [TyCon]
cg_tycons = [TyCon]
tycons,
cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_modBreaks = Maybe ModBreaks
mod_breaks } = CgGuts
tidy_cg
!ModDetails { md_insts :: ModDetails -> [ClsInst]
md_insts = [ClsInst]
cls_insts
, md_fam_insts :: ModDetails -> [FamInst]
md_fam_insts = [FamInst]
fam_insts } = ModDetails
mod_details
data_tycons :: [TyCon]
data_tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
(CoreProgram
prepd_binds, Set CostCentre
_) <- {-# SCC "CorePrep" #-}
IO (CoreProgram, Set CostCentre)
-> Hsc (CoreProgram, Set CostCentre)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CoreProgram, Set CostCentre)
-> Hsc (CoreProgram, Set CostCentre))
-> IO (CoreProgram, Set CostCentre)
-> Hsc (CoreProgram, Set CostCentre)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO (CoreProgram, Set CostCentre)
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
iNTERACTIVELoc CoreProgram
core_binds [TyCon]
data_tycons
([StgTopBinding]
stg_binds, InfoTableProvMap
_infotable_prov, ([CostCentre], [CostCentreStack])
_caf_ccs__caf_cc_stacks)
<- {-# SCC "CoreToStg" #-}
IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
-> Hsc
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
-> Hsc
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack])))
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
-> Hsc
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
(HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
(HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
Module
this_mod
ModLocation
iNTERACTIVELoc
CoreProgram
prepd_binds
CompiledByteCode
cbc <- IO CompiledByteCode -> Hsc CompiledByteCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CompiledByteCode -> Hsc CompiledByteCode)
-> IO CompiledByteCode -> Hsc CompiledByteCode
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> [StgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod
[StgTopBinding]
stg_binds [TyCon]
data_tycons Maybe ModBreaks
mod_breaks
let src_span :: SrcSpan
src_span = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
loadDecls Interp
interp HscEnv
hsc_env SrcSpan
src_span CompiledByteCode
cbc
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env (CgGuts -> [SptEntry]
cg_spt_entries CgGuts
tidy_cg)
let tcs :: [TyCon]
tcs = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filterOut TyCon -> Bool
isImplicitTyCon (ModGuts -> [TyCon]
mg_tcs ModGuts
simpl_mg)
patsyns :: [PatSyn]
patsyns = ModGuts -> [PatSyn]
mg_patsyns ModGuts
simpl_mg
ext_ids :: [DFunId]
ext_ids = [ DFunId
id | DFunId
id <- CoreProgram -> [DFunId]
forall b. [Bind b] -> [b]
bindersOfBinds CoreProgram
core_binds
, Name -> Bool
isExternalName (DFunId -> Name
idName DFunId
id)
, Bool -> Bool
not (DFunId -> Bool
isDFunId DFunId
id Bool -> Bool -> Bool
|| DFunId -> Bool
isImplicitId DFunId
id) ]
new_tythings :: [TyThing]
new_tythings = (DFunId -> TyThing) -> [DFunId] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map DFunId -> TyThing
AnId [DFunId]
ext_ids [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ (TyCon -> TyThing) -> [TyCon] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyThing
ATyCon [TyCon]
tcs [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ (PatSyn -> TyThing) -> [PatSyn] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map (ConLike -> TyThing
AConLike (ConLike -> TyThing) -> (PatSyn -> ConLike) -> PatSyn -> TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatSyn -> ConLike
PatSynCon) [PatSyn]
patsyns
ictxt :: InteractiveContext
ictxt = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
fix_env :: FixityEnv
fix_env = TcGblEnv -> FixityEnv
tcg_fix_env TcGblEnv
tc_gblenv
new_ictxt :: InteractiveContext
new_ictxt = InteractiveContext
-> [TyThing]
-> [ClsInst]
-> [FamInst]
-> Maybe [Mult]
-> FixityEnv
-> InteractiveContext
extendInteractiveContext InteractiveContext
ictxt [TyThing]
new_tythings [ClsInst]
cls_insts
[FamInst]
fam_insts Maybe [Mult]
defaults FixityEnv
fix_env
([TyThing], InteractiveContext)
-> Hsc ([TyThing], InteractiveContext)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyThing]
new_tythings, InteractiveContext
new_ictxt)
hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env [SptEntry]
entries = do
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
let add_spt_entry :: SptEntry -> IO ()
add_spt_entry :: SptEntry -> IO ()
add_spt_entry (SptEntry DFunId
i Fingerprint
fpr) = do
ForeignHValue
val <- Interp -> HscEnv -> Name -> IO ForeignHValue
loadName Interp
interp HscEnv
hsc_env (DFunId -> Name
idName DFunId
i)
Interp -> Fingerprint -> ForeignHValue -> IO ()
addSptEntry Interp
interp Fingerprint
fpr ForeignHValue
val
(SptEntry -> IO ()) -> [SptEntry] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SptEntry -> IO ()
add_spt_entry [SptEntry]
entries
hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
hscImport HscEnv
hsc_env String
str = HscEnv -> Hsc (ImportDecl GhcPs) -> IO (ImportDecl GhcPs)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (ImportDecl GhcPs) -> IO (ImportDecl GhcPs))
-> Hsc (ImportDecl GhcPs) -> IO (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ do
(L SrcSpan
_ (HsModule{hsmodImports :: HsModule -> [LImportDecl GhcPs]
hsmodImports=[LImportDecl GhcPs]
is})) <-
P (Located HsModule) -> String -> Hsc (Located HsModule)
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (Located HsModule)
parseModule String
str
case [LImportDecl GhcPs]
is of
[L _ i] -> ImportDecl GhcPs -> Hsc (ImportDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ImportDecl GhcPs
i
[LImportDecl GhcPs]
_ -> IO (ImportDecl GhcPs) -> Hsc (ImportDecl GhcPs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ImportDecl GhcPs) -> Hsc (ImportDecl GhcPs))
-> IO (ImportDecl GhcPs) -> Hsc (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> IO (ImportDecl GhcPs)
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO (ImportDecl GhcPs))
-> MsgEnvelope GhcMessage -> IO (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage) -> PsWarning -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> PsWarning
forall a. (Diagnostic a, Typeable a) => a -> PsWarning
PsUnknownMessage (DiagnosticMessage -> PsWarning) -> DiagnosticMessage -> PsWarning
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
text String
"parse error in import declaration"
hscTcExpr :: HscEnv
-> TcRnExprMode
-> String
-> IO Type
hscTcExpr :: HscEnv -> TcRnExprMode -> String -> IO Mult
hscTcExpr HscEnv
hsc_env0 TcRnExprMode
mode String
expr = HscEnv -> Hsc Mult -> IO Mult
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc Mult -> IO Mult) -> Hsc Mult -> IO Mult
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr <- String -> Hsc (LHsExpr GhcPs)
hscParseExpr String
expr
IO (Messages GhcMessage, Maybe Mult) -> Hsc Mult
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe Mult) -> Hsc Mult)
-> IO (Messages GhcMessage, Maybe Mult) -> Hsc Mult
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe Mult)
-> IO (Messages GhcMessage, Maybe Mult)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe Mult)
-> IO (Messages GhcMessage, Maybe Mult))
-> IO (Messages TcRnMessage, Maybe Mult)
-> IO (Messages GhcMessage, Maybe Mult)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRnExprMode
-> LHsExpr GhcPs
-> IO (Messages TcRnMessage, Maybe Mult)
tcRnExpr HscEnv
hsc_env TcRnExprMode
mode GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
parsed_expr
hscKcType
:: HscEnv
-> Bool
-> String
-> IO (Type, Kind)
hscKcType :: HscEnv -> Bool -> String -> IO (Mult, Mult)
hscKcType HscEnv
hsc_env0 Bool
normalise String
str = HscEnv -> Hsc (Mult, Mult) -> IO (Mult, Mult)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Mult, Mult) -> IO (Mult, Mult))
-> Hsc (Mult, Mult) -> IO (Mult, Mult)
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
GenLocated SrcSpanAnnA (HsType GhcPs)
ty <- String -> Hsc (LHsType GhcPs)
hscParseType String
str
IO (Messages GhcMessage, Maybe (Mult, Mult)) -> Hsc (Mult, Mult)
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe (Mult, Mult)) -> Hsc (Mult, Mult))
-> IO (Messages GhcMessage, Maybe (Mult, Mult)) -> Hsc (Mult, Mult)
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe (Mult, Mult))
-> IO (Messages GhcMessage, Maybe (Mult, Mult))
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe (Mult, Mult))
-> IO (Messages GhcMessage, Maybe (Mult, Mult)))
-> IO (Messages TcRnMessage, Maybe (Mult, Mult))
-> IO (Messages GhcMessage, Maybe (Mult, Mult))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ZonkFlexi
-> Bool
-> LHsType GhcPs
-> IO (Messages TcRnMessage, Maybe (Mult, Mult))
tcRnType HscEnv
hsc_env ZonkFlexi
DefaultFlexi Bool
normalise GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
ty
hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr String
expr = do
Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
maybe_stmt <- String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt String
expr
case Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
maybe_stmt of
Just (L SrcSpanAnnA
_ (BodyStmt XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Hsc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
_ -> MsgEnvelope GhcMessage
-> Hsc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage
-> Hsc (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> MsgEnvelope GhcMessage
-> Hsc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage) -> PsWarning -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> PsWarning
forall a. (Diagnostic a, Typeable a) => a -> PsWarning
PsUnknownMessage (DiagnosticMessage -> PsWarning) -> DiagnosticMessage -> PsWarning
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
text String
"not an expression:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
expr)
hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt = P (Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> String
-> Hsc
(Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
parseStmt
hscParseStmtWithLocation :: String -> Int -> String
-> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation :: String -> Int -> String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation String
source Int
linenumber String
stmt =
String
-> Int
-> P (Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> String
-> Hsc
(Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
forall thing.
(Outputable thing, Data thing) =>
String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation String
source Int
linenumber P (Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
parseStmt String
stmt
hscParseType :: String -> Hsc (LHsType GhcPs)
hscParseType :: String -> Hsc (LHsType GhcPs)
hscParseType = P (GenLocated SrcSpanAnnA (HsType GhcPs))
-> String -> Hsc (GenLocated SrcSpanAnnA (HsType GhcPs))
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (GenLocated SrcSpanAnnA (HsType GhcPs))
parseType
hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)
hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)
hscParseIdentifier HscEnv
hsc_env String
str =
HscEnv -> Hsc (LocatedN RdrName) -> IO (LocatedN RdrName)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (LocatedN RdrName) -> IO (LocatedN RdrName))
-> Hsc (LocatedN RdrName) -> IO (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ P (LocatedN RdrName) -> String -> Hsc (LocatedN RdrName)
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (LocatedN RdrName)
parseIdentifier String
str
hscParseThing :: (Outputable thing, Data thing)
=> Lexer.P thing -> String -> Hsc thing
hscParseThing :: P thing -> String -> Hsc thing
hscParseThing = String -> Int -> P thing -> String -> Hsc thing
forall thing.
(Outputable thing, Data thing) =>
String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation String
"<interactive>" Int
1
hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
-> Lexer.P thing -> String -> Hsc thing
hscParseThingWithLocation :: String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation String
source Int
linenumber P thing
parser String
str = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- Hsc Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
Logger
-> DynFlags -> SDoc -> (thing -> ()) -> Hsc thing -> Hsc thing
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
(String -> SDoc
text String
"Parser [source]")
(() -> thing -> ()
forall a b. a -> b -> a
const ()) (Hsc thing -> Hsc thing) -> Hsc thing -> Hsc thing
forall a b. (a -> b) -> a -> b
$ {-# SCC "Parser" #-} do
let buf :: StringBuffer
buf = String -> StringBuffer
stringToStringBuffer String
str
loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit String
source) Int
linenumber Int
1
case P thing -> PState -> ParseResult thing
forall a. P a -> PState -> ParseResult a
unP P thing
parser (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) StringBuffer
buf RealSrcLoc
loc) of
PFailed PState
pst ->
(Messages PsWarning, Messages PsWarning) -> Hsc thing
forall a. (Messages PsWarning, Messages PsWarning) -> Hsc a
handleWarningsThrowErrors (PState -> (Messages PsWarning, Messages PsWarning)
getMessages PState
pst)
POk PState
pst thing
thing -> do
(Messages PsWarning, Messages PsWarning) -> Hsc ()
logWarningsReportErrors (PState -> (Messages PsWarning, Messages PsWarning)
getMessages PState
pst)
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_parsed String
"Parser"
DumpFormat
FormatHaskell (thing -> SDoc
forall a. Outputable a => a -> SDoc
ppr thing
thing)
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_parsed_ast String
"Parser AST"
DumpFormat
FormatHaskell (BlankSrcSpan -> BlankEpAnnotations -> thing -> SDoc
forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations thing
thing)
thing -> Hsc thing
forall (m :: * -> *) a. Monad m => a -> m a
return thing
thing
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr HscEnv
hsc_env SrcSpan
loc CoreExpr
expr =
case Hooks -> Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
hscCompileCoreExprHook (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) of
Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
Nothing -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' HscEnv
hsc_env SrcSpan
loc CoreExpr
expr
Just HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
h -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
h HscEnv
hsc_env SrcSpan
loc CoreExpr
expr
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' HscEnv
hsc_env SrcSpan
srcspan CoreExpr
ds_expr
= do {
CoreExpr
simpl_expr <- HscEnv -> CoreExpr -> IO CoreExpr
simplifyExpr HscEnv
hsc_env CoreExpr
ds_expr
; let tidy_expr :: CoreExpr
tidy_expr = TidyEnv -> CoreExpr -> CoreExpr
tidyExpr TidyEnv
emptyTidyEnv CoreExpr
simpl_expr
; CoreExpr
prepd_expr <- HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr HscEnv
hsc_env CoreExpr
tidy_expr
; SDoc -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr (String -> SDoc
text String
"hscCompileExpr") HscEnv
hsc_env CoreExpr
prepd_expr
; let iNTERACTIVELoc :: ModLocation
iNTERACTIVELoc = ModLocation :: Maybe String -> String -> String -> String -> ModLocation
ModLocation{ ml_hs_file :: Maybe String
ml_hs_file = Maybe String
forall a. Maybe a
Nothing,
ml_hi_file :: String
ml_hi_file = String -> String
forall a. String -> a
panic String
"hscCompileCoreExpr':ml_hi_file",
ml_obj_file :: String
ml_obj_file = String -> String
forall a. String -> a
panic String
"hscCompileCoreExpr':ml_obj_file",
ml_hie_file :: String
ml_hie_file = String -> String
forall a. String -> a
panic String
"hscCompileCoreExpr':ml_hie_file" }
; let ictxt :: InteractiveContext
ictxt = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
; (StgRhs
stg_expr, InfoTableProvMap
_, ([CostCentre], [CostCentreStack])
_) <-
Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreExpr
-> IO (StgRhs, InfoTableProvMap, ([CostCentre], [CostCentreStack]))
myCoreToStgExpr (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
(HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
InteractiveContext
ictxt
(InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
ModLocation
iNTERACTIVELoc
CoreExpr
prepd_expr
; UnlinkedBCO
bcos <- HscEnv -> Module -> Mult -> StgRhs -> IO UnlinkedBCO
stgExprToBCOs HscEnv
hsc_env
(InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
(CoreExpr -> Mult
exprType CoreExpr
prepd_expr)
StgRhs
stg_expr
; Interp -> HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
loadExpr (HscEnv -> Interp
hscInterp HscEnv
hsc_env) HscEnv
hsc_env SrcSpan
srcspan UnlinkedBCO
bcos }
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env = do
ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet Logger
logger DynFlags
dflags (Bool
dump_if_trace Bool -> Bool -> Bool
|| Bool
dump_rn_stats)
String
"Interface statistics"
(ExternalPackageState -> SDoc
ifaceStats ExternalPackageState
eps)
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
dump_rn_stats :: Bool
dump_rn_stats = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_rn_stats DynFlags
dflags
dump_if_trace :: Bool
dump_if_trace = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_if_trace DynFlags
dflags
showModuleIndex :: (Int, Int) -> SDoc
showModuleIndex :: (Int, Int) -> SDoc
showModuleIndex (Int
i,Int
n) = String -> SDoc
text String
"[" SDoc -> SDoc -> SDoc
<> SDoc
pad SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" of " SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"] "
where
len :: a -> b
len a
x = Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Float -> Float -> Float
forall a. Floating a => a -> a -> a
logBase Float
10 (a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
xFloat -> Float -> Float
forall a. Num a => a -> a -> a
+Float
1) :: Float)
pad :: SDoc
pad = String -> SDoc
text (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int
forall b a. (Integral b, Integral a) => a -> b
len Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
forall b a. (Integral b, Integral a) => a -> b
len Int
i) Char
' ')