{-# LANGUAGE CPP, 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,
needsTemplateHaskellOrQQ,
DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,
GhcMode(..), GhcLink(..),
parseDynamicFlags, parseTargetFiles,
getSessionDynFlags, setSessionDynFlags,
getProgramDynFlags, setProgramDynFlags, setLogAction,
getInteractiveDynFlags, setInteractiveDynFlags,
interpretPackageEnv,
Target(..), TargetId(..), Phase,
setTargets,
getTargets,
addTarget,
removeTarget,
guessTarget,
depanal, depanalE,
load, LoadHowMuch(..), InteractiveImport(..),
SuccessFlag(..), succeeded, failed,
defaultWarnErrLogger, WarnErrLogger,
workingDirectoryChanged,
parseModule, typecheckModule, desugarModule, loadModule,
ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
TypecheckedMod, ParsedMod,
moduleInfo, renamedSource, typecheckedSource,
parsedSource, coreModule,
CoreModule(..),
compileToCoreModule, compileToCoreSimplified,
ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
mgLookupModule,
ModSummary(..), ms_mod_name, ModLocation(..),
getModSummary,
getModuleGraph,
isLoaded,
topSortModuleGraph,
ModuleInfo,
getModuleInfo,
modInfoTyThings,
modInfoTopLevelScope,
modInfoExports,
modInfoExportsWithSelectors,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
modInfoIface,
modInfoRdrEnv,
modInfoSafe,
lookupGlobalName,
findGlobalAnns,
mkPrintUnqualifiedForModule,
ModIface, ModIface_(..),
SafeHaskellMode(..),
PrintUnqualified, alwaysQualify,
execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..),
resumeExec,
runDecls, runDeclsWithLocation, runParsedDecls,
parseImportDecl,
setContext, getContext,
setGHCiMonad, getGHCiMonad,
getBindings, getInsts, getPrintUnqual,
findModule, lookupModule,
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(breakInfo_number, breakInfo_module),
GHC.Runtime.Eval.back,
GHC.Runtime.Eval.forward,
Unit,
Module, mkModule, pprModule, moduleName, moduleUnit,
ModuleName, mkModuleName, moduleNameString,
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, isFunTyCon,
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, splitForAllTys, 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,
ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), ApiAnnKey,
getAnnotation, getAndRemoveAnnotation,
getAnnotationComments, getAndRemoveAnnotationComments,
unicodeAnn,
cyclicModuleErr,
) where
#include "GhclibHsVersions.h"
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.CmdLine
import GHC.Driver.Session hiding (WarnReason(..))
import GHC.Driver.Backend
import GHC.Driver.Config
import GHC.Driver.Main
import GHC.Driver.Make
import GHC.Driver.Hooks
import GHC.Driver.Pipeline ( compileOne' )
import GHC.Driver.Monad
import GHC.Driver.Ppr
import GHC.ByteCode.Types
import GHC.Runtime.Eval
import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter
import GHC.Runtime.Interpreter.Types
import GHC.Runtime.Context
import GHCi.RemoteTypes
import qualified GHC.Parser as Parser
import GHC.Parser.Lexer
import GHC.Parser.Annotation
import GHC.Parser.Errors.Ppr
import GHC.Iface.Load ( loadSysInterface )
import GHC.Hs
import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Iface.Tidy
import GHC.Data.Bag ( listToBag )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
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.SysTools.FileCleanup
import GHC.SysTools
import GHC.SysTools.BaseDir
import GHC.Utils.Error
import GHC.Utils.Monad
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
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.FVs ( orphNamesOfFamInst )
import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )
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.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.SourceFile
import GHC.Unit
import GHC.Unit.External
import GHC.Unit.State
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.Set as S
import qualified Data.Sequence as Seq
import Data.Maybe
import Data.Time
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 )
import System.Directory
import Data.List (isPrefixOf)
defaultErrorHandler :: (ExceptionMonad m)
=> FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler :: 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.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle (\SomeException
exception -> 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 IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
Just (IOException
ioe :: IOException) ->
FatalMessager -> FatalMessager
fatalErrorMsg'' FatalMessager
fm (IOException -> String
forall a. Show a => a -> String
show IOException
ioe)
Maybe IOException
_ -> case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
Just AsyncException
UserInterrupt ->
IO () -> IO ()
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 -> FatalMessager
fatalErrorMsg'' FatalMessager
fm String
"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 (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 -> FatalMessager
fatalErrorMsg'' FatalMessager
fm
(GhcException -> String
forall a. Show a => a -> String
show (String -> GhcException
Panic (SomeException -> String
forall a. Show a => a -> String
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 (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
_ -> ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
GhcException
_ -> do FatalMessager -> FatalMessager
fatalErrorMsg'' FatalMessager
fm (GhcException -> String
forall a. Show a => a -> String
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 :: 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. 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 :: Maybe String -> Ghc a -> IO a
runGhc Maybe String
mb_top_dir Ghc a
ghc = do
IORef HscEnv
ref <- HscEnv -> IO (IORef HscEnv)
forall a. a -> IO (IORef a)
newIORef (String -> HscEnv
forall a. String -> a
panic String
"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 String -> Ghc ()
forall (m :: * -> *). GhcMonad m => Maybe String -> m ()
initGhcMonad Maybe String
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 :: Maybe String -> GhcT m a -> m a
runGhcT Maybe String
mb_top_dir GhcT m a
ghct = do
IORef HscEnv
ref <- IO (IORef HscEnv) -> m (IORef HscEnv)
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 (String -> HscEnv
forall a. String -> a
panic String
"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 String -> GhcT m ()
forall (m :: * -> *). GhcMonad m => Maybe String -> m ()
initGhcMonad Maybe String
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 :: m a -> m a
withCleanupSession m a
ghc = m a
ghc m a -> m () -> m a
forall (m :: * -> *) a b. 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
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
DynFlags -> IO ()
cleanTempFiles DynFlags
dflags
DynFlags -> IO ()
cleanTempDirs DynFlags
dflags
HscEnv -> IO ()
stopInterp HscEnv
hsc_env
initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
initGhcMonad :: Maybe String -> m ()
initGhcMonad Maybe String
mb_top_dir
= do { HscEnv
env <- IO HscEnv -> m HscEnv
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
$
do { String
top_dir <- Maybe String -> IO String
findTopDir Maybe String
mb_top_dir
; Settings
mySettings <- String -> IO Settings
initSysTools String
top_dir
; LlvmConfig
myLlvmConfig <- String -> IO LlvmConfig
lazyInitLlvmConfig String
top_dir
; DynFlags
dflags <- DynFlags -> IO DynFlags
initDynFlags (Settings -> LlvmConfig -> DynFlags
defaultDynFlags Settings
mySettings LlvmConfig
myLlvmConfig)
; DynFlags -> IO ()
forall (m :: * -> *). MonadIO m => DynFlags -> m ()
checkBrokenTablesNextToCode DynFlags
dflags
; DynFlags -> IO ()
setUnsafeGlobalDynFlags DynFlags
dflags
; DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags }
; HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
env }
checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()
checkBrokenTablesNextToCode :: DynFlags -> m ()
checkBrokenTablesNextToCode DynFlags
dflags
= do { Bool
broken <- DynFlags -> m Bool
forall (m :: * -> *). MonadIO m => DynFlags -> m Bool
checkBrokenTablesNextToCode' DynFlags
dflags
; Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
broken
(m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do { Any
_ <- IO Any -> m Any
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Any -> m Any) -> IO Any -> m Any
forall a b. (a -> b) -> a -> b
$ GhcApiError -> IO Any
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO Any) -> GhcApiError -> IO Any
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags SDoc
invalidLdErr
; IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FatalMessager
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unsupported linker"
}
}
where
invalidLdErr :: SDoc
invalidLdErr = String -> SDoc
text String
"Tables-next-to-code not supported on ARM" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"when using binutils ld (please see:" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"
checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool
checkBrokenTablesNextToCode' :: DynFlags -> m Bool
checkBrokenTablesNextToCode' DynFlags
dflags
| Bool -> Bool
not (Arch -> Bool
isARM Arch
arch) = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Way
WayDyn Way -> Set Way -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` DynFlags -> Set Way
ways DynFlags
dflags = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool -> Bool
not Bool
tablesNextToCode = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool
otherwise = do
LinkerInfo
linkerInfo <- IO LinkerInfo -> m LinkerInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LinkerInfo -> m LinkerInfo) -> IO LinkerInfo -> m LinkerInfo
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO LinkerInfo
getLinkerInfo DynFlags
dflags
case LinkerInfo
linkerInfo of
GnuLD [Option]
_ -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
LinkerInfo
_ -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
arch :: Arch
arch = Platform -> Arch
platformArch Platform
platform
tablesNextToCode :: Bool
tablesNextToCode = Platform -> Bool
platformTablesNextToCode Platform
platform
setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setSessionDynFlags :: DynFlags -> m ()
setSessionDynFlags DynFlags
dflags0 = do
DynFlags
dflags1 <- DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => DynFlags -> m DynFlags
checkNewDynFlags DynFlags
dflags0
DynFlags
dflags <- IO DynFlags -> m DynFlags
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 -> IO DynFlags
initUnits DynFlags
dflags1
Maybe Interp
interp <- if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags
then do
let
prog :: String
prog = DynFlags -> String
pgm_i DynFlags
dflags String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flavour
profiled :: Bool
profiled = DynFlags -> Set Way
ways DynFlags
dflags Set Way -> Way -> Bool
`hasWay` Way
WayProf
dynamic :: Bool
dynamic = DynFlags -> Set Way
ways DynFlags
dflags Set Way -> Way -> Bool
`hasWay` Way
WayDyn
flavour :: String
flavour
| Bool
profiled = String
"-prof"
| Bool
dynamic = String
"-dyn"
| Bool
otherwise = String
""
msg :: SDoc
msg = String -> SDoc
text String
"Starting " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
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 (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> SDoc -> IO ()
logInfo DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle SDoc
msg)
else IO () -> m (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
let
conf :: IServConfig
conf = IServConfig :: String
-> [String]
-> Bool
-> Bool
-> Maybe (CreateProcess -> IO ProcessHandle)
-> IO ()
-> IServConfig
IServConfig
{ iservConfProgram :: String
iservConfProgram = String
prog
, iservConfOpts :: [String]
iservConfOpts = DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_i
, iservConfProfiled :: Bool
iservConfProfiled = Bool
profiled
, iservConfDynamic :: Bool
iservConfDynamic = Bool
dynamic
, iservConfHook :: Maybe (CreateProcess -> IO ProcessHandle)
iservConfHook = Hooks -> Maybe (CreateProcess -> IO ProcessHandle)
createIservProcessHook (DynFlags -> Hooks
hooks DynFlags
dflags)
, iservConfTrace :: IO ()
iservConfTrace = IO ()
tr
}
MVar IServState
s <- IO (MVar IServState) -> m (MVar IServState)
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
Maybe Interp -> m (Maybe Interp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Interp -> Maybe Interp
forall a. a -> Maybe a
Just (IServConfig -> IServ -> Interp
ExternalInterp IServConfig
conf (MVar IServState -> IServ
IServ MVar IServState
s)))
else
#if defined(HAVE_INTERNAL_INTERPRETER)
return (Just InternalInterp)
#else
Maybe Interp -> m (Maybe Interp)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Interp
forall a. Maybe a
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 -> HscEnv
h{ hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags
, hsc_IC :: InteractiveContext
hsc_IC = (HscEnv -> InteractiveContext
hsc_IC HscEnv
h){ ic_dflags :: DynFlags
ic_dflags = DynFlags
dflags }
, hsc_interp :: Maybe Interp
hsc_interp = HscEnv -> Maybe Interp
hsc_interp HscEnv
h Maybe Interp -> Maybe Interp -> Maybe Interp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Interp
interp
, hsc_home_unit :: HomeUnit
hsc_home_unit = DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags
}
m ()
forall (m :: * -> *). GhcMonad m => m ()
invalidateModSummaryCache
setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
setProgramDynFlags :: DynFlags -> m Bool
setProgramDynFlags DynFlags
dflags = Bool -> DynFlags -> m Bool
forall (m :: * -> *). GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ Bool
True DynFlags
dflags
setLogAction :: GhcMonad m => LogAction -> m ()
setLogAction :: LogAction -> m ()
setLogAction LogAction
action = do
DynFlags
dflags' <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getProgramDynFlags
m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> DynFlags -> m Bool
forall (m :: * -> *). GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ Bool
False (DynFlags -> m Bool) -> DynFlags -> m Bool
forall a b. (a -> b) -> a -> b
$
DynFlags
dflags' { log_action :: LogAction
log_action = LogAction
action }
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ :: Bool -> DynFlags -> m Bool
setProgramDynFlags_ Bool
invalidate_needed DynFlags
dflags = do
DynFlags
dflags' <- DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => DynFlags -> m DynFlags
checkNewDynFlags 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
dflags'
DynFlags
dflags'' <- if Bool
changed
then IO DynFlags -> m DynFlags
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 -> IO DynFlags
initUnits DynFlags
dflags'
else DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags'
(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_dflags :: DynFlags
hsc_dflags = DynFlags
dflags'' }
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
changed
invalidateModSummaryCache :: GhcMonad m => m ()
invalidateModSummaryCache :: 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 :: ModuleGraph
hsc_mod_graph = (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG ModSummary -> ModSummary
inval (HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
h) }
where
inval :: ModSummary -> ModSummary
inval ModSummary
ms = ModSummary
ms { ms_hs_date :: UTCTime
ms_hs_date = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-NominalDiffTime
1) (ModSummary -> UTCTime
ms_hs_date ModSummary
ms) }
getProgramDynFlags :: GhcMonad m => m DynFlags
getProgramDynFlags :: m DynFlags
getProgramDynFlags = m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags :: DynFlags -> m ()
setInteractiveDynFlags DynFlags
dflags = do
DynFlags
dflags' <- DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => DynFlags -> m DynFlags
checkNewDynFlags DynFlags
dflags
DynFlags
dflags'' <- DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => DynFlags -> m DynFlags
checkNewInteractiveDynFlags DynFlags
dflags'
(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_IC :: InteractiveContext
hsc_IC = (HscEnv -> InteractiveContext
hsc_IC HscEnv
h) { ic_dflags :: DynFlags
ic_dflags = DynFlags
dflags'' }}
getInteractiveDynFlags :: GhcMonad m => m DynFlags
getInteractiveDynFlags :: 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 (m :: * -> *) a. Monad m => a -> m a
return (InteractiveContext -> DynFlags
ic_dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
h))
parseDynamicFlags :: MonadIO m =>
DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags :: DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlags DynFlags
dflags [Located String]
cmdline = do
(DynFlags
dflags1, [Located String]
leftovers, [Warn]
warns) <- DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlagsCmdLine DynFlags
dflags [Located String]
cmdline
DynFlags
dflags2 <- IO DynFlags -> m DynFlags
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 -> IO DynFlags
interpretPackageEnv DynFlags
dflags1
(DynFlags, [Located String], [Warn])
-> m (DynFlags, [Located String], [Warn])
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags2, [Located String]
leftovers, [Warn]
warns)
parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
parseTargetFiles :: DynFlags
-> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
parseTargetFiles DynFlags
dflags0 [String]
fileish_args =
let
normal_fileish_paths :: [String]
normal_fileish_paths = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
normalise_hyp [String]
fileish_args
([(String, Maybe Phase)]
srcs, [String]
objs) = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
normal_fileish_paths [] []
dflags1 :: DynFlags
dflags1 = DynFlags
dflags0 { ldInputs :: [Option]
ldInputs = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Option
FileOption String
"") [String]
objs
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [Option]
ldInputs DynFlags
dflags0 }
in (DynFlags
dflags1, [(String, Maybe Phase)]
srcs, [String]
objs)
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
-> ([(String, Maybe Phase)], [String])
partition_args :: [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [] [(String, Maybe Phase)]
srcs [String]
objs = ([(String, Maybe Phase)] -> [(String, Maybe Phase)]
forall a. [a] -> [a]
reverse [(String, Maybe Phase)]
srcs, [String] -> [String]
forall a. [a] -> [a]
reverse [String]
objs)
partition_args (String
"-x":String
suff:[String]
args) [(String, Maybe Phase)]
srcs [String]
objs
| String
"none" <- String
suff = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
args [(String, Maybe Phase)]
srcs [String]
objs
| Phase
StopLn <- Phase
phase = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
args [(String, Maybe Phase)]
srcs ([String]
slurp [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
objs)
| Bool
otherwise = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
rest ([(String, Maybe Phase)]
these_srcs [(String, Maybe Phase)]
-> [(String, Maybe Phase)] -> [(String, Maybe Phase)]
forall a. [a] -> [a] -> [a]
++ [(String, Maybe Phase)]
srcs) [String]
objs
where phase :: Phase
phase = String -> Phase
startPhase String
suff
([String]
slurp,[String]
rest) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-x") [String]
args
these_srcs :: [(String, Maybe Phase)]
these_srcs = [String] -> [Maybe Phase] -> [(String, Maybe Phase)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
slurp (Maybe Phase -> [Maybe Phase]
forall a. a -> [a]
repeat (Phase -> Maybe Phase
forall a. a -> Maybe a
Just Phase
phase))
partition_args (String
arg:[String]
args) [(String, Maybe Phase)]
srcs [String]
objs
| String -> Bool
looks_like_an_input String
arg = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
args ((String
arg,Maybe Phase
forall a. Maybe a
Nothing)(String, Maybe Phase)
-> [(String, Maybe Phase)] -> [(String, Maybe Phase)]
forall a. a -> [a] -> [a]
:[(String, Maybe Phase)]
srcs) [String]
objs
| Bool
otherwise = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
args [(String, Maybe Phase)]
srcs (String
argString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
objs)
looks_like_an_input :: String -> Bool
looks_like_an_input :: String -> Bool
looks_like_an_input String
m = String -> Bool
isSourceFilename String
m
Bool -> Bool -> Bool
|| String -> Bool
looksLikeModuleName String
m
Bool -> Bool -> Bool
|| String
"-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
m
Bool -> Bool -> Bool
|| Bool -> Bool
not (String -> Bool
hasExtension String
m)
normalise_hyp :: FilePath -> FilePath
normalise_hyp :: String -> String
normalise_hyp String
fp
| Bool
strt_dot_sl Bool -> Bool -> Bool
&& String
"-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
nfp = String
cur_dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nfp
| Bool
otherwise = String
nfp
where
#if defined(mingw32_HOST_OS)
strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
#else
strt_dot_sl :: Bool
strt_dot_sl = String
"./" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
fp
#endif
cur_dir :: String
cur_dir = Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: [Char
pathSeparator]
nfp :: String
nfp = String -> String
normalise String
fp
checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags
checkNewDynFlags :: DynFlags -> m DynFlags
checkNewDynFlags DynFlags
dflags = do
let (DynFlags
dflags', [Located String]
warnings) = DynFlags -> (DynFlags, [Located String])
makeDynFlagsConsistent DynFlags
dflags
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
dflags ((Located String -> Warn) -> [Located String] -> [Warn]
forall a b. (a -> b) -> [a] -> [b]
map (WarnReason -> Located String -> Warn
Warn WarnReason
NoReason) [Located String]
warnings)
DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags'
checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags
checkNewInteractiveDynFlags :: DynFlags -> m DynFlags
checkNewInteractiveDynFlags DynFlags
dflags0 = do
if Extension -> DynFlags -> Bool
xopt Extension
LangExt.StaticPointers DynFlags
dflags0
then do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Bag WarnMsg -> IO ()
printOrThrowWarnings DynFlags
dflags0 (Bag WarnMsg -> IO ()) -> Bag WarnMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ [WarnMsg] -> Bag WarnMsg
forall a. [a] -> Bag a
listToBag
[DynFlags -> SrcSpan -> SDoc -> WarnMsg
mkPlainWarnMsg DynFlags
dflags0 SrcSpan
interactiveSrcSpan
(SDoc -> WarnMsg) -> SDoc -> WarnMsg
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"StaticPointers is not supported in GHCi interactive expressions."]
DynFlags -> m DynFlags
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 (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags0
setTargets :: GhcMonad m => [Target] -> m ()
setTargets :: [Target] -> m ()
setTargets [Target]
targets = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\HscEnv
h -> HscEnv
h{ hsc_targets :: [Target]
hsc_targets = [Target]
targets })
getTargets :: GhcMonad m => m [Target]
getTargets :: m [Target]
getTargets = (HscEnv -> m [Target]) -> m [Target]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ([Target] -> m [Target]
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 :: 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 = Target
target Target -> [Target] -> [Target]
forall a. a -> [a] -> [a]
: HscEnv -> [Target]
hsc_targets HscEnv
h })
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget :: TargetId -> m ()
removeTarget TargetId
target_id
= (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\HscEnv
h -> HscEnv
h{ hsc_targets :: [Target]
hsc_targets = [Target] -> [Target]
filter (HscEnv -> [Target]
hsc_targets HscEnv
h) })
where
filter :: [Target] -> [Target]
filter [Target]
targets = [ Target
t | t :: Target
t@(Target TargetId
id Bool
_ Maybe (InputFileBuffer, UTCTime)
_) <- [Target]
targets, TargetId
id TargetId -> TargetId -> Bool
forall a. Eq a => a -> a -> Bool
/= TargetId
target_id ]
guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
guessTarget :: String -> Maybe Phase -> m Target
guessTarget String
str (Just Phase
phase)
= Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
Target (String -> Maybe Phase -> TargetId
TargetFile String
str (Phase -> Maybe Phase
forall a. a -> Maybe a
Just Phase
phase)) Bool
True Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing)
guessTarget String
str Maybe Phase
Nothing
| String -> Bool
isHaskellSrcFilename String
file
= Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (String -> Maybe Phase -> TargetId
TargetFile String
file Maybe Phase
forall a. Maybe a
Nothing))
| Bool
otherwise
= do Bool
exists <- IO Bool -> m Bool
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
$ String -> IO Bool
doesFileExist String
hs_file
if Bool
exists
then Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (String -> Maybe Phase -> TargetId
TargetFile String
hs_file Maybe Phase
forall a. Maybe a
Nothing))
else do
Bool
exists <- IO Bool -> m Bool
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
$ String -> IO Bool
doesFileExist String
lhs_file
if Bool
exists
then Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (String -> Maybe Phase -> TargetId
TargetFile String
lhs_file Maybe Phase
forall a. Maybe a
Nothing))
else do
if String -> Bool
looksLikeModuleName String
file
then Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (ModuleName -> TargetId
TargetModule (String -> ModuleName
mkModuleName String
file)))
else do
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
IO Target -> m Target
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
(String -> GhcException
ProgramError (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"target" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
file) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"is not a module name or a source file"))
where
(String
file,Bool
obj_allowed)
| Char
'*':String
rest <- String
str = (String
rest, Bool
False)
| Bool
otherwise = (String
str, Bool
True)
hs_file :: String
hs_file = String
file String -> String -> String
<.> String
"hs"
lhs_file :: String
lhs_file = String
file String -> String -> String
<.> String
"lhs"
target :: TargetId -> Target
target TargetId
tid = TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
Target TargetId
tid Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing
workingDirectoryChanged :: GhcMonad m => m ()
workingDirectoryChanged :: m ()
workingDirectoryChanged = (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
$ (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (HscEnv -> IO ()) -> HscEnv -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> IO ()
flushFinderCaches)
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]
, ParsedModule -> ApiAnns
pm_annotations :: ApiAnns }
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
type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
Maybe LHsDocString)
type TypecheckedSource = LHsBinds GhcTc
getModSummary :: GhcMonad m => ModuleName -> m ModSummary
getModSummary :: 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 (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 (String -> SDoc
text String
"Module not part of module graph")
[ModSummary
ms] -> ModSummary -> m ModSummary
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 (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 (String -> SDoc
text String
"getModSummary is ambiguous: " SDoc -> SDoc -> SDoc
<+> [ModSummary] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModSummary]
multiple)
parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule :: ModSummary -> m ParsedModule
parseModule ModSummary
ms = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
HsParsedModule
hpm <- IO HsParsedModule -> m HsParsedModule
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HsParsedModule -> m HsParsedModule)
-> IO HsParsedModule -> m HsParsedModule
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> IO HsParsedModule
hscParse HscEnv
hsc_env_tmp ModSummary
ms
ParsedModule -> m ParsedModule
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> ParsedSource -> [String] -> ApiAnns -> ParsedModule
ParsedModule ModSummary
ms (HsParsedModule -> ParsedSource
hpm_module HsParsedModule
hpm) (HsParsedModule -> [String]
hpm_src_files HsParsedModule
hpm)
(HsParsedModule -> ApiAnns
hpm_annotations HsParsedModule
hpm))
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule :: ParsedModule -> m TypecheckedModule
typecheckModule ParsedModule
pmod = do
let ms :: ModSummary
ms = ParsedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary ParsedModule
pmod
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
(TcGblEnv
tc_gbl_env, Maybe
(HsGroup GhcRn, [Located (ImportDecl GhcRn)],
Maybe [(Located (IE GhcRn), Avails)], Maybe LHsDocString)
rn_info)
<- IO
(TcGblEnv,
Maybe
(HsGroup GhcRn, [Located (ImportDecl GhcRn)],
Maybe [(Located (IE GhcRn), Avails)], Maybe LHsDocString))
-> m (TcGblEnv,
Maybe
(HsGroup GhcRn, [Located (ImportDecl GhcRn)],
Maybe [(Located (IE GhcRn), Avails)], Maybe LHsDocString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
(TcGblEnv,
Maybe
(HsGroup GhcRn, [Located (ImportDecl GhcRn)],
Maybe [(Located (IE GhcRn), Avails)], Maybe LHsDocString))
-> m (TcGblEnv,
Maybe
(HsGroup GhcRn, [Located (ImportDecl GhcRn)],
Maybe [(Located (IE GhcRn), Avails)], Maybe LHsDocString)))
-> IO
(TcGblEnv,
Maybe
(HsGroup GhcRn, [Located (ImportDecl GhcRn)],
Maybe [(Located (IE GhcRn), Avails)], Maybe LHsDocString))
-> m (TcGblEnv,
Maybe
(HsGroup GhcRn, [Located (ImportDecl GhcRn)],
Maybe [(Located (IE GhcRn), Avails)], Maybe LHsDocString))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> HsParsedModule
-> IO (TcGblEnv, Maybe RenamedSource)
hscTypecheckRename HscEnv
hsc_env_tmp ModSummary
ms (HsParsedModule -> IO (TcGblEnv, Maybe RenamedSource))
-> HsParsedModule -> IO (TcGblEnv, Maybe RenamedSource)
forall a b. (a -> b) -> a -> b
$
HsParsedModule :: ParsedSource -> [String] -> ApiAnns -> HsParsedModule
HsParsedModule { hpm_module :: ParsedSource
hpm_module = ParsedModule -> ParsedSource
forall m. ParsedMod m => m -> ParsedSource
parsedSource ParsedModule
pmod,
hpm_src_files :: [String]
hpm_src_files = ParsedModule -> [String]
pm_extra_src_files ParsedModule
pmod,
hpm_annotations :: ApiAnns
hpm_annotations = ParsedModule -> ApiAnns
pm_annotations ParsedModule
pmod }
ModDetails
details <- IO ModDetails -> m ModDetails
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModDetails -> m ModDetails) -> IO ModDetails -> m ModDetails
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails HscEnv
hsc_env_tmp TcGblEnv
tc_gbl_env
SafeHaskellMode
safe <- IO SafeHaskellMode -> m SafeHaskellMode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SafeHaskellMode -> m SafeHaskellMode)
-> IO SafeHaskellMode -> m SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) TcGblEnv
tc_gbl_env
TypecheckedModule -> m TypecheckedModule
forall (m :: * -> *) a. Monad m => a -> m a
return (TypecheckedModule -> m TypecheckedModule)
-> TypecheckedModule -> m TypecheckedModule
forall a b. (a -> b) -> a -> b
$
TypecheckedModule :: ParsedModule
-> Maybe RenamedSource
-> TypecheckedSource
-> ModuleInfo
-> (TcGblEnv, ModDetails)
-> TypecheckedModule
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
(HsGroup GhcRn, [Located (ImportDecl GhcRn)],
Maybe [(Located (IE GhcRn), Avails)], Maybe LHsDocString)
Maybe RenamedSource
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 :: TypeEnv
-> Avails
-> Maybe GlobalRdrEnv
-> [ClsInst]
-> Maybe ModIface
-> SafeHaskellMode
-> ModBreaks
-> ModuleInfo
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
$ ModDetails -> [ClsInst]
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 :: TypecheckedModule -> m DesugaredModule
desugarModule TypecheckedModule
tcm = 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
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
ModGuts
guts <- IO ModGuts -> m ModGuts
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
$ HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar HscEnv
hsc_env_tmp ModSummary
ms TcGblEnv
tcg
DesugaredModule -> m DesugaredModule
forall (m :: * -> *) a. Monad m => a -> m a
return (DesugaredModule -> m DesugaredModule)
-> DesugaredModule -> m DesugaredModule
forall a b. (a -> b) -> a -> b
$
DesugaredModule :: TypecheckedModule -> ModGuts -> DesugaredModule
DesugaredModule {
dm_typechecked_module :: TypecheckedModule
dm_typechecked_module = TypecheckedModule
tcm,
dm_core_module :: ModGuts
dm_core_module = ModGuts
guts
}
loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
loadModule :: mod -> m mod
loadModule mod
tcm = do
let ms :: ModSummary
ms = mod -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary mod
tcm
let mod :: ModuleName
mod = ModSummary -> ModuleName
ms_mod_name ModSummary
ms
let loc :: ModLocation
loc = ModSummary -> ModLocation
ms_location ModSummary
ms
let (TcGblEnv
tcg, ModDetails
_details) = mod -> (TcGblEnv, ModDetails)
forall m. TypecheckedMod m => m -> (TcGblEnv, ModDetails)
tm_internals mod
tcm
Maybe Linkable
mb_linkable <- case ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
ms of
Just UTCTime
t | UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> ModSummary -> UTCTime
ms_hs_date ModSummary
ms -> do
Linkable
l <- IO Linkable -> m Linkable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Linkable -> m Linkable) -> IO Linkable -> m Linkable
forall a b. (a -> b) -> a -> b
$ Module -> String -> UTCTime -> IO Linkable
findObjectLinkable (ModSummary -> Module
ms_mod ModSummary
ms)
(ModLocation -> String
ml_obj_file ModLocation
loc) UTCTime
t
Maybe Linkable -> m (Maybe Linkable)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
l)
Maybe UTCTime
_otherwise -> Maybe Linkable -> m (Maybe Linkable)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Linkable
forall a. Maybe a
Nothing
let source_modified :: SourceModified
source_modified | Maybe Linkable -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Linkable
mb_linkable = SourceModified
SourceModified
| Bool
otherwise = SourceModified
SourceUnmodified
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
HomeModInfo
mod_info <- IO HomeModInfo -> m HomeModInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HomeModInfo -> m HomeModInfo)
-> IO HomeModInfo -> m HomeModInfo
forall a b. (a -> b) -> a -> b
$ Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' (TcGblEnv -> Maybe TcGblEnv
forall a. a -> Maybe a
Just TcGblEnv
tcg) Maybe Messager
forall a. Maybe a
Nothing
HscEnv
hsc_env ModSummary
ms Int
1 Int
1 Maybe ModIface
forall a. Maybe a
Nothing Maybe Linkable
mb_linkable
SourceModified
source_modified
(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
e -> HscEnv
e{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
e) ModuleName
mod HomeModInfo
mod_info }
mod -> m mod
forall (m :: * -> *) a. Monad m => a -> m a
return mod
tcm
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})
= String -> SDoc
text String
"%module" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mn SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (SafeHaskellMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr SafeHaskellMode
sf) SDoc -> SDoc -> SDoc
<+> TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeEnv
te
SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
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 :: String -> m CoreModule
compileToCoreModule = Bool -> String -> m CoreModule
forall (m :: * -> *). GhcMonad m => Bool -> String -> m CoreModule
compileCore Bool
False
compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
compileToCoreSimplified :: String -> m CoreModule
compileToCoreSimplified = Bool -> String -> m CoreModule
forall (m :: * -> *). GhcMonad m => Bool -> String -> m CoreModule
compileCore Bool
True
compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
compileCore :: Bool -> String -> m CoreModule
compileCore Bool
simplify String
fn = do
Target
target <- String -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe Phase -> m Target
guessTarget String
fn Maybe Phase
forall a. Maybe a
Nothing
Target -> m ()
forall (m :: * -> *). GhcMonad m => Target -> m ()
addTarget Target
target
SuccessFlag
_ <- LoadHowMuch -> m SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m 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 ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fn) (String -> Bool) -> (ModSummary -> String) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> String
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 (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
[String]
plugins <- IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef [String]
tcg_th_coreplugins TcGblEnv
tcg)
HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify HscEnv
hsc_env [String]
plugins ModGuts
mod_guts
(CgGuts, ModDetails)
tidy_guts <- IO (CgGuts, ModDetails) -> m (CgGuts, ModDetails)
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)
tidyProgram HscEnv
hsc_env ModGuts
simpl_guts
Either (CgGuts, ModDetails) ModGuts
-> m (Either (CgGuts, ModDetails) ModGuts)
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 (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 -> String -> m CoreModule
forall a. String -> 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 :: Module -> TypeEnv -> CoreProgram -> SafeHaskellMode -> CoreModule
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 :: Module -> TypeEnv -> CoreProgram -> SafeHaskellMode -> CoreModule
CoreModule {
cm_module :: Module
cm_module = ModGuts -> Module
mg_module ModGuts
mg,
cm_types :: TypeEnv
cm_types = [Id] -> [TyCon] -> [FamInst] -> TypeEnv
typeEnvFromEntities (CoreProgram -> [Id]
forall b. [Bind b] -> [b]
bindersOfBinds (ModGuts -> CoreProgram
mg_binds ModGuts
mg))
(ModGuts -> [TyCon]
mg_tcs 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 :: 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 :: 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 (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)
getBindings :: GhcMonad m => m [TyThing]
getBindings :: 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 (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 :: 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 ->
([ClsInst], [FamInst]) -> m ([ClsInst], [FamInst])
forall (m :: * -> *) a. Monad m => a -> m a
return (([ClsInst], [FamInst]) -> m ([ClsInst], [FamInst]))
-> ([ClsInst], [FamInst]) -> m ([ClsInst], [FamInst])
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> ([ClsInst], [FamInst])
ic_instances (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
getPrintUnqual :: GhcMonad m => m PrintUnqualified
getPrintUnqual :: m PrintUnqualified
getPrintUnqual = (HscEnv -> m PrintUnqualified) -> m PrintUnqualified
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m PrintUnqualified) -> m PrintUnqualified)
-> (HscEnv -> m PrintUnqualified) -> m PrintUnqualified
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
PrintUnqualified -> m PrintUnqualified
forall (m :: * -> *) a. Monad m => a -> m a
return (PrintUnqualified -> m PrintUnqualified)
-> PrintUnqualified -> m PrintUnqualified
forall a b. (a -> b) -> a -> b
$ UnitState -> HomeUnit -> InteractiveContext -> PrintUnqualified
icPrintUnqual
(DynFlags -> UnitState
unitState DynFlags
dflags)
(HscEnv -> HomeUnit
hsc_home_unit 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 :: 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
let mg :: ModuleGraph
mg = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env
if ModuleGraph -> Module -> Bool
mgElemModule ModuleGraph
mg Module
mdl
then IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
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 do
IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
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 (m :: * -> *) a. Monad m => a -> m a
return (ModuleInfo -> Maybe ModuleInfo
forall a. a -> Maybe a
Just (ModuleInfo :: TypeEnv
-> Avails
-> Maybe GlobalRdrEnv
-> [ClsInst]
-> Maybe ModIface
-> SafeHaskellMode
-> ModBreaks
-> ModuleInfo
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 = String -> [ClsInst]
forall a. HasCallStack => String -> a
error String
"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
}))
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo HscEnv
hsc_env Module
mdl =
case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mdl) of
Maybe HomeModInfo
Nothing -> Maybe ModuleInfo -> IO (Maybe ModuleInfo)
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 (m :: * -> *) a. Monad m => a -> m a
return (ModuleInfo -> Maybe ModuleInfo
forall a. a -> Maybe a
Just (ModuleInfo :: TypeEnv
-> Avails
-> Maybe GlobalRdrEnv
-> [ClsInst]
-> Maybe ModIface
-> SafeHaskellMode
-> ModBreaks
-> ModuleInfo
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 = ModDetails -> [ClsInst]
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 (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
gre_name ([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))
mkPrintUnqualifiedForModule :: GhcMonad m =>
ModuleInfo
-> m (Maybe PrintUnqualified)
mkPrintUnqualifiedForModule :: ModuleInfo -> m (Maybe PrintUnqualified)
mkPrintUnqualifiedForModule ModuleInfo
minf = (HscEnv -> m (Maybe PrintUnqualified))
-> m (Maybe PrintUnqualified)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe PrintUnqualified))
-> m (Maybe PrintUnqualified))
-> (HscEnv -> m (Maybe PrintUnqualified))
-> m (Maybe PrintUnqualified)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
mk_print_unqual :: GlobalRdrEnv -> PrintUnqualified
mk_print_unqual = UnitState -> HomeUnit -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified
(DynFlags -> UnitState
unitState DynFlags
dflags)
(HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env)
Maybe PrintUnqualified -> m (Maybe PrintUnqualified)
forall (m :: * -> *) a. Monad m => a -> m a
return ((GlobalRdrEnv -> PrintUnqualified)
-> Maybe GlobalRdrEnv -> Maybe PrintUnqualified
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GlobalRdrEnv -> PrintUnqualified
mk_print_unqual (ModuleInfo -> Maybe GlobalRdrEnv
minf_rdr_env ModuleInfo
minf))
modInfoLookupName :: GhcMonad m =>
ModuleInfo -> Name
-> m (Maybe TyThing)
modInfoLookupName :: 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 (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 (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 :: Id -> Bool
isDictonaryId Id
id
= case Type -> ([Id], ThetaType, Type)
tcSplitSigmaTy (Id -> Type
idType Id
id) of {
([Id]
_tvs, ThetaType
_theta, Type
tau) -> Type -> Bool
isDictTy Type
tau }
lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupGlobalName :: 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 (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 :: ([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 (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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (GlobalRdrEnv -> m GlobalRdrEnv) -> GlobalRdrEnv -> m GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
getNameToInstancesIndex :: GhcMonad m
=> [Module]
-> Maybe [Module]
-> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
getNameToInstancesIndex :: [Module]
-> Maybe [Module]
-> m (Messages, 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, Maybe (NameEnv ([ClsInst], [FamInst])))
-> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
-> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))))
-> IO (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
-> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRn (NameEnv ([ClsInst], [FamInst]))
-> IO (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
forall a. HscEnv -> TcRn a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn (NameEnv ([ClsInst], [FamInst]))
-> IO (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))))
-> TcRn (NameEnv ([ClsInst], [FamInst]))
-> IO (Messages, 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 = String -> SDoc
text String
"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 :: InstEnvs -> InstEnv
ie_global :: InstEnv
ie_global, InstEnv
ie_local :: InstEnvs -> InstEnv
ie_local :: 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 (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 (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq ClsInst
clss, Seq FamInst -> [FamInst]
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 (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 (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 = Id -> Type
idType (DataCon -> Id
dataConWrapId DataCon
dc)
pprParenSymName :: NamedThing a => a -> SDoc
pprParenSymName :: 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 :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
getModuleSourceAndFlags :: Module -> m (String, InputFileBuffer, DynFlags)
getModuleSourceAndFlags Module
mod = do
ModSummary
m <- ModuleName -> m ModSummary
forall (m :: * -> *). GhcMonad m => ModuleName -> m ModSummary
getModSummary (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
case ModLocation -> Maybe String
ml_hs_file (ModLocation -> Maybe String) -> ModLocation -> Maybe String
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
m of
Maybe String
Nothing -> do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
IO (String, InputFileBuffer, DynFlags)
-> m (String, InputFileBuffer, DynFlags)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (String, InputFileBuffer, DynFlags)
-> m (String, InputFileBuffer, DynFlags))
-> IO (String, InputFileBuffer, DynFlags)
-> m (String, InputFileBuffer, DynFlags)
forall a b. (a -> b) -> a -> b
$ GhcApiError -> IO (String, InputFileBuffer, DynFlags)
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO (String, InputFileBuffer, DynFlags))
-> GhcApiError -> IO (String, InputFileBuffer, DynFlags)
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags (String -> SDoc
text String
"No source available for module " SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
Just String
sourceFile -> do
InputFileBuffer
source <- IO InputFileBuffer -> m InputFileBuffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InputFileBuffer -> m InputFileBuffer)
-> IO InputFileBuffer -> m InputFileBuffer
forall a b. (a -> b) -> a -> b
$ String -> IO InputFileBuffer
hGetStringBuffer String
sourceFile
(String, InputFileBuffer, DynFlags)
-> m (String, InputFileBuffer, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
sourceFile, InputFileBuffer
source, ModSummary -> DynFlags
ms_hspp_opts ModSummary
m)
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream :: Module -> m [Located Token]
getTokenStream Module
mod = do
(String
sourceFile, InputFileBuffer
source, DynFlags
dflags) <- Module -> m (String, InputFileBuffer, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
Module -> m (String, InputFileBuffer, DynFlags)
getModuleSourceAndFlags Module
mod
let startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
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] -> m [Located Token]
forall (m :: * -> *) a. Monad m => a -> m a
return [Located Token]
ts
PFailed PState
pst -> Bag WarnMsg -> m [Located Token]
forall (io :: * -> *) a. MonadIO io => Bag WarnMsg -> io a
throwErrors ((Error -> WarnMsg) -> Bag Error -> Bag WarnMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Error -> WarnMsg
pprError (PState -> Bag Error
getErrorMessages PState
pst))
getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
getRichTokenStream :: Module -> m [(Located Token, String)]
getRichTokenStream Module
mod = do
(String
sourceFile, InputFileBuffer
source, DynFlags
dflags) <- Module -> m (String, InputFileBuffer, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
Module -> m (String, InputFileBuffer, DynFlags)
getModuleSourceAndFlags Module
mod
let startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
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, String)] -> m [(Located Token, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Located Token, String)] -> m [(Located Token, String)])
-> [(Located Token, String)] -> m [(Located Token, String)]
forall a b. (a -> b) -> a -> b
$ RealSrcLoc
-> InputFileBuffer -> [Located Token] -> [(Located Token, String)]
addSourceToTokens RealSrcLoc
startLoc InputFileBuffer
source [Located Token]
ts
PFailed PState
pst -> Bag WarnMsg -> m [(Located Token, String)]
forall (io :: * -> *) a. MonadIO io => Bag WarnMsg -> io a
throwErrors ((Error -> WarnMsg) -> Bag Error -> Bag WarnMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Error -> WarnMsg
pprError (PState -> Bag Error
getErrorMessages PState
pst))
addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
-> [(Located Token, String)]
addSourceToTokens :: RealSrcLoc
-> InputFileBuffer -> [Located Token] -> [(Located Token, String)]
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,String
"") (Located Token, String)
-> [(Located Token, String)] -> [(Located Token, String)]
forall a. a -> [a] -> [a]
: RealSrcLoc
-> InputFileBuffer -> [Located Token] -> [(Located Token, String)]
addSourceToTokens RealSrcLoc
loc InputFileBuffer
buf [Located Token]
ts
RealSrcSpan RealSrcSpan
s Maybe BufSpan
_ -> (Located Token
t,String
str) (Located Token, String)
-> [(Located Token, String)] -> [(Located Token, String)]
forall a. a -> [a] -> [a]
: RealSrcLoc
-> InputFileBuffer -> [Located Token] -> [(Located Token, String)]
addSourceToTokens RealSrcLoc
newLoc InputFileBuffer
newBuf [Located Token]
ts
where
(RealSrcLoc
newLoc, InputFileBuffer
newBuf, String
str) = String
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, String)
go String
"" RealSrcLoc
loc InputFileBuffer
buf
start :: RealSrcLoc
start = RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
s
end :: RealSrcLoc
end = RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
s
go :: String
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, String)
go String
acc RealSrcLoc
loc InputFileBuffer
buf | RealSrcLoc
loc RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcLoc
start = String
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, String)
go String
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 = String
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, String)
go (Char
chChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) RealSrcLoc
nLoc InputFileBuffer
nBuf
| Bool
otherwise = (RealSrcLoc
loc, InputFileBuffer
buf, String -> String
forall a. [a] -> [a]
reverse String
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, String)] -> String
showRichTokenStream [(Located Token, String)]
ts = RealSrcLoc -> [(Located Token, String)] -> String -> String
forall e.
RealSrcLoc -> [(GenLocated SrcSpan e, String)] -> String -> String
go RealSrcLoc
startLoc [(Located Token, String)]
ts String
""
where sourceFile :: FastString
sourceFile = [SrcSpan] -> FastString
getFile ([SrcSpan] -> FastString) -> [SrcSpan] -> FastString
forall a b. (a -> b) -> a -> b
$ ((Located Token, String) -> SrcSpan)
-> [(Located Token, String)] -> [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, String) -> Located Token)
-> (Located Token, String)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located Token, String) -> Located Token
forall a b. (a, b) -> a
fst) [(Located Token, String)]
ts
getFile :: [SrcSpan] -> FastString
getFile [] = String -> FastString
forall a. String -> a
panic String
"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, String)] -> String -> String
go RealSrcLoc
_ [] = String -> String
forall a. a -> a
id
go RealSrcLoc
loc ((L SrcSpan
span e
_, String
str):[(GenLocated SrcSpan e, String)]
ts)
= case SrcSpan
span of
UnhelpfulSpan UnhelpfulSpanReason
_ -> RealSrcLoc -> [(GenLocated SrcSpan e, String)] -> String -> String
go RealSrcLoc
loc [(GenLocated SrcSpan e, String)]
ts
RealSrcSpan RealSrcSpan
s Maybe BufSpan
_
| Int
locLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tokLine -> ((Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
tokCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
locCol) Char
' ') String -> String -> String
forall a. [a] -> [a] -> [a]
++)
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++)
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcLoc -> [(GenLocated SrcSpan e, String)] -> String -> String
go RealSrcLoc
tokEnd [(GenLocated SrcSpan e, String)]
ts
| Bool
otherwise -> ((Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
tokLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
locLine) Char
'\n') String -> String -> String
forall a. [a] -> [a] -> [a]
++)
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
tokCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' ') String -> String -> String
forall a. [a] -> [a] -> [a]
++)
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++)
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcLoc -> [(GenLocated SrcSpan e, String)] -> String -> String
go RealSrcLoc
tokEnd [(GenLocated SrcSpan e, String)]
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 :: ModuleName -> Maybe FastString -> m Module
findModule ModuleName
mod_name Maybe FastString
maybe_pkg = (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 dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
case Maybe FastString
maybe_pkg of
Just FastString
pkg | Bool -> Bool
not (HomeUnit -> Unit -> Bool
isHomeUnit HomeUnit
home_unit (FastString -> Unit
fsToUnit FastString
pkg)) Bool -> Bool -> Bool
&& FastString
pkg FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> FastString
fsLit String
"this" -> IO Module -> m Module
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 -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mod_name Maybe FastString
maybe_pkg
case FindResult
res of
Found ModLocation
_ Module
m -> Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
FindResult
err -> WarnMsg -> IO Module
forall (io :: * -> *) a. MonadIO io => WarnMsg -> io a
throwOneError (WarnMsg -> IO Module) -> WarnMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> ModuleName -> FindResult -> WarnMsg
noModError DynFlags
dflags SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err
Maybe FastString
_otherwise -> do
Maybe Module
home <- ModuleName -> m (Maybe Module)
forall (m :: * -> *). GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule ModuleName
mod_name
case Maybe Module
home of
Just Module
m -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
Maybe Module
Nothing -> IO Module -> m Module
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 -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mod_name Maybe FastString
maybe_pkg
case FindResult
res of
Found ModLocation
loc Module
m | Bool -> Bool
not (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
m) -> Module -> IO Module
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 -> WarnMsg -> IO Module
forall (io :: * -> *) a. MonadIO io => WarnMsg -> io a
throwOneError (WarnMsg -> IO Module) -> WarnMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> ModuleName -> FindResult -> WarnMsg
noModError DynFlags
dflags SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err
modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError :: 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
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"module is not loaded:" SDoc -> SDoc -> SDoc
<+>
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
<+>
SDoc -> SDoc
parens (String -> SDoc
text (String -> Maybe String -> String
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"modNotLoadedError" (ModLocation -> Maybe String
ml_hs_file ModLocation
loc)))
lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
lookupModule :: ModuleName -> Maybe FastString -> m Module
lookupModule ModuleName
mod_name (Just FastString
pkg) = ModuleName -> Maybe FastString -> m Module
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
findModule ModuleName
mod_name (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
pkg)
lookupModule ModuleName
mod_name Maybe FastString
Nothing = (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 <- ModuleName -> m (Maybe Module)
forall (m :: * -> *). GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule ModuleName
mod_name
case Maybe Module
home of
Just Module
m -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
Maybe Module
Nothing -> IO Module -> m Module
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 -> Maybe FastString -> IO FindResult
findExposedPackageModule HscEnv
hsc_env ModuleName
mod_name Maybe FastString
forall a. Maybe a
Nothing
case FindResult
res of
Found ModLocation
_ Module
m -> Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
FindResult
err -> WarnMsg -> IO Module
forall (io :: * -> *) a. MonadIO io => WarnMsg -> io a
throwOneError (WarnMsg -> IO Module) -> WarnMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> ModuleName -> FindResult -> WarnMsg
noModError (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err
lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule :: ModuleName -> m (Maybe Module)
lookupLoadedHomeModule 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 HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) ModuleName
mod_name of
Just HomeModInfo
mod_info -> Maybe Module -> m (Maybe Module)
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe Module
forall a. Maybe a
Nothing
isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted :: 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 (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 :: 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 (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 :: String -> m ()
setGHCiMonad String
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 (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 -> String -> IO Name
hscIsGHCiMonad HscEnv
hsc_env String
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 :: Name
ic_monad = Name
ty }
in HscEnv
s { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic }
getGHCiMonad :: GhcMonad m => m Name
getGHCiMonad :: m Name
getGHCiMonad = (HscEnv -> Name) -> m HscEnv -> m Name
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 :: 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 (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 :: 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 (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 :: Int -> Bool -> Id -> m Term
obtainTermFromId Int
bound Bool
force Id
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 (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 -> Id -> IO Term
GHC.Runtime.Eval.obtainTermFromId HscEnv
hsc_env Int
bound Bool
force Id
id
lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupName :: 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 (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))
parser :: String
-> DynFlags
-> String
-> (Bag WarnMsg, Either (Bag WarnMsg) ParsedSource)
parser String
str DynFlags
dflags String
filename =
let
loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1
buf :: InputFileBuffer
buf = String -> InputFileBuffer
stringToStringBuffer String
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 (Bag Warning
warns,Bag Error
errs) = PState -> (Bag Warning, Bag Error)
getMessages PState
pst in
((Warning -> WarnMsg) -> Bag Warning -> Bag WarnMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Warning -> WarnMsg
pprWarning Bag Warning
warns, Bag WarnMsg -> Either (Bag WarnMsg) ParsedSource
forall a b. a -> Either a b
Left ((Error -> WarnMsg) -> Bag Error -> Bag WarnMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Error -> WarnMsg
pprError Bag Error
errs))
POk PState
pst ParsedSource
rdr_module ->
let (Bag Warning
warns,Bag Error
_) = PState -> (Bag Warning, Bag Error)
getMessages PState
pst in
((Warning -> WarnMsg) -> Bag Warning -> Bag WarnMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Warning -> WarnMsg
pprWarning Bag Warning
warns, ParsedSource -> Either (Bag WarnMsg) ParsedSource
forall a b. b -> Either a b
Right ParsedSource
rdr_module)
interpretPackageEnv :: DynFlags -> IO DynFlags
interpretPackageEnv :: DynFlags -> IO DynFlags
interpretPackageEnv DynFlags
dflags = do
Maybe String
mPkgEnv <- MaybeT IO String -> IO (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO String -> IO (Maybe String))
-> MaybeT IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ [MaybeT IO String] -> MaybeT IO String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([MaybeT IO String] -> MaybeT IO String)
-> [MaybeT IO String] -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ [
MaybeT IO String
getCmdLineArg MaybeT IO String
-> (String -> MaybeT IO String) -> MaybeT IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
env -> [MaybeT IO String] -> MaybeT IO String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
String -> MaybeT IO String
probeNullEnv String
env
, String -> MaybeT IO String
probeEnvFile String
env
, String -> MaybeT IO String
probeEnvName String
env
, String -> MaybeT IO String
forall a. String -> MaybeT IO a
cmdLineError String
env
]
, MaybeT IO String
getEnvVar MaybeT IO String
-> (String -> MaybeT IO String) -> MaybeT IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
env -> [MaybeT IO String] -> MaybeT IO String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
String -> MaybeT IO String
probeNullEnv String
env
, String -> MaybeT IO String
probeEnvFile String
env
, String -> MaybeT IO String
probeEnvName String
env
, String -> MaybeT IO String
forall a. String -> MaybeT IO a
envError String
env
]
, MaybeT IO ()
notIfHideAllPackages MaybeT IO () -> MaybeT IO String -> MaybeT IO String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [MaybeT IO String] -> MaybeT IO String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
MaybeT IO String
findLocalEnvFile MaybeT IO String
-> (String -> MaybeT IO String) -> MaybeT IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> MaybeT IO String
probeEnvFile
, String -> MaybeT IO String
probeEnvName String
defaultEnvName
]
]
case Maybe String
mPkgEnv of
Maybe String
Nothing ->
DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags
Just String
"-" -> do
DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags
Just String
envfile -> do
String
content <- String -> IO String
readFile String
envfile
DynFlags -> SDoc -> IO ()
compilationProgressMsg DynFlags
dflags (String -> SDoc
text String
"Loaded package environment from " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
envfile)
let ((Errs, Warns, ())
_, DynFlags
dflags') = CmdLineP DynFlags (Errs, Warns, ())
-> DynFlags -> ((Errs, Warns, ()), DynFlags)
forall s a. CmdLineP s a -> s -> (a, s)
runCmdLine (EwM (CmdLineP DynFlags) () -> CmdLineP DynFlags (Errs, Warns, ())
forall (m :: * -> *) a. EwM m a -> m (Errs, Warns, a)
runEwM (String -> String -> EwM (CmdLineP DynFlags) ()
setFlagsFromEnvFile String
envfile String
content)) DynFlags
dflags
DynFlags -> IO DynFlags
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 :: String -> MaybeT IO String
namedEnvPath String
name = do
String
appdir <- String -> ArchOS -> MaybeT IO String
versionedAppDir (DynFlags -> String
programName DynFlags
dflags) ArchOS
archOS
String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> MaybeT IO String) -> String -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ String
appdir String -> String -> String
</> String
"environments" String -> String -> String
</> String
name
probeEnvName :: String -> MaybeT IO FilePath
probeEnvName :: String -> MaybeT IO String
probeEnvName String
name = String -> MaybeT IO String
probeEnvFile (String -> MaybeT IO String)
-> MaybeT IO String -> MaybeT IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> MaybeT IO String
namedEnvPath String
name
probeEnvFile :: FilePath -> MaybeT IO FilePath
probeEnvFile :: String -> MaybeT IO String
probeEnvFile String
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 (String -> IO Bool
doesFileExist String
path)
String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
probeNullEnv :: FilePath -> MaybeT IO FilePath
probeNullEnv :: String -> MaybeT IO String
probeNullEnv String
"-" = String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"-"
probeNullEnv String
_ = MaybeT IO String
forall (m :: * -> *) a. MonadPlus m => m a
mzero
getCmdLineArg :: MaybeT IO String
getCmdLineArg :: MaybeT IO String
getCmdLineArg = IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe String) -> MaybeT IO String)
-> IO (Maybe String) -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe String
packageEnv DynFlags
dflags
getEnvVar :: MaybeT IO String
getEnvVar :: MaybeT IO String
getEnvVar = do
Either IOException String
mvar <- IO (Either IOException String)
-> MaybeT IO (Either IOException String)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO (Either IOException String)
-> MaybeT IO (Either IOException String))
-> IO (Either IOException String)
-> MaybeT IO (Either IOException String)
forall a b. (a -> b) -> a -> b
$ IO String -> IO (Either IOException String)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try (IO String -> IO (Either IOException String))
-> IO String -> IO (Either IOException String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
getEnv String
"GHC_ENVIRONMENT"
case Either IOException String
mvar of
Right String
var -> String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
var
Left IOException
err -> if IOException -> Bool
isDoesNotExistError IOException
err then MaybeT IO String
forall (m :: * -> *) a. MonadPlus m => m a
mzero
else IO String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO String -> MaybeT IO String) -> IO String -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ IOException -> IO String
forall e a. Exception e => e -> IO a
throwIO IOException
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 :: String
defaultEnvName = String
"default"
localEnvFileName :: FilePath
localEnvFileName :: String
localEnvFileName = String
".ghc.environment" String -> String -> String
<.> ArchOS -> String
versionedFilePath ArchOS
archOS
findLocalEnvFile :: MaybeT IO FilePath
findLocalEnvFile :: MaybeT IO String
findLocalEnvFile = do
String
curdir <- IO String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT IO String
getCurrentDirectory
String
homedir <- IO String -> MaybeT IO String
forall a. IO a -> MaybeT IO a
tryMaybeT IO String
getHomeDirectory
let probe :: String -> MaybeT IO String
probe String
dir | String -> Bool
isDrive String
dir Bool -> Bool -> Bool
|| String
dir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
homedir
= MaybeT IO String
forall (m :: * -> *) a. MonadPlus m => m a
mzero
probe String
dir = do
let file :: String
file = String
dir String -> String -> String
</> String
localEnvFileName
Bool
exists <- IO Bool -> MaybeT IO Bool
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (String -> IO Bool
doesFileExist String
file)
if Bool
exists
then String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
file
else String -> MaybeT IO String
probe (String -> String
takeDirectory String
dir)
String -> MaybeT IO String
probe String
curdir
cmdLineError :: String -> MaybeT IO a
cmdLineError :: String -> MaybeT IO a
cmdLineError String
env = IO a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO a -> MaybeT IO a) -> (String -> IO a) -> String -> 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)
-> (String -> GhcException) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GhcException
CmdLineError (String -> MaybeT IO a) -> String -> MaybeT IO a
forall a b. (a -> b) -> a -> b
$
String
"Package environment " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
env String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found"
envError :: String -> MaybeT IO a
envError :: String -> MaybeT IO a
envError String
env = IO a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO a -> MaybeT IO a) -> (String -> IO a) -> String -> 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)
-> (String -> GhcException) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GhcException
CmdLineError (String -> MaybeT IO a) -> String -> MaybeT IO a
forall a b. (a -> b) -> a -> b
$
String
"Package environment "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
env
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (specified in GHC_ENVIRONMENT) not found"
newtype GhcApiError = GhcApiError String
instance Show GhcApiError where
show :: GhcApiError -> String
show (GhcApiError String
msg) = String
msg
instance Exception GhcApiError
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags SDoc
msg = String -> GhcApiError
GhcApiError (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
msg)