{-# LANGUAGE CPP #-}
{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-}
{-# LANGUAGE TupleSections, NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
module GHC (
defaultErrorHandler,
defaultCleanupHandler,
prettyPrintGhcErrors,
withSignalHandlers,
withCleanupSession,
Ghc, GhcT, GhcMonad(..), HscEnv,
runGhc, runGhcT, initGhcMonad,
printException,
handleSourceError,
DynFlags(..), GeneralFlag(..), Severity(..), Backend, gopt,
ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend,
GhcMode(..), GhcLink(..),
parseDynamicFlags, parseTargetFiles,
getSessionDynFlags,
setTopSessionDynFlags,
setSessionDynFlags,
setUnitDynFlags,
getProgramDynFlags, setProgramDynFlags,
getInteractiveDynFlags, setInteractiveDynFlags,
interpretPackageEnv,
Logger, getLogger,
pushLogHook, popLogHook,
pushLogHookM, popLogHookM, modifyLogger,
putMsgM, putLogMsgM,
Target(..), TargetId(..), Phase,
setTargets,
getTargets,
addTarget,
removeTarget,
guessTarget,
depanal, depanalE,
load, loadWithCache, LoadHowMuch(..), InteractiveImport(..),
SuccessFlag(..), succeeded, failed,
defaultWarnErrLogger, WarnErrLogger,
workingDirectoryChanged,
parseModule, typecheckModule, desugarModule,
ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
TypecheckedMod, ParsedMod,
moduleInfo, renamedSource, typecheckedSource,
parsedSource, coreModule,
PkgQual(..),
CoreModule(..),
compileToCoreModule, compileToCoreSimplified,
ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
mgLookupModule,
ModSummary(..), ms_mod_name, ModLocation(..),
getModSummary,
getModuleGraph,
isLoaded,
isLoadedModule,
topSortModuleGraph,
ModuleInfo,
getModuleInfo,
modInfoTyThings,
modInfoTopLevelScope,
modInfoExports,
modInfoExportsWithSelectors,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
modInfoIface,
modInfoRdrEnv,
modInfoSafe,
lookupGlobalName,
findGlobalAnns,
mkNamePprCtxForModule,
ModIface, ModIface_(..),
SafeHaskellMode(..),
NamePprCtx, alwaysQualify,
execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..),
resumeExec,
runDecls, runDeclsWithLocation, runParsedDecls,
parseImportDecl,
setContext, getContext,
setGHCiMonad, getGHCiMonad,
getBindings, getInsts, getNamePprCtx,
findModule, lookupModule,
findQualifiedModule, lookupQualifiedModule,
renamePkgQualM, renameRawPkgQualM,
isModuleTrusted, moduleTrustReqs,
getNamesInScope,
getRdrNamesInScope,
getGRE,
moduleIsInterpreted,
getInfo,
showModule,
moduleIsBootOrNotObjectLinkable,
getNameToInstancesIndex,
exprType, TcRnExprMode(..),
typeKind,
parseName,
lookupName,
HValue, parseExpr, compileParsedExpr,
GHC.Runtime.Eval.compileExpr, dynCompileExpr,
ForeignHValue,
compileExprRemote, compileParsedExprRemote,
getDocs, GetDocsFailure(..),
runTcInteractive,
isStmt, hasImport, isImport, isDecl,
SingleStep(..),
Resume(..),
History(historyBreakInfo, historyEnclosingDecls),
GHC.getHistorySpan, getHistoryModule,
abandon, abandonAll,
getResumeContext,
GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(..),
GHC.Runtime.Eval.back,
GHC.Runtime.Eval.forward,
GHC.Runtime.Eval.setupBreakpoint,
Unit,
Module, mkModule, pprModule, moduleName, moduleUnit,
Name,
isExternalName, nameModule, pprParenSymName, nameSrcSpan,
NamedThing(..),
RdrName(Qual,Unqual),
Id, idType,
isImplicitId, isDeadBinder,
isExportedId, isLocalId, isGlobalId,
isRecordSelector,
isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
isDeadEndId, isDictonaryId,
recordSelectorTyCon,
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,
isPrimTyCon,
isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,
tyConClass_maybe,
synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,
TyVar,
alphaTyVars,
DataCon,
dataConType, dataConTyCon, dataConFieldLabels,
dataConIsInfix, isVanillaDataCon, dataConWrapperType,
dataConSrcBangs,
StrictnessMark(..), isMarkedStrict,
Class,
classMethods, classSCTheta, classTvsFds, classATs,
pprFundeps,
ClsInst,
instanceDFunId,
pprInstance, pprInstanceHdr,
pprFamInst,
FamInst,
Type, splitForAllTyCoVars, funResultTy,
pprParendType, pprTypeApp,
Kind,
PredType,
ThetaType, pprForAll, pprThetaArrowTy,
parseInstanceHead,
getInstancesForType,
TyThing(..),
module GHC.Hs,
FixityDirection(..),
defaultFixity, maxPrecedence,
negateFixity,
compareFixity,
LexicalFixity(..),
SrcLoc(..), RealSrcLoc,
mkSrcLoc, noSrcLoc,
srcLocFile, srcLocLine, srcLocCol,
SrcSpan(..), RealSrcSpan,
mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
srcSpanStart, srcSpanEnd,
srcSpanFile,
srcSpanStartLine, srcSpanEndLine,
srcSpanStartCol, srcSpanEndCol,
GenLocated(..), Located, RealLocated,
noLoc, mkGeneralLocated,
getLoc, unLoc,
getRealSrcSpan, unRealSrcSpan,
eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost_smallest,
spans, isSubspanOf,
GhcException(..), showGhcException,
GhcApiError(..),
Token,
getTokenStream, getRichTokenStream,
showRichTokenStream, addSourceToTokens,
parser,
AnnKeywordId(..),EpaComment(..),
cyclicModuleErr,
) where
import GHC.Prelude hiding (init)
import GHC.Platform
import GHC.Platform.Ways
import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename
, isSourceFilename, startPhase )
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.CmdLine
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Config.Finder (initFinderOpts)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Main
import GHC.Driver.Make
import GHC.Driver.Hooks
import GHC.Driver.Monad
import GHC.Driver.Ppr
import GHC.ByteCode.Types
import qualified GHC.Linker.Loader as Loader
import GHC.Runtime.Loader
import GHC.Runtime.Eval
import GHC.Runtime.Interpreter
import GHC.Runtime.Context
import GHCi.RemoteTypes
import qualified GHC.Parser as Parser
import GHC.Parser.Lexer
import GHC.Parser.Annotation
import GHC.Parser.Utils
import GHC.Iface.Load ( loadSysInterface )
import GHC.Hs
import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
import GHC.Rename.Names (renamePkgQual, renameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
import GHC.Tc.Utils.TcType
import GHC.Tc.Module
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family
import GHC.Utils.TmpFs
import GHC.Utils.Error
import GHC.Utils.Monad
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Logger
import GHC.Utils.Fingerprint
import GHC.Core.Predicate
import GHC.Core.Type hiding( typeKind )
import GHC.Core.TyCon
import GHC.Core.TyCo.Ppr ( pprForAll )
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts, orphNamesOfFamInst )
import GHC.Core.InstEnv
import GHC.Core
import GHC.Types.Id
import GHC.Types.Name hiding ( varName )
import GHC.Types.Avail
import GHC.Types.SrcLoc
import GHC.Types.TyThing.Ppr ( pprFamInst )
import GHC.Types.Annotations
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.SourceError
import GHC.Types.SafeHaskell
import GHC.Types.Error
import GHC.Types.Fixity
import GHC.Types.Target
import GHC.Types.Basic
import GHC.Types.TyThing
import GHC.Types.Name.Env
import GHC.Types.Name.Ppr
import GHC.Types.TypeEnv
import GHC.Types.BreakInfo
import GHC.Types.PkgQual
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Finder
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo
import Data.Foldable
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Sequence as Seq
import Data.Maybe
import Data.Typeable ( Typeable )
import Data.Word ( Word8 )
import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
import GHC.Utils.Exception
import Data.IORef
import System.FilePath
import Control.Concurrent
import Control.Applicative ((<|>))
import Control.Monad.Catch as MC
import GHC.Data.Maybe
import System.IO.Error ( isDoesNotExistError )
import System.Environment ( getEnv, getProgName )
import System.Directory
import Data.List (isPrefixOf)
import qualified Data.Set as S
defaultErrorHandler :: (ExceptionMonad m)
=> FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler :: forall (m :: * -> *) a.
ExceptionMonad m =>
FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler FatalMessager
fm (FlushOut IO ()
flushOut) m a
inner =
(SomeException -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle (\SomeException
exception -> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
IO ()
flushOut
case SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
Just (IOError
ioe :: IOException) ->
FatalMessager
fm (IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
ioe)
Maybe IOError
_ -> case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
Just AsyncException
UserInterrupt ->
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AsyncException -> IO ()
forall e a. Exception e => e -> IO a
throwIO AsyncException
UserInterrupt
Just AsyncException
StackOverflow ->
FatalMessager
fm FilePath
"stack overflow: use +RTS -K<size> to increase it"
Maybe AsyncException
_ -> case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
Just (ExitCode
ex :: ExitCode) -> IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall e a. Exception e => e -> IO a
throwIO ExitCode
ex
Maybe ExitCode
_ ->
FatalMessager
fm (GhcException -> FilePath
forall a. Show a => a -> FilePath
show (FilePath -> GhcException
Panic (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
exception)))
ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
(GhcException -> m a) -> m a -> m a
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException
(\GhcException
ge -> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
IO ()
flushOut
case GhcException
ge of
Signal Int
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ProgramError FilePath
_ -> FatalMessager
fm (GhcException -> FilePath
forall a. Show a => a -> FilePath
show GhcException
ge)
CmdLineError FilePath
_ -> FatalMessager
fm (FilePath
"<command line>: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ GhcException -> FilePath
forall a. Show a => a -> FilePath
show GhcException
ge)
GhcException
_ -> do
FilePath
progName <- IO FilePath
getProgName
FatalMessager
fm (FilePath
progName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ GhcException -> FilePath
forall a. Show a => a -> FilePath
show GhcException
ge)
ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
m a
inner
{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
defaultCleanupHandler :: forall (m :: * -> *) a. ExceptionMonad m => DynFlags -> m a -> m a
defaultCleanupHandler DynFlags
_ m a
m = m a
m
where _warning_suppression :: m a
_warning_suppression = m a
m m a -> m Any -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`MC.onException` m Any
forall a. HasCallStack => a
undefined
runGhc :: Maybe FilePath
-> Ghc a
-> IO a
runGhc :: forall a. Maybe FilePath -> Ghc a -> IO a
runGhc Maybe FilePath
mb_top_dir Ghc a
ghc = do
IORef HscEnv
ref <- HscEnv -> IO (IORef HscEnv)
forall a. a -> IO (IORef a)
newIORef (FilePath -> HscEnv
forall a. HasCallStack => FilePath -> a
panic FilePath
"empty session")
let session :: Session
session = IORef HscEnv -> Session
Session IORef HscEnv
ref
(Ghc a -> Session -> IO a) -> Session -> Ghc a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ghc a -> Session -> IO a
forall a. Ghc a -> Session -> IO a
unGhc Session
session (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ Ghc a -> Ghc a
forall (m :: * -> *) a. ExceptionMonad m => m a -> m a
withSignalHandlers (Ghc a -> Ghc a) -> Ghc a -> Ghc a
forall a b. (a -> b) -> a -> b
$ do
Maybe FilePath -> Ghc ()
forall (m :: * -> *). GhcMonad m => Maybe FilePath -> m ()
initGhcMonad Maybe FilePath
mb_top_dir
Ghc a -> Ghc a
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withCleanupSession Ghc a
ghc
runGhcT :: ExceptionMonad m =>
Maybe FilePath
-> GhcT m a
-> m a
runGhcT :: forall (m :: * -> *) a.
ExceptionMonad m =>
Maybe FilePath -> GhcT m a -> m a
runGhcT Maybe FilePath
mb_top_dir GhcT m a
ghct = do
IORef HscEnv
ref <- IO (IORef HscEnv) -> m (IORef HscEnv)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef HscEnv) -> m (IORef HscEnv))
-> IO (IORef HscEnv) -> m (IORef HscEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO (IORef HscEnv)
forall a. a -> IO (IORef a)
newIORef (FilePath -> HscEnv
forall a. HasCallStack => FilePath -> a
panic FilePath
"empty session")
let session :: Session
session = IORef HscEnv -> Session
Session IORef HscEnv
ref
(GhcT m a -> Session -> m a) -> Session -> GhcT m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip GhcT m a -> Session -> m a
forall (m :: * -> *) a. GhcT m a -> Session -> m a
unGhcT Session
session (GhcT m a -> m a) -> GhcT m a -> m a
forall a b. (a -> b) -> a -> b
$ GhcT m a -> GhcT m a
forall (m :: * -> *) a. ExceptionMonad m => m a -> m a
withSignalHandlers (GhcT m a -> GhcT m a) -> GhcT m a -> GhcT m a
forall a b. (a -> b) -> a -> b
$ do
Maybe FilePath -> GhcT m ()
forall (m :: * -> *). GhcMonad m => Maybe FilePath -> m ()
initGhcMonad Maybe FilePath
mb_top_dir
GhcT m a -> GhcT m a
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withCleanupSession GhcT m a
ghct
withCleanupSession :: GhcMonad m => m a -> m a
withCleanupSession :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
withCleanupSession m a
ghc = m a
ghc m a -> m () -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`MC.finally` m ()
cleanup
where
cleanup :: m ()
cleanup = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepTmpFiles DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Logger -> TmpFs -> IO ()
cleanTempFiles Logger
logger TmpFs
tmpfs
Logger -> TmpFs -> IO ()
cleanTempDirs Logger
logger TmpFs
tmpfs
(Interp -> IO ()) -> Maybe Interp -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Interp -> IO ()
stopInterp (HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env)
initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
initGhcMonad :: forall (m :: * -> *). GhcMonad m => Maybe FilePath -> m ()
initGhcMonad Maybe FilePath
mb_top_dir = HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> m ()) -> m HscEnv -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO HscEnv -> m HscEnv
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ( do
!Bool
keep_cafs <- IO Bool
c_keepCAFsForGHCi
Bool -> IO ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert Bool
keep_cafs
Maybe FilePath -> IO HscEnv
initHscEnv Maybe FilePath
mb_top_dir
)
setSessionDynFlags :: (HasCallStack, GhcMonad m) => DynFlags -> m ()
setSessionDynFlags :: forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags DynFlags
dflags0 = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
DynFlags
dflags <- Logger -> DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags Logger
logger DynFlags
dflags0
let all_uids :: Set UnitId
all_uids = HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env
case Set UnitId -> [UnitId]
forall a. Set a -> [a]
S.toList Set UnitId
all_uids of
[UnitId
uid] -> do
UnitId -> DynFlags -> m ()
forall (m :: * -> *). GhcMonad m => UnitId -> DynFlags -> m ()
setUnitDynFlagsNoCheck UnitId
uid DynFlags
dflags
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (HscEnv -> HscEnv
hscUpdateLoggerFlags (HscEnv -> HscEnv) -> (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags))
DynFlags
dflags' <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DynFlags -> m ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setTopSessionDynFlags DynFlags
dflags'
[] -> FilePath -> m ()
forall a. HasCallStack => FilePath -> a
panic FilePath
"nohue"
[UnitId]
_ -> FilePath -> m ()
forall a. HasCallStack => FilePath -> a
panic FilePath
"setSessionDynFlags can only be used with a single home unit"
setUnitDynFlags :: GhcMonad m => UnitId -> DynFlags -> m ()
setUnitDynFlags :: forall (m :: * -> *). GhcMonad m => UnitId -> DynFlags -> m ()
setUnitDynFlags UnitId
uid DynFlags
dflags0 = do
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
DynFlags
dflags1 <- Logger -> DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags Logger
logger DynFlags
dflags0
UnitId -> DynFlags -> m ()
forall (m :: * -> *). GhcMonad m => UnitId -> DynFlags -> m ()
setUnitDynFlagsNoCheck UnitId
uid DynFlags
dflags1
setUnitDynFlagsNoCheck :: GhcMonad m => UnitId -> DynFlags -> m ()
setUnitDynFlagsNoCheck :: forall (m :: * -> *). GhcMonad m => UnitId -> DynFlags -> m ()
setUnitDynFlagsNoCheck UnitId
uid DynFlags
dflags1 = do
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let old_hue :: HomeUnitEnv
old_hue = (() :: Constraint) => UnitId -> UnitEnv -> HomeUnitEnv
UnitId -> UnitEnv -> HomeUnitEnv
ue_findHomeUnitEnv UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
let cached_unit_dbs :: Maybe [UnitDatabase UnitId]
cached_unit_dbs = HomeUnitEnv -> Maybe [UnitDatabase UnitId]
homeUnitEnv_unit_dbs HomeUnitEnv
old_hue
([UnitDatabase UnitId]
dbs,UnitState
unit_state,HomeUnit
home_unit,Maybe PlatformConstants
mconstants) <- IO
([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
-> m ([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
-> m ([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants))
-> IO
([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
-> m ([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> Set UnitId
-> IO
([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags1 Maybe [UnitDatabase UnitId]
cached_unit_dbs (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env)
DynFlags
updated_dflags <- IO DynFlags -> m DynFlags
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> m DynFlags) -> IO DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe PlatformConstants -> IO DynFlags
updatePlatformConstants DynFlags
dflags1 Maybe PlatformConstants
mconstants
let upd :: HomeUnitEnv -> HomeUnitEnv
upd HomeUnitEnv
hue =
HomeUnitEnv
hue
{ homeUnitEnv_units = unit_state
, homeUnitEnv_unit_dbs = Just dbs
, homeUnitEnv_dflags = updated_dflags
, homeUnitEnv_home_unit = Just home_unit
}
let unit_env :: UnitEnv
unit_env = (HomeUnitEnv -> HomeUnitEnv) -> UnitId -> UnitEnv -> UnitEnv
ue_updateHomeUnitEnv HomeUnitEnv -> HomeUnitEnv
upd UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
let dflags :: DynFlags
dflags = DynFlags
updated_dflags
let unit_env0 :: UnitEnv
unit_env0 = UnitEnv
unit_env
{ ue_platform = targetPlatform dflags
, ue_namever = ghcNameVersion dflags
}
let !unit_env1 :: UnitEnv
unit_env1 =
if DynFlags -> UnitId
homeUnitId_ DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitId
uid
then
(() :: Constraint) => UnitId -> UnitId -> UnitEnv -> UnitEnv
UnitId -> UnitId -> UnitEnv -> UnitEnv
ue_renameUnitId
UnitId
uid
(DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
UnitEnv
unit_env0
else UnitEnv
unit_env0
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
h -> HscEnv
h{ hsc_unit_env = unit_env1
}
m ()
forall (m :: * -> *). GhcMonad m => m ()
invalidateModSummaryCache
setTopSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setTopSessionDynFlags :: forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setTopSessionDynFlags DynFlags
dflags = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
Maybe Interp
interp <- if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags
then do
let
prog :: FilePath
prog = DynFlags -> FilePath
pgm_i DynFlags
dflags FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
flavour
profiled :: Bool
profiled = DynFlags -> Ways
ways DynFlags
dflags Ways -> Way -> Bool
`hasWay` Way
WayProf
dynamic :: Bool
dynamic = DynFlags -> Ways
ways DynFlags
dflags Ways -> Way -> Bool
`hasWay` Way
WayDyn
flavour :: FilePath
flavour
| Bool
profiled = FilePath
"-prof"
| Bool
dynamic = FilePath
"-dyn"
| Bool
otherwise = FilePath
""
msg :: SDoc
msg = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Starting " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
prog
IO ()
tr <- if DynFlags -> Int
verbosity DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
then IO () -> m (IO ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> SDoc -> IO ()
logInfo Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle SDoc
msg)
else IO () -> m (IO ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
let
conf :: IServConfig
conf = IServConfig
{ iservConfProgram :: FilePath
iservConfProgram = FilePath
prog
, iservConfOpts :: [FilePath]
iservConfOpts = DynFlags -> (DynFlags -> [FilePath]) -> [FilePath]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [FilePath]
opt_i
, iservConfProfiled :: Bool
iservConfProfiled = Bool
profiled
, iservConfDynamic :: Bool
iservConfDynamic = Bool
dynamic
, iservConfHook :: Maybe (CreateProcess -> IO ProcessHandle)
iservConfHook = Hooks -> Maybe (CreateProcess -> IO ProcessHandle)
createIservProcessHook (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env)
, iservConfTrace :: IO ()
iservConfTrace = IO ()
tr
}
MVar IServState
s <- IO (MVar IServState) -> m (MVar IServState)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar IServState) -> m (MVar IServState))
-> IO (MVar IServState) -> m (MVar IServState)
forall a b. (a -> b) -> a -> b
$ IServState -> IO (MVar IServState)
forall a. a -> IO (MVar a)
newMVar IServState
IServPending
Loader
loader <- IO Loader -> m Loader
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Loader
Loader.uninitializedLoader
Maybe Interp -> m (Maybe Interp)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Interp -> Maybe Interp
forall a. a -> Maybe a
Just (InterpInstance -> Loader -> Interp
Interp (IServConfig -> IServ -> InterpInstance
ExternalInterp IServConfig
conf (MVar IServState -> IServ
IServ MVar IServState
s)) Loader
loader))
else
#if defined(HAVE_INTERNAL_INTERPRETER)
do
Loader
loader <- IO Loader -> m Loader
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Loader
Loader.uninitializedLoader
Maybe Interp -> m (Maybe Interp)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Interp -> Maybe Interp
forall a. a -> Maybe a
Just (InterpInstance -> Loader -> Interp
Interp InterpInstance
InternalInterp Loader
loader))
#else
return Nothing
#endif
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
h -> (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags
HscEnv
h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags }
, hsc_interp = hsc_interp h <|> interp
}
m ()
forall (m :: * -> *). GhcMonad m => m ()
invalidateModSummaryCache
setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
setProgramDynFlags :: forall (m :: * -> *). GhcMonad m => DynFlags -> m Bool
setProgramDynFlags DynFlags
dflags = Bool -> DynFlags -> m Bool
forall (m :: * -> *). GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ Bool
True DynFlags
dflags
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ :: forall (m :: * -> *). GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ Bool
invalidate_needed DynFlags
dflags = do
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
DynFlags
dflags0 <- Logger -> DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags Logger
logger DynFlags
dflags
DynFlags
dflags_prev <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getProgramDynFlags
let changed :: Bool
changed = DynFlags -> DynFlags -> Bool
packageFlagsChanged DynFlags
dflags_prev DynFlags
dflags0
if Bool
changed
then do
UnitEnv
old_unit_env <- (() :: Constraint) => DynFlags -> UnitEnv -> UnitEnv
DynFlags -> UnitEnv -> UnitEnv
ue_setFlags DynFlags
dflags0 (UnitEnv -> UnitEnv) -> (HscEnv -> UnitEnv) -> HscEnv -> UnitEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env (HscEnv -> UnitEnv) -> m HscEnv -> m UnitEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
UnitEnvGraph HomeUnitEnv
home_unit_graph <- UnitEnvGraph HomeUnitEnv
-> (HomeUnitEnv -> m HomeUnitEnv) -> m (UnitEnvGraph HomeUnitEnv)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (UnitEnv -> UnitEnvGraph HomeUnitEnv
ue_home_unit_graph UnitEnv
old_unit_env) ((HomeUnitEnv -> m HomeUnitEnv) -> m (UnitEnvGraph HomeUnitEnv))
-> (HomeUnitEnv -> m HomeUnitEnv) -> m (UnitEnvGraph HomeUnitEnv)
forall a b. (a -> b) -> a -> b
$ \HomeUnitEnv
homeUnitEnv -> do
let cached_unit_dbs :: Maybe [UnitDatabase UnitId]
cached_unit_dbs = HomeUnitEnv -> Maybe [UnitDatabase UnitId]
homeUnitEnv_unit_dbs HomeUnitEnv
homeUnitEnv
dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
homeUnitEnv
old_hpt :: HomePackageTable
old_hpt = HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
homeUnitEnv
home_units :: Set UnitId
home_units = UnitEnvGraph HomeUnitEnv -> Set UnitId
forall v. UnitEnvGraph v -> Set UnitId
unitEnv_keys (UnitEnv -> UnitEnvGraph HomeUnitEnv
ue_home_unit_graph UnitEnv
old_unit_env)
([UnitDatabase UnitId]
dbs,UnitState
unit_state,HomeUnit
home_unit,Maybe PlatformConstants
mconstants) <- IO
([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
-> m ([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
-> m ([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants))
-> IO
([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
-> m ([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> Set UnitId
-> IO
([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags Maybe [UnitDatabase UnitId]
cached_unit_dbs Set UnitId
home_units
DynFlags
updated_dflags <- IO DynFlags -> m DynFlags
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> m DynFlags) -> IO DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe PlatformConstants -> IO DynFlags
updatePlatformConstants DynFlags
dflags0 Maybe PlatformConstants
mconstants
HomeUnitEnv -> m HomeUnitEnv
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HomeUnitEnv
{ homeUnitEnv_units :: UnitState
homeUnitEnv_units = UnitState
unit_state
, homeUnitEnv_unit_dbs :: Maybe [UnitDatabase UnitId]
homeUnitEnv_unit_dbs = [UnitDatabase UnitId] -> Maybe [UnitDatabase UnitId]
forall a. a -> Maybe a
Just [UnitDatabase UnitId]
dbs
, homeUnitEnv_dflags :: DynFlags
homeUnitEnv_dflags = DynFlags
updated_dflags
, homeUnitEnv_hpt :: HomePackageTable
homeUnitEnv_hpt = HomePackageTable
old_hpt
, homeUnitEnv_home_unit :: Maybe HomeUnit
homeUnitEnv_home_unit = HomeUnit -> Maybe HomeUnit
forall a. a -> Maybe a
Just HomeUnit
home_unit
}
let dflags1 :: DynFlags
dflags1 = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags (HomeUnitEnv -> DynFlags) -> HomeUnitEnv -> DynFlags
forall a b. (a -> b) -> a -> b
$ UnitId -> UnitEnvGraph HomeUnitEnv -> HomeUnitEnv
forall v. UnitId -> UnitEnvGraph v -> v
unitEnv_lookup (UnitEnv -> UnitId
ue_currentUnit UnitEnv
old_unit_env) UnitEnvGraph HomeUnitEnv
home_unit_graph
let unit_env :: UnitEnv
unit_env = UnitEnv
{ ue_platform :: Platform
ue_platform = DynFlags -> Platform
targetPlatform DynFlags
dflags1
, ue_namever :: GhcNameVersion
ue_namever = DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags1
, ue_home_unit_graph :: UnitEnvGraph HomeUnitEnv
ue_home_unit_graph = UnitEnvGraph HomeUnitEnv
home_unit_graph
, ue_current_unit :: UnitId
ue_current_unit = UnitEnv -> UnitId
ue_currentUnit UnitEnv
old_unit_env
, ue_eps :: ExternalUnitCache
ue_eps = UnitEnv -> ExternalUnitCache
ue_eps UnitEnv
old_unit_env
}
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
h -> (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags1 HscEnv
h{ hsc_unit_env = unit_env }
else (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags0)
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
invalidate_needed (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: * -> *). GhcMonad m => m ()
invalidateModSummaryCache
Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
changed
invalidateModSummaryCache :: GhcMonad m => m ()
invalidateModSummaryCache :: forall (m :: * -> *). GhcMonad m => m ()
invalidateModSummaryCache =
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
h -> HscEnv
h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }
where
inval :: ModSummary -> ModSummary
inval ModSummary
ms = ModSummary
ms { ms_hs_hash = fingerprint0 }
getProgramDynFlags :: GhcMonad m => m DynFlags
getProgramDynFlags :: forall (m :: * -> *). GhcMonad m => m DynFlags
getProgramDynFlags = m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags :: forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags DynFlags
dflags = do
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
DynFlags
dflags' <- Logger -> DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags Logger
logger DynFlags
dflags
DynFlags
dflags'' <- Logger -> DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewInteractiveDynFlags Logger
logger DynFlags
dflags'
(HscEnv -> m HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> m HscEnv) -> m ()
modifySessionM ((HscEnv -> m HscEnv) -> m ()) -> (HscEnv -> m HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env0 -> do
let ic0 :: InteractiveContext
ic0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env0
HscEnv
plugin_env <- IO HscEnv -> m HscEnv
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO HscEnv
initializePlugins (HscEnv -> IO HscEnv) -> HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
mkInteractiveHscEnv (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$
HscEnv
hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }}
HscEnv -> m HscEnv
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv -> m HscEnv) -> HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env0
{ hsc_IC = ic0
{ ic_plugins = hsc_plugins plugin_env
, ic_dflags = hsc_dflags plugin_env
}
}
getInteractiveDynFlags :: GhcMonad m => m DynFlags
getInteractiveDynFlags :: forall (m :: * -> *). GhcMonad m => m DynFlags
getInteractiveDynFlags = (HscEnv -> m DynFlags) -> m DynFlags
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m DynFlags) -> m DynFlags)
-> (HscEnv -> m DynFlags) -> m DynFlags
forall a b. (a -> b) -> a -> b
$ \HscEnv
h -> DynFlags -> m DynFlags
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (InteractiveContext -> DynFlags
ic_dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
h))
parseDynamicFlags
:: MonadIO m
=> Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags :: forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFlags Logger
logger DynFlags
dflags [Located FilePath]
cmdline = do
(DynFlags
dflags1, [Located FilePath]
leftovers, [Warn]
warns) <- DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFlagsCmdLine DynFlags
dflags [Located FilePath]
cmdline
let logger1 :: Logger
logger1 = Logger -> LogFlags -> Logger
setLogFlags Logger
logger (DynFlags -> LogFlags
initLogFlags DynFlags
dflags1)
DynFlags
dflags2 <- IO DynFlags -> m DynFlags
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> m DynFlags) -> IO DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> IO DynFlags
interpretPackageEnv Logger
logger1 DynFlags
dflags1
(DynFlags, [Located FilePath], [Warn])
-> m (DynFlags, [Located FilePath], [Warn])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags2, [Located FilePath]
leftovers, [Warn]
warns)
parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
parseTargetFiles :: DynFlags
-> [FilePath] -> (DynFlags, [(FilePath, Maybe Phase)], [FilePath])
parseTargetFiles DynFlags
dflags0 [FilePath]
fileish_args =
let
normal_fileish_paths :: [FilePath]
normal_fileish_paths = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
normalise_hyp [FilePath]
fileish_args
([(FilePath, Maybe Phase)]
srcs, [FilePath]
raw_objs) = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
normal_fileish_paths [] []
objs :: [FilePath]
objs = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> FilePath -> FilePath
augmentByWorkingDirectory DynFlags
dflags0) [FilePath]
raw_objs
dflags1 :: DynFlags
dflags1 = DynFlags
dflags0 { ldInputs = map (FileOption "") objs
++ ldInputs dflags0 }
in (DynFlags
dflags1, [(FilePath, Maybe Phase)]
srcs, [FilePath]
objs)
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
-> ([(String, Maybe Phase)], [String])
partition_args :: [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [] [(FilePath, Maybe Phase)]
srcs [FilePath]
objs = ([(FilePath, Maybe Phase)] -> [(FilePath, Maybe Phase)]
forall a. [a] -> [a]
reverse [(FilePath, Maybe Phase)]
srcs, [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
objs)
partition_args (FilePath
"-x":FilePath
suff:[FilePath]
args) [(FilePath, Maybe Phase)]
srcs [FilePath]
objs
| FilePath
"none" <- FilePath
suff = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args [(FilePath, Maybe Phase)]
srcs [FilePath]
objs
| Phase
StopLn <- Phase
phase = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args [(FilePath, Maybe Phase)]
srcs ([FilePath]
slurp [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
objs)
| Bool
otherwise = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
rest ([(FilePath, Maybe Phase)]
these_srcs [(FilePath, Maybe Phase)]
-> [(FilePath, Maybe Phase)] -> [(FilePath, Maybe Phase)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Maybe Phase)]
srcs) [FilePath]
objs
where phase :: Phase
phase = FilePath -> Phase
startPhase FilePath
suff
([FilePath]
slurp,[FilePath]
rest) = (FilePath -> Bool) -> [FilePath] -> ([FilePath], [FilePath])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"-x") [FilePath]
args
these_srcs :: [(FilePath, Maybe Phase)]
these_srcs = [FilePath] -> [Maybe Phase] -> [(FilePath, Maybe Phase)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
slurp (Maybe Phase -> [Maybe Phase]
forall a. a -> [a]
repeat (Phase -> Maybe Phase
forall a. a -> Maybe a
Just Phase
phase))
partition_args (FilePath
arg:[FilePath]
args) [(FilePath, Maybe Phase)]
srcs [FilePath]
objs
| FilePath -> Bool
looks_like_an_input FilePath
arg = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args ((FilePath
arg,Maybe Phase
forall a. Maybe a
Nothing)(FilePath, Maybe Phase)
-> [(FilePath, Maybe Phase)] -> [(FilePath, Maybe Phase)]
forall a. a -> [a] -> [a]
:[(FilePath, Maybe Phase)]
srcs) [FilePath]
objs
| Bool
otherwise = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args [(FilePath, Maybe Phase)]
srcs (FilePath
argFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
objs)
looks_like_an_input :: String -> Bool
looks_like_an_input :: FilePath -> Bool
looks_like_an_input FilePath
m = FilePath -> Bool
isSourceFilename FilePath
m
Bool -> Bool -> Bool
|| FilePath -> Bool
looksLikeModuleName FilePath
m
Bool -> Bool -> Bool
|| FilePath
"-" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
m
Bool -> Bool -> Bool
|| Bool -> Bool
not (FilePath -> Bool
hasExtension FilePath
m)
normalise_hyp :: FilePath -> FilePath
normalise_hyp :: FilePath -> FilePath
normalise_hyp FilePath
fp
| Bool
strt_dot_sl Bool -> Bool -> Bool
&& FilePath
"-" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
nfp = FilePath
cur_dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
nfp
| Bool
otherwise = FilePath
nfp
where
#if defined(mingw32_HOST_OS)
strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
#else
strt_dot_sl :: Bool
strt_dot_sl = FilePath
"./" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
fp
#endif
cur_dir :: FilePath
cur_dir = Char
'.' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: [Char
pathSeparator]
nfp :: FilePath
nfp = FilePath -> FilePath
normalise FilePath
fp
checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags :: forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags Logger
logger DynFlags
dflags = do
let (DynFlags
dflags', [Located FilePath]
warnings) = DynFlags -> (DynFlags, [Located FilePath])
makeDynFlagsConsistent DynFlags
dflags
let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> GhcMessageOpts -> DiagOpts -> [Warn] -> IO ()
handleFlagWarnings Logger
logger DiagnosticOpts GhcMessage
GhcMessageOpts
print_config DiagOpts
diag_opts ((Located FilePath -> Warn) -> [Located FilePath] -> [Warn]
forall a b. (a -> b) -> [a] -> [b]
map (DiagnosticReason -> Located FilePath -> Warn
Warn DiagnosticReason
WarningWithoutFlag) [Located FilePath]
warnings)
DynFlags -> m DynFlags
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags'
checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewInteractiveDynFlags :: forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewInteractiveDynFlags Logger
logger DynFlags
dflags0 = do
if Extension -> DynFlags -> Bool
xopt Extension
LangExt.StaticPointers DynFlags
dflags0
then do
let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags0
print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags0
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger DiagnosticOpts GhcMessage
GhcMessageOpts
print_config DiagOpts
diag_opts (Messages GhcMessage -> IO ()) -> Messages GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage
(MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ (DriverMessage -> GhcMessage)
-> MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage
(MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage)
-> MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
interactiveSrcSpan DriverMessage
DriverStaticPointersNotSupported
DynFlags -> m DynFlags
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> m DynFlags) -> DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Extension -> DynFlags
xopt_unset DynFlags
dflags0 Extension
LangExt.StaticPointers
else DynFlags -> m DynFlags
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags0
setTargets :: GhcMonad m => [Target] -> m ()
setTargets :: forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target]
targets = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\HscEnv
h -> HscEnv
h{ hsc_targets = targets })
getTargets :: GhcMonad m => m [Target]
getTargets :: forall (m :: * -> *). GhcMonad m => m [Target]
getTargets = (HscEnv -> m [Target]) -> m [Target]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ([Target] -> m [Target]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Target] -> m [Target])
-> (HscEnv -> [Target]) -> HscEnv -> m [Target]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> [Target]
hsc_targets)
addTarget :: GhcMonad m => Target -> m ()
addTarget :: forall (m :: * -> *). GhcMonad m => Target -> m ()
addTarget Target
target
= (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\HscEnv
h -> HscEnv
h{ hsc_targets = target : hsc_targets h })
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget :: forall (m :: * -> *). GhcMonad m => TargetId -> m ()
removeTarget TargetId
target_id
= (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\HscEnv
h -> HscEnv
h{ hsc_targets = filter (hsc_targets h) })
where
filter :: [Target] -> [Target]
filter [Target]
targets = [ Target
t | t :: Target
t@Target { targetId :: Target -> TargetId
targetId = TargetId
id } <- [Target]
targets, TargetId
id TargetId -> TargetId -> Bool
forall a. Eq a => a -> a -> Bool
/= TargetId
target_id ]
guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target
guessTarget :: forall (m :: * -> *).
GhcMonad m =>
FilePath -> Maybe UnitId -> Maybe Phase -> m Target
guessTarget FilePath
str Maybe UnitId
mUnitId (Just Phase
phase)
= do
UnitId
tuid <- Maybe UnitId -> m UnitId
forall (m :: * -> *). GhcMonad m => Maybe UnitId -> m UnitId
unitIdOrHomeUnit Maybe UnitId
mUnitId
Target -> m Target
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId
-> Bool -> UnitId -> Maybe (InputFileBuffer, UTCTime) -> Target
Target (FilePath -> Maybe Phase -> TargetId
TargetFile FilePath
str (Phase -> Maybe Phase
forall a. a -> Maybe a
Just Phase
phase)) Bool
True UnitId
tuid Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing)
guessTarget FilePath
str Maybe UnitId
mUnitId Maybe Phase
Nothing
| FilePath -> Bool
isHaskellSrcFilename FilePath
file
= TargetId -> m Target
target (FilePath -> Maybe Phase -> TargetId
TargetFile FilePath
file Maybe Phase
forall a. Maybe a
Nothing)
| Bool
otherwise
= do Bool
exists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
hs_file
if Bool
exists
then TargetId -> m Target
target (FilePath -> Maybe Phase -> TargetId
TargetFile FilePath
hs_file Maybe Phase
forall a. Maybe a
Nothing)
else do
Bool
exists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
lhs_file
if Bool
exists
then TargetId -> m Target
target (FilePath -> Maybe Phase -> TargetId
TargetFile FilePath
lhs_file Maybe Phase
forall a. Maybe a
Nothing)
else do
if FilePath -> Bool
looksLikeModuleName FilePath
file
then TargetId -> m Target
target (ModuleName -> TargetId
TargetModule (FilePath -> ModuleName
mkModuleName FilePath
file))
else do
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
IO Target -> m Target
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Target -> m Target) -> IO Target -> m Target
forall a b. (a -> b) -> a -> b
$ GhcException -> IO Target
forall a. GhcException -> IO a
throwGhcExceptionIO
(FilePath -> GhcException
ProgramError (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (SDoc -> FilePath) -> SDoc -> FilePath
forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"target" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
file) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"is not a module name or a source file"))
where
(FilePath
file,Bool
obj_allowed)
| Char
'*':FilePath
rest <- FilePath
str = (FilePath
rest, Bool
False)
| Bool
otherwise = (FilePath
str, Bool
True)
hs_file :: FilePath
hs_file = FilePath
file FilePath -> FilePath -> FilePath
<.> FilePath
"hs"
lhs_file :: FilePath
lhs_file = FilePath
file FilePath -> FilePath -> FilePath
<.> FilePath
"lhs"
target :: TargetId -> m Target
target TargetId
tid = do
UnitId
tuid <- Maybe UnitId -> m UnitId
forall (m :: * -> *). GhcMonad m => Maybe UnitId -> m UnitId
unitIdOrHomeUnit Maybe UnitId
mUnitId
Target -> m Target
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Target -> m Target) -> Target -> m Target
forall a b. (a -> b) -> a -> b
$ TargetId
-> Bool -> UnitId -> Maybe (InputFileBuffer, UTCTime) -> Target
Target TargetId
tid Bool
obj_allowed UnitId
tuid Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing
unitIdOrHomeUnit :: GhcMonad m => Maybe UnitId -> m UnitId
unitIdOrHomeUnit :: forall (m :: * -> *). GhcMonad m => Maybe UnitId -> m UnitId
unitIdOrHomeUnit Maybe UnitId
mUnitId = do
UnitId
currentHomeUnitId <- HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId (HomeUnit -> UnitId) -> (HscEnv -> HomeUnit) -> HscEnv -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> HomeUnit
hsc_home_unit (HscEnv -> UnitId) -> m HscEnv -> m UnitId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
UnitId -> m UnitId
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnitId -> Maybe UnitId -> UnitId
forall a. a -> Maybe a -> a
fromMaybe UnitId
currentHomeUnitId Maybe UnitId
mUnitId)
workingDirectoryChanged :: GhcMonad m => m ()
workingDirectoryChanged :: forall (m :: * -> *). GhcMonad m => m ()
workingDirectoryChanged = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FinderCache -> UnitEnv -> IO ()
flushFinderCaches (HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env) (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
class ParsedMod m where
modSummary :: m -> ModSummary
parsedSource :: m -> ParsedSource
class ParsedMod m => TypecheckedMod m where
renamedSource :: m -> Maybe RenamedSource
typecheckedSource :: m -> TypecheckedSource
moduleInfo :: m -> ModuleInfo
tm_internals :: m -> (TcGblEnv, ModDetails)
class TypecheckedMod m => DesugaredMod m where
coreModule :: m -> ModGuts
data ParsedModule =
ParsedModule { ParsedModule -> ModSummary
pm_mod_summary :: ModSummary
, ParsedModule -> ParsedSource
pm_parsed_source :: ParsedSource
, :: [FilePath] }
instance ParsedMod ParsedModule where
modSummary :: ParsedModule -> ModSummary
modSummary ParsedModule
m = ParsedModule -> ModSummary
pm_mod_summary ParsedModule
m
parsedSource :: ParsedModule -> ParsedSource
parsedSource ParsedModule
m = ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
m
data TypecheckedModule =
TypecheckedModule { TypecheckedModule -> ParsedModule
tm_parsed_module :: ParsedModule
, TypecheckedModule -> Maybe RenamedSource
tm_renamed_source :: Maybe RenamedSource
, TypecheckedModule -> TypecheckedSource
tm_typechecked_source :: TypecheckedSource
, TypecheckedModule -> ModuleInfo
tm_checked_module_info :: ModuleInfo
, TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_ :: (TcGblEnv, ModDetails)
}
instance ParsedMod TypecheckedModule where
modSummary :: TypecheckedModule -> ModSummary
modSummary TypecheckedModule
m = ParsedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary (TypecheckedModule -> ParsedModule
tm_parsed_module TypecheckedModule
m)
parsedSource :: TypecheckedModule -> ParsedSource
parsedSource TypecheckedModule
m = ParsedModule -> ParsedSource
forall m. ParsedMod m => m -> ParsedSource
parsedSource (TypecheckedModule -> ParsedModule
tm_parsed_module TypecheckedModule
m)
instance TypecheckedMod TypecheckedModule where
renamedSource :: TypecheckedModule -> Maybe RenamedSource
renamedSource TypecheckedModule
m = TypecheckedModule -> Maybe RenamedSource
tm_renamed_source TypecheckedModule
m
typecheckedSource :: TypecheckedModule -> TypecheckedSource
typecheckedSource TypecheckedModule
m = TypecheckedModule -> TypecheckedSource
tm_typechecked_source TypecheckedModule
m
moduleInfo :: TypecheckedModule -> ModuleInfo
moduleInfo TypecheckedModule
m = TypecheckedModule -> ModuleInfo
tm_checked_module_info TypecheckedModule
m
tm_internals :: TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals TypecheckedModule
m = TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_ TypecheckedModule
m
data DesugaredModule =
DesugaredModule { DesugaredModule -> TypecheckedModule
dm_typechecked_module :: TypecheckedModule
, DesugaredModule -> ModGuts
dm_core_module :: ModGuts
}
instance ParsedMod DesugaredModule where
modSummary :: DesugaredModule -> ModSummary
modSummary DesugaredModule
m = TypecheckedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
parsedSource :: DesugaredModule -> ParsedSource
parsedSource DesugaredModule
m = TypecheckedModule -> ParsedSource
forall m. ParsedMod m => m -> ParsedSource
parsedSource (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
instance TypecheckedMod DesugaredModule where
renamedSource :: DesugaredModule -> Maybe RenamedSource
renamedSource DesugaredModule
m = TypecheckedModule -> Maybe RenamedSource
forall m. TypecheckedMod m => m -> Maybe RenamedSource
renamedSource (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
typecheckedSource :: DesugaredModule -> TypecheckedSource
typecheckedSource DesugaredModule
m = TypecheckedModule -> TypecheckedSource
forall m. TypecheckedMod m => m -> TypecheckedSource
typecheckedSource (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
moduleInfo :: DesugaredModule -> ModuleInfo
moduleInfo DesugaredModule
m = TypecheckedModule -> ModuleInfo
forall m. TypecheckedMod m => m -> ModuleInfo
moduleInfo (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
tm_internals :: DesugaredModule -> (TcGblEnv, ModDetails)
tm_internals DesugaredModule
m = TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_ (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
instance DesugaredMod DesugaredModule where
coreModule :: DesugaredModule -> ModGuts
coreModule DesugaredModule
m = DesugaredModule -> ModGuts
dm_core_module DesugaredModule
m
type ParsedSource = Located (HsModule GhcPs)
type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
Maybe (LHsDoc GhcRn))
type TypecheckedSource = LHsBinds GhcTc
getModSummary :: GhcMonad m => ModuleName -> m ModSummary
getModSummary :: forall (m :: * -> *). GhcMonad m => ModuleName -> m ModSummary
getModSummary ModuleName
mod = do
ModuleGraph
mg <- (HscEnv -> ModuleGraph) -> m HscEnv -> m ModuleGraph
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HscEnv -> ModuleGraph
hsc_mod_graph m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let mods_by_name :: [ModSummary]
mods_by_name = [ ModSummary
ms | ModSummary
ms <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mg
, ModSummary -> ModuleName
ms_mod_name ModSummary
ms ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
mod
, ModSummary -> IsBootInterface
isBootSummary ModSummary
ms IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot ]
case [ModSummary]
mods_by_name of
[] -> do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
IO ModSummary -> m ModSummary
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> m ModSummary) -> IO ModSummary -> m ModSummary
forall a b. (a -> b) -> a -> b
$ GhcApiError -> IO ModSummary
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO ModSummary) -> GhcApiError -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Module not part of module graph")
[ModSummary
ms] -> ModSummary -> m ModSummary
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
ms
[ModSummary]
multiple -> do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
IO ModSummary -> m ModSummary
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> m ModSummary) -> IO ModSummary -> m ModSummary
forall a b. (a -> b) -> a -> b
$ GhcApiError -> IO ModSummary
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO ModSummary) -> GhcApiError -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"getModSummary is ambiguous: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ModSummary] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModSummary]
multiple)
parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule :: forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
parseModule ModSummary
ms = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
IO ParsedModule -> m ParsedModule
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ParsedModule -> m ParsedModule)
-> IO ParsedModule -> m ParsedModule
forall a b. (a -> b) -> a -> b
$ do
let lcl_hsc_env :: HscEnv
lcl_hsc_env = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) HscEnv
hsc_env
HsParsedModule
hpm <- HscEnv -> ModSummary -> IO HsParsedModule
hscParse HscEnv
lcl_hsc_env ModSummary
ms
ParsedModule -> IO ParsedModule
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> ParsedSource -> [FilePath] -> ParsedModule
ParsedModule ModSummary
ms (HsParsedModule -> ParsedSource
hpm_module HsParsedModule
hpm) (HsParsedModule -> [FilePath]
hpm_src_files HsParsedModule
hpm))
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule :: forall (m :: * -> *).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
typecheckModule ParsedModule
pmod = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
IO TypecheckedModule -> m TypecheckedModule
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TypecheckedModule -> m TypecheckedModule)
-> IO TypecheckedModule -> m TypecheckedModule
forall a b. (a -> b) -> a -> b
$ do
let ms :: ModSummary
ms = ParsedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary ParsedModule
pmod
let lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
let lcl_hsc_env :: HscEnv
lcl_hsc_env = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
lcl_dflags HscEnv
hsc_env
let lcl_logger :: Logger
lcl_logger = HscEnv -> Logger
hsc_logger HscEnv
lcl_hsc_env
(TcGblEnv
tc_gbl_env, Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe (LHsDoc GhcRn))
rn_info) <- HscEnv
-> ModSummary
-> HsParsedModule
-> IO (TcGblEnv, Maybe RenamedSource)
hscTypecheckRename HscEnv
lcl_hsc_env ModSummary
ms (HsParsedModule -> IO (TcGblEnv, Maybe RenamedSource))
-> HsParsedModule -> IO (TcGblEnv, Maybe RenamedSource)
forall a b. (a -> b) -> a -> b
$
HsParsedModule { hpm_module :: ParsedSource
hpm_module = ParsedModule -> ParsedSource
forall m. ParsedMod m => m -> ParsedSource
parsedSource ParsedModule
pmod,
hpm_src_files :: [FilePath]
hpm_src_files = ParsedModule -> [FilePath]
pm_extra_src_files ParsedModule
pmod }
ModDetails
details <- Logger -> TcGblEnv -> IO ModDetails
makeSimpleDetails Logger
lcl_logger TcGblEnv
tc_gbl_env
SafeHaskellMode
safe <- DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode DynFlags
lcl_dflags TcGblEnv
tc_gbl_env
TypecheckedModule -> IO TypecheckedModule
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypecheckedModule -> IO TypecheckedModule)
-> TypecheckedModule -> IO TypecheckedModule
forall a b. (a -> b) -> a -> b
$
TypecheckedModule {
tm_internals_ :: (TcGblEnv, ModDetails)
tm_internals_ = (TcGblEnv
tc_gbl_env, ModDetails
details),
tm_parsed_module :: ParsedModule
tm_parsed_module = ParsedModule
pmod,
tm_renamed_source :: Maybe RenamedSource
tm_renamed_source = Maybe RenamedSource
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe (LHsDoc GhcRn))
rn_info,
tm_typechecked_source :: TypecheckedSource
tm_typechecked_source = TcGblEnv -> TypecheckedSource
tcg_binds TcGblEnv
tc_gbl_env,
tm_checked_module_info :: ModuleInfo
tm_checked_module_info =
ModuleInfo {
minf_type_env :: TypeEnv
minf_type_env = ModDetails -> TypeEnv
md_types ModDetails
details,
minf_exports :: Avails
minf_exports = ModDetails -> Avails
md_exports ModDetails
details,
minf_rdr_env :: Maybe GlobalRdrEnv
minf_rdr_env = GlobalRdrEnv -> Maybe GlobalRdrEnv
forall a. a -> Maybe a
Just (TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
tc_gbl_env),
minf_instances :: [ClsInst]
minf_instances = SafeHaskellMode -> [ClsInst] -> [ClsInst]
fixSafeInstances SafeHaskellMode
safe ([ClsInst] -> [ClsInst]) -> [ClsInst] -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ InstEnv -> [ClsInst]
instEnvElts (InstEnv -> [ClsInst]) -> InstEnv -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ ModDetails -> InstEnv
md_insts ModDetails
details,
minf_iface :: Maybe ModIface
minf_iface = Maybe ModIface
forall a. Maybe a
Nothing,
minf_safe :: SafeHaskellMode
minf_safe = SafeHaskellMode
safe,
minf_modBreaks :: ModBreaks
minf_modBreaks = ModBreaks
emptyModBreaks
}}
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule :: forall (m :: * -> *).
GhcMonad m =>
TypecheckedModule -> m DesugaredModule
desugarModule TypecheckedModule
tcm = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
IO DesugaredModule -> m DesugaredModule
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DesugaredModule -> m DesugaredModule)
-> IO DesugaredModule -> m DesugaredModule
forall a b. (a -> b) -> a -> b
$ do
let ms :: ModSummary
ms = TypecheckedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary TypecheckedModule
tcm
let (TcGblEnv
tcg, ModDetails
_) = TypecheckedModule -> (TcGblEnv, ModDetails)
forall m. TypecheckedMod m => m -> (TcGblEnv, ModDetails)
tm_internals TypecheckedModule
tcm
let lcl_hsc_env :: HscEnv
lcl_hsc_env = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) HscEnv
hsc_env
ModGuts
guts <- HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar HscEnv
lcl_hsc_env ModSummary
ms TcGblEnv
tcg
DesugaredModule -> IO DesugaredModule
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DesugaredModule -> IO DesugaredModule)
-> DesugaredModule -> IO DesugaredModule
forall a b. (a -> b) -> a -> b
$
DesugaredModule {
dm_typechecked_module :: TypecheckedModule
dm_typechecked_module = TypecheckedModule
tcm,
dm_core_module :: ModGuts
dm_core_module = ModGuts
guts
}
data CoreModule
= CoreModule {
CoreModule -> Module
cm_module :: !Module,
CoreModule -> TypeEnv
cm_types :: !TypeEnv,
CoreModule -> CoreProgram
cm_binds :: CoreProgram,
CoreModule -> SafeHaskellMode
cm_safe :: SafeHaskellMode
}
instance Outputable CoreModule where
ppr :: CoreModule -> SDoc
ppr (CoreModule {cm_module :: CoreModule -> Module
cm_module = Module
mn, cm_types :: CoreModule -> TypeEnv
cm_types = TypeEnv
te, cm_binds :: CoreModule -> CoreProgram
cm_binds = CoreProgram
cb,
cm_safe :: CoreModule -> SafeHaskellMode
cm_safe = SafeHaskellMode
sf})
= FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"%module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mn SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SafeHaskellMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr SafeHaskellMode
sf) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeEnv
te
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((CoreBind -> SDoc) -> CoreProgram -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreProgram
cb)
compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
compileToCoreModule :: forall (m :: * -> *). GhcMonad m => FilePath -> m CoreModule
compileToCoreModule = Bool -> FilePath -> m CoreModule
forall (m :: * -> *).
GhcMonad m =>
Bool -> FilePath -> m CoreModule
compileCore Bool
False
compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
compileToCoreSimplified :: forall (m :: * -> *). GhcMonad m => FilePath -> m CoreModule
compileToCoreSimplified = Bool -> FilePath -> m CoreModule
forall (m :: * -> *).
GhcMonad m =>
Bool -> FilePath -> m CoreModule
compileCore Bool
True
compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
compileCore :: forall (m :: * -> *).
GhcMonad m =>
Bool -> FilePath -> m CoreModule
compileCore Bool
simplify FilePath
fn = do
Target
target <- FilePath -> Maybe UnitId -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
FilePath -> Maybe UnitId -> Maybe Phase -> m Target
guessTarget FilePath
fn Maybe UnitId
forall a. Maybe a
Nothing Maybe Phase
forall a. Maybe a
Nothing
Target -> m ()
forall (m :: * -> *). GhcMonad m => Target -> m ()
addTarget Target
target
SuccessFlag
_ <- LoadHowMuch -> m SuccessFlag
forall (f :: * -> *). GhcMonad f => LoadHowMuch -> f SuccessFlag
load LoadHowMuch
LoadAllTargets
ModuleGraph
modGraph <- [ModuleName] -> Bool -> m ModuleGraph
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [] Bool
True
case (ModSummary -> Bool) -> [ModSummary] -> Maybe ModSummary
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
fn) (FilePath -> Bool)
-> (ModSummary -> FilePath) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> FilePath
msHsFilePath) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
modGraph) of
Just ModSummary
modSummary -> do
(TcGblEnv
tcg, ModGuts
mod_guts) <-
do TypecheckedModule
tm <- ParsedModule -> m TypecheckedModule
forall (m :: * -> *).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
typecheckModule (ParsedModule -> m TypecheckedModule)
-> m ParsedModule -> m TypecheckedModule
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModSummary -> m ParsedModule
forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
parseModule ModSummary
modSummary
let tcg :: TcGblEnv
tcg = (TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a, b) -> a
fst (TypecheckedModule -> (TcGblEnv, ModDetails)
forall m. TypecheckedMod m => m -> (TcGblEnv, ModDetails)
tm_internals TypecheckedModule
tm)
(,) TcGblEnv
tcg (ModGuts -> (TcGblEnv, ModGuts))
-> (DesugaredModule -> ModGuts)
-> DesugaredModule
-> (TcGblEnv, ModGuts)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DesugaredModule -> ModGuts
forall m. DesugaredMod m => m -> ModGuts
coreModule (DesugaredModule -> (TcGblEnv, ModGuts))
-> m DesugaredModule -> m (TcGblEnv, ModGuts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypecheckedModule -> m DesugaredModule
forall (m :: * -> *).
GhcMonad m =>
TypecheckedModule -> m DesugaredModule
desugarModule TypecheckedModule
tm
(Either (CgGuts, ModDetails) ModGuts -> CoreModule)
-> m (Either (CgGuts, ModDetails) ModGuts) -> m CoreModule
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (SafeHaskellMode
-> Either (CgGuts, ModDetails) ModGuts -> CoreModule
gutsToCoreModule (ModGuts -> SafeHaskellMode
mg_safe_haskell ModGuts
mod_guts)) (m (Either (CgGuts, ModDetails) ModGuts) -> m CoreModule)
-> m (Either (CgGuts, ModDetails) ModGuts) -> m CoreModule
forall a b. (a -> b) -> a -> b
$
if Bool
simplify
then do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
ModGuts
simpl_guts <- IO ModGuts -> m ModGuts
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> m ModGuts) -> IO ModGuts -> m ModGuts
forall a b. (a -> b) -> a -> b
$ do
[FilePath]
plugins <- IORef [FilePath] -> IO [FilePath]
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef [FilePath]
tcg_th_coreplugins TcGblEnv
tcg)
HscEnv -> [FilePath] -> ModGuts -> IO ModGuts
hscSimplify HscEnv
hsc_env [FilePath]
plugins ModGuts
mod_guts
(CgGuts, ModDetails)
tidy_guts <- IO (CgGuts, ModDetails) -> m (CgGuts, ModDetails)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CgGuts, ModDetails) -> m (CgGuts, ModDetails))
-> IO (CgGuts, ModDetails) -> m (CgGuts, ModDetails)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
hscTidy HscEnv
hsc_env ModGuts
simpl_guts
Either (CgGuts, ModDetails) ModGuts
-> m (Either (CgGuts, ModDetails) ModGuts)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (CgGuts, ModDetails) ModGuts
-> m (Either (CgGuts, ModDetails) ModGuts))
-> Either (CgGuts, ModDetails) ModGuts
-> m (Either (CgGuts, ModDetails) ModGuts)
forall a b. (a -> b) -> a -> b
$ (CgGuts, ModDetails) -> Either (CgGuts, ModDetails) ModGuts
forall a b. a -> Either a b
Left (CgGuts, ModDetails)
tidy_guts
else
Either (CgGuts, ModDetails) ModGuts
-> m (Either (CgGuts, ModDetails) ModGuts)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (CgGuts, ModDetails) ModGuts
-> m (Either (CgGuts, ModDetails) ModGuts))
-> Either (CgGuts, ModDetails) ModGuts
-> m (Either (CgGuts, ModDetails) ModGuts)
forall a b. (a -> b) -> a -> b
$ ModGuts -> Either (CgGuts, ModDetails) ModGuts
forall a b. b -> Either a b
Right ModGuts
mod_guts
Maybe ModSummary
Nothing -> FilePath -> m CoreModule
forall a. HasCallStack => FilePath -> a
panic "compileToCoreModule: target FilePath not found in\
module dependency graph"
where
gutsToCoreModule :: SafeHaskellMode
-> Either (CgGuts, ModDetails) ModGuts
-> CoreModule
gutsToCoreModule :: SafeHaskellMode
-> Either (CgGuts, ModDetails) ModGuts -> CoreModule
gutsToCoreModule SafeHaskellMode
safe_mode (Left (CgGuts
cg, ModDetails
md)) = CoreModule {
cm_module :: Module
cm_module = CgGuts -> Module
cg_module CgGuts
cg,
cm_types :: TypeEnv
cm_types = ModDetails -> TypeEnv
md_types ModDetails
md,
cm_binds :: CoreProgram
cm_binds = CgGuts -> CoreProgram
cg_binds CgGuts
cg,
cm_safe :: SafeHaskellMode
cm_safe = SafeHaskellMode
safe_mode
}
gutsToCoreModule SafeHaskellMode
safe_mode (Right ModGuts
mg) = CoreModule {
cm_module :: Module
cm_module = ModGuts -> Module
mg_module ModGuts
mg,
cm_types :: TypeEnv
cm_types = [Var] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv
typeEnvFromEntities (CoreProgram -> [Var]
forall b. [Bind b] -> [b]
bindersOfBinds (ModGuts -> CoreProgram
mg_binds ModGuts
mg))
(ModGuts -> [TyCon]
mg_tcs ModGuts
mg) (ModGuts -> [PatSyn]
mg_patsyns ModGuts
mg)
(ModGuts -> [FamInst]
mg_fam_insts ModGuts
mg),
cm_binds :: CoreProgram
cm_binds = ModGuts -> CoreProgram
mg_binds ModGuts
mg,
cm_safe :: SafeHaskellMode
cm_safe = SafeHaskellMode
safe_mode
}
getModuleGraph :: GhcMonad m => m ModuleGraph
getModuleGraph :: forall (m :: * -> *). GhcMonad m => m ModuleGraph
getModuleGraph = (HscEnv -> ModuleGraph) -> m HscEnv -> m ModuleGraph
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HscEnv -> ModuleGraph
hsc_mod_graph m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded :: forall (m :: * -> *). GhcMonad m => ModuleName -> m Bool
isLoaded ModuleName
m = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$! Maybe HomeModInfo -> Bool
forall a. Maybe a -> Bool
isJust (HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) ModuleName
m)
isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool
isLoadedModule :: forall (m :: * -> *). GhcMonad m => UnitId -> ModuleName -> m Bool
isLoadedModule UnitId
uid ModuleName
m = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$! Maybe HomeModInfo -> Bool
forall a. Maybe a -> Bool
isJust (UnitEnvGraph HomeUnitEnv
-> UnitId -> ModuleName -> Maybe HomeModInfo
lookupHug (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env) UnitId
uid ModuleName
m)
getBindings :: GhcMonad m => m [TyThing]
getBindings :: forall (m :: * -> *). GhcMonad m => m [TyThing]
getBindings = (HscEnv -> m [TyThing]) -> m [TyThing]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [TyThing]) -> m [TyThing])
-> (HscEnv -> m [TyThing]) -> m [TyThing]
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
[TyThing] -> m [TyThing]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyThing] -> m [TyThing]) -> [TyThing] -> m [TyThing]
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> [TyThing]
icInScopeTTs (InteractiveContext -> [TyThing])
-> InteractiveContext -> [TyThing]
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
getInsts :: forall (m :: * -> *). GhcMonad m => m ([ClsInst], [FamInst])
getInsts = (HscEnv -> m ([ClsInst], [FamInst])) -> m ([ClsInst], [FamInst])
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m ([ClsInst], [FamInst])) -> m ([ClsInst], [FamInst]))
-> (HscEnv -> m ([ClsInst], [FamInst])) -> m ([ClsInst], [FamInst])
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
let (InstEnv
inst_env, [FamInst]
fam_env) = InteractiveContext -> (InstEnv, [FamInst])
ic_instances (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
in ([ClsInst], [FamInst]) -> m ([ClsInst], [FamInst])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstEnv -> [ClsInst]
instEnvElts InstEnv
inst_env, [FamInst]
fam_env)
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx :: forall (m :: * -> *). GhcMonad m => m NamePprCtx
getNamePprCtx = (HscEnv -> m NamePprCtx) -> m NamePprCtx
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m NamePprCtx) -> m NamePprCtx)
-> (HscEnv -> m NamePprCtx) -> m NamePprCtx
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
NamePprCtx -> m NamePprCtx
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamePprCtx -> m NamePprCtx) -> NamePprCtx -> m NamePprCtx
forall a b. (a -> b) -> a -> b
$ UnitEnv -> InteractiveContext -> NamePprCtx
icNamePprCtx (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
data ModuleInfo = ModuleInfo {
ModuleInfo -> TypeEnv
minf_type_env :: TypeEnv,
ModuleInfo -> Avails
minf_exports :: [AvailInfo],
ModuleInfo -> Maybe GlobalRdrEnv
minf_rdr_env :: Maybe GlobalRdrEnv,
ModuleInfo -> [ClsInst]
minf_instances :: [ClsInst],
ModuleInfo -> Maybe ModIface
minf_iface :: Maybe ModIface,
ModuleInfo -> SafeHaskellMode
minf_safe :: SafeHaskellMode,
ModuleInfo -> ModBreaks
minf_modBreaks :: ModBreaks
}
getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)
getModuleInfo :: forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
getModuleInfo Module
mdl = (HscEnv -> m (Maybe ModuleInfo)) -> m (Maybe ModuleInfo)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe ModuleInfo)) -> m (Maybe ModuleInfo))
-> (HscEnv -> m (Maybe ModuleInfo)) -> m (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
if Module -> UnitId
moduleUnitId Module
mdl UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env
then IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo))
-> IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo HscEnv
hsc_env Module
mdl
else IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo))
-> IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo HscEnv
hsc_env Module
mdl
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo HscEnv
hsc_env Module
mdl
= do ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
ModIface
iface <- HscEnv -> Module -> IO ModIface
hscGetModuleInterface HscEnv
hsc_env Module
mdl
let
avails :: Avails
avails = ModIface -> Avails
forall (phase :: ModIfacePhase). ModIface_ phase -> Avails
mi_exports ModIface
iface
pte :: TypeEnv
pte = ExternalPackageState -> TypeEnv
eps_PTE ExternalPackageState
eps
tys :: [TyThing]
tys = [ TyThing
ty | Name
name <- (AvailInfo -> [Name]) -> Avails -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNames Avails
avails,
Just TyThing
ty <- [TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
pte Name
name] ]
Maybe ModuleInfo -> IO (Maybe ModuleInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleInfo -> Maybe ModuleInfo
forall a. a -> Maybe a
Just (ModuleInfo {
minf_type_env :: TypeEnv
minf_type_env = [TyThing] -> TypeEnv
mkTypeEnv [TyThing]
tys,
minf_exports :: Avails
minf_exports = Avails
avails,
minf_rdr_env :: Maybe GlobalRdrEnv
minf_rdr_env = GlobalRdrEnv -> Maybe GlobalRdrEnv
forall a. a -> Maybe a
Just (GlobalRdrEnv -> Maybe GlobalRdrEnv)
-> GlobalRdrEnv -> Maybe GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$! ModuleName -> Avails -> GlobalRdrEnv
availsToGlobalRdrEnv (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mdl) Avails
avails,
minf_instances :: [ClsInst]
minf_instances = FilePath -> [ClsInst]
forall a. HasCallStack => FilePath -> a
error FilePath
"getModuleInfo: instances for package module unimplemented",
minf_iface :: Maybe ModIface
minf_iface = ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface,
minf_safe :: SafeHaskellMode
minf_safe = IfaceTrustInfo -> SafeHaskellMode
getSafeMode (IfaceTrustInfo -> SafeHaskellMode)
-> IfaceTrustInfo -> SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ ModIface -> IfaceTrustInfo
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust ModIface
iface,
minf_modBreaks :: ModBreaks
minf_modBreaks = ModBreaks
emptyModBreaks
}))
availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv :: ModuleName -> Avails -> GlobalRdrEnv
availsToGlobalRdrEnv ModuleName
mod_name Avails
avails
= [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv (Maybe ImportSpec -> Avails -> [GlobalRdrElt]
gresFromAvails (ImportSpec -> Maybe ImportSpec
forall a. a -> Maybe a
Just ImportSpec
imp_spec) Avails
avails)
where
imp_spec :: ImportSpec
imp_spec = ImpSpec { is_decl :: ImpDeclSpec
is_decl = ImpDeclSpec
decl, is_item :: ImpItemSpec
is_item = ImpItemSpec
ImpAll}
decl :: ImpDeclSpec
decl = ImpDeclSpec { is_mod :: ModuleName
is_mod = ModuleName
mod_name, is_as :: ModuleName
is_as = ModuleName
mod_name,
is_qual :: Bool
is_qual = Bool
False,
is_dloc :: SrcSpan
is_dloc = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc }
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo HscEnv
hsc_env Module
mdl =
case Module -> UnitEnvGraph HomeUnitEnv -> Maybe HomeModInfo
lookupHugByModule Module
mdl (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env) of
Maybe HomeModInfo
Nothing -> Maybe ModuleInfo -> IO (Maybe ModuleInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleInfo
forall a. Maybe a
Nothing
Just HomeModInfo
hmi -> do
let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
hmi
iface :: ModIface
iface = HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi
Maybe ModuleInfo -> IO (Maybe ModuleInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleInfo -> Maybe ModuleInfo
forall a. a -> Maybe a
Just (ModuleInfo {
minf_type_env :: TypeEnv
minf_type_env = ModDetails -> TypeEnv
md_types ModDetails
details,
minf_exports :: Avails
minf_exports = ModDetails -> Avails
md_exports ModDetails
details,
minf_rdr_env :: Maybe GlobalRdrEnv
minf_rdr_env = ModIface -> Maybe GlobalRdrEnv
forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe GlobalRdrEnv
mi_globals (ModIface -> Maybe GlobalRdrEnv) -> ModIface -> Maybe GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$! HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi,
minf_instances :: [ClsInst]
minf_instances = InstEnv -> [ClsInst]
instEnvElts (InstEnv -> [ClsInst]) -> InstEnv -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ ModDetails -> InstEnv
md_insts ModDetails
details,
minf_iface :: Maybe ModIface
minf_iface = ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface,
minf_safe :: SafeHaskellMode
minf_safe = IfaceTrustInfo -> SafeHaskellMode
getSafeMode (IfaceTrustInfo -> SafeHaskellMode)
-> IfaceTrustInfo -> SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ ModIface -> IfaceTrustInfo
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust ModIface
iface
,minf_modBreaks :: ModBreaks
minf_modBreaks = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi
}))
modInfoTyThings :: ModuleInfo -> [TyThing]
modInfoTyThings :: ModuleInfo -> [TyThing]
modInfoTyThings ModuleInfo
minf = TypeEnv -> [TyThing]
typeEnvElts (ModuleInfo -> TypeEnv
minf_type_env ModuleInfo
minf)
modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
modInfoTopLevelScope ModuleInfo
minf
= (GlobalRdrEnv -> [Name]) -> Maybe GlobalRdrEnv -> Maybe [Name]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GlobalRdrElt -> Name) -> [GlobalRdrElt] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> Name
greMangledName ([GlobalRdrElt] -> [Name])
-> (GlobalRdrEnv -> [GlobalRdrElt]) -> GlobalRdrEnv -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts) (ModuleInfo -> Maybe GlobalRdrEnv
minf_rdr_env ModuleInfo
minf)
modInfoExports :: ModuleInfo -> [Name]
modInfoExports :: ModuleInfo -> [Name]
modInfoExports ModuleInfo
minf = (AvailInfo -> [Name]) -> Avails -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNames (Avails -> [Name]) -> Avails -> [Name]
forall a b. (a -> b) -> a -> b
$! ModuleInfo -> Avails
minf_exports ModuleInfo
minf
modInfoExportsWithSelectors :: ModuleInfo -> [Name]
modInfoExportsWithSelectors :: ModuleInfo -> [Name]
modInfoExportsWithSelectors ModuleInfo
minf = (AvailInfo -> [Name]) -> Avails -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNamesWithSelectors (Avails -> [Name]) -> Avails -> [Name]
forall a b. (a -> b) -> a -> b
$! ModuleInfo -> Avails
minf_exports ModuleInfo
minf
modInfoInstances :: ModuleInfo -> [ClsInst]
modInfoInstances :: ModuleInfo -> [ClsInst]
modInfoInstances = ModuleInfo -> [ClsInst]
minf_instances
modInfoIsExportedName :: ModuleInfo -> Name -> Bool
modInfoIsExportedName :: ModuleInfo -> Name -> Bool
modInfoIsExportedName ModuleInfo
minf Name
name = Name -> NameSet -> Bool
elemNameSet Name
name (Avails -> NameSet
availsToNameSet (ModuleInfo -> Avails
minf_exports ModuleInfo
minf))
mkNamePprCtxForModule ::
GhcMonad m =>
ModuleInfo ->
m (Maybe NamePprCtx)
mkNamePprCtxForModule :: forall (m :: * -> *).
GhcMonad m =>
ModuleInfo -> m (Maybe NamePprCtx)
mkNamePprCtxForModule ModuleInfo
minf = (HscEnv -> m (Maybe NamePprCtx)) -> m (Maybe NamePprCtx)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe NamePprCtx)) -> m (Maybe NamePprCtx))
-> (HscEnv -> m (Maybe NamePprCtx)) -> m (Maybe NamePprCtx)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
let mk_name_ppr_ctx :: GlobalRdrEnv -> NamePprCtx
mk_name_ppr_ctx = PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
mkNamePprCtx PromotionTickContext
ptc (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
ptc :: PromotionTickContext
ptc = DynFlags -> PromotionTickContext
initPromotionTickContext (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
Maybe NamePprCtx -> m (Maybe NamePprCtx)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((GlobalRdrEnv -> NamePprCtx)
-> Maybe GlobalRdrEnv -> Maybe NamePprCtx
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GlobalRdrEnv -> NamePprCtx
mk_name_ppr_ctx (ModuleInfo -> Maybe GlobalRdrEnv
minf_rdr_env ModuleInfo
minf))
modInfoLookupName :: GhcMonad m =>
ModuleInfo -> Name
-> m (Maybe TyThing)
modInfoLookupName :: forall (m :: * -> *).
GhcMonad m =>
ModuleInfo -> Name -> m (Maybe TyThing)
modInfoLookupName ModuleInfo
minf Name
name = (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing))
-> (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
case TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv (ModuleInfo -> TypeEnv
minf_type_env ModuleInfo
minf) Name
name of
Just TyThing
tyThing -> Maybe TyThing -> m (Maybe TyThing)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just TyThing
tyThing)
Maybe TyThing
Nothing -> IO (Maybe TyThing) -> m (Maybe TyThing)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name)
modInfoIface :: ModuleInfo -> Maybe ModIface
modInfoIface :: ModuleInfo -> Maybe ModIface
modInfoIface = ModuleInfo -> Maybe ModIface
minf_iface
modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv
modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv
modInfoRdrEnv = ModuleInfo -> Maybe GlobalRdrEnv
minf_rdr_env
modInfoSafe :: ModuleInfo -> SafeHaskellMode
modInfoSafe :: ModuleInfo -> SafeHaskellMode
modInfoSafe = ModuleInfo -> SafeHaskellMode
minf_safe
modInfoModBreaks :: ModuleInfo -> ModBreaks
modInfoModBreaks :: ModuleInfo -> ModBreaks
modInfoModBreaks = ModuleInfo -> ModBreaks
minf_modBreaks
isDictonaryId :: Id -> Bool
isDictonaryId :: Var -> Bool
isDictonaryId Var
id
= case Type -> ([Var], ThetaType, Type)
tcSplitSigmaTy (Var -> Type
idType Var
id) of {
([Var]
_tvs, ThetaType
_theta, Type
tau) -> Type -> Bool
isDictTy Type
tau }
lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupGlobalName :: forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
lookupGlobalName Name
name = (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing))
-> (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
IO (Maybe TyThing) -> m (Maybe TyThing)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe TyThing) -> m (Maybe TyThing))
-> IO (Maybe TyThing) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name
findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
findGlobalAnns :: forall (m :: * -> *) a.
(GhcMonad m, Typeable a) =>
([Word8] -> a) -> AnnTarget Name -> m [a]
findGlobalAnns [Word8] -> a
deserialize AnnTarget Name
target = (HscEnv -> m [a]) -> m [a]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [a]) -> m [a]) -> (HscEnv -> m [a]) -> m [a]
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
AnnEnv
ann_env <- IO AnnEnv -> m AnnEnv
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AnnEnv -> m AnnEnv) -> IO AnnEnv -> m AnnEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations HscEnv
hsc_env Maybe ModGuts
forall a. Maybe a
Nothing
[a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Word8] -> a) -> AnnEnv -> AnnTarget Name -> [a]
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> AnnTarget Name -> [a]
findAnns [Word8] -> a
deserialize AnnEnv
ann_env AnnTarget Name
target)
getGRE :: GhcMonad m => m GlobalRdrEnv
getGRE :: forall (m :: * -> *). GhcMonad m => m GlobalRdrEnv
getGRE = (HscEnv -> m GlobalRdrEnv) -> m GlobalRdrEnv
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m GlobalRdrEnv) -> m GlobalRdrEnv)
-> (HscEnv -> m GlobalRdrEnv) -> m GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env-> GlobalRdrEnv -> m GlobalRdrEnv
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GlobalRdrEnv -> m GlobalRdrEnv) -> GlobalRdrEnv -> m GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> GlobalRdrEnv
icReaderEnv (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
getNameToInstancesIndex :: GhcMonad m
=> [Module]
-> Maybe [Module]
-> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
getNameToInstancesIndex :: forall (m :: * -> *).
GhcMonad m =>
[Module]
-> Maybe [Module]
-> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
getNameToInstancesIndex [Module]
visible_mods Maybe [Module]
mods_to_load = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
IO (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
-> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
-> m (Messages TcRnMessage,
Maybe (NameEnv ([ClsInst], [FamInst]))))
-> IO
(Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
-> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRn (NameEnv ([ClsInst], [FamInst]))
-> IO
(Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn (NameEnv ([ClsInst], [FamInst]))
-> IO
(Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst]))))
-> TcRn (NameEnv ([ClsInst], [FamInst]))
-> IO
(Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
forall a b. (a -> b) -> a -> b
$
do { case Maybe [Module]
mods_to_load of
Maybe [Module]
Nothing -> HscEnv -> InteractiveContext -> IOEnv (Env TcGblEnv TcLclEnv) ()
loadUnqualIfaces HscEnv
hsc_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
Just [Module]
mods ->
let doc :: SDoc
doc = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Need interface for reporting instances in scope"
in IfG () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IfG () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ (Module -> IOEnv (Env IfGblEnv ()) ModIface) -> [Module] -> IfG ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> Module -> IOEnv (Env IfGblEnv ()) ModIface
forall lcl. SDoc -> Module -> IfM lcl ModIface
loadSysInterface SDoc
doc) [Module]
mods
; InstEnvs {InstEnv
ie_global :: InstEnv
ie_global :: InstEnvs -> InstEnv
ie_global, InstEnv
ie_local :: InstEnv
ie_local :: InstEnvs -> InstEnv
ie_local} <- TcM InstEnvs
tcGetInstEnvs
; let visible_mods' :: ModuleSet
visible_mods' = [Module] -> ModuleSet
mkModuleSet [Module]
visible_mods
; (FamInstEnv
pkg_fie, FamInstEnv
home_fie) <- TcM (FamInstEnv, FamInstEnv)
tcGetFamInstEnvs
; let cls_index :: Map Name (Seq ClsInst)
cls_index = (Seq ClsInst -> Seq ClsInst -> Seq ClsInst)
-> [(Name, Seq ClsInst)] -> Map Name (Seq ClsInst)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Seq ClsInst -> Seq ClsInst -> Seq ClsInst
forall a. Monoid a => a -> a -> a
mappend
[ (Name
n, ClsInst -> Seq ClsInst
forall a. a -> Seq a
Seq.singleton ClsInst
ispec)
| ClsInst
ispec <- InstEnv -> [ClsInst]
instEnvElts InstEnv
ie_local [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ InstEnv -> [ClsInst]
instEnvElts InstEnv
ie_global
, ModuleSet -> ClsInst -> Bool
instIsVisible ModuleSet
visible_mods' ClsInst
ispec
, Name
n <- NameSet -> [Name]
nameSetElemsStable (NameSet -> [Name]) -> NameSet -> [Name]
forall a b. (a -> b) -> a -> b
$ ClsInst -> NameSet
orphNamesOfClsInst ClsInst
ispec
]
; let fam_index :: Map Name (Seq FamInst)
fam_index = (Seq FamInst -> Seq FamInst -> Seq FamInst)
-> [(Name, Seq FamInst)] -> Map Name (Seq FamInst)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Seq FamInst -> Seq FamInst -> Seq FamInst
forall a. Monoid a => a -> a -> a
mappend
[ (Name
n, FamInst -> Seq FamInst
forall a. a -> Seq a
Seq.singleton FamInst
fispec)
| FamInst
fispec <- FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
home_fie [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
pkg_fie
, Name
n <- NameSet -> [Name]
nameSetElemsStable (NameSet -> [Name]) -> NameSet -> [Name]
forall a b. (a -> b) -> a -> b
$ FamInst -> NameSet
orphNamesOfFamInst FamInst
fispec
]
; NameEnv ([ClsInst], [FamInst])
-> TcRn (NameEnv ([ClsInst], [FamInst]))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (NameEnv ([ClsInst], [FamInst])
-> TcRn (NameEnv ([ClsInst], [FamInst])))
-> NameEnv ([ClsInst], [FamInst])
-> TcRn (NameEnv ([ClsInst], [FamInst]))
forall a b. (a -> b) -> a -> b
$ [(Name, ([ClsInst], [FamInst]))] -> NameEnv ([ClsInst], [FamInst])
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, ([ClsInst], [FamInst]))]
-> NameEnv ([ClsInst], [FamInst]))
-> [(Name, ([ClsInst], [FamInst]))]
-> NameEnv ([ClsInst], [FamInst])
forall a b. (a -> b) -> a -> b
$
[ (Name
nm, (Seq ClsInst -> [ClsInst]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq ClsInst
clss, Seq FamInst -> [FamInst]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq FamInst
fams))
| (Name
nm, (Seq ClsInst
clss, Seq FamInst
fams)) <- Map Name (Seq ClsInst, Seq FamInst)
-> [(Name, (Seq ClsInst, Seq FamInst))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Name (Seq ClsInst, Seq FamInst)
-> [(Name, (Seq ClsInst, Seq FamInst))])
-> Map Name (Seq ClsInst, Seq FamInst)
-> [(Name, (Seq ClsInst, Seq FamInst))]
forall a b. (a -> b) -> a -> b
$ ((Seq ClsInst, Seq FamInst)
-> (Seq ClsInst, Seq FamInst) -> (Seq ClsInst, Seq FamInst))
-> Map Name (Seq ClsInst, Seq FamInst)
-> Map Name (Seq ClsInst, Seq FamInst)
-> Map Name (Seq ClsInst, Seq FamInst)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (Seq ClsInst, Seq FamInst)
-> (Seq ClsInst, Seq FamInst) -> (Seq ClsInst, Seq FamInst)
forall a. Monoid a => a -> a -> a
mappend
((Seq ClsInst -> (Seq ClsInst, Seq FamInst))
-> Map Name (Seq ClsInst) -> Map Name (Seq ClsInst, Seq FamInst)
forall a b. (a -> b) -> Map Name a -> Map Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Seq FamInst
forall a. Seq a
Seq.empty) Map Name (Seq ClsInst)
cls_index)
((Seq FamInst -> (Seq ClsInst, Seq FamInst))
-> Map Name (Seq FamInst) -> Map Name (Seq ClsInst, Seq FamInst)
forall a b. (a -> b) -> Map Name a -> Map Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Seq ClsInst
forall a. Seq a
Seq.empty,) Map Name (Seq FamInst)
fam_index)
] }
dataConType :: DataCon -> Type
dataConType :: DataCon -> Type
dataConType DataCon
dc = Var -> Type
idType (DataCon -> Var
dataConWrapId DataCon
dc)
pprParenSymName :: NamedThing a => a -> SDoc
pprParenSymName :: forall a. NamedThing a => a -> SDoc
pprParenSymName a
a = OccName -> SDoc -> SDoc
parenSymOcc (a -> OccName
forall a. NamedThing a => a -> OccName
getOccName a
a) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (a -> Name
forall a. NamedThing a => a -> Name
getName a
a))
getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags)
getModuleSourceAndFlags :: ModSummary -> IO (FilePath, InputFileBuffer, DynFlags)
getModuleSourceAndFlags ModSummary
m = do
case ModLocation -> Maybe FilePath
ml_hs_file (ModLocation -> Maybe FilePath) -> ModLocation -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
m of
Maybe FilePath
Nothing -> GhcApiError -> IO (FilePath, InputFileBuffer, DynFlags)
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO (FilePath, InputFileBuffer, DynFlags))
-> GhcApiError -> IO (FilePath, InputFileBuffer, DynFlags)
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr (ModSummary -> DynFlags
ms_hspp_opts ModSummary
m) (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"No source available for module " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModSummary -> Module
ms_mod ModSummary
m))
Just FilePath
sourceFile -> do
InputFileBuffer
source <- FilePath -> IO InputFileBuffer
hGetStringBuffer FilePath
sourceFile
(FilePath, InputFileBuffer, DynFlags)
-> IO (FilePath, InputFileBuffer, DynFlags)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
sourceFile, InputFileBuffer
source, ModSummary -> DynFlags
ms_hspp_opts ModSummary
m)
getTokenStream :: ModSummary -> IO [Located Token]
getTokenStream :: ModSummary -> IO [Located Token]
getTokenStream ModSummary
mod = do
(FilePath
sourceFile, InputFileBuffer
source, DynFlags
dflags) <- ModSummary -> IO (FilePath, InputFileBuffer, DynFlags)
getModuleSourceAndFlags ModSummary
mod
let startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
sourceFile) Int
1 Int
1
case ParserOpts
-> InputFileBuffer -> RealSrcLoc -> ParseResult [Located Token]
lexTokenStream (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) InputFileBuffer
source RealSrcLoc
startLoc of
POk PState
_ [Located Token]
ts -> [Located Token] -> IO [Located Token]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Located Token]
ts
PFailed PState
pst -> Messages GhcMessage -> IO [Located Token]
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PState -> Messages PsMessage
getPsErrorMessages PState
pst)
getRichTokenStream :: ModSummary -> IO [(Located Token, String)]
getRichTokenStream :: ModSummary -> IO [(Located Token, FilePath)]
getRichTokenStream ModSummary
mod = do
(FilePath
sourceFile, InputFileBuffer
source, DynFlags
dflags) <- ModSummary -> IO (FilePath, InputFileBuffer, DynFlags)
getModuleSourceAndFlags ModSummary
mod
let startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
sourceFile) Int
1 Int
1
case ParserOpts
-> InputFileBuffer -> RealSrcLoc -> ParseResult [Located Token]
lexTokenStream (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) InputFileBuffer
source RealSrcLoc
startLoc of
POk PState
_ [Located Token]
ts -> [(Located Token, FilePath)] -> IO [(Located Token, FilePath)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Located Token, FilePath)] -> IO [(Located Token, FilePath)])
-> [(Located Token, FilePath)] -> IO [(Located Token, FilePath)]
forall a b. (a -> b) -> a -> b
$ RealSrcLoc
-> InputFileBuffer
-> [Located Token]
-> [(Located Token, FilePath)]
addSourceToTokens RealSrcLoc
startLoc InputFileBuffer
source [Located Token]
ts
PFailed PState
pst -> Messages GhcMessage -> IO [(Located Token, FilePath)]
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PState -> Messages PsMessage
getPsErrorMessages PState
pst)
addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
-> [(Located Token, String)]
addSourceToTokens :: RealSrcLoc
-> InputFileBuffer
-> [Located Token]
-> [(Located Token, FilePath)]
addSourceToTokens RealSrcLoc
_ InputFileBuffer
_ [] = []
addSourceToTokens RealSrcLoc
loc InputFileBuffer
buf (t :: Located Token
t@(L SrcSpan
span Token
_) : [Located Token]
ts)
= case SrcSpan
span of
UnhelpfulSpan UnhelpfulSpanReason
_ -> (Located Token
t,FilePath
"") (Located Token, FilePath)
-> [(Located Token, FilePath)] -> [(Located Token, FilePath)]
forall a. a -> [a] -> [a]
: RealSrcLoc
-> InputFileBuffer
-> [Located Token]
-> [(Located Token, FilePath)]
addSourceToTokens RealSrcLoc
loc InputFileBuffer
buf [Located Token]
ts
RealSrcSpan RealSrcSpan
s Maybe BufSpan
_ -> (Located Token
t,FilePath
str) (Located Token, FilePath)
-> [(Located Token, FilePath)] -> [(Located Token, FilePath)]
forall a. a -> [a] -> [a]
: RealSrcLoc
-> InputFileBuffer
-> [Located Token]
-> [(Located Token, FilePath)]
addSourceToTokens RealSrcLoc
newLoc InputFileBuffer
newBuf [Located Token]
ts
where
(RealSrcLoc
newLoc, InputFileBuffer
newBuf, FilePath
str) = FilePath
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, FilePath)
go FilePath
"" RealSrcLoc
loc InputFileBuffer
buf
start :: RealSrcLoc
start = RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
s
end :: RealSrcLoc
end = RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
s
go :: FilePath
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, FilePath)
go FilePath
acc RealSrcLoc
loc InputFileBuffer
buf | RealSrcLoc
loc RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcLoc
start = FilePath
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, FilePath)
go FilePath
acc RealSrcLoc
nLoc InputFileBuffer
nBuf
| RealSrcLoc
start RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
<= RealSrcLoc
loc Bool -> Bool -> Bool
&& RealSrcLoc
loc RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcLoc
end = FilePath
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, FilePath)
go (Char
chChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
acc) RealSrcLoc
nLoc InputFileBuffer
nBuf
| Bool
otherwise = (RealSrcLoc
loc, InputFileBuffer
buf, FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
acc)
where (Char
ch, InputFileBuffer
nBuf) = InputFileBuffer -> (Char, InputFileBuffer)
nextChar InputFileBuffer
buf
nLoc :: RealSrcLoc
nLoc = RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
loc Char
ch
showRichTokenStream :: [(Located Token, String)] -> String
showRichTokenStream :: [(Located Token, FilePath)] -> FilePath
showRichTokenStream [(Located Token, FilePath)]
ts = RealSrcLoc -> [(Located Token, FilePath)] -> FilePath -> FilePath
forall {e}.
RealSrcLoc
-> [(GenLocated SrcSpan e, FilePath)] -> FilePath -> FilePath
go RealSrcLoc
startLoc [(Located Token, FilePath)]
ts FilePath
""
where sourceFile :: FastString
sourceFile = [SrcSpan] -> FastString
getFile ([SrcSpan] -> FastString) -> [SrcSpan] -> FastString
forall a b. (a -> b) -> a -> b
$ ((Located Token, FilePath) -> SrcSpan)
-> [(Located Token, FilePath)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (Located Token -> SrcSpan)
-> ((Located Token, FilePath) -> Located Token)
-> (Located Token, FilePath)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located Token, FilePath) -> Located Token
forall a b. (a, b) -> a
fst) [(Located Token, FilePath)]
ts
getFile :: [SrcSpan] -> FastString
getFile [] = FilePath -> FastString
forall a. HasCallStack => FilePath -> a
panic FilePath
"showRichTokenStream: No source file found"
getFile (UnhelpfulSpan UnhelpfulSpanReason
_ : [SrcSpan]
xs) = [SrcSpan] -> FastString
getFile [SrcSpan]
xs
getFile (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_ : [SrcSpan]
_) = RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
s
startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
sourceFile Int
1 Int
1
go :: RealSrcLoc
-> [(GenLocated SrcSpan e, FilePath)] -> FilePath -> FilePath
go RealSrcLoc
_ [] = FilePath -> FilePath
forall a. a -> a
id
go RealSrcLoc
loc ((L SrcSpan
span e
_, FilePath
str):[(GenLocated SrcSpan e, FilePath)]
ts)
= case SrcSpan
span of
UnhelpfulSpan UnhelpfulSpanReason
_ -> RealSrcLoc
-> [(GenLocated SrcSpan e, FilePath)] -> FilePath -> FilePath
go RealSrcLoc
loc [(GenLocated SrcSpan e, FilePath)]
ts
RealSrcSpan RealSrcSpan
s Maybe BufSpan
_
| Int
locLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tokLine -> ((Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
tokCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
locCol) Char
' ') FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
(FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
str FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
(FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcLoc
-> [(GenLocated SrcSpan e, FilePath)] -> FilePath -> FilePath
go RealSrcLoc
tokEnd [(GenLocated SrcSpan e, FilePath)]
ts
| Bool
otherwise -> ((Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
tokLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
locLine) Char
'\n') FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
(FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
tokCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' ') FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
(FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
str FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
(FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcLoc
-> [(GenLocated SrcSpan e, FilePath)] -> FilePath -> FilePath
go RealSrcLoc
tokEnd [(GenLocated SrcSpan e, FilePath)]
ts
where (Int
locLine, Int
locCol) = (RealSrcLoc -> Int
srcLocLine RealSrcLoc
loc, RealSrcLoc -> Int
srcLocCol RealSrcLoc
loc)
(Int
tokLine, Int
tokCol) = (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s)
tokEnd :: RealSrcLoc
tokEnd = RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
s
findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
findModule :: forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
findModule ModuleName
mod_name Maybe FastString
maybe_pkg = do
PkgQual
pkg_qual <- ModuleName -> Maybe FastString -> m PkgQual
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m PkgQual
renamePkgQualM ModuleName
mod_name Maybe FastString
maybe_pkg
PkgQual -> ModuleName -> m Module
forall (m :: * -> *).
GhcMonad m =>
PkgQual -> ModuleName -> m Module
findQualifiedModule PkgQual
pkg_qual ModuleName
mod_name
findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
findQualifiedModule :: forall (m :: * -> *).
GhcMonad m =>
PkgQual -> ModuleName -> m Module
findQualifiedModule PkgQual
pkgqual ModuleName
mod_name = (HscEnv -> m Module) -> m Module
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Module) -> m Module)
-> (HscEnv -> m Module) -> m Module
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
let mhome_unit :: Maybe HomeUnit
mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
case PkgQual
pkgqual of
ThisPkg UnitId
uid -> do
Maybe Module
home <- UnitId -> ModuleName -> m (Maybe Module)
forall (m :: * -> *).
GhcMonad m =>
UnitId -> ModuleName -> m (Maybe Module)
lookupLoadedHomeModule UnitId
uid ModuleName
mod_name
case Maybe Module
home of
Just Module
m -> Module -> m Module
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
Maybe Module
Nothing -> IO Module -> m Module
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> m Module) -> IO Module -> m Module
forall a b. (a -> b) -> a -> b
$ do
FindResult
res <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mod_name PkgQual
pkgqual
case FindResult
res of
Found ModLocation
loc Module
m | Maybe HomeUnit -> Module -> Bool
notHomeModuleMaybe Maybe HomeUnit
mhome_unit Module
m -> Module -> IO Module
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
| Bool
otherwise -> DynFlags -> Module -> ModLocation -> IO Module
forall a. DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError DynFlags
dflags Module
m ModLocation
loc
FindResult
err -> MsgEnvelope GhcMessage -> IO Module
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO Module)
-> MsgEnvelope GhcMessage -> IO Module
forall a b. (a -> b) -> a -> b
$ HscEnv
-> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
noModError HscEnv
hsc_env SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err
PkgQual
_ -> IO Module -> m Module
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> m Module) -> IO Module -> m Module
forall a b. (a -> b) -> a -> b
$ do
FindResult
res <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mod_name PkgQual
pkgqual
case FindResult
res of
Found ModLocation
_ Module
m -> Module -> IO Module
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
FindResult
err -> MsgEnvelope GhcMessage -> IO Module
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO Module)
-> MsgEnvelope GhcMessage -> IO Module
forall a b. (a -> b) -> a -> b
$ HscEnv
-> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
noModError HscEnv
hsc_env SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err
modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError :: forall a. DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError DynFlags
dflags Module
m ModLocation
loc = GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a) -> GhcException -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> GhcException
CmdLineError (FilePath -> GhcException) -> FilePath -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (SDoc -> FilePath) -> SDoc -> FilePath
forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"module is not loaded:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"modNotLoadedError" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
loc)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
renamePkgQualM :: forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m PkgQual
renamePkgQualM ModuleName
mn Maybe FastString
p = (HscEnv -> m PkgQual) -> m PkgQual
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m PkgQual) -> m PkgQual)
-> (HscEnv -> m PkgQual) -> m PkgQual
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> PkgQual -> m PkgQual
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
renamePkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) ModuleName
mn Maybe FastString
p)
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
renameRawPkgQualM :: forall (m :: * -> *).
GhcMonad m =>
ModuleName -> RawPkgQual -> m PkgQual
renameRawPkgQualM ModuleName
mn RawPkgQual
p = (HscEnv -> m PkgQual) -> m PkgQual
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m PkgQual) -> m PkgQual)
-> (HscEnv -> m PkgQual) -> m PkgQual
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> PkgQual -> m PkgQual
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
renameRawPkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) ModuleName
mn RawPkgQual
p)
lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
lookupModule :: forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
lookupModule ModuleName
mod_name Maybe FastString
maybe_pkg = do
PkgQual
pkgqual <- ModuleName -> Maybe FastString -> m PkgQual
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m PkgQual
renamePkgQualM ModuleName
mod_name Maybe FastString
maybe_pkg
PkgQual -> ModuleName -> m Module
forall (m :: * -> *).
GhcMonad m =>
PkgQual -> ModuleName -> m Module
lookupQualifiedModule PkgQual
pkgqual ModuleName
mod_name
lookupQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
lookupQualifiedModule :: forall (m :: * -> *).
GhcMonad m =>
PkgQual -> ModuleName -> m Module
lookupQualifiedModule PkgQual
NoPkgQual ModuleName
mod_name = (HscEnv -> m Module) -> m Module
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Module) -> m Module)
-> (HscEnv -> m Module) -> m Module
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
Maybe Module
home <- UnitId -> ModuleName -> m (Maybe Module)
forall (m :: * -> *).
GhcMonad m =>
UnitId -> ModuleName -> m (Maybe Module)
lookupLoadedHomeModule (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId (HomeUnit -> UnitId) -> HomeUnit -> UnitId
forall a b. (a -> b) -> a -> b
$ HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) ModuleName
mod_name
case Maybe Module
home of
Just Module
m -> Module -> m Module
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
Maybe Module
Nothing -> IO Module -> m Module
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> m Module) -> IO Module -> m Module
forall a b. (a -> b) -> a -> b
$ do
let fc :: FinderCache
fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
let units :: UnitState
units = (() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let fopts :: FinderOpts
fopts = DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags
FindResult
res <- FinderCache
-> FinderOpts
-> UnitState
-> ModuleName
-> PkgQual
-> IO FindResult
findExposedPackageModule FinderCache
fc FinderOpts
fopts UnitState
units ModuleName
mod_name PkgQual
NoPkgQual
case FindResult
res of
Found ModLocation
_ Module
m -> Module -> IO Module
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
FindResult
err -> MsgEnvelope GhcMessage -> IO Module
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO Module)
-> MsgEnvelope GhcMessage -> IO Module
forall a b. (a -> b) -> a -> b
$ HscEnv
-> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
noModError HscEnv
hsc_env SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err
lookupQualifiedModule PkgQual
pkgqual ModuleName
mod_name = PkgQual -> ModuleName -> m Module
forall (m :: * -> *).
GhcMonad m =>
PkgQual -> ModuleName -> m Module
findQualifiedModule PkgQual
pkgqual ModuleName
mod_name
lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module)
lookupLoadedHomeModule :: forall (m :: * -> *).
GhcMonad m =>
UnitId -> ModuleName -> m (Maybe Module)
lookupLoadedHomeModule UnitId
uid ModuleName
mod_name = (HscEnv -> m (Maybe Module)) -> m (Maybe Module)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe Module)) -> m (Maybe Module))
-> (HscEnv -> m (Maybe Module)) -> m (Maybe Module)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
case UnitEnvGraph HomeUnitEnv
-> UnitId -> ModuleName -> Maybe HomeModInfo
lookupHug (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env) UnitId
uid ModuleName
mod_name of
Just HomeModInfo
mod_info -> Maybe Module -> m (Maybe Module)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> Maybe Module
forall a. a -> Maybe a
Just (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
mod_info)))
Maybe HomeModInfo
_not_a_home_module -> Maybe Module -> m (Maybe Module)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Module
forall a. Maybe a
Nothing
isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted :: forall (m :: * -> *). GhcMonad m => Module -> m Bool
isModuleTrusted Module
m = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe HscEnv
hsc_env Module
m SrcSpan
noSrcSpan
moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId)
moduleTrustReqs :: forall (m :: * -> *). GhcMonad m => Module -> m (Bool, Set UnitId)
moduleTrustReqs Module
m = (HscEnv -> m (Bool, Set UnitId)) -> m (Bool, Set UnitId)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Bool, Set UnitId)) -> m (Bool, Set UnitId))
-> (HscEnv -> m (Bool, Set UnitId)) -> m (Bool, Set UnitId)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
IO (Bool, Set UnitId) -> m (Bool, Set UnitId)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Bool, Set UnitId) -> m (Bool, Set UnitId))
-> IO (Bool, Set UnitId) -> m (Bool, Set UnitId)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
hscGetSafe HscEnv
hsc_env Module
m SrcSpan
noSrcSpan
setGHCiMonad :: GhcMonad m => String -> m ()
setGHCiMonad :: forall (m :: * -> *). GhcMonad m => FilePath -> m ()
setGHCiMonad FilePath
name = (HscEnv -> m ()) -> m ()
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m ()) -> m ()) -> (HscEnv -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
Name
ty <- IO Name -> m Name
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Name -> m Name) -> IO Name -> m Name
forall a b. (a -> b) -> a -> b
$ HscEnv -> FilePath -> IO Name
hscIsGHCiMonad HscEnv
hsc_env FilePath
name
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
s ->
let ic :: InteractiveContext
ic = (HscEnv -> InteractiveContext
hsc_IC HscEnv
s) { ic_monad = ty }
in HscEnv
s { hsc_IC = ic }
getGHCiMonad :: GhcMonad m => m Name
getGHCiMonad :: forall (m :: * -> *). GhcMonad m => m Name
getGHCiMonad = (HscEnv -> Name) -> m HscEnv -> m Name
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InteractiveContext -> Name
ic_monad (InteractiveContext -> Name)
-> (HscEnv -> InteractiveContext) -> HscEnv -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> InteractiveContext
hsc_IC) m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan :: forall (m :: * -> *). GhcMonad m => History -> m SrcSpan
getHistorySpan History
h = (HscEnv -> m SrcSpan) -> m SrcSpan
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m SrcSpan) -> m SrcSpan)
-> (HscEnv -> m SrcSpan) -> m SrcSpan
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
SrcSpan -> m SrcSpan
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> m SrcSpan) -> SrcSpan -> m SrcSpan
forall a b. (a -> b) -> a -> b
$ HscEnv -> History -> SrcSpan
GHC.Runtime.Eval.getHistorySpan HscEnv
hsc_env History
h
obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
obtainTermFromVal :: forall (m :: * -> *) a.
GhcMonad m =>
Int -> Bool -> Type -> a -> m Term
obtainTermFromVal Int
bound Bool
force Type
ty a
a = (HscEnv -> m Term) -> m Term
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Term) -> m Term) -> (HscEnv -> m Term) -> m Term
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
IO Term -> m Term
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Term -> m Term) -> IO Term -> m Term
forall a b. (a -> b) -> a -> b
$ HscEnv -> Int -> Bool -> Type -> a -> IO Term
forall a. HscEnv -> Int -> Bool -> Type -> a -> IO Term
GHC.Runtime.Eval.obtainTermFromVal HscEnv
hsc_env Int
bound Bool
force Type
ty a
a
obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
obtainTermFromId :: forall (m :: * -> *). GhcMonad m => Int -> Bool -> Var -> m Term
obtainTermFromId Int
bound Bool
force Var
id = (HscEnv -> m Term) -> m Term
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Term) -> m Term) -> (HscEnv -> m Term) -> m Term
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
IO Term -> m Term
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Term -> m Term) -> IO Term -> m Term
forall a b. (a -> b) -> a -> b
$ HscEnv -> Int -> Bool -> Var -> IO Term
GHC.Runtime.Eval.obtainTermFromId HscEnv
hsc_env Int
bound Bool
force Var
id
lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupName :: forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
lookupName Name
name =
(HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing))
-> (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
IO (Maybe TyThing) -> m (Maybe TyThing)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe TyThing) -> m (Maybe TyThing))
-> IO (Maybe TyThing) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName HscEnv
hsc_env Name
name
parser :: String
-> DynFlags
-> FilePath
-> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs)))
parser :: FilePath
-> DynFlags
-> FilePath
-> (Messages GhcMessage, Either (Messages GhcMessage) ParsedSource)
parser FilePath
str DynFlags
dflags FilePath
filename =
let
loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
filename) Int
1 Int
1
buf :: InputFileBuffer
buf = FilePath -> InputFileBuffer
stringToStringBuffer FilePath
str
in
case P ParsedSource -> PState -> ParseResult ParsedSource
forall a. P a -> PState -> ParseResult a
unP P ParsedSource
Parser.parseModule (ParserOpts -> InputFileBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) InputFileBuffer
buf RealSrcLoc
loc) of
PFailed PState
pst ->
let (Messages PsMessage
warns,Messages PsMessage
errs) = PState -> (Messages PsMessage, Messages PsMessage)
getPsMessages PState
pst in
(PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsMessage
warns, Messages GhcMessage -> Either (Messages GhcMessage) ParsedSource
forall a b. a -> Either a b
Left (Messages GhcMessage -> Either (Messages GhcMessage) ParsedSource)
-> Messages GhcMessage -> Either (Messages GhcMessage) ParsedSource
forall a b. (a -> b) -> a -> b
$ PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsMessage
errs)
POk PState
pst ParsedSource
rdr_module ->
let (Messages PsMessage
warns,Messages PsMessage
_) = PState -> (Messages PsMessage, Messages PsMessage)
getPsMessages PState
pst in
(PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsMessage
warns, ParsedSource -> Either (Messages GhcMessage) ParsedSource
forall a b. b -> Either a b
Right ParsedSource
rdr_module)
interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags
interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags
interpretPackageEnv Logger
logger DynFlags
dflags = do
Maybe FilePath
mPkgEnv <- MaybeT IO FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO FilePath -> IO (Maybe FilePath))
-> MaybeT IO FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ [MaybeT IO FilePath] -> MaybeT IO FilePath
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([MaybeT IO FilePath] -> MaybeT IO FilePath)
-> [MaybeT IO FilePath] -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ [
MaybeT IO FilePath
getCmdLineArg MaybeT IO FilePath
-> (FilePath -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
env -> [MaybeT IO FilePath] -> MaybeT IO FilePath
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
FilePath -> MaybeT IO FilePath
probeNullEnv FilePath
env
, FilePath -> MaybeT IO FilePath
probeEnvFile FilePath
env
, FilePath -> MaybeT IO FilePath
probeEnvName FilePath
env
, FilePath -> MaybeT IO FilePath
forall a. FilePath -> MaybeT IO a
cmdLineError FilePath
env
]
, MaybeT IO FilePath
getEnvVar MaybeT IO FilePath
-> (FilePath -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
env -> [MaybeT IO FilePath] -> MaybeT IO FilePath
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
FilePath -> MaybeT IO FilePath
probeNullEnv FilePath
env
, FilePath -> MaybeT IO FilePath
probeEnvFile FilePath
env
, FilePath -> MaybeT IO FilePath
probeEnvName FilePath
env
, FilePath -> MaybeT IO FilePath
forall a. FilePath -> MaybeT IO a
envError FilePath
env
]
, MaybeT IO ()
notIfHideAllPackages MaybeT IO () -> MaybeT IO FilePath -> MaybeT IO FilePath
forall a b. MaybeT IO a -> MaybeT IO b -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [MaybeT IO FilePath] -> MaybeT IO FilePath
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
MaybeT IO FilePath
findLocalEnvFile MaybeT IO FilePath
-> (FilePath -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> MaybeT IO FilePath
probeEnvFile
, FilePath -> MaybeT IO FilePath
probeEnvName FilePath
defaultEnvName
]
]
case Maybe FilePath
mPkgEnv of
Maybe FilePath
Nothing ->
DynFlags -> IO DynFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags
Just FilePath
"-" -> do
DynFlags -> IO DynFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags
Just FilePath
envfile -> do
FilePath
content <- FilePath -> IO FilePath
readFile FilePath
envfile
Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Loaded package environment from " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
envfile)
let ((Errs, Warns, ())
_, DynFlags
dflags') = CmdLineP DynFlags (Errs, Warns, ())
-> DynFlags -> ((Errs, Warns, ()), DynFlags)
forall s a. CmdLineP s a -> s -> (a, s)
runCmdLineP (EwM (CmdLineP DynFlags) () -> CmdLineP DynFlags (Errs, Warns, ())
forall (m :: * -> *) a. EwM m a -> m (Errs, Warns, a)
runEwM (FilePath -> FilePath -> EwM (CmdLineP DynFlags) ()
setFlagsFromEnvFile FilePath
envfile FilePath
content)) DynFlags
dflags
DynFlags -> IO DynFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags'
where
archOS :: ArchOS
archOS = Platform -> ArchOS
platformArchOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)
namedEnvPath :: String -> MaybeT IO FilePath
namedEnvPath :: FilePath -> MaybeT IO FilePath
namedEnvPath FilePath
name = do
FilePath
appdir <- FilePath -> ArchOS -> MaybeT IO FilePath
versionedAppDir (DynFlags -> FilePath
programName DynFlags
dflags) ArchOS
archOS
FilePath -> MaybeT IO FilePath
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> MaybeT IO FilePath) -> FilePath -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
appdir FilePath -> FilePath -> FilePath
</> FilePath
"environments" FilePath -> FilePath -> FilePath
</> FilePath
name
probeEnvName :: String -> MaybeT IO FilePath
probeEnvName :: FilePath -> MaybeT IO FilePath
probeEnvName FilePath
name = FilePath -> MaybeT IO FilePath
probeEnvFile (FilePath -> MaybeT IO FilePath)
-> MaybeT IO FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> MaybeT IO FilePath
namedEnvPath FilePath
name
probeEnvFile :: FilePath -> MaybeT IO FilePath
probeEnvFile :: FilePath -> MaybeT IO FilePath
probeEnvFile FilePath
path = do
Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> MaybeT IO Bool -> MaybeT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Bool -> MaybeT IO Bool
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (FilePath -> IO Bool
doesFileExist FilePath
path)
FilePath -> MaybeT IO FilePath
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
probeNullEnv :: FilePath -> MaybeT IO FilePath
probeNullEnv :: FilePath -> MaybeT IO FilePath
probeNullEnv FilePath
"-" = FilePath -> MaybeT IO FilePath
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"-"
probeNullEnv FilePath
_ = MaybeT IO FilePath
forall a. MaybeT IO a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
getCmdLineArg :: MaybeT IO String
getCmdLineArg :: MaybeT IO FilePath
getCmdLineArg = IO (Maybe FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe FilePath) -> MaybeT IO FilePath)
-> IO (Maybe FilePath) -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe FilePath
packageEnv DynFlags
dflags
getEnvVar :: MaybeT IO String
getEnvVar :: MaybeT IO FilePath
getEnvVar = do
Either IOError FilePath
mvar <- IO (Either IOError FilePath) -> MaybeT IO (Either IOError FilePath)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO (Either IOError FilePath)
-> MaybeT IO (Either IOError FilePath))
-> IO (Either IOError FilePath)
-> MaybeT IO (Either IOError FilePath)
forall a b. (a -> b) -> a -> b
$ IO FilePath -> IO (Either IOError FilePath)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try (IO FilePath -> IO (Either IOError FilePath))
-> IO FilePath -> IO (Either IOError FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getEnv FilePath
"GHC_ENVIRONMENT"
case Either IOError FilePath
mvar of
Right FilePath
var -> FilePath -> MaybeT IO FilePath
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
var
Left IOError
err -> if IOError -> Bool
isDoesNotExistError IOError
err then MaybeT IO FilePath
forall a. MaybeT IO a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
else IO FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO FilePath -> MaybeT IO FilePath)
-> IO FilePath -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ IOError -> IO FilePath
forall e a. Exception e => e -> IO a
throwIO IOError
err
notIfHideAllPackages :: MaybeT IO ()
notIfHideAllPackages :: MaybeT IO ()
notIfHideAllPackages =
Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideAllPackages DynFlags
dflags))
defaultEnvName :: String
defaultEnvName :: FilePath
defaultEnvName = FilePath
"default"
localEnvFileName :: FilePath
localEnvFileName :: FilePath
localEnvFileName = FilePath
".ghc.environment" FilePath -> FilePath -> FilePath
<.> ArchOS -> FilePath
versionedFilePath ArchOS
archOS
findLocalEnvFile :: MaybeT IO FilePath
findLocalEnvFile :: MaybeT IO FilePath
findLocalEnvFile = do
FilePath
curdir <- IO FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT IO FilePath
getCurrentDirectory
FilePath
homedir <- IO FilePath -> MaybeT IO FilePath
forall a. IO a -> MaybeT IO a
tryMaybeT IO FilePath
getHomeDirectory
let probe :: FilePath -> MaybeT IO FilePath
probe FilePath
dir | FilePath -> Bool
isDrive FilePath
dir Bool -> Bool -> Bool
|| FilePath
dir FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
homedir
= MaybeT IO FilePath
forall a. MaybeT IO a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
probe FilePath
dir = do
let file :: FilePath
file = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
localEnvFileName
Bool
exists <- IO Bool -> MaybeT IO Bool
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (FilePath -> IO Bool
doesFileExist FilePath
file)
if Bool
exists
then FilePath -> MaybeT IO FilePath
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
file
else FilePath -> MaybeT IO FilePath
probe (FilePath -> FilePath
takeDirectory FilePath
dir)
FilePath -> MaybeT IO FilePath
probe FilePath
curdir
cmdLineError :: String -> MaybeT IO a
cmdLineError :: forall a. FilePath -> MaybeT IO a
cmdLineError FilePath
env = IO a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO a -> MaybeT IO a)
-> (FilePath -> IO a) -> FilePath -> MaybeT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a)
-> (FilePath -> GhcException) -> FilePath -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcException
CmdLineError (FilePath -> MaybeT IO a) -> FilePath -> MaybeT IO a
forall a b. (a -> b) -> a -> b
$
FilePath
"Package environment " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
env FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not found"
envError :: String -> MaybeT IO a
envError :: forall a. FilePath -> MaybeT IO a
envError FilePath
env = IO a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO a -> MaybeT IO a)
-> (FilePath -> IO a) -> FilePath -> MaybeT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a)
-> (FilePath -> GhcException) -> FilePath -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcException
CmdLineError (FilePath -> MaybeT IO a) -> FilePath -> MaybeT IO a
forall a b. (a -> b) -> a -> b
$
FilePath
"Package environment "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
env
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (specified in GHC_ENVIRONMENT) not found"
newtype GhcApiError = GhcApiError String
instance Show GhcApiError where
show :: GhcApiError -> FilePath
show (GhcApiError FilePath
msg) = FilePath
msg
instance Exception GhcApiError
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags SDoc
msg = FilePath -> GhcApiError
GhcApiError (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags SDoc
msg)
foreign import ccall unsafe "keepCAFsForGHCi"
c_keepCAFsForGHCi :: IO Bool