ghcide-2.14.0.0: session-loader/Development/IDE/Session.hs
{-# LANGUAGE TypeFamilies #-}
{-|
The logic for setting up a ghcide session by tapping into hie-bios.
-}
module Development.IDE.Session
(SessionLoadingOptions(..)
,CacheDirs(..)
,loadSessionWithOptions
,getInitialGhcLibDirDefault
,getHieDbLoc
,retryOnSqliteBusy
,retryOnException
,SessionLoaderPendingBarrierVar(..)
,setSessionLoaderPendingBarrier
,clearSessionLoaderPendingBarrier
,Log(..)
,runWithDb
) where
-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
-- the real GHC library and the types are incompatible. Furthermore, when
-- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios!
import Control.Concurrent.Strict
import Control.Exception.Safe as Safe
import Control.Monad
import Control.Monad.Extra as Extra
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
import qualified Crypto.Hash.SHA1 as H
import Data.Aeson hiding (Error, Key)
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as B
import Data.Default
import Data.Hashable hiding (hash)
import qualified Data.HashMap.Strict as HM
import Data.List
import Data.List.Extra as L
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Proxy
import qualified Data.Text as T
import Data.Version
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Shake hiding (Log, knownTargets,
withHieDb)
import qualified Development.IDE.GHC.Compat as Compat
import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile,
TargetModule, Var,
Warning, getOptions)
import Development.IDE.GHC.Compat.Env hiding (Logger)
import Development.IDE.GHC.Util
import Development.IDE.Graph (Action, Key)
import qualified Development.IDE.Session.Implicit as GhcIde
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Exports
import Development.IDE.Types.HscEnvEq (HscEnvEq)
import Development.IDE.Types.Location
import Development.IDE.Types.Options
import qualified HIE.Bios as HieBios
import HIE.Bios.Environment hiding (getCacheDir)
import HIE.Bios.Types hiding (Log)
import qualified HIE.Bios.Types as HieBios
import Ide.Logger (Pretty (pretty),
Priority (Debug, Error, Info, Warning),
Recorder, WithPriority,
cmapWithPrio, logWith,
nest,
toCologActionWithPrio,
vcat, viaShow, (<+>))
import Ide.Types (Config,
SessionLoadingPreferenceConfig (..),
sessionLoading)
import Language.LSP.Protocol.Message
import Language.LSP.Server
import System.Directory
import qualified System.Directory.Extra as IO
import System.FilePath
import System.Info
import Control.Applicative (Alternative ((<|>)))
import Data.Void
import Control.Concurrent.STM.Stats (atomically, modifyTVar',
readTVar, writeTVar)
import Control.Monad.Trans.Cont (ContT (ContT, runContT))
import Data.Foldable (for_)
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import qualified Data.HashSet as Set
import Database.SQLite.Simple
import Development.IDE.Core.Tracing (withTrace)
import Development.IDE.Core.WorkerThread
import Development.IDE.Session.Dependency
import Development.IDE.Session.Diagnostics (renderCradleError)
import Development.IDE.Session.Ghc hiding (Log)
import Development.IDE.Types.Shake (WithHieDb,
WithHieDbShield (..),
toNoFileKey)
import HieDb.Create
import HieDb.Types
import Ide.PluginUtils (toAbsolute)
import qualified System.Random as Random
import System.Random (RandomGen)
import Text.ParserCombinators.ReadP (readP_to_S)
import Control.Concurrent.STM (STM, TVar)
import qualified Control.Monad.STM as STM
import Control.Monad.Trans.Reader
import qualified Development.IDE.Session.Ghc as Ghc
import qualified Development.IDE.Session.OrderedSet as S
import qualified Focus
import qualified StmContainers.Map as STM
data Log
= LogSettingInitialDynFlags
| LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void)
| LogGetInitialGhcLibDirDefaultCradleNone
| LogHieDbRetry !Int !Int !Int !SomeException
| LogHieDbRetriesExhausted !Int !Int !Int !SomeException
| LogHieDbWriterThreadSQLiteError !SQLError
| LogHieDbWriterThreadException !SomeException
| LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath))
| LogCradlePath !FilePath
| LogCradleNotFound !FilePath
| LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath, String))
| LogCradle !(Cradle Void)
| LogNoneCradleFound FilePath
| LogHieBios HieBios.Log
| LogSessionLoadingChanged
| LogSessionWorkerThread LogWorkerThread
| LogSessionNewLoadedFiles ![FilePath]
| LogSessionReloadOnError FilePath ![FilePath]
| LogGetOptionsLoop !FilePath
| LogLookupSessionCache !FilePath
| LogTime !String
| LogSessionGhc Ghc.Log
deriving instance Show Log
instance Pretty Log where
pretty = \case
LogSessionWorkerThread msg -> pretty msg
LogTime s -> "Time:" <+> pretty s
LogLookupSessionCache path -> "Looking up session cache for" <+> pretty path
LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp
LogSessionReloadOnError path files ->
"Reloading file due to error in" <+> pretty path <+> "with files:" <+> pretty files
LogSessionNewLoadedFiles files ->
"New loaded files:" <+> pretty files
LogNoneCradleFound path ->
"None cradle found for" <+> pretty path <+> ", ignoring the file"
LogSettingInitialDynFlags ->
"Setting initial dynflags..."
LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle ->
nest 2 $
vcat
[ "Couldn't load cradle for ghc libdir."
, "Cradle error:" <+> viaShow cradleError
, "Root dir path:" <+> pretty rootDirPath
, "hie.yaml path:" <+> pretty hieYamlPath
, "Cradle:" <+> viaShow cradle ]
LogGetInitialGhcLibDirDefaultCradleNone ->
"Couldn't load cradle. Cradle not found."
LogHieDbRetry delay maxDelay retriesRemaining e ->
nest 2 $
vcat
[ "Retrying hiedb action..."
, "delay:" <+> pretty delay
, "maximum delay:" <+> pretty maxDelay
, "retries remaining:" <+> pretty retriesRemaining
, "SQLite error:" <+> pretty (displayException e) ]
LogHieDbRetriesExhausted baseDelay maxDelay retriesRemaining e ->
nest 2 $
vcat
[ "Retries exhausted for hiedb action."
, "base delay:" <+> pretty baseDelay
, "maximum delay:" <+> pretty maxDelay
, "retries remaining:" <+> pretty retriesRemaining
, "Exception:" <+> pretty (displayException e) ]
LogHieDbWriterThreadSQLiteError e ->
nest 2 $
vcat
[ "HieDb writer thread SQLite error:"
, pretty (displayException e) ]
LogHieDbWriterThreadException e ->
nest 2 $
vcat
[ "HieDb writer thread exception:"
, pretty (displayException e) ]
LogKnownFilesUpdated targetToPathsMap ->
nest 2 $
vcat
[ "Known files updated:"
, viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap
]
LogCradlePath path ->
"Cradle path:" <+> pretty path
LogCradleNotFound path ->
vcat
[ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "."
, "Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)."
, "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ]
LogSessionLoadingResult e ->
"Session loading result:" <+> viaShow e
LogCradle cradle ->
"Cradle:" <+> viaShow cradle
LogHieBios msg -> pretty msg
LogSessionGhc msg -> pretty msg
LogSessionLoadingChanged ->
"Session Loading config changed, reloading the full session."
-- | Bump this version number when making changes to the format of the data stored in hiedb
hiedbDataVersion :: String
hiedbDataVersion = "2"
data SessionLoadingOptions = SessionLoadingOptions
{ findCradle :: FilePath -> IO (Maybe FilePath)
-- | Load the cradle with an optional 'hie.yaml' location.
-- If a 'hie.yaml' is given, use it to load the cradle.
-- Otherwise, use the provided project root directory to determine the cradle type.
, loadCradle :: Recorder (WithPriority Log) -> Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void)
-- | Given the project name and a set of command line flags,
-- return the path for storing generated GHC artifacts,
-- or 'Nothing' to respect the cradle setting
, getCacheDirs :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs
-- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
, getInitialGhcLibDir :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)
}
instance Default SessionLoadingOptions where
def = SessionLoadingOptions
{findCradle = HieBios.findCradle
,loadCradle = loadWithImplicitCradle
,getCacheDirs = getCacheDirsDefault
,getInitialGhcLibDir = getInitialGhcLibDirDefault
}
-- | Find the cradle for a given 'hie.yaml' configuration.
--
-- If a 'hie.yaml' is given, the cradle is read from the config.
-- If this config does not comply to the "hie.yaml"
-- specification, an error is raised.
--
-- If no location for "hie.yaml" is provided, the implicit config is used
-- using the provided root directory for discovering the project.
-- The implicit config uses different heuristics to determine the type
-- of the project that may or may not be accurate.
loadWithImplicitCradle
:: Recorder (WithPriority Log)
-> Maybe FilePath
-- ^ Optional 'hie.yaml' location. Will be used if given.
-> FilePath
-- ^ Root directory of the project. Required as a fallback
-- if no 'hie.yaml' location is given.
-> IO (HieBios.Cradle Void)
loadWithImplicitCradle recorder mHieYaml rootDir = do
let logger = toCologActionWithPrio (cmapWithPrio LogHieBios recorder)
case mHieYaml of
Just yaml -> HieBios.loadCradle logger yaml
Nothing -> GhcIde.loadImplicitCradle logger rootDir
getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)
getInitialGhcLibDirDefault recorder rootDir = do
hieYaml <- findCradle def (rootDir </> "a")
cradle <- loadCradle def recorder hieYaml rootDir
libDirRes <- getRuntimeGhcLibDir cradle
case libDirRes of
CradleSuccess libdir -> pure $ Just $ LibDir libdir
CradleFail err -> do
logWith recorder Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle
pure Nothing
CradleNone -> do
logWith recorder Warning LogGetInitialGhcLibDirDefaultCradleNone
pure Nothing
-- | If the action throws exception that satisfies predicate then we sleep for
-- a duration determined by the random exponential backoff formula,
-- `uniformRandom(0, min (maxDelay, (baseDelay * 2) ^ retryAttempt))`, and try
-- the action again for a maximum of `maxRetryCount` times.
-- `MonadIO`, `MonadCatch` are used as constraints because there are a few
-- HieDb functions that don't return IO values.
retryOnException
:: (MonadIO m, MonadCatch m, RandomGen g, Exception e)
=> (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just
-> Recorder (WithPriority Log)
-> Int -- ^ maximum backoff delay in microseconds
-> Int -- ^ base backoff delay in microseconds
-> Int -- ^ maximum number of times to retry
-> g -- ^ random number generator
-> m a -- ^ action that may throw exception
-> m a
retryOnException exceptionPred recorder maxDelay !baseDelay !maxTimesRetry rng action = do
result <- tryJust exceptionPred action
case result of
Left e
| maxTimesRetry > 0 -> do
-- multiply by 2 because baseDelay is midpoint of uniform range
let newBaseDelay = min maxDelay (baseDelay * 2)
let (delay, newRng) = Random.randomR (0, newBaseDelay) rng
let newMaxTimesRetry = maxTimesRetry - 1
liftIO $ do
logWith recorder Warning $ LogHieDbRetry delay maxDelay newMaxTimesRetry (toException e)
threadDelay delay
retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxTimesRetry newRng action
| otherwise -> do
liftIO $ do
logWith recorder Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxTimesRetry (toException e)
throwIO e
Right b -> pure b
-- | in microseconds
oneSecond :: Int
oneSecond = 1000000
-- | in microseconds
oneMillisecond :: Int
oneMillisecond = 1000
-- | default maximum number of times to retry hiedb call
maxRetryCount :: Int
maxRetryCount = 10
retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g)
=> Recorder (WithPriority Log) -> g -> m a -> m a
retryOnSqliteBusy recorder rng action =
let isErrorBusy e
| SQLError{ sqlError = ErrorBusy } <- e = Just e
| otherwise = Nothing
in
retryOnException isErrorBusy recorder oneSecond oneMillisecond maxRetryCount rng action
makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb
makeWithHieDbRetryable recorder rng hieDb f =
retryOnSqliteBusy recorder rng (f hieDb)
-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for
-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial
-- by a worker thread using a dedicated database connection.
-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
--
-- Also see Note [Serializing runs in separate thread]
runWithDb :: Recorder (WithPriority Log) -> FilePath -> ContT () IO (WithHieDbShield, IndexQueue)
runWithDb recorder fp = ContT $ \k -> do
-- use non-deterministic seed because maybe multiple HLS start at same time
-- and send bursts of requests
rng <- Random.newStdGen
-- Delete the database if it has an incompatible schema version
retryOnSqliteBusy
recorder
rng
(withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp)
withHieDb fp $ \writedb -> do
-- the type signature is necessary to avoid concretizing the tyvar
-- e.g. `withWriteDbRetryable initConn` without type signature will
-- instantiate tyvar `a` to `()`
let withWriteDbRetryable :: WithHieDb
withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb
withWriteDbRetryable (setupHieDb . getConn)
-- Clear the index of any files that might have been deleted since the last run
_ <- withWriteDbRetryable deleteMissingRealFiles
_ <- withWriteDbRetryable garbageCollectTypeNames
runContT (withWorkerQueue (cmapWithPrio LogSessionWorkerThread recorder) "hiedb thread" (writer withWriteDbRetryable))
$ \chan -> withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan))
where
writer withHieDbRetryable l = do
-- TODO: probably should let exceptions be caught/logged/handled by top level handler
l withHieDbRetryable
`Safe.catch` \e@SQLError{} -> do
logWith recorder Error $ LogHieDbWriterThreadSQLiteError e
`Safe.catchAny` \f -> do
logWith recorder Error $ LogHieDbWriterThreadException f
getHieDbLoc :: FilePath -> IO FilePath
getHieDbLoc dir = do
let db = intercalate "-" [dirHash, takeBaseName dir, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb"
dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir
cDir <- IO.getXdgDirectory IO.XdgCache cacheDir
createDirectoryIfMissing True cDir
pure (cDir </> db)
-- Note [SessionState and batch load]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- SessionState manages the state for batch loading files in the session loader.
--
-- - When a new file needs to be loaded, it is added to the 'pendingFiles' set.
-- - The loader processes files from 'pendingFiles', attempting to load them in batches.
-- - (SBL1) If a file is already in 'failedFiles', it is loaded individually (single-file mode).
-- - (SBL2) Otherwise, the loader tries to load as many files as possible together (batch mode).
--
-- On success:
-- - (SBL3) All successfully loaded files are removed from 'pendingFiles' and 'failedFiles',
-- and added to 'loadedFiles'.
--
-- On failure:
-- - (SBL4) If loading a single file fails, it is added to 'failedFiles' and removed from 'loadedFiles' and 'pendingFiles'.
-- - (SBL5) If batch loading fails, all files attempted are added to 'failedFiles'.
--
-- This approach ensures efficient batch loading while isolating problematic files for individual handling.
-- SBL3
handleBatchLoadSuccess :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO ()
handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets = do
pendings <- getPendingFiles sessionState
-- this_flags_map might contains files not in pendingFiles, take the intersection
let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map)
atomically $ do
STM.insert this_flags_map hieYaml (fileToFlags sessionState)
insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets
logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded
atomically $ forM_ (Set.toList newLoaded) $ flip S.delete (pendingFiles sessionState)
mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded)
addCradleFiles sessionState newLoaded
-- SBL5
handleBatchLoadFailure :: SessionState -> [FilePath] -> IO ()
handleBatchLoadFailure sessionState files = do
mapM_ (addErrorLoadingFile sessionState) files
-- SBL4
handleSingleLoadFailure :: SessionState -> FilePath -> IO ()
handleSingleLoadFailure sessionState file = do
addErrorLoadingFile sessionState file
atomically $ S.delete file (pendingFiles sessionState)
removeCradleFile sessionState file
data SessionState = SessionState
{ loadedFiles :: !(Var (HashSet FilePath))
-- ^ Set of files that loaded successfully
, failedFiles :: !(Var (HashSet FilePath))
-- ^ Set of files that we tried to load but failed
-- for various reasons, such as cradle load errors
, pendingFiles :: !(S.OrderedSet FilePath)
-- ^ Files we are currently trying to load into the HLS session.
, hscEnvs :: !(Var HieMap)
-- ^ Map @hie.yaml@ location to all components that have this @hie.yaml@ as
-- the root location.
, fileToFlags :: !FlagsMap
-- ^ Map @hie.yaml@ to all modules that have this @hie.yaml@ as the root location.
, filesMap :: !FilesMap
-- ^ Maps a 'NormalizedFilePath' to its @hie.yaml@, the reverse of 'fileToFlags'.
, version :: !(Var Int)
-- ^ Session loading version, incremented whenever the shake cache needs to be invalidated.
, sessionLoadingPreferenceConfig :: !(Var (Maybe SessionLoadingPreferenceConfig))
-- ^ How do we load files? The user can choose to load multiple components at once
-- or to load only one component after the other.
--
-- Changing this value invalidates the entire shake session.
}
newtype SessionLoaderPendingBarrierVar = SessionLoaderPendingBarrierVar (TVar (Maybe Int))
instance IsIdeGlobal SessionLoaderPendingBarrierVar
setSessionLoaderPendingBarrier :: IdeState -> Int -> IO ()
setSessionLoaderPendingBarrier ideState n = do
SessionLoaderPendingBarrierVar barrier <- getIdeGlobalState ideState
atomically $ writeTVar barrier (Just n)
clearSessionLoaderPendingBarrier :: IdeState -> IO ()
clearSessionLoaderPendingBarrier ideState = do
SessionLoaderPendingBarrierVar barrier <- getIdeGlobalState ideState
atomically $ writeTVar barrier Nothing
waitForSessionLoaderPendingBarrier :: TVar (Maybe Int) -> SessionState -> IO ()
waitForSessionLoaderPendingBarrier barrier state =
-- Block the session-loader queue until we have enqueued enough pending files.
-- This is used by tests to enforce true batch setup before consuming pending work.
atomically $ do
mTarget <- readTVar barrier
case mTarget of
Nothing -> pure ()
Just targetSize -> do
pending <- S.toHashSet (pendingFiles state)
if Set.size pending < targetSize
then STM.retry
else writeTVar barrier Nothing
-- | Helper functions for SessionState management
-- These functions encapsulate common operations on the SessionState
-- | Add a file to the set of files with errors during loading
addErrorLoadingFile :: MonadIO m => SessionState -> FilePath -> m ()
addErrorLoadingFile state file =
liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs)
-- | Remove a file from the set of files with errors during loading
removeErrorLoadingFile :: MonadIO m => SessionState -> FilePath -> m ()
removeErrorLoadingFile state file =
liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.delete file xs)
addCradleFiles :: MonadIO m => SessionState -> HashSet FilePath -> m ()
addCradleFiles state files =
liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ files <> xs)
-- | Remove a file from the cradle files set
removeCradleFile :: MonadIO m => SessionState -> FilePath -> m ()
removeCradleFile state file =
liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ Set.delete file xs)
-- | Clear error loading files and reset to empty set
clearErrorLoadingFiles :: MonadIO m => SessionState -> m ()
clearErrorLoadingFiles state =
liftIO $ modifyVar_' (failedFiles state) (const $ return Set.empty)
-- | Clear cradle files and reset to empty set
clearCradleFiles :: MonadIO m => SessionState -> m ()
clearCradleFiles state =
liftIO $ modifyVar_' (loadedFiles state) (const $ return Set.empty)
-- | Reset the file maps in the session state
resetFileMaps :: SessionState -> STM ()
resetFileMaps state = do
STM.reset (filesMap state)
STM.reset (fileToFlags state)
-- | Insert or update file flags for a specific hieYaml and normalized file path
insertFileFlags :: SessionState -> Maybe FilePath -> NormalizedFilePath -> (IdeResult HscEnvEq, DependencyInfo) -> STM ()
insertFileFlags state hieYaml ncfp flags =
STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp flags)) hieYaml (fileToFlags state)
-- | Insert a file mapping from normalized path to hieYaml location
insertFileMapping :: SessionState -> Maybe FilePath -> NormalizedFilePath -> STM ()
insertFileMapping state hieYaml ncfp =
STM.insert hieYaml ncfp (filesMap state)
-- | Remove a file from the pending file set
removeFromPending :: SessionState -> FilePath -> STM ()
removeFromPending state file =
S.delete file (pendingFiles state)
-- | Add a file to the pending file set
addToPending :: SessionState -> FilePath -> STM ()
addToPending state file =
S.insert file (pendingFiles state)
-- | Insert multiple file mappings at once
insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM ()
insertAllFileMappings state mappings =
mapM_ (\(yaml, path) -> insertFileMapping state yaml path) mappings
-- | Increment the version counter
incrementVersion :: SessionState -> IO Int
incrementVersion state = modifyVar' (version state) succ
-- | Get files from the pending file set
getPendingFiles :: SessionState -> IO (HashSet FilePath)
getPendingFiles state = atomically $ S.toHashSet (pendingFiles state)
-- | Handle errors during session loading by recording file as having error and removing from pending
handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> SessionM ()
handleSingleFileProcessingError' state hieYaml file e = do
handleSingleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty
-- | Common pattern: Insert file flags, insert file mapping, and remove from pending
handleSingleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> SessionM ()
handleSingleFileProcessingError state hieYaml file diags extraDepFiles = liftIO $ do
dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles
let ncfp = toNormalizedFilePath' file
let flags = ((diags, Nothing), dep)
handleSingleLoadFailure state file
atomically $ do
insertFileFlags state hieYaml ncfp flags
insertFileMapping state hieYaml ncfp
-- | Get the set of extra files to load based on the current file path.
--
-- If the current file is in error loading files, we fallback to single loading mode (empty set)
-- Otherwise, we remove error files from pending files and also exclude the current file
getExtraFilesToLoad :: SessionState -> FilePath -> IO [FilePath]
getExtraFilesToLoad state cfp = do
pendingFiles <- getPendingFiles state
errorFiles <- readVar (failedFiles state)
old_files <- readVar (loadedFiles state)
-- if the file is in error loading files, we fall back to single loading mode
return $
Set.toList $
if cfp `Set.member` errorFiles
then Set.empty
-- remove error files from pending files since error loading need to load one by one
else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files
-- | We allow users to specify a loading strategy.
-- Check whether this config was changed since the last time we have loaded
-- a session.
--
-- If the loading configuration changed, we likely should restart the session
-- in its entirety.
didSessionLoadingPreferenceConfigChange :: SessionState -> SessionM Bool
didSessionLoadingPreferenceConfigChange s = do
clientConfig <- asks sessionClientConfig
let biosSessionLoadingVar = sessionLoadingPreferenceConfig s
mLoadingConfig <- liftIO $ readVar biosSessionLoadingVar
case mLoadingConfig of
Nothing -> do
liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))
pure False
Just loadingConfig -> do
liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))
pure (loadingConfig /= sessionLoading clientConfig)
newSessionState :: IO SessionState
newSessionState = do
-- Initialize SessionState
sessionState <- SessionState
<$> newVar (Set.fromList []) -- loadedFiles
<*> newVar (Set.fromList []) -- failedFiles
<*> S.newIO -- pendingFiles
<*> newVar Map.empty -- hscEnvs
<*> STM.newIO -- fileToFlags
<*> STM.newIO -- filesMap
<*> newVar 0 -- version
<*> newVar Nothing -- sessionLoadingPreferenceConfig
return sessionState
-- | Given a root directory, return a Shake 'Action' which setups an
-- 'IdeGhcSession' given a file.
-- Some of the many things this does:
--
-- * Find the cradle for the file
-- * Get the session options,
-- * Get the GHC lib directory
-- * Make sure the GHC compiletime and runtime versions match
-- * Restart the Shake session
--
-- This is the key function which implements multi-component support. All
-- components mapping to the same hie.yaml file are mapped to the same
-- HscEnv which is updated as new components are discovered.
loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TaskQueue (IO ()) -> IO (Action IdeGhcSession)
loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory]
sessionState <- newSessionState
let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar (version sessionState))
-- This caches the mapping from Mod.hs -> hie.yaml
cradleLoc <- liftIO $ memoIO $ \v -> do
res <- findCradle v
-- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
-- try and normalise that
-- e.g. see https://github.com/haskell/ghcide/issues/126
let res' = toAbsolutePath <$> res
return $ normalise <$> res'
return $ do
clientConfig <- getClientConfigAction
extras@ShakeExtras{ideNc, knownTargetsVar
} <- getShakeExtras
let invalidateShakeCache = do
void $ incrementVersion sessionState
return $ toNoFileKey GhcSessionIO
ideOptions <- getIdeOptions
SessionLoaderPendingBarrierVar pendingBarrier <- getIdeGlobalAction
-- see Note [Serializing runs in separate thread]
-- Start the 'getOptionsLoop' if the queue is empty
liftIO $ atomically $
Extra.whenM (isEmptyTaskQueue que) $ do
let newSessionLoadingOptions = SessionLoadingOptions
{ findCradle = cradleLoc
, ..
}
sessionShake = SessionShake
{ restartSession = restartShakeSession extras
, invalidateCache = invalidateShakeCache
, enqueueActions = shakeEnqueue extras
}
sessionEnv = SessionEnv
{ sessionLspContext = lspEnv extras
, sessionRootDir = rootDir
, sessionIdeOptions = ideOptions
, sessionPendingBarrier = pendingBarrier
, sessionClientConfig = clientConfig
, sessionSharedNameCache = ideNc
, sessionLoadingOptions = newSessionLoadingOptions
}
writeTaskQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv)
-- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action
-- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes.
-- The GlobPattern of a FileSystemWatcher can be absolute or relative.
-- We use the absolute one because it is supported by more LSP clients.
-- Here we make sure deps are absolute and later we use those absolute deps as GlobPattern.
let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath $ Map.keys deps)
returnWithVersion $ \file -> do
let absFile = toAbsolutePath file
absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile
-- | Given a file, this function will return the HscEnv and the dependencies
-- it would look up the cache first, if the cache is not available, it would
-- submit a request to the getOptionsLoop to get the options for the file
-- and wait until the options are available
lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo)
lookupOrWaitCache recorder sessionState absFile = do
let ncfp = toNormalizedFilePath' absFile
cacheResult <- maybeM
(return Nothing)
(guardedA (checkDependencyInfo . snd))
(atomically $ do
-- wait until target file is not in pendingFiles
Extra.whenM (S.lookup absFile (pendingFiles sessionState)) STM.retry
-- check if in the cache
checkInCache sessionState ncfp)
logWith recorder Debug $ LogLookupSessionCache absFile
case cacheResult of
Just r -> return r
Nothing -> do
-- if not ok, we need to reload the session
atomically $ addToPending sessionState absFile
lookupOrWaitCache recorder sessionState absFile
checkInCache :: SessionState -> NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo))
checkInCache sessionState ncfp = runMaybeT $ do
cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState)
m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState)
MaybeT $ pure $ HM.lookup ncfp m
-- | Modify the shake state.
data SessionShake = SessionShake
{ restartSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
, invalidateCache :: IO Key
, enqueueActions :: DelayedAction () -> IO (IO ())
}
-- | Read-only data that the initialisation logic needs access to.
data SessionEnv = SessionEnv
{ sessionLspContext :: Maybe (LanguageContextEnv Config)
, sessionRootDir :: FilePath
, sessionIdeOptions :: IdeOptions
, sessionPendingBarrier :: TVar (Maybe Int)
, sessionClientConfig :: Config
, sessionSharedNameCache :: NameCache
, sessionLoadingOptions :: SessionLoadingOptions
}
type SessionM = ReaderT SessionEnv IO
-- | The main function which gets options for a file.
--
-- The general approach is as follows:
-- 1. Find the 'hie.yaml' for the next file target, if there is any.
-- 2. Check in the cache, whether the given 'hie.yaml' was already loaded before
-- 3.1. If it wasn't, initialise a new session and continue with step 4.
-- 3.2. If it is loaded, check whether we need to reload the session, e.g. because the `.cabal` file was modified
-- 3.2.1. If we need to reload, remove the
--
-- See Note [SessionState and batch load] for an overview of the strategy.
getOptionsLoop :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> SessionM ()
getOptionsLoop recorder sessionShake sessionState knownTargetsVar = forever $ do
pendingBarrier <- asks sessionPendingBarrier
IdeTesting isTestMode <- asks (optTesting . sessionIdeOptions)
when isTestMode $
liftIO $ waitForSessionLoaderPendingBarrier pendingBarrier sessionState
-- Get the next file to load
file <- liftIO $ atomically $ S.readQueue (pendingFiles sessionState)
logWith recorder Debug (LogGetOptionsLoop file)
hieLoc <- findHieYamlForTarget (filesMap sessionState) file
sessionOpts recorder sessionShake sessionState knownTargetsVar (hieLoc, file)
`Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file
findHieYamlForTarget :: FilesMap -> FilePath -> SessionM (Maybe FilePath)
findHieYamlForTarget filesMapping file = do
let ncfp = toNormalizedFilePath' file
cachedHieYamlLocation <- join <$> liftIO (atomically (STM.lookup ncfp filesMapping))
sessionLoadingOptions <- asks sessionLoadingOptions
hieYaml <- liftIO $ findCradle sessionLoadingOptions file
pure $ cachedHieYamlLocation <|> hieYaml
-- | This caches the mapping from hie.yaml + Mod.hs -> [String]
-- Returns the Ghc session and the cradle dependencies
sessionOpts :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> (Maybe FilePath, FilePath) -> SessionM ()
sessionOpts recorder sessionShake sessionState knownTargetsVar (hieYaml, file) = do
Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState) $ do
logWith recorder Info LogSessionLoadingChanged
liftIO $ atomically $ resetFileMaps sessionState
-- Don't even keep the name cache, we start from scratch here!
liftIO $ modifyVar_ (hscEnvs sessionState) (const (return Map.empty))
-- cleanup error loading files and cradle files
clearErrorLoadingFiles sessionState
clearCradleFiles sessionState
cacheKey <- liftIO $ invalidateCache sessionShake
liftIO $ restartSession sessionShake VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey])
v <- liftIO $ atomically $ STM.lookup hieYaml (fileToFlags sessionState)
case v >>= HM.lookup (toNormalizedFilePath' file) of
Just (_opts, old_di) -> do
deps_ok <- liftIO $ checkDependencyInfo old_di
if not deps_ok
then do
-- if deps are old, we can try to load the error files again
removeErrorLoadingFile sessionState file
removeCradleFile sessionState file
-- If the dependencies are out of date then clear both caches and start
-- again.
liftIO $ atomically $ resetFileMaps sessionState
-- Keep the same name cache
liftIO $ modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml)
-- This file needs to be reloaded!
consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file
else do
-- If deps are ok, we can just remove the file from pending files.
-- This unblocks the STM waiting in 'lookupOrWaitCache'.
liftIO $ atomically $ removeFromPending sessionState file
Nothing ->
-- This file has never been loaded before, so actually load it now!
consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file
consultCradle :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> Maybe FilePath -> FilePath -> SessionM ()
consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp = do
(cradle, eopts) <- loadCradleWithNotifications recorder sessionState hieYaml cfp
logWith recorder Debug $ LogSessionLoadingResult eopts
let ncfp = toNormalizedFilePath' cfp
case eopts of
-- The cradle gave us some options so get to work turning them
-- into and HscEnv.
Right (opts, libDir, version) -> do
let compileTime = fullCompilerVersion
case reverse $ readP_to_S parseVersion version of
[] -> error $ "GHC version could not be parsed: " <> version
((runTime, _):_)
| compileTime == runTime -> session recorder sessionShake sessionState knownTargetsVar (hieYaml, ncfp, opts, libDir)
| otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..})
-- Failure case, either a cradle error or the none cradle
Left err -> do
-- what if the error to load file is one of old_files ?
let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err
old_files <- liftIO $ readVar (loadedFiles sessionState)
let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files)
if length errorToLoadNewFiles > 1
then do
-- We tried loading multiple files, but some failed to load!
-- Unfortunately, 'hie-bios' is an all-or-nothing kind of deal,
-- and we don't know whether some of the files could have been loaded,
-- or none of them have been!
-- To work around this, we try to remove the failing targets from the set of extra targets,
-- to still get a fast reload.
--
-- How do we do this? We mark all of the extra target files as files that failed to
-- to load and retry to load the original target.
-- We decide the extra targets in 'getExtraFilesToLoad', which takes the
-- set of failed targets into account.
liftIO $ handleBatchLoadFailure sessionState errorToLoadNewFiles
-- retry without other files
logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles)
consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp
else do
-- We are only loading this file and it failed, so we definitely know,
-- we can't load it.
-- Add it to the list of permanently failed to load targets and do not retry!
let res = map (\err' -> renderCradleError err' cradle ncfp) err
handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err
-- | Set up the GHC session for the new 'ComponentOptions' we have discovered.
--
-- The units found in these 'ComponentOptions' are merged with the set of existing home units,
-- replacing the older home unit with the new ones.
-- We update the GHC session to use a multiple home unit session, and restart the shake session accordingly.
session ::
Recorder (WithPriority Log) ->
SessionShake ->
SessionState ->
TVar (Hashed KnownTargets) ->
(Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) ->
SessionM ()
session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir) = do
let initEmptyHscEnv = emptyHscEnvM libDir
(new_components_info, old_components_info) <- packageSetup recorder sessionState initEmptyHscEnv (hieYaml, cfp, opts)
-- For each component, now make a new HscEnvEq which contains the
-- HscEnv for the hie.yaml file but the DynFlags for that component
-- For GHC's supporting multi component sessions, we create a shared
-- HscEnv but set the active component accordingly
hscEnv <- initEmptyHscEnv
ideOptions <- asks sessionIdeOptions
let new_cache = newComponentCache (cmapWithPrio LogSessionGhc recorder) (optExtensions ideOptions) cfp hscEnv
all_target_details <- liftIO $ new_cache old_components_info new_components_info
(all_targets, this_flags_map) <- liftIO $ addErrorTargetIfUnknown all_target_details hieYaml cfp
-- The VFS doesn't change on cradle edits, re-use the old one.
-- Invalidate all the existing GhcSession build nodes by restarting the Shake session
liftIO $ do
checkProject <- optCheckProject ideOptions
restartSession sessionShake VFSUnmodified "new component" [] $ do
-- It is necessary to call 'handleBatchLoadSuccess' in restartSession
-- to ensure the GhcSession rule does not return before a new session is started.
-- Otherwise, invalid compilation results may propagate to downstream rules,
-- potentially resulting in lost diagnostics and other issues.
handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets
keys2 <- invalidateCache sessionShake
keys1 <- extendKnownTargets recorder knownTargetsVar all_targets
-- Typecheck all files in the project on startup
unless (null new_components_info || not checkProject) $ do
cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets)
void $ enqueueActions sessionShake $ mkDelayedAction "InitialLoad" Debug $ void $ do
mmt <- uses GetModificationTime cfps'
let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
modIfaces <- uses GetModIface cs_exist
-- update exports map
shakeExtras <- getShakeExtras
let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces
liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>)
return [keys1, keys2]
-- | Create a new HscEnv from a hieYaml root and a set of options
packageSetup :: Recorder (WithPriority Log) -> SessionState -> SessionM HscEnv -> (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> SessionM ([ComponentInfo], [ComponentInfo])
packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do
getCacheDirs <- asks (getCacheDirs . sessionLoadingOptions)
haddockparse <- asks (optHaddockParse . sessionIdeOptions)
rootDir <- asks sessionRootDir
-- Parse DynFlags for the newly discovered component
hscEnv <- newEmptyHscEnv
newTargetDfs <- liftIO $ evalGhcEnv hscEnv $ setOptions haddockparse cfp opts (hsc_dflags hscEnv) rootDir
let deps = componentDependencies opts ++ maybeToList hieYaml
dep_info <- liftIO $ getDependencyInfo (fmap (toAbsolute rootDir) deps)
-- Now lookup to see whether we are combining with an existing HscEnv
-- or making a new one. The lookup returns the HscEnv and a list of
-- information about other components loaded into the HscEnv
-- (unitId, DynFlag, Targets)
liftIO $ modifyVar (hscEnvs sessionState) $
addComponentInfo (cmapWithPrio LogSessionGhc recorder) getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts)
addErrorTargetIfUnknown :: Foldable t => t [TargetDetails] -> Maybe FilePath -> NormalizedFilePath -> IO ([TargetDetails], HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))
addErrorTargetIfUnknown all_target_details hieYaml cfp = do
let flags_map' = HM.fromList (concatMap toFlagsMap all_targets')
all_targets' = concat all_target_details
this_dep_info <- getDependencyInfo $ maybeToList hieYaml
let (all_targets, this_flags_map) = case HM.lookup cfp flags_map' of
Just _ -> (all_targets', flags_map')
Nothing -> (this_target_details : all_targets', HM.insert cfp this_flags flags_map')
where
this_target_details = TargetDetails (TargetFile cfp) this_error_env this_dep_info [cfp]
this_flags = (this_error_env, this_dep_info)
this_error_env = ([this_error], Nothing)
this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) cfp
(T.unlines
[ "No cradle target found. Is this file listed in the targets of your cradle?"
, "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
])
Nothing
pure (all_targets, this_flags_map)
-- | Populate the knownTargetsVar with all the
-- files in the project so that `knownFiles` can learn about them and
-- we can generate a complete module graph
extendKnownTargets :: Recorder (WithPriority Log) -> TVar (Hashed KnownTargets) -> [TargetDetails] -> IO Key
extendKnownTargets recorder knownTargetsVar newTargets = do
knownTargets <- concatForM newTargets $ \TargetDetails{..} ->
case targetTarget of
TargetFile f -> do
-- If a target file has multiple possible locations, then we
-- assume they are all separate file targets.
-- This happens with '.hs-boot' files if they are in the root directory of the project.
-- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'.
-- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the
-- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'.
-- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either
--
-- * TargetFile Foo.hs-boot
-- * TargetModule Foo
--
-- If we don't generate a TargetFile for each potential location, we will only have
-- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot'
-- and also not find 'TargetModule Foo'.
fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs))
TargetModule _ -> do
found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
return [(targetTarget, Set.fromList found)]
hasUpdate <- atomically $ do
known <- readTVar knownTargetsVar
let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets)
hasUpdate = if known /= known' then Just (unhashed known') else Nothing
writeTVar knownTargetsVar known'
pure hasUpdate
for_ hasUpdate $ \x ->
logWith recorder Debug $ LogKnownFilesUpdated (targetMap x)
return $ toNoFileKey GetKnownTargets
loadCradleWithNotifications ::
Recorder (WithPriority Log) ->
SessionState ->
Maybe FilePath ->
FilePath ->
SessionM (Cradle Void, Either [CradleError] (ComponentOptions, FilePath, String))
loadCradleWithNotifications recorder sessionState hieYaml cfp = do
rootDir <- asks sessionRootDir
let lfpLog = makeRelative rootDir cfp
logWith recorder Info $ LogCradlePath lfpLog
when (isNothing hieYaml) $
logWith recorder Warning $ LogCradleNotFound lfpLog
-- Find the 'Cradle' for the target
loadingOptions <- asks sessionLoadingOptions
cradle <- liftIO $ loadCradle loadingOptions recorder hieYaml rootDir
-- Test notification for better observability.
IdeTesting isTesting <- asks (optTesting . sessionIdeOptions)
lspEnv <- asks sessionLspContext
when isTesting $ mRunLspT lspEnv $
sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)
-- Display a user friendly progress message here: They probably don't know what a cradle is
let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
<> " (for " <> T.pack lfpLog <> ")"
sessionPref <- asks (sessionLoading . sessionClientConfig)
extraToLoads <- liftIO $ getExtraFilesToLoad sessionState cfp
-- Start loading the file!
eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $
withTrace "Load cradle" $ \addTag -> do
addTag "file" lfpLog
res <- liftIO $ cradleToOptsAndLibDir recorder sessionPref cradle cfp extraToLoads
addTag "result" (show res)
return res
pure (cradle, eopts)
-- | Run the specific cradle on a specific FilePath via hie-bios.
-- This then builds dependencies or whatever based on the cradle, gets the
-- GHC options/dynflags needed for the session and the GHC library directory
cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> Cradle Void -> FilePath -> [FilePath]
-> IO (Either [CradleError] (ComponentOptions, FilePath, String))
cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do
-- let noneCradleFoundMessage :: FilePath -> T.Text
-- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"
-- Start off by getting the session options
logWith recorder Debug $ LogCradle cradle
cradleRes <- HieBios.getCompilerOptions file loadStyle cradle
case cradleRes of
CradleSuccess r -> do
-- Now get the GHC lib dir
libDirRes <- getRuntimeGhcLibDir cradle
versionRes <- getRuntimeGhcVersion cradle
case liftA2 (,) libDirRes versionRes of
-- This is the successful path
(CradleSuccess (libDir, version)) -> pure (Right (r, libDir, version))
CradleFail err -> return (Left [err])
CradleNone -> do
logWith recorder Info $ LogNoneCradleFound file
return (Left [])
CradleFail err -> return (Left [err])
CradleNone -> do
logWith recorder Info $ LogNoneCradleFound file
return (Left [])
where
loadStyle = case loadConfig of
PreferSingleComponentLoading -> LoadFile
PreferMultiComponentLoading -> LoadWithContext old_fps
-- ----------------------------------------------------------------------------
-- Utilities
-- ----------------------------------------------------------------------------
emptyHscEnvM :: FilePath -> SessionM HscEnv
emptyHscEnvM libDir = do
nc <- asks sessionSharedNameCache
liftIO $ Ghc.emptyHscEnv nc libDir
toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]
toFlagsMap TargetDetails{..} =
[ (l, (targetEnv, targetDepends)) | l <- targetLocations]
-- | Mapping from @hie.yaml@ to all components that have been loaded
-- from this @hie.yaml@ location.
--
-- See Note [Multi Cradle Dependency Info]
type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo]
-- | Maps a @hie.yaml@ location to all its Target Filepaths and options.
-- Reverse of 'FilesMap'.
type FlagsMap = STM.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))
-- | Maps a Filepath to its respective @hie.yaml@ location.
-- It aims to be the reverse of 'FlagsMap'.
type FilesMap = STM.Map NormalizedFilePath (Maybe FilePath)
-- | Memoize an IO function, with the characteristics:
--
-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
--
-- * If there are exceptions, repeatedly reraise them.
--
-- * If the caller is aborted (async exception) finish computing it anyway.
memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)
memoIO op = do
ref <- newVar Map.empty
return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->
case Map.lookup k mp of
Nothing -> do
res <- onceFork $ op k
return (Map.insert k res mp, res)
Just res -> return (mp, res)
----------------------------------------------------------------------------------------------------
data PackageSetupException
= PackageSetupException
{ message :: !String
}
| GhcVersionMismatch
{ compileTime :: !Version
, runTime :: !Version
}
deriving (Eq, Show, Typeable)
instance Exception PackageSetupException
showPackageSetupException :: PackageSetupException -> String
showPackageSetupException GhcVersionMismatch{..} = unwords
["ghcide compiled against GHC"
,showVersion compileTime
,"but currently using"
,showVersion runTime
,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project."
]
showPackageSetupException PackageSetupException{..} = unwords
[ "ghcide compiled by GHC", showVersion fullCompilerVersion
, "failed to load packages:", message <> "."
, "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."]
renderPackageSetupException :: FilePath -> PackageSetupException -> FileDiagnostic
renderPackageSetupException fp e =
ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) Nothing