{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
module HscMain
(
newHscEnv
, Messager, batchMsg
, HscStatus (..)
, hscIncrementalCompile
, hscCompileCmmFile
, hscGenHardCode
, hscInteractive
, hscParse
, hscTypecheckRename
, hscDesugar
, makeSimpleDetails
, hscSimplify
, hscCheckSafe
, hscGetSafe
, hscParseIdentifier
, hscTcRcLookupName
, hscTcRnGetInfo
, hscIsGHCiMonad
, hscGetModuleInterface
, hscRnImportDecls
, hscTcRnLookupRdrName
, hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
, hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
, hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
, hscParseExpr
, hscCompileCoreExpr
, hscCompileCoreExpr'
, hscParse', hscSimplify', hscDesugar', tcRnModule'
, getHscEnv
, hscSimpleIface', hscNormalIface'
, oneShotMsg
, hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
, ioMsgMaybe
, showModuleIndex
, hscAddSptEntries
) where
import GhcPrelude
import Data.Data hiding (Fixity, TyCon)
import Data.Maybe ( fromJust )
import Id
import GHCi ( addSptEntry )
import GHCi.RemoteTypes ( ForeignHValue )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker
import CoreTidy ( tidyExpr )
import Type ( Type )
import Type ( Kind )
import CoreLint ( lintInteractiveExpr )
import VarEnv ( emptyTidyEnv )
import Panic
import ConLike
import Control.Concurrent
import Module
import Packages
import RdrName
import HsSyn
import HsDumpAst
import CoreSyn
import StringBuffer
import Parser
import Lexer
import SrcLoc
import TcRnDriver
import TcIface ( typecheckIface )
import TcRnMonad
import NameCache ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState )
import PrelInfo
import MkIface
import Desugar
import SimplCore
import TidyPgm
import CorePrep
import CoreToStg ( coreToStg )
import qualified StgCmm ( codeGen )
import StgSyn
import StgFVs ( annTopBindingsFreeVars )
import CostCentre
import ProfInit
import TyCon
import Name
import SimplStg ( stg2stg )
import Cmm
import CmmParse ( parseCmmFile )
import CmmBuildInfoTables
import CmmPipeline
import CmmInfo
import CodeOutput
import InstEnv
import FamInstEnv
import Fingerprint ( Fingerprint )
import Hooks
import TcEnv
import PrelNames
import Plugins
import DynamicLoading ( initializePlugins )
import DynFlags
import ErrUtils
import Platform ( platformOS, osSubsectionsViaSymbols )
import Outputable
import NameEnv
import HscStats ( ppSourceStats )
import HscTypes
import FastString
import UniqSupply
import Bag
import Exception
import qualified Stream
import Stream (Stream)
import Util
import Data.List
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
import System.Directory
import System.IO (fixIO)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Set (Set)
import HieAst ( mkHieFile )
import HieTypes ( getAsts, hie_asts )
import HieBin ( readHieFile, writeHieFile , hie_file_result)
import HieDebug ( diffFile, validateScopes )
#include "GhclibHsVersions.h"
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags = do
IORef ExternalPackageState
eps_var <- ExternalPackageState -> IO (IORef ExternalPackageState)
forall a. a -> IO (IORef a)
newIORef ExternalPackageState
initExternalPackageState
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'r'
IORef NameCache
nc_var <- NameCache -> IO (IORef NameCache)
forall a. a -> IO (IORef a)
newIORef (UniqSupply -> [Name] -> NameCache
initNameCache UniqSupply
us [Name]
knownKeyNames)
IORef (InstalledModuleEnv InstalledFindResult)
fc_var <- InstalledModuleEnv InstalledFindResult
-> IO (IORef (InstalledModuleEnv InstalledFindResult))
forall a. a -> IO (IORef a)
newIORef InstalledModuleEnv InstalledFindResult
forall a. InstalledModuleEnv a
emptyInstalledModuleEnv
MVar (Maybe IServ)
iserv_mvar <- Maybe IServ -> IO (MVar (Maybe IServ))
forall a. a -> IO (MVar a)
newMVar Maybe IServ
forall a. Maybe a
Nothing
HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv :: DynFlags
-> [Target]
-> ModuleGraph
-> InteractiveContext
-> HomePackageTable
-> IORef ExternalPackageState
-> IORef NameCache
-> IORef (InstalledModuleEnv InstalledFindResult)
-> Maybe (Module, IORef TypeEnv)
-> MVar (Maybe IServ)
-> HscEnv
HscEnv { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags
, 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_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
emptyHomePackageTable
, hsc_EPS :: IORef ExternalPackageState
hsc_EPS = IORef ExternalPackageState
eps_var
, hsc_NC :: IORef NameCache
hsc_NC = IORef NameCache
nc_var
, hsc_FC :: IORef (InstalledModuleEnv InstalledFindResult)
hsc_FC = IORef (InstalledModuleEnv InstalledFindResult)
fc_var
, hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
hsc_type_env_var = Maybe (Module, IORef TypeEnv)
forall a. Maybe a
Nothing
, hsc_iserv :: MVar (Maybe IServ)
hsc_iserv = MVar (Maybe IServ)
iserv_mvar
}
getWarnings :: Hsc WarningMessages
getWarnings :: Hsc WarningMessages
getWarnings = (HscEnv
-> WarningMessages -> IO (WarningMessages, WarningMessages))
-> Hsc WarningMessages
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv
-> WarningMessages -> IO (WarningMessages, WarningMessages))
-> Hsc WarningMessages)
-> (HscEnv
-> WarningMessages -> IO (WarningMessages, WarningMessages))
-> Hsc WarningMessages
forall a b. (a -> b) -> a -> b
$ \HscEnv
_ WarningMessages
w -> (WarningMessages, WarningMessages)
-> IO (WarningMessages, WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return (WarningMessages
w, WarningMessages
w)
clearWarnings :: Hsc ()
clearWarnings :: Hsc ()
clearWarnings = (HscEnv -> WarningMessages -> IO ((), WarningMessages)) -> Hsc ()
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO ((), WarningMessages)) -> Hsc ())
-> (HscEnv -> WarningMessages -> IO ((), WarningMessages))
-> Hsc ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
_ WarningMessages
_ -> ((), WarningMessages) -> IO ((), WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), WarningMessages
forall a. Bag a
emptyBag)
logWarnings :: WarningMessages -> Hsc ()
logWarnings :: WarningMessages -> Hsc ()
logWarnings WarningMessages
w = (HscEnv -> WarningMessages -> IO ((), WarningMessages)) -> Hsc ()
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO ((), WarningMessages)) -> Hsc ())
-> (HscEnv -> WarningMessages -> IO ((), WarningMessages))
-> Hsc ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
_ WarningMessages
w0 -> ((), WarningMessages) -> IO ((), WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), WarningMessages
w0 WarningMessages -> WarningMessages -> WarningMessages
forall a. Bag a -> Bag a -> Bag a
`unionBags` WarningMessages
w)
getHscEnv :: Hsc HscEnv
getHscEnv :: Hsc HscEnv
getHscEnv = (HscEnv -> WarningMessages -> IO (HscEnv, WarningMessages))
-> Hsc HscEnv
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO (HscEnv, WarningMessages))
-> Hsc HscEnv)
-> (HscEnv -> WarningMessages -> IO (HscEnv, WarningMessages))
-> Hsc HscEnv
forall a b. (a -> b) -> a -> b
$ \HscEnv
e WarningMessages
w -> (HscEnv, WarningMessages) -> IO (HscEnv, WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, WarningMessages
w)
handleWarnings :: Hsc ()
handleWarnings :: Hsc ()
handleWarnings = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
WarningMessages
w <- Hsc WarningMessages
getWarnings
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> WarningMessages -> IO ()
printOrThrowWarnings DynFlags
dflags WarningMessages
w
Hsc ()
clearWarnings
logWarningsReportErrors :: Messages -> Hsc ()
logWarningsReportErrors :: (WarningMessages, WarningMessages) -> Hsc ()
logWarningsReportErrors (WarningMessages
warns,WarningMessages
errs) = do
WarningMessages -> Hsc ()
logWarnings WarningMessages
warns
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
$ WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
errs) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ WarningMessages -> Hsc ()
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors WarningMessages
errs
ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
ioMsgMaybe :: IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe IO ((WarningMessages, WarningMessages), Maybe a)
ioA = do
((WarningMessages
warns,WarningMessages
errs), Maybe a
mb_r) <- IO ((WarningMessages, WarningMessages), Maybe a)
-> Hsc ((WarningMessages, WarningMessages), Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ((WarningMessages, WarningMessages), Maybe a)
ioA
WarningMessages -> Hsc ()
logWarnings WarningMessages
warns
case Maybe a
mb_r of
Maybe a
Nothing -> WarningMessages -> Hsc a
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors WarningMessages
errs
Just a
r -> ASSERT( isEmptyBag errs ) return r
ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' :: IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' IO ((WarningMessages, WarningMessages), Maybe a)
ioA = do
((WarningMessages
warns,WarningMessages
_errs), Maybe a
mb_r) <- IO ((WarningMessages, WarningMessages), Maybe a)
-> Hsc ((WarningMessages, WarningMessages), Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((WarningMessages, WarningMessages), Maybe a)
-> Hsc ((WarningMessages, WarningMessages), Maybe a))
-> IO ((WarningMessages, WarningMessages), Maybe a)
-> Hsc ((WarningMessages, WarningMessages), Maybe a)
forall a b. (a -> b) -> a -> b
$ IO ((WarningMessages, WarningMessages), Maybe a)
ioA
WarningMessages -> Hsc ()
logWarnings WarningMessages
warns
Maybe a -> Hsc (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mb_r
hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
hscTcRnLookupRdrName HscEnv
hsc_env0 Located 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 ((WarningMessages, WarningMessages), Maybe [Name]) -> Hsc [Name]
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe [Name])
-> Hsc [Name])
-> IO ((WarningMessages, WarningMessages), Maybe [Name])
-> Hsc [Name]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Located RdrName
-> IO ((WarningMessages, WarningMessages), Maybe [Name])
tcRnLookupRdrName HscEnv
hsc_env Located 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 ((WarningMessages, WarningMessages), Maybe TyThing)
-> Hsc (Maybe TyThing)
forall a.
IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' (IO ((WarningMessages, WarningMessages), Maybe TyThing)
-> Hsc (Maybe TyThing))
-> IO ((WarningMessages, WarningMessages), Maybe TyThing)
-> Hsc (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name -> IO ((WarningMessages, WarningMessages), 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
((WarningMessages, WarningMessages),
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a.
IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' (IO
((WarningMessages, WarningMessages),
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> IO
((WarningMessages, WarningMessages),
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name
-> IO
((WarningMessages, WarningMessages),
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 ((WarningMessages, WarningMessages), Maybe Name) -> Hsc Name
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe Name) -> Hsc Name)
-> IO ((WarningMessages, WarningMessages), Maybe Name) -> Hsc Name
forall a b. (a -> b) -> a -> b
$ HscEnv
-> String -> IO ((WarningMessages, WarningMessages), 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 ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc ModIface
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc ModIface)
-> IO ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc ModIface
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> IO ((WarningMessages, WarningMessages), 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 ((WarningMessages, WarningMessages), Maybe GlobalRdrEnv)
-> Hsc GlobalRdrEnv
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe GlobalRdrEnv)
-> Hsc GlobalRdrEnv)
-> IO ((WarningMessages, WarningMessages), Maybe GlobalRdrEnv)
-> Hsc GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LImportDecl GhcPs]
-> IO ((WarningMessages, WarningMessages), 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 = {-# SCC "Parser" #-}
Hsc DynFlags
-> SDoc
-> (HsParsedModule -> ())
-> Hsc HsParsedModule
-> Hsc HsParsedModule
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(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
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
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 GhcPs))
parseMod | HscSource
HsigFile HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
= P (Located (HsModule GhcPs))
parseSignature
| Bool
otherwise = P (Located (HsModule GhcPs))
parseModule
case P (Located (HsModule GhcPs))
-> PState -> ParseResult (Located (HsModule GhcPs))
forall a. P a -> PState -> ParseResult a
unP P (Located (HsModule GhcPs))
parseMod (DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState DynFlags
dflags StringBuffer
buf RealSrcLoc
loc) of
PFailed DynFlags -> (WarningMessages, WarningMessages)
warnFn SrcSpan
span SDoc
err -> do
(WarningMessages, WarningMessages) -> Hsc ()
logWarningsReportErrors (DynFlags -> (WarningMessages, WarningMessages)
warnFn DynFlags
dflags)
Hsc ()
handleWarnings
IO HsParsedModule -> Hsc HsParsedModule
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HsParsedModule -> Hsc HsParsedModule)
-> IO HsParsedModule -> Hsc HsParsedModule
forall a b. (a -> b) -> a -> b
$ ErrMsg -> IO HsParsedModule
forall (m :: * -> *) ab. MonadIO m => ErrMsg -> m ab
throwOneError (DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
span SDoc
err)
POk PState
pst Located (HsModule GhcPs)
rdr_module -> do
(WarningMessages, WarningMessages) -> Hsc ()
logWarningsReportErrors (PState -> DynFlags -> (WarningMessages, WarningMessages)
getMessages PState
pst 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
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_parsed String
"Parser" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
Located (HsModule GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (HsModule GhcPs)
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
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_parsed_ast String
"Parser AST" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
BlankSrcSpan -> Located (HsModule GhcPs) -> SDoc
forall a. Data a => BlankSrcSpan -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan Located (HsModule GhcPs)
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
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_source_stats String
"Source Statistics" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
Bool -> Located (HsModule GhcPs) -> SDoc
ppSourceStats Bool
False Located (HsModule GhcPs)
rdr_module
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 GhcPs) -> [String] -> ApiAnns -> HsParsedModule
HsParsedModule {
hpm_module :: Located (HsModule GhcPs)
hpm_module = Located (HsModule GhcPs)
rdr_module,
hpm_src_files :: [String]
hpm_src_files = [String]
srcs2,
hpm_annotations :: ApiAnns
hpm_annotations
= (([SrcSpan] -> [SrcSpan] -> [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
(++) ([(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall a b. (a -> b) -> a -> b
$ PState -> [(ApiAnnKey, [SrcSpan])]
annotations PState
pst,
[(SrcSpan, [Located AnnotationComment])]
-> Map SrcSpan [Located AnnotationComment]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(SrcSpan, [Located AnnotationComment])]
-> Map SrcSpan [Located AnnotationComment])
-> [(SrcSpan, [Located AnnotationComment])]
-> Map SrcSpan [Located AnnotationComment]
forall a b. (a -> b) -> a -> b
$ ((SrcSpan
noSrcSpan,PState -> [Located AnnotationComment]
comment_q PState
pst)
(SrcSpan, [Located AnnotationComment])
-> [(SrcSpan, [Located AnnotationComment])]
-> [(SrcSpan, [Located AnnotationComment])]
forall a. a -> [a] -> [a]
:(PState -> [(SrcSpan, [Located AnnotationComment])]
annotations_comments PState
pst)))
}
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
DynFlags
-> (Plugin -> [String] -> HsParsedModule -> Hsc HsParsedModule)
-> HsParsedModule
-> Hsc HsParsedModule
forall (m :: * -> *) a.
Monad m =>
DynFlags -> PluginOperation m a -> a -> m a
withPlugins DynFlags
dflags 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
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_rn_ast String
"Renamer" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
BlankSrcSpan -> RenamedStuff -> SDoc
forall a. Data a => BlankSrcSpan -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan 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 (RenamedStuff -> RenamedSource
forall a. HasCallStack => Maybe a -> a
fromJust 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
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 -> WarningMessages -> IO (HscEnv, WarningMessages))
-> Hsc HscEnv
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO (HscEnv, WarningMessages))
-> Hsc HscEnv)
-> (HscEnv -> WarningMessages -> IO (HscEnv, WarningMessages))
-> Hsc HscEnv
forall a b. (a -> b) -> a -> b
$ \HscEnv
e WarningMessages
w -> (HscEnv, WarningMessages) -> IO (HscEnv, WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, WarningMessages
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 Map FastString (HieAST Int) -> [SDoc]
forall a. Map FastString (HieAST a) -> [SDoc]
validateScopes (Map FastString (HieAST Int) -> [SDoc])
-> Map FastString (HieAST Int) -> [SDoc]
forall a b. (a -> b) -> a -> b
$ HieASTs Int -> Map FastString (HieAST Int)
forall a. HieASTs a -> Map FastString (HieAST a)
getAsts (HieASTs Int -> Map FastString (HieAST Int))
-> HieASTs Int -> Map FastString (HieAST Int)
forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs Int
hie_asts HieFile
hieFile of
[] -> DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Got valid scopes"
[SDoc]
xs -> do
DynFlags -> SDoc -> IO ()
putMsg 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_ (DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags) [SDoc]
xs
NameCache
nc <- IORef NameCache -> IO NameCache
forall a. IORef a -> IO a
readIORef (IORef NameCache -> IO NameCache)
-> IORef NameCache -> IO NameCache
forall a b. (a -> b) -> a -> b
$ HscEnv -> IORef NameCache
hsc_NC HscEnv
hs_env
(HieFileResult
file', NameCache
_) <- NameCache -> String -> IO (HieFileResult, NameCache)
readHieFile NameCache
nc String
out_file
case Diff HieFile
diffFile HieFile
hieFile (HieFileResult -> HieFile
hie_file_result HieFileResult
file') of
[] ->
DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Got no roundtrip errors"
[SDoc]
xs -> do
DynFlags -> SDoc -> IO ()
putMsg 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_ (DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags) [SDoc]
xs
RenamedStuff -> Hsc RenamedStuff
forall (m :: * -> *) a. Monad m => a -> m a
return 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, RenamedStuff) -> IO (TcGblEnv, RenamedStuff)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (TcGblEnv, RenamedStuff) -> IO (TcGblEnv, RenamedStuff))
-> Hsc (TcGblEnv, RenamedStuff) -> IO (TcGblEnv, RenamedStuff)
forall a b. (a -> b) -> a -> b
$ do
TcGblEnv
tc_result <- Bool -> ModSummary -> Maybe HsParsedModule -> Hsc TcGblEnv
hsc_typecheck Bool
True ModSummary
mod_summary (HsParsedModule -> Maybe HsParsedModule
forall a. a -> Maybe a
Just HsParsedModule
rdr_module)
RenamedStuff
rn_info <- ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff ModSummary
mod_summary TcGblEnv
tc_result
(TcGblEnv, RenamedStuff) -> Hsc (TcGblEnv, RenamedStuff)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tc_result, RenamedStuff
rn_info)
hscTypecheck :: Bool
-> ModSummary -> Maybe HsParsedModule
-> Hsc TcGblEnv
hscTypecheck :: Bool -> ModSummary -> Maybe HsParsedModule -> Hsc TcGblEnv
hscTypecheck Bool
keep_rn ModSummary
mod_summary Maybe HsParsedModule
mb_rdr_module = do
TcGblEnv
tc_result <- Bool -> ModSummary -> Maybe HsParsedModule -> Hsc TcGblEnv
hsc_typecheck Bool
keep_rn ModSummary
mod_summary Maybe HsParsedModule
mb_rdr_module
RenamedStuff
_ <- ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff ModSummary
mod_summary TcGblEnv
tc_result
TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tc_result
hsc_typecheck :: Bool
-> ModSummary -> Maybe HsParsedModule
-> Hsc TcGblEnv
hsc_typecheck :: Bool -> ModSummary -> Maybe HsParsedModule -> Hsc TcGblEnv
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
outer_mod :: Module
outer_mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
mod_name :: ModuleName
mod_name = Module -> ModuleName
moduleName Module
outer_mod
outer_mod' :: Module
outer_mod' = UnitId -> ModuleName -> Module
mkModule (DynFlags -> UnitId
thisPackage DynFlags
dflags) ModuleName
mod_name
inner_mod :: Module
inner_mod = DynFlags -> ModuleName -> Module
canonicalizeHomeModule DynFlags
dflags 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
MASSERT( moduleUnitId outer_mod == thisPackage dflags )
if HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& Bool -> Bool
not (Module -> Bool
isHoleModule Module
inner_mod)
then IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv)
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> RealSrcSpan
-> IO ((WarningMessages, WarningMessages), 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, Bool
_, ModDetails
_) <- IO (ModIface, Bool, ModDetails) -> Hsc (ModIface, Bool, ModDetails)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Bool, ModDetails)
-> Hsc (ModIface, Bool, ModDetails))
-> IO (ModIface, Bool, ModDetails)
-> Hsc (ModIface, Bool, ModDetails)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcGblEnv -> Maybe Fingerprint -> IO (ModIface, Bool, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result0 Maybe Fingerprint
forall a. Maybe a
Nothing
IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv)
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$
HscEnv
-> HsParsedModule
-> TcGblEnv
-> ModIface
-> IO ((WarningMessages, WarningMessages), 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
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
TcGblEnv
tcg_res <- {-# SCC "Typecheck-Rename" #-}
IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv)
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$
HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
tcRnModule HscEnv
hsc_env ModSummary
sum
Bool
save_rn_syntax HsParsedModule
mod
(Bool
tcSafeOK, WarningMessages
whyUnsafe) <- IO (Bool, WarningMessages) -> Hsc (Bool, WarningMessages)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Bool, WarningMessages) -> Hsc (Bool, WarningMessages))
-> IO (Bool, WarningMessages) -> Hsc (Bool, WarningMessages)
forall a b. (a -> b) -> a -> b
$ IORef (Bool, WarningMessages) -> IO (Bool, WarningMessages)
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef (Bool, WarningMessages)
tcg_safeInfer TcGblEnv
tcg_res)
let allSafeOK :: Bool
allSafeOK = DynFlags -> Bool
safeInferred DynFlags
dflags Bool -> Bool -> Bool
&& Bool
tcSafeOK
TcGblEnv
res <- 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 -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_res WarningMessages
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
$ (Bool, WarningMessages) -> Bool
forall a b. (a, b) -> a
fst ((Bool, WarningMessages) -> Bool)
-> IO (Bool, WarningMessages) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Bool, WarningMessages) -> IO (Bool, WarningMessages)
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef (Bool, WarningMessages)
tcg_safeInfer 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
$ do
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 -> (WarningMessages -> Hsc ()
logWarnings (WarningMessages -> Hsc ()) -> WarningMessages -> Hsc ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$
WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnSafe) (ErrMsg -> ErrMsg) -> ErrMsg -> ErrMsg
forall a b. (a -> b) -> a -> b
$
DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainWarnMsg DynFlags
dflags (DynFlags -> SrcSpan
warnSafeOnLoc DynFlags
dflags) (SDoc -> ErrMsg) -> SDoc -> ErrMsg
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 ->
(WarningMessages -> Hsc ()
logWarnings (WarningMessages -> Hsc ()) -> WarningMessages -> Hsc ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$
WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnTrustworthySafe) (ErrMsg -> ErrMsg) -> ErrMsg -> ErrMsg
forall a b. (a -> b) -> a -> b
$
DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainWarnMsg DynFlags
dflags (DynFlags -> SrcSpan
trustworthyOnLoc DynFlags
dflags) (SDoc -> ErrMsg) -> SDoc -> ErrMsg
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'
TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
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
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!"
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
ModGuts
r <- IO ((WarningMessages, WarningMessages), Maybe ModGuts)
-> Hsc ModGuts
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe ModGuts)
-> Hsc ModGuts)
-> IO ((WarningMessages, WarningMessages), Maybe ModGuts)
-> Hsc ModGuts
forall a b. (a -> b) -> a -> b
$
{-# SCC "deSugar" #-}
HscEnv
-> ModLocation
-> TcGblEnv
-> IO ((WarningMessages, WarningMessages), Maybe ModGuts)
deSugar HscEnv
hsc_env ModLocation
mod_location TcGblEnv
tc_result
Hsc ()
handleWarnings
ModGuts -> Hsc ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
r
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 -> ModSummary -> IO ()
hscIncrementalFrontend :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
hscIncrementalFrontend :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
hscIncrementalFrontend
Bool
always_do_basic_recompilation_check Maybe TcGblEnv
m_tc_result
Maybe Messager
mHscMessage ModSummary
mod_summary SourceModified
source_modified Maybe ModIface
mb_old_iface (Int, Int)
mod_index
= do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
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 ModSummary
mod_summary
Maybe Messager
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
skip :: a -> m (Either a b)
skip a
iface = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ RecompileRequired -> IO ()
msg RecompileRequired
UpToDate
Either a b -> m (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a b -> m (Either a b)) -> Either a b -> m (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
iface
compile :: b -> RecompileRequired -> Hsc (Either a (FrontendResult, b))
compile b
mb_old_hash RecompileRequired
reason = do
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ RecompileRequired -> IO ()
msg RecompileRequired
reason
FrontendResult
result <- ModSummary -> Hsc FrontendResult
genericHscFrontend ModSummary
mod_summary
Either a (FrontendResult, b) -> Hsc (Either a (FrontendResult, b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (FrontendResult, b)
-> Hsc (Either a (FrontendResult, b)))
-> Either a (FrontendResult, b)
-> Hsc (Either a (FrontendResult, b))
forall a b. (a -> b) -> a -> b
$ (FrontendResult, b) -> Either a (FrontendResult, b)
forall a b. b -> Either a b
Right (FrontendResult
result, b
mb_old_hash)
stable :: Bool
stable = case SourceModified
source_modified of
SourceModified
SourceUnmodifiedAndStable -> Bool
True
SourceModified
_ -> Bool
False
case Maybe TcGblEnv
m_tc_result of
Just TcGblEnv
tc_result
| Bool -> Bool
not Bool
always_do_basic_recompilation_check ->
Either ModIface (FrontendResult, Maybe Fingerprint)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ModIface (FrontendResult, Maybe Fingerprint)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint)))
-> Either ModIface (FrontendResult, Maybe Fingerprint)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall a b. (a -> b) -> a -> b
$ (FrontendResult, Maybe Fingerprint)
-> Either ModIface (FrontendResult, Maybe Fingerprint)
forall a b. b -> Either a b
Right (TcGblEnv -> FrontendResult
FrontendTypecheck TcGblEnv
tc_result, Maybe Fingerprint
forall a. Maybe a
Nothing)
Maybe TcGblEnv
_ -> do
(RecompileRequired
recomp_reqd, Maybe ModIface
mb_checked_iface)
<- {-# SCC "checkOldIface" #-}
IO (RecompileRequired, Maybe ModIface)
-> Hsc (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RecompileRequired, Maybe ModIface)
-> Hsc (RecompileRequired, Maybe ModIface))
-> IO (RecompileRequired, Maybe ModIface)
-> Hsc (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 ModIface -> Fingerprint
mi_iface_hash Maybe ModIface
mb_checked_iface
case Maybe ModIface
mb_checked_iface of
Just ModIface
iface | Bool -> Bool
not (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp_reqd) ->
case Maybe TcGblEnv
m_tc_result of
Maybe TcGblEnv
Nothing
| ModIface -> Bool
mi_used_th ModIface
iface Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
stable ->
Maybe Fingerprint
-> RecompileRequired
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall b a.
b -> RecompileRequired -> Hsc (Either a (FrontendResult, b))
compile Maybe Fingerprint
mb_old_hash (String -> RecompileRequired
RecompBecause String
"TH")
Maybe TcGblEnv
_ ->
ModIface
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall (m :: * -> *) a b. MonadIO m => a -> m (Either a b)
skip ModIface
iface
Maybe ModIface
_ ->
case Maybe TcGblEnv
m_tc_result of
Maybe TcGblEnv
Nothing -> Maybe Fingerprint
-> RecompileRequired
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall b a.
b -> RecompileRequired -> Hsc (Either a (FrontendResult, b))
compile Maybe Fingerprint
mb_old_hash RecompileRequired
recomp_reqd
Just TcGblEnv
tc_result ->
Either ModIface (FrontendResult, Maybe Fingerprint)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ModIface (FrontendResult, Maybe Fingerprint)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint)))
-> Either ModIface (FrontendResult, Maybe Fingerprint)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall a b. (a -> b) -> a -> b
$ (FrontendResult, Maybe Fingerprint)
-> Either ModIface (FrontendResult, Maybe Fingerprint)
forall a b. b -> Either a b
Right (TcGblEnv -> FrontendResult
FrontendTypecheck TcGblEnv
tc_result, Maybe Fingerprint
mb_old_hash)
genericHscFrontend :: ModSummary -> Hsc FrontendResult
genericHscFrontend :: ModSummary -> Hsc FrontendResult
genericHscFrontend ModSummary
mod_summary =
(Hooks -> Maybe (ModSummary -> Hsc FrontendResult))
-> (ModSummary -> Hsc FrontendResult)
-> Hsc (ModSummary -> Hsc FrontendResult)
forall (f :: * -> *) a.
(Functor f, HasDynFlags f) =>
(Hooks -> Maybe a) -> a -> f a
getHooked Hooks -> Maybe (ModSummary -> Hsc FrontendResult)
hscFrontendHook ModSummary -> Hsc FrontendResult
genericHscFrontend' Hsc (ModSummary -> Hsc FrontendResult)
-> ((ModSummary -> Hsc FrontendResult) -> Hsc FrontendResult)
-> Hsc FrontendResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((ModSummary -> Hsc FrontendResult)
-> ModSummary -> Hsc FrontendResult
forall a b. (a -> b) -> a -> b
$ ModSummary
mod_summary)
genericHscFrontend' :: ModSummary -> Hsc FrontendResult
genericHscFrontend' :: ModSummary -> Hsc FrontendResult
genericHscFrontend' ModSummary
mod_summary
= TcGblEnv -> FrontendResult
FrontendTypecheck (TcGblEnv -> FrontendResult) -> Hsc TcGblEnv -> Hsc FrontendResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ModSummary -> Hsc TcGblEnv
hscFileFrontEnd ModSummary
mod_summary
hscIncrementalCompile :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
-> IO (HscStatus, HomeModInfo)
hscIncrementalCompile :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO (HscStatus, HomeModInfo)
hscIncrementalCompile Bool
always_do_basic_recompilation_check Maybe TcGblEnv
m_tc_result
Maybe Messager
mHscMessage HscEnv
hsc_env' ModSummary
mod_summary SourceModified
source_modified Maybe ModIface
mb_old_iface (Int, Int)
mod_index
= do
DynFlags
dflags <- HscEnv -> DynFlags -> IO DynFlags
initializePlugins HscEnv
hsc_env' (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env')
let hsc_env'' :: HscEnv
hsc_env'' = HscEnv
hsc_env' { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags }
IORef TypeEnv
type_env_var <- TypeEnv -> IO (IORef TypeEnv)
forall a. a -> IO (IORef a)
newIORef TypeEnv
forall a. NameEnv a
emptyNameEnv
let mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
hsc_env :: HscEnv
hsc_env | GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env''))
= HscEnv
hsc_env'' { hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
hsc_type_env_var = (Module, IORef TypeEnv) -> Maybe (Module, IORef TypeEnv)
forall a. a -> Maybe a
Just (Module
mod, IORef TypeEnv
type_env_var) }
| Bool
otherwise
= HscEnv
hsc_env''
HscEnv
-> Hsc (HscStatus, HomeModInfo) -> IO (HscStatus, HomeModInfo)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (HscStatus, HomeModInfo) -> IO (HscStatus, HomeModInfo))
-> Hsc (HscStatus, HomeModInfo) -> IO (HscStatus, HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
Either ModIface (FrontendResult, Maybe Fingerprint)
e <- Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
hscIncrementalFrontend Bool
always_do_basic_recompilation_check Maybe TcGblEnv
m_tc_result Maybe Messager
mHscMessage
ModSummary
mod_summary SourceModified
source_modified Maybe ModIface
mb_old_iface (Int, Int)
mod_index
case Either ModIface (FrontendResult, Maybe Fingerprint)
e of
Left ModIface
iface -> do
HomeModInfo
hmi <- IO HomeModInfo -> Hsc HomeModInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HomeModInfo -> Hsc HomeModInfo)
-> ((HomeModInfo -> IO HomeModInfo) -> IO HomeModInfo)
-> (HomeModInfo -> IO HomeModInfo)
-> Hsc HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HomeModInfo -> IO HomeModInfo) -> IO HomeModInfo
forall a. (a -> IO a) -> IO a
fixIO ((HomeModInfo -> IO HomeModInfo) -> Hsc HomeModInfo)
-> (HomeModInfo -> IO HomeModInfo) -> Hsc HomeModInfo
forall a b. (a -> b) -> a -> b
$ \HomeModInfo
hmi' -> do
let hsc_env' :: HscEnv
hsc_env' =
HscEnv
hsc_env {
hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
(ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary) HomeModInfo
hmi'
}
ModDetails
details <- HscEnv -> ModIface -> IO ModDetails
genModDetails HscEnv
hsc_env' ModIface
iface
HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo :: ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo{
hm_details :: ModDetails
hm_details = ModDetails
details,
hm_iface :: ModIface
hm_iface = ModIface
iface,
hm_linkable :: Maybe Linkable
hm_linkable = Maybe Linkable
forall a. Maybe a
Nothing }
(HscStatus, HomeModInfo) -> Hsc (HscStatus, HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscStatus
HscUpToDate, HomeModInfo
hmi)
Right (FrontendTypecheck TcGblEnv
tc_result, Maybe Fingerprint
mb_old_hash) ->
ModSummary
-> TcGblEnv -> Maybe Fingerprint -> Hsc (HscStatus, HomeModInfo)
finish ModSummary
mod_summary TcGblEnv
tc_result Maybe Fingerprint
mb_old_hash
finish :: ModSummary
-> TcGblEnv
-> Maybe Fingerprint
-> Hsc (HscStatus, HomeModInfo)
finish :: ModSummary
-> TcGblEnv -> Maybe Fingerprint -> Hsc (HscStatus, HomeModInfo)
finish ModSummary
summary TcGblEnv
tc_result Maybe Fingerprint
mb_old_hash = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
target :: HscTarget
target = DynFlags -> HscTarget
hscTarget DynFlags
dflags
hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
summary
should_desugar :: Bool
should_desugar =
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
mk_simple_iface :: Hsc (ModIface, Bool, ModDetails, HscStatus)
mk_simple_iface = do
let hsc_status :: HscStatus
hsc_status =
case (HscTarget
target, HscSource
hsc_src) of
(HscTarget
HscNothing, HscSource
_) -> HscStatus
HscNotGeneratingCode
(HscTarget
_, HscSource
HsBootFile) -> HscStatus
HscUpdateBoot
(HscTarget
_, HscSource
HsigFile) -> HscStatus
HscUpdateSig
(HscTarget, HscSource)
_ -> String -> HscStatus
forall a. String -> a
panic String
"finish"
(ModIface
iface, Bool
no_change, ModDetails
details) <- IO (ModIface, Bool, ModDetails) -> Hsc (ModIface, Bool, ModDetails)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Bool, ModDetails)
-> Hsc (ModIface, Bool, ModDetails))
-> IO (ModIface, Bool, ModDetails)
-> Hsc (ModIface, Bool, ModDetails)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> TcGblEnv -> Maybe Fingerprint -> IO (ModIface, Bool, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result Maybe Fingerprint
mb_old_hash
(ModIface, Bool, ModDetails, HscStatus)
-> Hsc (ModIface, Bool, ModDetails, HscStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
iface, Bool
no_change, ModDetails
details, HscStatus
hsc_status)
(ModIface
iface, Bool
no_change, ModDetails
details, HscStatus
hsc_status) <-
if Bool
should_desugar
then do
ModGuts
desugared_guts0 <- ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' (ModSummary -> ModLocation
ms_location ModSummary
summary) TcGblEnv
tc_result
if HscTarget
target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscNothing
then Hsc (ModIface, Bool, ModDetails, HscStatus)
mk_simple_iface
else 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
desugared_guts <- [String] -> ModGuts -> Hsc ModGuts
hscSimplify' [String]
plugins ModGuts
desugared_guts0
(ModIface
iface, Bool
no_change, ModDetails
details, CgGuts
cgguts) <-
IO (ModIface, Bool, ModDetails, CgGuts)
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Bool, ModDetails, CgGuts)
-> Hsc (ModIface, Bool, ModDetails, CgGuts))
-> IO (ModIface, Bool, ModDetails, CgGuts)
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModGuts
-> Maybe Fingerprint
-> IO (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface HscEnv
hsc_env ModGuts
desugared_guts Maybe Fingerprint
mb_old_hash
(ModIface, Bool, ModDetails, HscStatus)
-> Hsc (ModIface, Bool, ModDetails, HscStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
iface, Bool
no_change, ModDetails
details, CgGuts -> ModSummary -> HscStatus
HscRecomp CgGuts
cgguts ModSummary
summary)
else Hsc (ModIface, Bool, ModDetails, HscStatus)
mk_simple_iface
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscMaybeWriteIface DynFlags
dflags ModIface
iface Bool
no_change ModSummary
summary
(HscStatus, HomeModInfo) -> Hsc (HscStatus, HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return
( HscStatus
hsc_status
, HomeModInfo :: ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo
{hm_details :: ModDetails
hm_details = ModDetails
details, hm_iface :: ModIface
hm_iface = ModIface
iface, hm_linkable :: Maybe Linkable
hm_linkable = Maybe Linkable
forall a. Maybe a
Nothing})
hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscMaybeWriteIface DynFlags
dflags ModIface
iface Bool
no_change ModSummary
summary =
let force_write_interface :: Bool
force_write_interface = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
write_interface :: Bool
write_interface = case DynFlags -> HscTarget
hscTarget DynFlags
dflags of
HscTarget
HscNothing -> Bool
False
HscTarget
HscInterpreted -> Bool
False
HscTarget
_ -> Bool
True
in 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
$
DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscWriteIface DynFlags
dflags ModIface
iface Bool
no_change ModSummary
summary
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 ->
DynFlags -> String -> IO ()
compilationProgressMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"compilation IS NOT required"
RecompileRequired
_ ->
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
batchMsg :: Messager
batchMsg :: Messager
batchMsg HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
recomp ModSummary
mod_summary =
case RecompileRequired
recomp of
RecompileRequired
MustCompile -> String -> String -> IO ()
showMsg String
"Compiling " String
""
RecompileRequired
UpToDate
| DynFlags -> Int
verbosity (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 -> String -> String -> IO ()
showMsg String
"Skipping " String
""
| Bool
otherwise -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
RecompBecause String
reason -> String -> String -> IO ()
showMsg String
"Compiling " (String
" [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]")
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
showMsg :: String -> String -> IO ()
showMsg String
msg String
reason =
DynFlags -> String -> IO ()
compilationProgressMsg DynFlags
dflags (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
((Int, Int) -> String
showModuleIndex (Int, Int)
mod_index String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> HscTarget -> Bool -> ModSummary -> String
showModMsg DynFlags
dflags (DynFlags -> HscTarget
hscTarget DynFlags
dflags)
(RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp) ModSummary
mod_summary)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason
hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd ModSummary
mod_summary = Bool -> ModSummary -> Maybe HsParsedModule -> Hsc TcGblEnv
hscTypecheck Bool
False ModSummary
mod_summary Maybe HsParsedModule
forall a. Maybe a
Nothing
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' = do
case DynFlags -> Bool
safeLanguageOn DynFlags
dflags of
Bool
True -> do
WarningMessages -> Hsc ()
logWarnings (WarningMessages -> Hsc ()) -> WarningMessages -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [GenLocated SrcSpan (RuleDecl GhcTc)] -> WarningMessages
forall pass.
DynFlags -> [GenLocated SrcSpan (RuleDecl pass)] -> WarningMessages
warns DynFlags
dflags (TcGblEnv -> [GenLocated SrcSpan (RuleDecl GhcTc)]
tcg_rules TcGblEnv
tcg_env')
TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env' { tcg_rules :: [GenLocated SrcSpan (RuleDecl GhcTc)]
tcg_rules = [] }
Bool
False
| DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not ([GenLocated SrcSpan (RuleDecl GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GenLocated SrcSpan (RuleDecl GhcTc)] -> Bool)
-> [GenLocated SrcSpan (RuleDecl GhcTc)] -> Bool
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [GenLocated SrcSpan (RuleDecl GhcTc)]
tcg_rules TcGblEnv
tcg_env')
-> TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env' (WarningMessages -> Hsc TcGblEnv)
-> WarningMessages -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [GenLocated SrcSpan (RuleDecl GhcTc)] -> WarningMessages
forall pass.
DynFlags -> [GenLocated SrcSpan (RuleDecl pass)] -> WarningMessages
warns DynFlags
dflags (TcGblEnv -> [GenLocated SrcSpan (RuleDecl 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 SrcSpan (RuleDecl pass)] -> WarningMessages
warns DynFlags
dflags [GenLocated SrcSpan (RuleDecl pass)]
rules = [ErrMsg] -> WarningMessages
forall a. [a] -> Bag a
listToBag ([ErrMsg] -> WarningMessages) -> [ErrMsg] -> WarningMessages
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpan (RuleDecl pass) -> ErrMsg)
-> [GenLocated SrcSpan (RuleDecl pass)] -> [ErrMsg]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> GenLocated SrcSpan (RuleDecl pass) -> ErrMsg
forall pass.
DynFlags -> GenLocated SrcSpan (RuleDecl pass) -> ErrMsg
warnRules DynFlags
dflags) [GenLocated SrcSpan (RuleDecl pass)]
rules
warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl pass) -> ErrMsg
warnRules DynFlags
dflags (L SrcSpan
loc (HsRule { rd_name :: forall pass. RuleDecl pass -> Located (SourceText, FastString)
rd_name = Located (SourceText, FastString)
n })) =
DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainWarnMsg DynFlags
dflags SrcSpan
loc (SDoc -> ErrMsg) -> SDoc -> ErrMsg
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
$ Located (SourceText, FastString)
-> SrcSpanLess (Located (SourceText, FastString))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (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"
warnRules DynFlags
_ (L SrcSpan
_ (XRuleDecl XXRuleDecl pass
_)) = String -> ErrMsg
forall a. String -> a
panic String
"hscCheckSafeImports"
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
WarningMessages
oldErrs <- Hsc WarningMessages
getWarnings
Hsc ()
clearWarnings
Set InstalledUnitId
safePkgs <- [InstalledUnitId] -> Set InstalledUnitId
forall a. Ord a => [a] -> Set a
S.fromList ([InstalledUnitId] -> Set InstalledUnitId)
-> Hsc [InstalledUnitId] -> Hsc (Set InstalledUnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Module, SrcSpan, Bool) -> Hsc (Maybe InstalledUnitId))
-> [(Module, SrcSpan, Bool)] -> Hsc [InstalledUnitId]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Module, SrcSpan, Bool) -> Hsc (Maybe InstalledUnitId)
forall a. (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
checkSafe [(Module, SrcSpan, Bool)]
safeImps
WarningMessages
safeErrs <- Hsc WarningMessages
getWarnings
Hsc ()
clearWarnings
(WarningMessages
infErrs, Set InstalledUnitId
infPkgs) <- case (DynFlags -> Bool
safeInferOn DynFlags
dflags) of
Bool
False -> (WarningMessages, Set InstalledUnitId)
-> Hsc (WarningMessages, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (WarningMessages
forall a. Bag a
emptyBag, Set InstalledUnitId
forall a. Set a
S.empty)
Bool
True -> do Set InstalledUnitId
infPkgs <- [InstalledUnitId] -> Set InstalledUnitId
forall a. Ord a => [a] -> Set a
S.fromList ([InstalledUnitId] -> Set InstalledUnitId)
-> Hsc [InstalledUnitId] -> Hsc (Set InstalledUnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Module, SrcSpan, Bool) -> Hsc (Maybe InstalledUnitId))
-> [(Module, SrcSpan, Bool)] -> Hsc [InstalledUnitId]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Module, SrcSpan, Bool) -> Hsc (Maybe InstalledUnitId)
forall a. (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
checkSafe [(Module, SrcSpan, Bool)]
regImps
WarningMessages
infErrs <- Hsc WarningMessages
getWarnings
Hsc ()
clearWarnings
(WarningMessages, Set InstalledUnitId)
-> Hsc (WarningMessages, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (WarningMessages
infErrs, Set InstalledUnitId
infPkgs)
WarningMessages -> Hsc ()
logWarnings WarningMessages
oldErrs
case (WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
safeErrs) of
Bool
False -> IO TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TcGblEnv -> Hsc TcGblEnv)
-> (WarningMessages -> IO TcGblEnv)
-> WarningMessages
-> Hsc TcGblEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> IO TcGblEnv
forall e a. Exception e => e -> IO a
throwIO (SourceError -> IO TcGblEnv)
-> (WarningMessages -> SourceError)
-> WarningMessages
-> IO TcGblEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningMessages -> SourceError
mkSrcErr (WarningMessages -> Hsc TcGblEnv)
-> WarningMessages -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ WarningMessages
safeErrs
Bool
True -> do
let infPassed :: Bool
infPassed = WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
infErrs
TcGblEnv
tcg_env' <- case (Bool -> Bool
not Bool
infPassed) of
Bool
True -> TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env WarningMessages
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 InstalledUnitId -> Hsc ()
checkPkgTrust Set InstalledUnitId
pkgReqs
let newTrust :: ImportAvails
newTrust = DynFlags
-> Set InstalledUnitId
-> Set InstalledUnitId
-> Bool
-> ImportAvails
pkgTrustReqs DynFlags
dflags Set InstalledUnitId
safePkgs Set InstalledUnitId
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 InstalledUnitId
pkgReqs = ImportAvails -> Set InstalledUnitId
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
"HscMain.condense: Pattern match failure!"
condense (Module
m, ImportedModsVal
x:[ImportedModsVal]
xs) = do ImportedModsVal
imv <- (ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal)
-> ImportedModsVal -> [ImportedModsVal] -> Hsc ImportedModsVal
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m a) -> a -> [b] -> m a
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
= do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
WarningMessages -> Hsc ImportedModsVal
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors (WarningMessages -> Hsc ImportedModsVal)
-> WarningMessages -> Hsc ImportedModsVal
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags (ImportedModsVal -> SrcSpan
imv_span ImportedModsVal
v1)
(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 InstalledUnitId)
checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
checkSafe (Module
m, SrcSpan
l, a
_) = (Maybe InstalledUnitId, Set InstalledUnitId)
-> Maybe InstalledUnitId
forall a b. (a, b) -> a
fst ((Maybe InstalledUnitId, Set InstalledUnitId)
-> Maybe InstalledUnitId)
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
-> Hsc (Maybe InstalledUnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Module
-> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' Module
m SrcSpan
l
pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId ->
Bool -> ImportAvails
pkgTrustReqs :: DynFlags
-> Set InstalledUnitId
-> Set InstalledUnitId
-> Bool
-> ImportAvails
pkgTrustReqs DynFlags
dflags Set InstalledUnitId
req Set InstalledUnitId
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 InstalledUnitId
imp_trust_pkgs = Set InstalledUnitId
req Set InstalledUnitId -> Set InstalledUnitId -> Set InstalledUnitId
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set InstalledUnitId
inf
}
pkgTrustReqs DynFlags
dflags Set InstalledUnitId
_ Set InstalledUnitId
_ Bool
_ | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Unsafe
= ImportAvails
emptyImportAvails
pkgTrustReqs DynFlags
_ Set InstalledUnitId
req Set InstalledUnitId
_ Bool
_ = ImportAvails
emptyImportAvails { imp_trust_pkgs :: Set InstalledUnitId
imp_trust_pkgs = Set InstalledUnitId
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 InstalledUnitId
pkgs <- (Maybe InstalledUnitId, Set InstalledUnitId) -> Set InstalledUnitId
forall a b. (a, b) -> b
snd ((Maybe InstalledUnitId, Set InstalledUnitId)
-> Set InstalledUnitId)
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
-> Hsc (Set InstalledUnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Module
-> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
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 InstalledUnitId -> Hsc ()
checkPkgTrust Set InstalledUnitId
pkgs
WarningMessages
errs <- Hsc WarningMessages
getWarnings
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
$ WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
errs
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
hscGetSafe HscEnv
hsc_env Module
m SrcSpan
l = HscEnv
-> Hsc (Bool, Set InstalledUnitId)
-> IO (Bool, Set InstalledUnitId)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (Bool, Set InstalledUnitId) -> IO (Bool, Set InstalledUnitId))
-> Hsc (Bool, Set InstalledUnitId)
-> IO (Bool, Set InstalledUnitId)
forall a b. (a -> b) -> a -> b
$ do
(Maybe InstalledUnitId
self, Set InstalledUnitId
pkgs) <- Module
-> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' Module
m SrcSpan
l
Bool
good <- WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag (WarningMessages -> Bool) -> Hsc WarningMessages -> Hsc Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Hsc WarningMessages
getWarnings
Hsc ()
clearWarnings
let pkgs' :: Set InstalledUnitId
pkgs' | Just InstalledUnitId
p <- Maybe InstalledUnitId
self = InstalledUnitId -> Set InstalledUnitId -> Set InstalledUnitId
forall a. Ord a => a -> Set a -> Set a
S.insert InstalledUnitId
p Set InstalledUnitId
pkgs
| Bool
otherwise = Set InstalledUnitId
pkgs
(Bool, Set InstalledUnitId) -> Hsc (Bool, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
good, Set InstalledUnitId
pkgs')
hscCheckSafe' :: Module -> SrcSpan
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' :: Module
-> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' Module
m SrcSpan
l = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(Bool
tw, Set InstalledUnitId
pkgs) <- Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
isModSafe Module
m SrcSpan
l
case Bool
tw of
Bool
False -> (Maybe InstalledUnitId, Set InstalledUnitId)
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe InstalledUnitId
forall a. Maybe a
Nothing, Set InstalledUnitId
pkgs)
Bool
True | DynFlags -> Module -> Bool
isHomePkg DynFlags
dflags Module
m -> (Maybe InstalledUnitId, Set InstalledUnitId)
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe InstalledUnitId
forall a. Maybe a
Nothing, Set InstalledUnitId
pkgs)
| Bool
otherwise -> (Maybe InstalledUnitId, Set InstalledUnitId)
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledUnitId -> Maybe InstalledUnitId
forall a. a -> Maybe a
Just (InstalledUnitId -> Maybe InstalledUnitId)
-> InstalledUnitId -> Maybe InstalledUnitId
forall a b. (a -> b) -> a -> b
$ UnitId -> InstalledUnitId
toInstalledUnitId (Module -> UnitId
moduleUnitId Module
m), Set InstalledUnitId
pkgs)
where
isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
isModSafe Module
m SrcSpan
l = do
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 -> WarningMessages -> Hsc (Bool, Set InstalledUnitId)
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors (WarningMessages -> Hsc (Bool, Set InstalledUnitId))
-> WarningMessages -> Hsc (Bool, Set InstalledUnitId)
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
l
(SDoc -> ErrMsg) -> SDoc -> ErrMsg
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
mi_trust ModIface
iface'
trust_own_pkg :: Bool
trust_own_pkg = ModIface -> 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_Trustworthy]
safeP :: Bool
safeP = DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted DynFlags
dflags SafeHaskellMode
trust Bool
trust_own_pkg Module
m
pkgRs :: Set InstalledUnitId
pkgRs = [InstalledUnitId] -> Set InstalledUnitId
forall a. Ord a => [a] -> Set a
S.fromList ([InstalledUnitId] -> Set InstalledUnitId)
-> ([(InstalledUnitId, Bool)] -> [InstalledUnitId])
-> [(InstalledUnitId, Bool)]
-> Set InstalledUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((InstalledUnitId, Bool) -> InstalledUnitId)
-> [(InstalledUnitId, Bool)] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledUnitId, Bool) -> InstalledUnitId
forall a b. (a, b) -> a
fst ([(InstalledUnitId, Bool)] -> Set InstalledUnitId)
-> [(InstalledUnitId, Bool)] -> Set InstalledUnitId
forall a b. (a -> b) -> a -> b
$ ((InstalledUnitId, Bool) -> Bool)
-> [(InstalledUnitId, Bool)] -> [(InstalledUnitId, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (InstalledUnitId, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(InstalledUnitId, Bool)] -> [(InstalledUnitId, Bool)])
-> [(InstalledUnitId, Bool)] -> [(InstalledUnitId, Bool)]
forall a b. (a -> b) -> a -> b
$ Dependencies -> [(InstalledUnitId, Bool)]
dep_pkgs (Dependencies -> [(InstalledUnitId, Bool)])
-> Dependencies -> [(InstalledUnitId, Bool)]
forall a b. (a -> b) -> a -> b
$ ModIface -> Dependencies
mi_deps ModIface
iface'
errs :: WarningMessages
errs = case (Bool
safeM, Bool
safeP) of
(Bool
True, Bool
True ) -> WarningMessages
forall a. Bag a
emptyBag
(Bool
True, Bool
False) -> WarningMessages
pkgTrustErr
(Bool
False, Bool
_ ) -> WarningMessages
modTrustErr
in do
WarningMessages -> Hsc ()
logWarnings WarningMessages
errs
(Bool, Set InstalledUnitId) -> Hsc (Bool, Set InstalledUnitId)
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 InstalledUnitId
pkgRs)
where
pkgTrustErr :: WarningMessages
pkgTrustErr = ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkErrMsg DynFlags
dflags SrcSpan
l (DynFlags -> PrintUnqualified
pkgQual DynFlags
dflags) (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [ ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> 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
<> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> UnitId
moduleUnitId Module
m)
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
") the module resides in isn't trusted."
]
modTrustErr :: WarningMessages
modTrustErr = ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkErrMsg DynFlags
dflags SrcSpan
l (DynFlags -> PrintUnqualified
pkgQual DynFlags
dflags) (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [ ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> 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 -> SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted DynFlags
_ SafeHaskellMode
Sf_None Bool
_ Module
_ = Bool
False
packageTrusted DynFlags
_ SafeHaskellMode
Sf_Ignore Bool
_ Module
_ = Bool
False
packageTrusted DynFlags
_ SafeHaskellMode
Sf_Unsafe Bool
_ Module
_ = Bool
False
packageTrusted DynFlags
dflags SafeHaskellMode
_ Bool
_ Module
_
| Bool -> Bool
not (DynFlags -> Bool
packageTrustOn DynFlags
dflags) = Bool
True
packageTrusted DynFlags
_ SafeHaskellMode
Sf_Safe Bool
False Module
_ = Bool
True
packageTrusted DynFlags
dflags SafeHaskellMode
_ Bool
_ Module
m
| DynFlags -> Module -> Bool
isHomePkg DynFlags
dflags Module
m = Bool
True
| Bool
otherwise = InstalledPackageInfo
ComponentId
SourcePackageId
PackageName
InstalledUnitId
UnitId
ModuleName
Module
-> Bool
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Bool
trusted (InstalledPackageInfo
ComponentId
SourcePackageId
PackageName
InstalledUnitId
UnitId
ModuleName
Module
-> Bool)
-> InstalledPackageInfo
ComponentId
SourcePackageId
PackageName
InstalledUnitId
UnitId
ModuleName
Module
-> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags
-> UnitId
-> InstalledPackageInfo
ComponentId
SourcePackageId
PackageName
InstalledUnitId
UnitId
ModuleName
Module
getPackageDetails DynFlags
dflags (Module -> UnitId
moduleUnitId Module
m)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' Module
m = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
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 = DynFlags
-> HomePackageTable
-> PackageIfaceTable
-> Module
-> Maybe ModIface
lookupIfaceByModule DynFlags
dflags HomePackageTable
homePkgT PackageIfaceTable
pkgIfaceT Module
m
Maybe ModIface
iface' <- 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 -> ((WarningMessages, WarningMessages), Maybe ModIface)
-> Maybe ModIface
forall a b. (a, b) -> b
snd (((WarningMessages, WarningMessages), Maybe ModIface)
-> Maybe ModIface)
-> Hsc ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc (Maybe ModIface)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (IO ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc ((WarningMessages, WarningMessages), Maybe ModIface)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc ((WarningMessages, WarningMessages), Maybe ModIface))
-> IO ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc ((WarningMessages, WarningMessages), Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> IO ((WarningMessages, WarningMessages), Maybe ModIface)
getModuleInterface HscEnv
hsc_env Module
m)
Maybe ModIface -> Hsc (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
iface'
isHomePkg :: DynFlags -> Module -> Bool
isHomePkg :: DynFlags -> Module -> Bool
isHomePkg DynFlags
dflags Module
m
| DynFlags -> UnitId
thisPackage DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> UnitId
moduleUnitId Module
m = Bool
True
| Bool
otherwise = Bool
False
checkPkgTrust :: Set InstalledUnitId -> Hsc ()
checkPkgTrust :: Set InstalledUnitId -> Hsc ()
checkPkgTrust Set InstalledUnitId
pkgs = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let errors :: [ErrMsg]
errors = (InstalledUnitId -> [ErrMsg] -> [ErrMsg])
-> [ErrMsg] -> Set InstalledUnitId -> [ErrMsg]
forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr InstalledUnitId -> [ErrMsg] -> [ErrMsg]
go [] Set InstalledUnitId
pkgs
go :: InstalledUnitId -> [ErrMsg] -> [ErrMsg]
go InstalledUnitId
pkg [ErrMsg]
acc
| InstalledPackageInfo
ComponentId
SourcePackageId
PackageName
InstalledUnitId
UnitId
ModuleName
Module
-> Bool
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Bool
trusted (InstalledPackageInfo
ComponentId
SourcePackageId
PackageName
InstalledUnitId
UnitId
ModuleName
Module
-> Bool)
-> InstalledPackageInfo
ComponentId
SourcePackageId
PackageName
InstalledUnitId
UnitId
ModuleName
Module
-> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags
-> InstalledUnitId
-> InstalledPackageInfo
ComponentId
SourcePackageId
PackageName
InstalledUnitId
UnitId
ModuleName
Module
getInstalledPackageDetails DynFlags
dflags InstalledUnitId
pkg
= [ErrMsg]
acc
| Bool
otherwise
= (ErrMsg -> [ErrMsg] -> [ErrMsg]
forall a. a -> [a] -> [a]
:[ErrMsg]
acc) (ErrMsg -> [ErrMsg]) -> ErrMsg -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkErrMsg DynFlags
dflags SrcSpan
noSrcSpan (DynFlags -> PrintUnqualified
pkgQual DynFlags
dflags)
(SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"The package (" SDoc -> SDoc -> SDoc
<> InstalledUnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstalledUnitId
pkg SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
") is required" SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
" to be trusted but it isn't!"
case [ErrMsg]
errors of
[] -> () -> Hsc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[ErrMsg]
_ -> (IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> ([ErrMsg] -> IO ()) -> [ErrMsg] -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SourceError -> IO ())
-> ([ErrMsg] -> SourceError) -> [ErrMsg] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningMessages -> SourceError
mkSrcErr (WarningMessages -> SourceError)
-> ([ErrMsg] -> WarningMessages) -> [ErrMsg] -> SourceError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ErrMsg] -> WarningMessages
forall a. [a] -> Bag a
listToBag) [ErrMsg]
errors
markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env WarningMessages
whyUnsafe = do
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnsafe DynFlags
dflags)
(WarningMessages -> Hsc ()
logWarnings (WarningMessages -> Hsc ()) -> WarningMessages -> Hsc ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnsafe) (ErrMsg -> ErrMsg) -> ErrMsg -> ErrMsg
forall a b. (a -> b) -> a -> b
$
DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainWarnMsg DynFlags
dflags (DynFlags -> SrcSpan
warnUnsafeOnLoc DynFlags
dflags) (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, WarningMessages) -> (Bool, WarningMessages) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TcGblEnv -> IORef (Bool, WarningMessages)
tcg_safeInfer TcGblEnv
tcg_env) (Bool
False, WarningMessages
whyUnsafe)
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 InstalledUnitId
imp_trust_pkgs = Set InstalledUnitId
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
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
$ WarningMessages -> [SDoc]
pprErrMsgBagWithLoc WarningMessages
whyUnsafe) SDoc -> SDoc -> SDoc
$+$
([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [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 = [[SDoc]] -> [SDoc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SDoc]] -> [SDoc]) -> [[SDoc]] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ((String, DynFlags -> SrcSpan, DynFlags -> Bool,
DynFlags -> DynFlags)
-> [SDoc])
-> [(String, DynFlags -> SrcSpan, DynFlags -> Bool,
DynFlags -> DynFlags)]
-> [[SDoc]]
forall a b. (a -> b) -> [a] -> [b]
map (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 = [Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage Severity
SevOutput (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 :: [ClsInst] -> [SDoc]
badInsts [ClsInst]
insts = [[SDoc]] -> [SDoc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SDoc]] -> [SDoc]) -> [[SDoc]] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (ClsInst -> [SDoc]) -> [ClsInst] -> [[SDoc]]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> [SDoc]
badInst [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))
= [Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage Severity
SevOutput (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
let hsc_env_with_plugins :: HscEnv
hsc_env_with_plugins = 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, Bool, ModDetails)
hscSimpleIface :: HscEnv
-> TcGblEnv -> Maybe Fingerprint -> IO (ModIface, Bool, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result Maybe Fingerprint
mb_old_iface
= HscEnv
-> Hsc (ModIface, Bool, ModDetails)
-> IO (ModIface, Bool, ModDetails)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (ModIface, Bool, ModDetails)
-> IO (ModIface, Bool, ModDetails))
-> Hsc (ModIface, Bool, ModDetails)
-> IO (ModIface, Bool, ModDetails)
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails)
hscSimpleIface' TcGblEnv
tc_result Maybe Fingerprint
mb_old_iface
hscSimpleIface' :: TcGblEnv
-> Maybe Fingerprint
-> Hsc (ModIface, Bool, ModDetails)
hscSimpleIface' :: TcGblEnv -> Maybe Fingerprint -> Hsc (ModIface, Bool, 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, Bool
no_change)
<- {-# SCC "MkFinalIface" #-}
IO (ModIface, Bool) -> Hsc (ModIface, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Bool) -> Hsc (ModIface, Bool))
-> IO (ModIface, Bool) -> Hsc (ModIface, Bool)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> Maybe Fingerprint
-> SafeHaskellMode
-> ModDetails
-> TcGblEnv
-> IO (ModIface, Bool)
mkIfaceTc HscEnv
hsc_env Maybe Fingerprint
mb_old_iface 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, Bool, ModDetails) -> Hsc (ModIface, Bool, ModDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
new_iface, Bool
no_change, ModDetails
details)
hscNormalIface :: HscEnv
-> ModGuts
-> Maybe Fingerprint
-> IO (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface :: HscEnv
-> ModGuts
-> Maybe Fingerprint
-> IO (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface HscEnv
hsc_env ModGuts
simpl_result Maybe Fingerprint
mb_old_iface =
HscEnv
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
-> IO (ModIface, Bool, ModDetails, CgGuts)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (ModIface, Bool, ModDetails, CgGuts)
-> IO (ModIface, Bool, ModDetails, CgGuts))
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
-> IO (ModIface, Bool, ModDetails, CgGuts)
forall a b. (a -> b) -> a -> b
$ ModGuts
-> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface' ModGuts
simpl_result Maybe Fingerprint
mb_old_iface
hscNormalIface' :: ModGuts
-> Maybe Fingerprint
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface' :: ModGuts
-> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface' ModGuts
simpl_result Maybe Fingerprint
mb_old_iface = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
(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
simpl_result
(ModIface
new_iface, Bool
no_change)
<- {-# SCC "MkFinalIface" #-}
IO (ModIface, Bool) -> Hsc (ModIface, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Bool) -> Hsc (ModIface, Bool))
-> IO (ModIface, Bool) -> Hsc (ModIface, Bool)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> Maybe Fingerprint
-> ModDetails
-> ModGuts
-> IO (ModIface, Bool)
mkIface HscEnv
hsc_env Maybe Fingerprint
mb_old_iface ModDetails
details ModGuts
simpl_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, Bool, ModDetails, CgGuts)
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
new_iface, Bool
no_change, ModDetails
details, CgGuts
cg_guts)
hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscWriteIface DynFlags
dflags ModIface
iface Bool
no_change ModSummary
mod_summary = do
let ifaceFile :: String
ifaceFile = ModLocation -> String
ml_hi_file (ModSummary -> ModLocation
ms_location ModSummary
mod_summary)
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
$
{-# SCC "writeIface" #-}
DynFlags -> String -> ModIface -> IO ()
writeIfaceFile DynFlags
dflags String
ifaceFile ModIface
iface
DynFlags -> IO () -> IO ()
forall (m :: * -> *). MonadIO m => DynFlags -> m () -> m ()
whenGeneratingDynamicToo DynFlags
dflags (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let dynIfaceFile :: String
dynIfaceFile = String -> String -> String
replaceExtension String
ifaceFile (DynFlags -> String
dynHiSuf DynFlags
dflags)
dynIfaceFile' :: String
dynIfaceFile' = Bool -> String -> String
addBootSuffix_maybe (ModIface -> Bool
mi_boot ModIface
iface) String
dynIfaceFile
dynDflags :: DynFlags
dynDflags = DynFlags -> DynFlags
dynamicTooMkDynamicDynFlags DynFlags
dflags
DynFlags -> String -> ModIface -> IO ()
writeIfaceFile DynFlags
dynDflags String
dynIfaceFile' ModIface
iface
hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
hscGenHardCode :: HscEnv
-> CgGuts
-> ModSummary
-> String
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
hscGenHardCode HscEnv
hsc_env CgGuts
cgguts ModSummary
mod_summary 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 -> [InstalledUnitId]
cg_dep_pkgs = [InstalledUnitId]
dependencies,
cg_hpc_info :: CgGuts -> HpcInfo
cg_hpc_info = HpcInfo
hpc_info } = CgGuts
cgguts
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
location :: ModLocation
location = ModSummary -> ModLocation
ms_location ModSummary
mod_summary
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, ([CostCentre]
caf_ccs, [CostCentreStack]
caf_cc_stacks))
<- {-# SCC "CoreToStg" #-}
DynFlags
-> Module -> CoreProgram -> IO ([StgTopBinding], CollectedCCs)
myCoreToStg DynFlags
dflags Module
this_mod CoreProgram
prepd_binds
let cost_centre_info :: CollectedCCs
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)
prof_init :: SDoc
prof_init = Module -> CollectedCCs -> SDoc
profilingInitCode Module
this_mod CollectedCCs
cost_centre_info
foreign_stubs :: ForeignStubs
foreign_stubs = ForeignStubs
foreign_stubs0 ForeignStubs -> SDoc -> ForeignStubs
`appendStubC` SDoc
prof_init
IO DynFlags
-> SDoc
-> ((String, Maybe String, [(ForeignSrcLang, String)]) -> ())
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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)]) -> ()
forall a b. a -> b -> a
const ()) (IO (String, Maybe String, [(ForeignSrcLang, String)])
-> IO (String, Maybe String, [(ForeignSrcLang, String)]))
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
forall a b. (a -> b) -> a -> b
$ do
Stream IO CmmGroup ()
cmms <- {-# SCC "StgCmm" #-}
HscEnv
-> Module
-> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroup ())
doCodeGen HscEnv
hsc_env Module
this_mod [TyCon]
data_tycons
CollectedCCs
cost_centre_info
[StgTopBinding]
stg_binds HpcInfo
hpc_info
Stream IO RawCmmGroup ()
rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
DynFlags -> Stream IO CmmGroup () -> IO (Stream IO RawCmmGroup ())
cmmToRawCmm DynFlags
dflags Stream IO CmmGroup ()
cmms
let dump :: b -> IO b
dump b
a = do DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_cmm_raw String
"Raw Cmm"
(b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
a)
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
a
rawcmms1 :: Stream IO RawCmmGroup ()
rawcmms1 = (RawCmmGroup -> IO RawCmmGroup)
-> Stream IO RawCmmGroup () -> Stream IO RawCmmGroup ()
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM RawCmmGroup -> IO RawCmmGroup
forall b. Outputable b => b -> IO b
dump Stream IO RawCmmGroup ()
rawcmms0
(String
output_filename, (Bool
_stub_h_exists, Maybe String
stub_c_exists), [(ForeignSrcLang, String)]
foreign_fps)
<- {-# SCC "codeOutput" #-}
DynFlags
-> Module
-> String
-> ModLocation
-> ForeignStubs
-> [(ForeignSrcLang, String)]
-> [InstalledUnitId]
-> Stream IO RawCmmGroup ()
-> IO (String, (Bool, Maybe String), [(ForeignSrcLang, String)])
codeOutput DynFlags
dflags Module
this_mod String
output_filename ModLocation
location
ForeignStubs
foreign_stubs [(ForeignSrcLang, String)]
foreign_files [InstalledUnitId]
dependencies Stream IO RawCmmGroup ()
rawcmms1
(String, Maybe String, [(ForeignSrcLang, String)])
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
output_filename, Maybe String
stub_c_exists, [(ForeignSrcLang, String)]
foreign_fps)
hscInteractive :: HscEnv
-> CgGuts
-> ModSummary
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive :: HscEnv
-> CgGuts
-> ModSummary
-> IO (Maybe String, CompiledByteCode, [SptEntry])
hscInteractive HscEnv
hsc_env CgGuts
cgguts ModSummary
mod_summary = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags 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
location :: ModLocation
location = ModSummary -> ModLocation
ms_location ModSummary
mod_summary
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
CompiledByteCode
comp_bc <- HscEnv
-> Module
-> CoreProgram
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod CoreProgram
prepd_binds [TyCon]
data_tycons Maybe ModBreaks
mod_breaks
(Bool
_istub_h_exists, Maybe String
istub_c_exists)
<- DynFlags
-> Module -> ModLocation -> ForeignStubs -> IO (Bool, Maybe String)
outputForeignStubs DynFlags
dflags 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 ()
hscCompileCmmFile :: HscEnv -> String -> String -> IO ()
hscCompileCmmFile HscEnv
hsc_env String
filename String
output_filename = HscEnv -> Hsc () -> IO ()
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc () -> IO ()) -> Hsc () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
CmmGroup
cmm <- IO ((WarningMessages, WarningMessages), Maybe CmmGroup)
-> Hsc CmmGroup
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe CmmGroup)
-> Hsc CmmGroup)
-> IO ((WarningMessages, WarningMessages), Maybe CmmGroup)
-> Hsc CmmGroup
forall a b. (a -> b) -> a -> b
$ DynFlags
-> String
-> IO ((WarningMessages, WarningMessages), Maybe CmmGroup)
parseCmmFile DynFlags
dflags String
filename
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_cmm_verbose String
"Parsed Cmm" (CmmGroup -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmGroup
cmm)
let
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 = UnitId -> ModuleName -> Module
mkModule (DynFlags -> UnitId
thisPackage DynFlags
dflags) ModuleName
mod_name
(ModuleSRTInfo
_, CmmGroup
cmmgroup) <- HscEnv -> ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup)
cmmPipeline HscEnv
hsc_env (Module -> ModuleSRTInfo
emptySRT Module
cmm_mod) CmmGroup
cmm
DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_cmm String
"Output Cmm" (CmmGroup -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmGroup
cmmgroup)
Stream IO RawCmmGroup ()
rawCmms <- DynFlags -> Stream IO CmmGroup () -> IO (Stream IO RawCmmGroup ())
cmmToRawCmm DynFlags
dflags (CmmGroup -> Stream IO CmmGroup ()
forall (m :: * -> *) a. Monad m => a -> Stream m a ()
Stream.yield CmmGroup
cmmgroup)
(String, (Bool, Maybe String), [(ForeignSrcLang, String)])
_ <- DynFlags
-> Module
-> String
-> ModLocation
-> ForeignStubs
-> [(ForeignSrcLang, String)]
-> [InstalledUnitId]
-> Stream IO RawCmmGroup ()
-> IO (String, (Bool, Maybe String), [(ForeignSrcLang, String)])
codeOutput DynFlags
dflags Module
cmm_mod String
output_filename ModLocation
no_loc ForeignStubs
NoStubs [] []
Stream IO RawCmmGroup ()
rawCmms
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 -> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroup ())
doCodeGen :: HscEnv
-> Module
-> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroup ())
doCodeGen HscEnv
hsc_env Module
this_mod [TyCon]
data_tycons
CollectedCCs
cost_centre_info [StgTopBinding]
stg_binds HpcInfo
hpc_info = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let stg_binds_w_fvs :: [CgStgTopBinding]
stg_binds_w_fvs = [StgTopBinding] -> [CgStgTopBinding]
annTopBindingsFreeVars [StgTopBinding]
stg_binds
let cmm_stream :: Stream IO CmmGroup ()
cmm_stream :: Stream IO CmmGroup ()
cmm_stream = {-# SCC "StgCmm" #-}
DynFlags
-> Module
-> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup ()
StgCmm.codeGen DynFlags
dflags Module
this_mod [TyCon]
data_tycons
CollectedCCs
cost_centre_info [CgStgTopBinding]
stg_binds_w_fvs HpcInfo
hpc_info
let dump1 :: b -> IO b
dump1 b
a = do DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_cmm_from_stg
String
"Cmm produced by codegen" (b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
a)
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
a
ppr_stream1 :: Stream IO CmmGroup ()
ppr_stream1 = (CmmGroup -> IO CmmGroup)
-> Stream IO CmmGroup () -> Stream IO CmmGroup ()
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM CmmGroup -> IO CmmGroup
forall b. Outputable b => b -> IO b
dump1 Stream IO CmmGroup ()
cmm_stream
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'S'
let
pipeline_stream :: Stream IO CmmGroup ()
pipeline_stream
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitObjs DynFlags
dflags Bool -> Bool -> Bool
|| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitSections DynFlags
dflags Bool -> Bool -> Bool
||
OS -> Bool
osSubsectionsViaSymbols (Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags))
= {-# SCC "cmmPipeline" #-}
let run_pipeline :: a -> CmmGroup -> IO (a, CmmGroup)
run_pipeline a
us CmmGroup
cmmgroup = do
(ModuleSRTInfo
_topSRT, CmmGroup
cmmgroup) <-
HscEnv -> ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup)
cmmPipeline HscEnv
hsc_env (Module -> ModuleSRTInfo
emptySRT Module
this_mod) CmmGroup
cmmgroup
(a, CmmGroup) -> IO (a, CmmGroup)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
us, CmmGroup
cmmgroup)
in do UniqSupply
_ <- (UniqSupply -> CmmGroup -> IO (UniqSupply, CmmGroup))
-> UniqSupply
-> Stream IO CmmGroup ()
-> Stream IO CmmGroup UniqSupply
forall (m :: * -> *) c a b.
Monad m =>
(c -> a -> m (c, b)) -> c -> Stream m a () -> Stream m b c
Stream.mapAccumL UniqSupply -> CmmGroup -> IO (UniqSupply, CmmGroup)
forall a. a -> CmmGroup -> IO (a, CmmGroup)
run_pipeline UniqSupply
us Stream IO CmmGroup ()
ppr_stream1
() -> Stream IO CmmGroup ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= {-# SCC "cmmPipeline" #-}
let run_pipeline :: ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup)
run_pipeline = HscEnv -> ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup)
cmmPipeline HscEnv
hsc_env
in Stream IO CmmGroup ModuleSRTInfo -> Stream IO CmmGroup ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Stream IO CmmGroup ModuleSRTInfo -> Stream IO CmmGroup ())
-> Stream IO CmmGroup ModuleSRTInfo -> Stream IO CmmGroup ()
forall a b. (a -> b) -> a -> b
$ (ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup))
-> ModuleSRTInfo
-> Stream IO CmmGroup ()
-> Stream IO CmmGroup ModuleSRTInfo
forall (m :: * -> *) c a b.
Monad m =>
(c -> a -> m (c, b)) -> c -> Stream m a () -> Stream m b c
Stream.mapAccumL ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup)
run_pipeline (Module -> ModuleSRTInfo
emptySRT Module
this_mod) Stream IO CmmGroup ()
ppr_stream1
let
dump2 :: b -> IO b
dump2 b
a = do DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_cmm
String
"Output Cmm" (b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
a)
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
a
ppr_stream2 :: Stream IO CmmGroup ()
ppr_stream2 = (CmmGroup -> IO CmmGroup)
-> Stream IO CmmGroup () -> Stream IO CmmGroup ()
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM CmmGroup -> IO CmmGroup
forall b. Outputable b => b -> IO b
dump2 Stream IO CmmGroup ()
pipeline_stream
Stream IO CmmGroup () -> IO (Stream IO CmmGroup ())
forall (m :: * -> *) a. Monad m => a -> m a
return Stream IO CmmGroup ()
ppr_stream2
myCoreToStg :: DynFlags -> Module -> CoreProgram
-> IO ( [StgTopBinding]
, CollectedCCs )
myCoreToStg :: DynFlags
-> Module -> CoreProgram -> IO ([StgTopBinding], CollectedCCs)
myCoreToStg DynFlags
dflags Module
this_mod CoreProgram
prepd_binds = do
let ([StgTopBinding]
stg_binds, CollectedCCs
cost_centre_info)
= {-# SCC "Core2Stg" #-}
DynFlags
-> Module -> CoreProgram -> ([StgTopBinding], CollectedCCs)
coreToStg DynFlags
dflags Module
this_mod CoreProgram
prepd_binds
[StgTopBinding]
stg_binds2
<- {-# SCC "Stg2Stg" #-}
DynFlags -> Module -> [StgTopBinding] -> IO [StgTopBinding]
stg2stg DynFlags
dflags Module
this_mod [StgTopBinding]
stg_binds
([StgTopBinding], CollectedCCs)
-> IO ([StgTopBinding], CollectedCCs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgTopBinding]
stg_binds2, CollectedCCs
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 (GhciLStmt GhcPs)
maybe_stmt <- String -> Int -> String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation String
source Int
linenumber String
stmt
case Maybe (GhciLStmt GhcPs)
maybe_stmt of
Maybe (GhciLStmt 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 GhciLStmt 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 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, LHsExpr GhcTc
tc_expr, FixityEnv
fix_env) <- IO
((WarningMessages, WarningMessages),
Maybe ([DFunId], LHsExpr GhcTc, FixityEnv))
-> Hsc ([DFunId], LHsExpr GhcTc, FixityEnv)
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO
((WarningMessages, WarningMessages),
Maybe ([DFunId], LHsExpr GhcTc, FixityEnv))
-> Hsc ([DFunId], LHsExpr GhcTc, FixityEnv))
-> IO
((WarningMessages, WarningMessages),
Maybe ([DFunId], LHsExpr GhcTc, FixityEnv))
-> Hsc ([DFunId], LHsExpr GhcTc, FixityEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs
-> IO
((WarningMessages, WarningMessages),
Maybe ([DFunId], LHsExpr GhcTc, FixityEnv))
tcRnStmt HscEnv
hsc_env GhciLStmt GhcPs
stmt
CoreExpr
ds_expr <- IO ((WarningMessages, WarningMessages), Maybe CoreExpr)
-> Hsc CoreExpr
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe CoreExpr)
-> Hsc CoreExpr)
-> IO ((WarningMessages, WarningMessages), Maybe CoreExpr)
-> Hsc CoreExpr
forall a b. (a -> b) -> a -> b
$ HscEnv
-> LHsExpr GhcTc
-> IO ((WarningMessages, WarningMessages), Maybe CoreExpr)
deSugarExpr HscEnv
hsc_env LHsExpr GhcTc
tc_expr
IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr 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 :: forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls = [LHsDecl GhcPs]
decls }) <-
HscEnv
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs)))
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$
String
-> Int
-> P (Located (HsModule GhcPs))
-> String
-> Hsc (Located (HsModule GhcPs))
forall thing.
(Outputable thing, Data thing) =>
String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation String
source Int
line_num P (Located (HsModule GhcPs))
parseModule String
str
[LHsDecl GhcPs] -> IO [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return [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 :: forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls = [LHsDecl GhcPs]
decls }) <-
HscEnv
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs)))
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$
String
-> Int
-> P (Located (HsModule GhcPs))
-> String
-> Hsc (Located (HsModule GhcPs))
forall thing.
(Outputable thing, Data thing) =>
String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation String
source Int
linenumber P (Located (HsModule GhcPs))
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
TcGblEnv
tc_gblenv <- IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv)
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LHsDecl GhcPs]
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
tcRnDeclsi HscEnv
hsc_env [LHsDecl GhcPs]
decls
let defaults :: Maybe [Type]
defaults = TcGblEnv -> Maybe [Type]
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
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
-> CoreProgram
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod
CoreProgram
prepd_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
$ HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
linkDecls 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 [Type]
-> FixityEnv
-> InteractiveContext
extendInteractiveContext InteractiveContext
ictxt [TyThing]
new_tythings [ClsInst]
cls_insts
[FamInst]
fam_insts Maybe [Type]
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 add_spt_entry :: SptEntry -> IO ()
add_spt_entry :: SptEntry -> IO ()
add_spt_entry (SptEntry DFunId
i Fingerprint
fpr) = do
ForeignHValue
val <- HscEnv -> Name -> IO ForeignHValue
getHValue HscEnv
hsc_env (DFunId -> Name
idName DFunId
i)
HscEnv -> Fingerprint -> ForeignHValue -> IO ()
addSptEntry HscEnv
hsc_env 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 :: forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports=[LImportDecl GhcPs]
is})) <-
P (Located (HsModule GhcPs))
-> String -> Hsc (Located (HsModule GhcPs))
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (Located (HsModule GhcPs))
parseModule String
str
case [LImportDecl GhcPs]
is of
[L SrcSpan
_ ImportDecl GhcPs
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
$ ErrMsg -> IO (ImportDecl GhcPs)
forall (m :: * -> *) ab. MonadIO m => ErrMsg -> m ab
throwOneError (ErrMsg -> IO (ImportDecl GhcPs))
-> ErrMsg -> IO (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) SrcSpan
noSrcSpan (SDoc -> ErrMsg) -> SDoc -> ErrMsg
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 Type
hscTcExpr HscEnv
hsc_env0 TcRnExprMode
mode String
expr = HscEnv -> Hsc Type -> IO Type
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc Type -> IO Type) -> Hsc Type -> IO Type
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
LHsExpr GhcPs
parsed_expr <- String -> Hsc (LHsExpr GhcPs)
hscParseExpr String
expr
IO ((WarningMessages, WarningMessages), Maybe Type) -> Hsc Type
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe Type) -> Hsc Type)
-> IO ((WarningMessages, WarningMessages), Maybe Type) -> Hsc Type
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRnExprMode
-> LHsExpr GhcPs
-> IO ((WarningMessages, WarningMessages), Maybe Type)
tcRnExpr HscEnv
hsc_env TcRnExprMode
mode LHsExpr GhcPs
parsed_expr
hscKcType
:: HscEnv
-> Bool
-> String
-> IO (Type, Kind)
hscKcType :: HscEnv -> Bool -> String -> IO (Type, Type)
hscKcType HscEnv
hsc_env0 Bool
normalise String
str = HscEnv -> Hsc (Type, Type) -> IO (Type, Type)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Type, Type) -> IO (Type, Type))
-> Hsc (Type, Type) -> IO (Type, Type)
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
LHsType GhcPs
ty <- String -> Hsc (LHsType GhcPs)
hscParseType String
str
IO ((WarningMessages, WarningMessages), Maybe (Type, Type))
-> Hsc (Type, Type)
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe (Type, Type))
-> Hsc (Type, Type))
-> IO ((WarningMessages, WarningMessages), Maybe (Type, Type))
-> Hsc (Type, Type)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Bool
-> LHsType GhcPs
-> IO ((WarningMessages, WarningMessages), Maybe (Type, Type))
tcRnType HscEnv
hsc_env Bool
normalise LHsType GhcPs
ty
hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr String
expr = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
Maybe (GhciLStmt GhcPs)
maybe_stmt <- String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt String
expr
case Maybe (GhciLStmt GhcPs)
maybe_stmt of
Just (L SrcSpan
_ (BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LHsExpr GhcPs
expr SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) -> LHsExpr GhcPs -> Hsc (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
expr
Maybe (GhciLStmt GhcPs)
_ -> WarningMessages -> Hsc (LHsExpr GhcPs)
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors (WarningMessages -> Hsc (LHsExpr GhcPs))
-> WarningMessages -> Hsc (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) SrcSpan
noSrcSpan
(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 (GhciLStmt GhcPs))
-> String -> Hsc (Maybe (GhciLStmt GhcPs))
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (Maybe (GhciLStmt 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 (GhciLStmt GhcPs))
-> String
-> Hsc (Maybe (GhciLStmt GhcPs))
forall thing.
(Outputable thing, Data thing) =>
String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation String
source Int
linenumber P (Maybe (GhciLStmt GhcPs))
parseStmt String
stmt
hscParseType :: String -> Hsc (LHsType GhcPs)
hscParseType :: String -> Hsc (LHsType GhcPs)
hscParseType = P (LHsType GhcPs) -> String -> Hsc (LHsType GhcPs)
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (LHsType GhcPs)
parseType
hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
hscParseIdentifier HscEnv
hsc_env String
str =
HscEnv -> Hsc (Located RdrName) -> IO (Located RdrName)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Located RdrName) -> IO (Located RdrName))
-> Hsc (Located RdrName) -> IO (Located RdrName)
forall a b. (a -> b) -> a -> b
$ P (Located RdrName) -> String -> Hsc (Located RdrName)
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (Located 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
= Hsc DynFlags -> SDoc -> (thing -> ()) -> Hsc thing -> Hsc thing
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(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
DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
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 (DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState DynFlags
dflags StringBuffer
buf RealSrcLoc
loc) of
PFailed DynFlags -> (WarningMessages, WarningMessages)
warnFn SrcSpan
span SDoc
err -> do
(WarningMessages, WarningMessages) -> Hsc ()
logWarningsReportErrors (DynFlags -> (WarningMessages, WarningMessages)
warnFn DynFlags
dflags)
Hsc ()
handleWarnings
let msg :: ErrMsg
msg = DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
span SDoc
err
WarningMessages -> Hsc thing
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors (WarningMessages -> Hsc thing) -> WarningMessages -> Hsc thing
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag ErrMsg
msg
POk PState
pst thing
thing -> do
(WarningMessages, WarningMessages) -> Hsc ()
logWarningsReportErrors (PState -> DynFlags -> (WarningMessages, WarningMessages)
getMessages PState
pst 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
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_parsed String
"Parser" (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
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_parsed_ast String
"Parser AST" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
BlankSrcSpan -> thing -> SDoc
forall a. Data a => BlankSrcSpan -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan 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 =
(Hooks
-> Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue))
-> (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
-> DynFlags
-> HscEnv
-> SrcSpan
-> CoreExpr
-> IO ForeignHValue
forall a. (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook Hooks -> Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
hscCompileCoreExprHook HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) HscEnv
hsc_env
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' HscEnv
hsc_env SrcSpan
srcspan CoreExpr
ds_expr
= do { let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
; CoreExpr
simpl_expr <- DynFlags -> CoreExpr -> IO CoreExpr
simplifyExpr DynFlags
dflags CoreExpr
ds_expr
; let tidy_expr :: CoreExpr
tidy_expr = TidyEnv -> CoreExpr -> CoreExpr
tidyExpr TidyEnv
emptyTidyEnv CoreExpr
simpl_expr
; CoreExpr
prepd_expr <- DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr DynFlags
dflags HscEnv
hsc_env CoreExpr
tidy_expr
; String -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr String
"hscCompileExpr" HscEnv
hsc_env CoreExpr
prepd_expr
; UnlinkedBCO
bcos <- HscEnv -> Module -> CoreExpr -> IO UnlinkedBCO
coreExprToBCOs HscEnv
hsc_env
(InteractiveContext -> Module
icInteractiveModule (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)) CoreExpr
prepd_expr
; ForeignHValue
hval <- HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
linkExpr HscEnv
hsc_env SrcSpan
srcspan UnlinkedBCO
bcos
; ForeignHValue -> IO ForeignHValue
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignHValue
hval }
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env = do
ExternalPackageState
eps <- IORef ExternalPackageState -> IO ExternalPackageState
forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)
DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet 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
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) -> String
showModuleIndex :: (Int, Int) -> String
showModuleIndex (Int
i,Int
n) = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
padded String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] "
where
n_str :: String
n_str = Int -> String
forall a. Show a => a -> String
show Int
n
i_str :: String
i_str = Int -> String
forall a. Show a => a -> String
show Int
i
padded :: String
padded = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n_str Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
i_str) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
i_str