ide-backend-0.9.0: IdeSession/Update/ExecuteSessionUpdate.hs
-- | Execution of session updates
--
-- Note that we do _NOT_ deal with session restarts here.
--
-- See comments for IdeSessionUpdate for a motivation of the split between the
-- IdeSessionUpdate type and the ExecuteSessionUpdate type.
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleInstances #-}
module IdeSession.Update.ExecuteSessionUpdate (runSessionUpdate) where
import Prelude hiding (mod, span)
import Control.Applicative (Applicative, (<$>))
import Control.Monad (when, void, forM, liftM, filterM)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT, asks)
import Control.Monad.State (MonadState(..))
import Data.Accessor (Accessor, (.>))
import Data.Digest.Pure.MD5 (MD5Digest)
import Data.Foldable (forM_)
import Data.Maybe (isJust, catMaybes, fromMaybe)
import Data.Monoid (Monoid(..))
import System.Exit (ExitCode(..))
import System.FilePath (makeRelative, (</>), takeExtension, replaceExtension, dropFileName)
import System.FilePath.Find (find, always, extension, (&&?), (||?), fileType, (==?), FileType (RegularFile))
import System.Posix.Files (setFileTimes, getFileStatus, modificationTime)
import qualified Control.Exception as Ex
import qualified Data.Accessor.Monad.MTL.State as Acc
import qualified Data.ByteString.Char8 as BSS
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.Text as Text
import qualified System.Directory as Dir
import IdeSession.Cabal
import IdeSession.Config
import IdeSession.ExeCabalClient (invokeExeCabal)
import IdeSession.GHC.API
import IdeSession.RPC.API (ExternalException)
import IdeSession.State
import IdeSession.Strict.Container
import IdeSession.Strict.IORef (StrictIORef)
import IdeSession.Types.Private hiding (RunResult(..))
import IdeSession.Types.Progress
import IdeSession.Types.Public (RunBufferMode(..), Targets(..))
import IdeSession.Update.IdeSessionUpdate
import IdeSession.Util
import qualified IdeSession.GHC.Client as GHC
import qualified IdeSession.Strict.IORef as IORef
import qualified IdeSession.Strict.IntMap as IntMap
import qualified IdeSession.Strict.List as List
import qualified IdeSession.Strict.Map as Map
import qualified IdeSession.Strict.Maybe as Maybe
import qualified IdeSession.Strict.Trie as Trie
{-------------------------------------------------------------------------------
We execute session updates in a monad in which we have Reader access to
the IdeStaticInfo and the progress back, and State access to the IdeIdleState.
We do _not_ deal with different IDE states here; that is the responsibility
of updateSession itself.
-------------------------------------------------------------------------------}
data IdeSessionUpdateEnv = IdeSessionUpdateEnv {
ideUpdateStaticInfo :: IdeStaticInfo
, ideUpdateCallback :: Progress -> IO ()
-- For the StateT instance
, ideUpdateStateRef :: StrictIORef IdeIdleState
-- For liftIO
, ideUpdateExceptionRef :: StrictIORef (Maybe ExternalException)
}
newtype ExecuteSessionUpdate a = ExecuteSessionUpdate {
unwrapUpdate :: ReaderT IdeSessionUpdateEnv IO a
}
deriving ( Functor
, Applicative
, Monad
, MonadReader IdeSessionUpdateEnv
)
-- We define MonadState using an IORef rather than StateT so that if an exception
-- happens during the execution of a session update, writes to the state are not
-- lost
instance MonadState IdeIdleState ExecuteSessionUpdate where
get = ExecuteSessionUpdate $ do
stRef <- ideUpdateStateRef <$> ask
liftIO $ IORef.readIORef stRef
put s = ExecuteSessionUpdate $ do
stRef <- ideUpdateStateRef <$> ask
liftIO $ IORef.writeIORef stRef s
-- | Kind of like 'liftIO', but with a special treatment for external
-- exceptions. When the IO action throws an ExternalException, _or_ when a
-- previous IO exception threw an ExternalException, we return a dummy value
-- and record the exception separately. Thus, for an action of type
--
-- > foo :: IO ()
--
-- we will return () on an exception, as if the action returned successfully;
-- similarly, for an action of type
--
-- > bar :: IO [SourceError]
--
-- we will return the empty list on an exception. The rationale is that if
-- ExternalException occurs, we will eventually record the session as dead (in
-- the top-level updateSession function), but everything else in the execution
-- of the session update should still happen (#251).
--
-- NOTE: We deal _only_ with external exceptions here. Any other kind of
-- exception should be explicitly caught and dealt with by the IO action.
tryIO :: Dummy a => IO a -> ExecuteSessionUpdate a
tryIO act = ExecuteSessionUpdate $ do
exRef <- ideUpdateExceptionRef <$> ask
mPreviousException <- liftIO $ IORef.readIORef exRef
case mPreviousException of
Just _ ->
return dummy
Nothing -> do
mNewException <- liftIO $ Ex.try $ act
case mNewException of
Left ex -> do liftIO $ IORef.writeIORef exRef (Just ex)
return dummy
Right a -> return a
-- | For code that we _know_ is exception free we can just execute the action.
-- Of course, this needs manual verification that these cases are actually okay.
-- If the action _does_ throw an exception this may end the session update
-- prematurely.
exceptionFree :: IO a -> ExecuteSessionUpdate a
exceptionFree = ExecuteSessionUpdate . liftIO
runSessionUpdate :: Bool
-> IdeSessionUpdate
-> IdeStaticInfo
-> (Progress -> IO ())
-> IdeIdleState
-> IO (IdeIdleState, Maybe ExternalException)
runSessionUpdate justRestarted update staticInfo callback ideIdleState = do
stRef <- IORef.newIORef ideIdleState
exRef <- IORef.newIORef Nothing
runReaderT (unwrapUpdate $ executeSessionUpdate justRestarted update')
IdeSessionUpdateEnv {
ideUpdateStaticInfo = staticInfo
, ideUpdateCallback = liftIO . callback
, ideUpdateStateRef = stRef
, ideUpdateExceptionRef = exRef
}
ideIdleState' <- IORef.readIORef stRef
mException <- IORef.readIORef exRef
return (ideIdleState', mException)
where
update' = reflectSessionState ideIdleState update
-- | Execute a session update
--
-- Notes:
--
-- * We do NOT deal with updates there that require a session restart (updates
-- to relative includes, targets, certain ghc options).
-- * The assume the session update has already been passed through
-- 'reflectSessionState' to reflect the state of the session.
-- * Due to the MonadState instance, writes to the state will be preserved
-- even if an exception occurs during the execution of the session update.
-- Such exceptions should only happen when we contact the server (do RPC
-- calls); it is therefore important we make sure to update our local state
-- before updating the rmote state, so that _if_ a remote exception occurs,
-- we can reset the state on the next call to updateSession.
executeSessionUpdate :: Bool -> IdeSessionUpdate -> ExecuteSessionUpdate ()
executeSessionUpdate justRestarted IdeSessionUpdate{..} = do
executeUpdateBufferModes ideUpdateStdoutMode ideUpdateStderrMode
executeUpdateEnv ideUpdateEnv
executeUpdateArgs ideUpdateArgs
filesChanged <- executeUpdateFiles ideUpdateFileCmds
enabledCodeGen <- executeUpdateCodeGen ideUpdateCodeGen
optionWarnings <- executeUpdateGhcOpts ideUpdateGhcOpts
-- Unrecord object files whose C files have been deleted (#241)
removeObsoleteObjectFiles
let ghcOptionsChanged :: Bool
ghcOptionsChanged = isJust optionWarnings
-- Recompile C files. Notes:
--
-- - Unless ghc options have changed, we recompile C files only when they
-- have been modified (by comparing the timestamp on the C file to the
-- timestamp on the correponding object file).
-- - We do this _after_ setting ghc because because some ghc options are
-- passed to the C compiler (#218)
-- - Similarly, when the ghc options have changed, we conversatively
-- recompile (and, importantly, relink -- #218) _all_ C files.
(numActions, cErrors) <- updateObjectFiles ghcOptionsChanged
let cFilesChanged :: Bool
cFilesChanged = numActions > 0
let needsRecompile =
-- We recompile both when source code and when data files change
-- as we don't know which data files are included at compile time
filesChanged
|| -- We need to (re)compile if codegen was just enabled
enabledCodeGen
|| -- Changing ghc options might require a recompile
ghcOptionsChanged
-- If any C files changed we may have to recompile Haskell files
|| cFilesChanged
-- If we just restarted we have to recompile even if the files
-- didn't change
|| justRestarted
when needsRecompile $ local (incrementNumSteps numActions) $ do
GhcCompileResult{..} <- rpcCompile
oldComputed <- Acc.get ideComputed
srcDir <- asks $ ideSessionSourceDir . ideSessionDir . ideUpdateStaticInfo
let applyDiff :: Strict (Map ModuleName) (Diff v)
-> (Computed -> Strict (Map ModuleName) v)
-> Strict (Map ModuleName) v
applyDiff diff f = applyMapDiff diff $ Maybe.maybe Map.empty f oldComputed
let diffSpan = Map.map (fmap mkIdMap) ghcCompileSpanInfo
diffTypes = Map.map (fmap mkExpMap) ghcCompileExpTypes
diffAuto = Map.map (fmap (constructAuto ghcCompileCache)) ghcCompileAuto
Acc.set ideComputed $ Maybe.just Computed {
computedErrors = force cErrors
List.++ ghcCompileErrors
List.++ force (fromMaybe [] optionWarnings)
, computedLoadedModules = ghcCompileLoaded
, computedFileMap = mkFileMapRelative srcDir ghcCompileFileMap
, computedImports = ghcCompileImports `applyDiff` computedImports
, computedAutoMap = diffAuto `applyDiff` computedAutoMap
, computedSpanInfo = diffSpan `applyDiff` computedSpanInfo
, computedExpTypes = diffTypes `applyDiff` computedExpTypes
, computedUseSites = ghcCompileUseSites `applyDiff` computedUseSites
, computedPkgDeps = ghcCompilePkgDeps `applyDiff` computedPkgDeps
, computedCache = mkCacheRelative srcDir ghcCompileCache
}
when ideUpdateDocs $ executeBuildDoc
forM_ ideUpdateExes $ uncurry executeBuildExe
forM_ ideUpdateLicenses $ executeBuildLicenses
where
incrementNumSteps :: Int -> IdeSessionUpdateEnv -> IdeSessionUpdateEnv
incrementNumSteps count IdeSessionUpdateEnv{..} = IdeSessionUpdateEnv{
ideUpdateCallback = \p -> ideUpdateCallback p {
progressStep = progressStep p + count
, progressNumSteps = progressNumSteps p + count
}
, ..
}
mkCacheRelative :: FilePath -> ExplicitSharingCache -> ExplicitSharingCache
mkCacheRelative srcDir ExplicitSharingCache{..} =
ExplicitSharingCache {
filePathCache = IntMap.map aux filePathCache
, idPropCache = idPropCache
}
where
aux :: BSS.ByteString -> BSS.ByteString
aux = BSS.pack . makeRelative srcDir . BSS.unpack
mkFileMapRelative :: FilePath -> Strict (Map FilePath) ModuleId -> Strict (Map FilePath) ModuleId
mkFileMapRelative srcDir = Map.mapKeys (makeRelative srcDir)
constructAuto :: ExplicitSharingCache -> Strict [] IdInfo
-> Strict Trie (Strict [] IdInfo)
constructAuto cache lk =
Trie.fromListWith (List.++) $ map aux (toLazyList lk)
where
aux :: IdInfo -> (BSS.ByteString, Strict [] IdInfo)
aux idInfo@IdInfo{idProp = k} =
let idProp = IntMap.findWithDefault
(error "constructAuto: could not resolve idPropPtr")
(idPropPtr k)
(idPropCache cache)
in ( BSS.pack . Text.unpack . idName $ idProp
, List.singleton idInfo
)
-- | Remove context sensitivty from session updates
--
-- Some updates (such as ideUpdateDeleteFiles) are context sensitive: their
-- meaning depends on the state of the session when the update is performed.
-- For these updates we "reflect" the current state of the session once, just
-- before we execute the update.
reflectSessionState :: IdeIdleState -> IdeSessionUpdate -> IdeSessionUpdate
reflectSessionState IdeIdleState{..} update = mconcat [
when' (ideUpdateDeleteFiles update) $ mconcat $
[updateSourceFileDelete (fst m) | m <- _managedSource]
++ [updateDataFileDelete (fst m) | m <- _managedData]
, update {
ideUpdateDeleteFiles = False
}
]
where
when' :: forall m. Monoid m => Bool -> m -> m
when' True a = a
when' False _ = mempty
ManagedFilesInternal{..} = _ideManagedFiles
{-------------------------------------------------------------------------------
Simple updates
-------------------------------------------------------------------------------}
-- | Execute file update commands
--
-- Returns whether any files actually changed.
--
-- We share the directory where the files are stored with the server, so we
-- don't need to explicitly send over any changed files
executeUpdateFiles :: [FileCmd] -> ExecuteSessionUpdate Bool
executeUpdateFiles fileCmds = or <$> forM fileCmds executeFileCmd
-- | Enable/disable code gen
--
-- Returns if code gen was enabled (and wasn't previously)
--
-- Enabling/disabling code generation has no effect on the server, as we pass
-- this flag on each call to rpcCompile
executeUpdateCodeGen :: Maybe Bool -> ExecuteSessionUpdate Bool
executeUpdateCodeGen = maybeSet ideGenerateCode
-- | Update buffer modes
--
-- Updating buffer modes is local only, because we pass the required buffer
-- mode on each and every call to runStmt, rather than setting a server side
-- flag
executeUpdateBufferModes :: Maybe RunBufferMode -> Maybe RunBufferMode -> ExecuteSessionUpdate ()
executeUpdateBufferModes stdoutMode stderrMode = do
void $ maybeSet ideStdoutBufferMode stdoutMode
void $ maybeSet ideStderrBufferMode stderrMode
-- | Update server environment
executeUpdateEnv :: Maybe [(String, Maybe String)] -> ExecuteSessionUpdate ()
executeUpdateEnv env = do
changed <- maybeSet ideEnv env
when changed rpcSetEnv
-- | Update snippet arguments
executeUpdateArgs :: Maybe [String] -> ExecuteSessionUpdate ()
executeUpdateArgs args = do
changed <- maybeSet ideArgs args
when changed rpcSetArgs
-- | Update ghc options
--
-- Returns Just a (possibly empty) set of a warnings if options were changed,
-- or Nothing otherwise.
--
-- We don't deal with setting relative includes here: this always requires a
-- session restart; similarly, we assume that if any of the changed options
-- require a session restart that this has already happened.
executeUpdateGhcOpts :: Maybe [String] -> ExecuteSessionUpdate (Maybe [SourceError])
executeUpdateGhcOpts opts = do
changed <- maybeSet ideGhcOpts opts
if changed then Just <$> rpcSetGhcOpts
else return Nothing
{-------------------------------------------------------------------------------
Recompile object files
-------------------------------------------------------------------------------}
-- | Recompile any C files that need recompiling and mark all Haskell modules
-- that require recompilation.
--
-- Returns the number of actions that were executed, so we can adjust Progress
-- messages returned by ghc.
updateObjectFiles :: Bool -> ExecuteSessionUpdate (Int, [SourceError])
updateObjectFiles ghcOptionsChanged = do
-- We first figure out which files are updated so that we can number
-- progress messages
outdated <- outdatedObjectFiles ghcOptionsChanged
if not (null outdated)
then do
-- We first unload all object files in case any symbols need to be
-- re-resolved.
rpcUnloadObjectFiles =<< Acc.get ideObjectFiles
-- Recompile the C files and load the corresponding object files
cErrors <- recompileCFiles outdated
objErrors <- rpcLoadObjectFiles
-- Finally, mark Haskell files as updated
--
-- When C files change, the addresses of the symbols exported in the
-- corresponding object files may change. To make sure that these
-- changes are properly propagated, we unload and reload all object
-- files (so that we reapply symbol resolution, necessary in case the
-- object files refer to each other), and we mark all Haskell modules
-- as updated so that we will recompile them.
--
-- NOTE: When using HscInterpreted/LinkInMemory C symbols get resolved
-- during compilation, not during a separate linking step. To be
-- precise, they get resolved from deep inside the compiler. Example
-- callchain:
--
-- > lookupStaticPtr <-- does the resolution
-- > called by generateCCall
-- > called by schemeT
-- > called by schemeE
-- > called by doCase
-- > called by schemeE
-- > called by schemeER_wrk
-- > called by schemeR_wrk
-- > called by schemeR
-- > called by schemeTopBind
-- > called by byteCodeGen
-- > called by hscInteractive
--
-- Hence, we really need to recompile, rather than just relink.
markAsUpdated $ dependenciesOf outdated
return (length outdated, cErrors ++ objErrors)
else
return (0, [])
where
-- We don't know what the dependencies of the C files are, so we just
-- reload _all_ Haskell modules
dependenciesOf :: [FilePath] -> FilePath -> Bool
dependenciesOf _recompiled src = takeExtension src == ".hs"
removeObsoleteObjectFiles :: ExecuteSessionUpdate ()
removeObsoleteObjectFiles = do
objectFiles <- Acc.get ideObjectFiles
obsolete <- filterM isObsolete objectFiles
forM_ obsolete $ \(cFile, (objFile, _timestamp)) -> do
exceptionFree $ Dir.removeFile objFile
Acc.set (ideObjectFiles .> lookup' cFile) Nothing
rpcUnloadObjectFiles obsolete
where
isObsolete :: (FilePath, (FilePath, LogicalTimestamp)) -> ExecuteSessionUpdate Bool
isObsolete (cFile, _) = do
cInfo <- Acc.get (ideManagedFiles .> managedSource .> lookup' cFile)
return $ not (isJust cInfo)
recompileCFiles :: [FilePath] -> ExecuteSessionUpdate [SourceError]
recompileCFiles cFiles = do
callback <- asks ideUpdateCallback
sessionDir <- asks $ ideSessionDir . ideUpdateStaticInfo
let srcDir, objDir :: FilePath
srcDir = ideSessionSourceDir sessionDir
objDir = ideSessionObjDir sessionDir
errorss <- forM (zip cFiles [1..]) $ \(relC, i) -> do
let relObj = replaceExtension relC ".o"
absC = srcDir </> relC
absObj = objDir </> relObj
let msg = "Compiling " ++ relC
exceptionFree $ callback $ Progress {
progressStep = i
, progressNumSteps = length cFiles
, progressParsedMsg = Just (Text.pack msg)
, progressOrigMsg = Just (Text.pack msg)
}
exceptionFree $ Dir.createDirectoryIfMissing True (dropFileName absObj)
errors <- runGcc absC absObj objDir
if null errors
then do
ts' <- updateFileTimes absObj
Acc.set (ideObjectFiles .> lookup' relC) (Just (absObj, ts'))
else do
Acc.set (ideObjectFiles .> lookup' relC) Nothing
return errors
return $ concat errorss
-- | Figure out which C files need to be recompiled
outdatedObjectFiles :: Bool -> ExecuteSessionUpdate [FilePath]
outdatedObjectFiles ghcOptionsChanged = do
IdeStaticInfo{..} <- asks ideUpdateStaticInfo
managedFiles <- Acc.get (ideManagedFiles .> managedSource)
let cFiles :: [(FilePath, LogicalTimestamp)]
cFiles = filter ((`elem` cExtensions) . takeExtension . fst)
$ map (\(fp, (_, ts)) -> (fp, ts))
$ managedFiles
-- If ghc options have changed we consider _all_ C files to be outdated; see
-- comments in executeSessionUpdate.
if ghcOptionsChanged
then return $ map fst cFiles
else liftM catMaybes $ do
forM cFiles $ \(c_fp, c_ts) -> do
-- ideObjectFiles is indexed by the names of the corresponding C files
mObjFile <- Acc.get (ideObjectFiles .> lookup' c_fp)
return $ case mObjFile of
-- No existing object file yet
Nothing -> Just c_fp
-- We _do_ have an existing object file, and it is older than
-- the C file. We need to recompile
Just (_, obj_ts) | obj_ts < c_ts -> Just c_fp
-- Otherwise we don't have to do anything
_ -> Nothing
-- | Call gcc via ghc, with the same parameters cabal uses.
runGcc :: FilePath -> FilePath -> FilePath -> ExecuteSessionUpdate [SourceError]
runGcc absC absObj pref = do
ideStaticInfo@IdeStaticInfo{..} <- asks ideUpdateStaticInfo
callback <- asks ideUpdateCallback
relIncl <- Acc.get ideRelativeIncludes
-- Pass GHC options so that ghc can pass the relevant options to gcc
ghcOpts <- Acc.get ideGhcOpts
let ideDistDir = ideSessionDistDir ideSessionDir
ideSourceDir = ideSessionSourceDir ideSessionDir
exceptionFree $ do
let SessionConfig{..} = ideConfig
stdoutLog = ideDistDir </> "ide-backend-cc.stdout"
stderrLog = ideDistDir </> "ide-backend-cc.stderr"
includeDirs = map (ideSourceDir </>) relIncl
runCcArgs = RunCcArgs{ rcPackageDBStack = configPackageDBStack
, rcExtraPathDirs = configExtraPathDirs
, rcDistDir = ideDistDir
, rcStdoutLog = stdoutLog
, rcStderrLog = stderrLog
, rcAbsC = absC
, rcAbsObj = absObj
, rcPref = pref
, rcIncludeDirs = includeDirs
, rcOptions = ghcOpts
}
-- (_exitCode, _stdout, _stderr)
-- <- readProcessWithExitCode _gcc _args _stdin
-- The real deal; we call gcc via ghc via cabal functions:
exitCode <- invokeExeCabal ideStaticInfo (ReqExeCc runCcArgs) callback
stdout <- readFile stdoutLog
stderr <- readFile stderrLog
case exitCode of
ExitSuccess -> return []
ExitFailure _ -> return (parseErrorMsgs stdout stderr)
where
-- TODO: Parse the error messages returned by gcc. For now, we just
-- return all output as a single, unlocated, error.
parseErrorMsgs :: String -> String -> [SourceError]
parseErrorMsgs stdout stderr = [SourceError
{ errorKind = KindError
, errorSpan = TextSpan (Text.pack "<gcc error>")
, errorMsg = Text.pack (stdout ++ stderr)
}]
-- | Force recompilation of the given modules
--
-- NOTE: Calling markAsUpdated _by itself_ is not sufficient to call a recompile
-- of these files, as executeSessionUpdate needs some additional information to
-- even ask ghc for a recompile at all (see 'needsRecompile'). Currently we use
-- 'markAsUpdated' after we (re)compile C files, which executeSessionUpdate is
-- told about separately.
--
-- TODO: Should we update data files here too?
markAsUpdated :: (FilePath -> Bool) -> ExecuteSessionUpdate ()
markAsUpdated shouldMark = do
IdeStaticInfo{..} <- asks ideUpdateStaticInfo
sources <- Acc.get (ideManagedFiles .> managedSource)
sources' <- forM sources $ \(path, (digest, oldTS)) ->
if shouldMark path
then do newTS <- updateFileTimes (ideSessionSourceDir ideSessionDir </> path)
return (path, (digest, newTS))
else return (path, (digest, oldTS))
Acc.set (ideManagedFiles .> managedSource) sources'
{-------------------------------------------------------------------------------
File commands
-------------------------------------------------------------------------------}
-- | Execute a file command
--
-- Returns 'True' if any files were changed.
--
-- TODO: We should verify each use of exceptionFree here.
executeFileCmd :: FileCmd -> ExecuteSessionUpdate Bool
executeFileCmd cmd = do
IdeStaticInfo{..} <- asks ideUpdateStaticInfo
let remotePath :: FilePath
remotePath = fileInfoRemoteDir info ideSessionDir </> fileInfoRemoteFile info
case cmd of
FileWrite _ bs -> do
old <- Acc.get cachedInfo
-- We always overwrite the file, and then later set the timestamp back
-- to what it was if it turns out the hash was the same. If we compute
-- the hash first, we would force the entire lazy bytestring into memory
newHash <- exceptionFree $ writeFileAtomic remotePath bs
case old of
Just (oldHash, oldTS) | oldHash == newHash -> do
exceptionFree $ setFileTimes remotePath oldTS oldTS
return False
_ -> do
newTS <- updateFileTimes remotePath
Acc.set cachedInfo (Just (newHash, newTS))
return True
FileCopy _ localFile -> do
-- We just call 'FileWrite' because we need to read the file anyway to
-- compute the hash. Note that `localPath` is interpreted relative to the
-- current directory
bs <- exceptionFree $ BSL.readFile localFile
executeFileCmd (FileWrite info bs)
FileDelete _ -> do
exceptionFree $ ignoreDoesNotExist $ Dir.removeFile remotePath
Acc.set cachedInfo Nothing
-- TODO: We should really return True only if the file existed
return True
where
info :: FileInfo
info = case cmd of FileWrite i _ -> i
FileCopy i _ -> i
FileDelete i -> i
cachedInfo :: Accessor IdeIdleState (Maybe (MD5Digest, LogicalTimestamp))
cachedInfo = ideManagedFiles .> fileInfoAccessor info .> lookup' (fileInfoRemoteFile info)
{-------------------------------------------------------------------------------
Executables, documentation, licenses
-------------------------------------------------------------------------------}
executeBuildExe :: [String] -> [(ModuleName, FilePath)] -> ExecuteSessionUpdate ()
executeBuildExe extraOpts ms = do
ideStaticInfo@IdeStaticInfo{..} <- asks ideUpdateStaticInfo
let SessionConfig{..} = ideConfig
let ideDistDir = ideSessionDistDir ideSessionDir
ideSourceDir = ideSessionSourceDir ideSessionDir
callback <- asks ideUpdateCallback
mcomputed <- Acc.get ideComputed
ghcOpts <- Acc.get ideGhcOpts
relativeIncludes <- Acc.get ideRelativeIncludes
-- Note that these do not contain the @packageDbArgs@ options.
when (not configGenerateModInfo) $
-- TODO: replace the check with an inspection of state component (#87)
fail "Features using cabal API require configGenerateModInfo, currently (#86)."
exceptionFree $ Dir.createDirectoryIfMissing False $ ideDistDir </> "build"
let beStdoutLog = ideDistDir </> "build/ide-backend-exe.stdout"
beStderrLog = ideDistDir </> "build/ide-backend-exe.stderr"
errors = case toLazyMaybe mcomputed of
Nothing ->
error "This session state does not admit artifact generation."
Just Computed{computedErrors} -> toLazyList computedErrors
exitCode <-
if any (== KindError) $ map errorKind errors then do
exceptionFree $ do
writeFile beStderrLog
"Source or other errors encountered. Not attempting to build executables."
return $ ExitFailure 1
else do
let ghcOpts' = "-rtsopts=some" : ghcOpts ++ extraOpts
exceptionFree $ do
(loadedMs, pkgs) <- buildDeps mcomputed
libDeps <- externalDeps pkgs
let beArgs =
BuildExeArgs{ bePackageDBStack = configPackageDBStack
, beExtraPathDirs = configExtraPathDirs
, beSourcesDir = ideSourceDir
, beDistDir = ideDistDir
, beRelativeIncludes = relativeIncludes
, beGhcOpts = ghcOpts'
, beLibDeps = libDeps
, beLoadedMs = loadedMs
, beStdoutLog
, beStderrLog
}
invokeExeCabal ideStaticInfo (ReqExeBuild beArgs ms) callback
-- Solution 2. to #119: update timestamps of .o (and all other) files
-- according to the session's artificial timestamp.
newTS <- nextLogicalTimestamp
exceptionFree $ do
objectPaths <- find always
(fileType ==? RegularFile
&&? (extension ==? ".o"
||? extension ==? ".hi"
||? extension ==? ".a"))
(ideDistDir </> "build")
forM_ objectPaths $ \path -> do
fileStatus <- getFileStatus path
-- We only reset the timestamp, if ghc modified the file.
when (modificationTime fileStatus > newTS) $
setFileTimes path newTS newTS
Acc.set ideBuildExeStatus (Just exitCode)
executeBuildDoc :: ExecuteSessionUpdate ()
executeBuildDoc = do
ideStaticInfo@IdeStaticInfo{..} <- asks ideUpdateStaticInfo
let SessionConfig{..} = ideConfig
let ideDistDir = ideSessionDistDir ideSessionDir
ideSourceDir = ideSessionSourceDir ideSessionDir
callback <- asks ideUpdateCallback
mcomputed <- Acc.get ideComputed
ghcOpts <- Acc.get ideGhcOpts
relativeIncludes <- Acc.get ideRelativeIncludes
when (not configGenerateModInfo) $
-- TODO: replace the check with an inspection of state component (#87)
fail "Features using cabal API require configGenerateModInfo, currently (#86)."
exceptionFree $ Dir.createDirectoryIfMissing False $ ideDistDir </> "doc"
let beStdoutLog = ideDistDir </> "doc/ide-backend-doc.stdout"
beStderrLog = ideDistDir </> "doc/ide-backend-doc.stderr"
errors = case toLazyMaybe mcomputed of
Nothing ->
error "This session state does not admit artifact generation."
Just Computed{computedErrors} -> toLazyList computedErrors
isDummyError err =
errorKind err == KindError
&& errorMsg err == Text.pack "GHC server died (dummy error)"
exitCode <-
-- If some modules contain source errors we might still want to be able
-- to generate documentation of the remainder. However, we rely on ghc's
-- dependency tracking to tell us _which_ modules we need to compile.
-- If the ghc server died we don't get any dependency information, and
-- would hence conclude that the module graph is empty and generate
-- empty documentation, which is confusing.
-- (Note that a similar situation will arise if the root of the module
-- graph contains source errors, in which case we will also get an
-- empty dependency graph. This is harder to take into account, however.)
if any isDummyError errors then do
exceptionFree $ do
writeFile beStderrLog
"GHC server died. Not attempting to build documentation."
return $ ExitFailure 1
else exceptionFree $ do
(loadedMs, pkgs) <- buildDeps mcomputed
libDeps <- externalDeps pkgs
let beArgs =
BuildExeArgs{ bePackageDBStack = configPackageDBStack
, beExtraPathDirs = configExtraPathDirs
, beSourcesDir =
makeRelative ideSessionDir ideSourceDir
, beDistDir =
makeRelative ideSessionDir ideDistDir
, beRelativeIncludes = relativeIncludes
, beGhcOpts = ghcOpts
, beLibDeps = libDeps
, beLoadedMs = loadedMs
, beStdoutLog
, beStderrLog
}
invokeExeCabal ideStaticInfo (ReqExeDoc beArgs) callback
Acc.set ideBuildDocStatus (Just exitCode)
executeBuildLicenses :: FilePath -> ExecuteSessionUpdate ()
executeBuildLicenses cabalsDir = do
ideStaticInfo@IdeStaticInfo{..} <- asks ideUpdateStaticInfo
let SessionConfig{configGenerateModInfo} = ideConfig
let ideDistDir = ideSessionDistDir ideSessionDir
callback <- asks ideUpdateCallback
mcomputed <- Acc.get ideComputed
when (not configGenerateModInfo) $
-- TODO: replace the check with an inspection of state component (#87)
fail "Features using cabal API require configGenerateModInfo, currently (#86)."
let liStdoutLog = ideDistDir </> "licenses.stdout" -- progress
liStderrLog = ideDistDir </> "licenses.stderr" -- warnings and errors
errors = case toLazyMaybe mcomputed of
Nothing ->
error "This session state does not admit artifact generation."
Just Computed{computedErrors} -> toLazyList computedErrors
exitCode <-
if any (== KindError) $ map errorKind errors then do
exceptionFree $ do
writeFile liStderrLog
"Source or other errors encountered. Not attempting to build licenses."
return $ ExitFailure 1
else exceptionFree $ do
(_, pkgs) <- buildDeps mcomputed
let liArgs =
LicenseArgs{ liPackageDBStack = configPackageDBStack ideConfig
, liExtraPathDirs = configExtraPathDirs ideConfig
, liLicenseExc = configLicenseExc ideConfig
, liDistDir = ideDistDir
, liStdoutLog
, liStderrLog
, licenseFixed = configLicenseFixed ideConfig
, liCabalsDir = cabalsDir
, liPkgs = pkgs
}
invokeExeCabal ideStaticInfo (ReqExeLic liArgs) callback
Acc.set ideBuildLicensesStatus (Just exitCode)
{-------------------------------------------------------------------------------
Auxiliary (ide-backend specific)
-------------------------------------------------------------------------------}
-- | Update the file times of the given file with the next logical timestamp
updateFileTimes :: FilePath -> ExecuteSessionUpdate LogicalTimestamp
updateFileTimes path = do
ts <- nextLogicalTimestamp
exceptionFree $ setFileTimes path ts ts
return ts
-- | Get the next available logical timestamp
nextLogicalTimestamp :: ExecuteSessionUpdate LogicalTimestamp
nextLogicalTimestamp = do
newTS <- Acc.get ideLogicalTimestamp
Acc.modify ideLogicalTimestamp (+ 1)
return newTS
{-------------------------------------------------------------------------------
Convenience wrappers around the RPC calls
-------------------------------------------------------------------------------}
rpcCompile :: ExecuteSessionUpdate GhcCompileResult
rpcCompile = do
IdeIdleState{..} <- get
callback <- asks ideUpdateCallback
sourceDir <- asks $ ideSessionSourceDir . ideSessionDir . ideUpdateStaticInfo
-- We need to translate the targets to absolute paths
let targets = case _ideTargets of
TargetsInclude l -> TargetsInclude $ map (sourceDir </>) l
TargetsExclude l -> TargetsExclude $ map (sourceDir </>) l
tryIO $ GHC.rpcCompile _ideGhcServer _ideGenerateCode targets callback
rpcSetEnv :: ExecuteSessionUpdate ()
rpcSetEnv = do
IdeIdleState{..} <- get
tryIO $ GHC.rpcSetEnv _ideGhcServer _ideEnv
rpcSetArgs :: ExecuteSessionUpdate ()
rpcSetArgs = do
IdeIdleState{..} <- get
tryIO $ GHC.rpcSetArgs _ideGhcServer _ideArgs
rpcSetGhcOpts :: ExecuteSessionUpdate [SourceError]
rpcSetGhcOpts = do
IdeIdleState{..} <- get
srcDir <- asks $ ideSessionSourceDir . ideSessionDir . ideUpdateStaticInfo
-- relative include path is part of the state rather than the
-- config as of c0bf0042
let relOpts = relInclToOpts srcDir _ideRelativeIncludes
(leftover, warnings) <- tryIO $ GHC.rpcSetGhcOpts _ideGhcServer (_ideGhcOpts ++ relOpts)
return
[ SourceError {
errorKind = KindWarning
, errorSpan = TextSpan (Text.pack "No location information")
, errorMsg = Text.pack w
}
| w <- warnings ++ map unrecognized leftover
]
where
unrecognized :: String -> String
unrecognized str = "Unrecognized option " ++ show str
-- | Unload all current object files
rpcUnloadObjectFiles :: [(FilePath, (FilePath, LogicalTimestamp))] -> ExecuteSessionUpdate ()
rpcUnloadObjectFiles objects = do
IdeIdleState{..} <- get
tryIO $ GHC.rpcUnload _ideGhcServer $ map (fst . snd) objects
-- | Reload all current object files
rpcLoadObjectFiles :: ExecuteSessionUpdate [SourceError]
rpcLoadObjectFiles = do
IdeIdleState{..} <- get
didLoad <- tryIO $ GHC.rpcLoad _ideGhcServer $ map (fst . snd) _ideObjectFiles
case didLoad of
Just err ->
return [ SourceError {
errorKind = KindError
, errorSpan = TextSpan (Text.pack "No location information")
, errorMsg = Text.pack $ "Failure during object loading: " ++ err
}]
Nothing ->
return []
{-------------------------------------------------------------------------------
Dummy values (see tryIO)
-------------------------------------------------------------------------------}
class Dummy a where
dummy :: a
instance Dummy () where
dummy = ()
instance Dummy [a] where
dummy = []
instance (Dummy a, Dummy b) => Dummy (a, b) where
dummy = (dummy, dummy)
instance Dummy (Maybe a) where
dummy = Nothing
instance Dummy (Strict [] a) where
dummy = List.nil
instance Dummy (Strict (Map k) a) where
dummy = Map.empty
instance Dummy (Strict IntMap a) where
dummy = IntMap.empty
instance Dummy ExplicitSharingCache where
dummy = ExplicitSharingCache {
filePathCache = dummy
, idPropCache = dummy
}
instance Dummy GhcCompileResult where
dummy = GhcCompileResult {
ghcCompileLoaded = dummy
, ghcCompileCache = dummy
, ghcCompileFileMap = dummy
, ghcCompileImports = dummy
, ghcCompileAuto = dummy
, ghcCompileSpanInfo = dummy
, ghcCompilePkgDeps = dummy
, ghcCompileExpTypes = dummy
, ghcCompileUseSites = dummy
, ghcCompileErrors = force [SourceError {
errorKind = KindError
, errorSpan = TextSpan (Text.pack "No location information")
, errorMsg = Text.pack "GHC server died (dummy error)"
}]
}
{-------------------------------------------------------------------------------
Auxiliary (generic)
-------------------------------------------------------------------------------}
maybeSet :: (MonadState st m, Eq a) => Accessor st a -> Maybe a -> m Bool
maybeSet _ Nothing = return False
maybeSet acc (Just new) = do
old <- Acc.get acc
if old /= new then Acc.set acc new >> return True
else return False