diff --git a/cabal.project b/cabal.project index 989edd0344..59f565677b 100644 --- a/cabal.project +++ b/cabal.project @@ -8,7 +8,7 @@ packages: ./hls-test-utils -index-state: 2025-04-19T07:34:07Z +index-state: 2025-04-26T07:34:07Z tests: True test-show-details: direct @@ -52,8 +52,10 @@ constraints: allow-newer: cabal-install-parsers:Cabal-syntax, + if impl(ghc >= 9.11) benchmarks: False allow-newer: cabal-install-parsers:base, cabal-install-parsers:time, + diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index be18c8aa56..eed0ed5919 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -73,7 +73,7 @@ library , Glob , haddock-library >=1.8 && <1.12 , hashable - , hie-bios ^>=0.14.0 + , hie-bios ^>=0.15.0 , hie-compat ^>=0.3.0.0 , hiedb ^>= 0.6.0.2 , hls-graph == 2.10.0.0 @@ -203,6 +203,7 @@ library Development.IDE.GHC.CPP Development.IDE.GHC.Warnings Development.IDE.Types.Action + Development.IDE.Session.OrderedSet if flag(pedantic) ghc-options: diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 50a30c6ad2..76d10c9d66 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -25,6 +25,7 @@ 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) import Data.Bifunctor @@ -103,8 +104,7 @@ import qualified Data.HashSet as Set import qualified Data.Set as OS import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.Core.WorkerThread (awaitRunInThread, - withWorkerQueue) +import Development.IDE.Core.WorkerThread (withWorkerQueue) import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Types.Shake (WithHieDb, @@ -118,11 +118,17 @@ import qualified System.Random as Random import System.Random (RandomGen) import Text.ParserCombinators.ReadP (readP_to_S) +import Control.Concurrent.STM (STM) +import qualified Control.Monad.STM as STM +import qualified Development.IDE.Session.OrderedSet as S +import qualified Focus +import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State +import qualified StmContainers.Map as STM #if MIN_VERSION_ghc(9,13,0) import GHC.Driver.Make (checkHomeUnitsClosed) @@ -148,10 +154,22 @@ data Log | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log | LogSessionLoadingChanged + | LogSessionNewLoadedFiles ![FilePath] + | LogSessionReloadOnError FilePath ![FilePath] + | LogGetOptionsLoop !FilePath + | LogLookupSessionCache !FilePath + | LogTime !String deriving instance Show Log instance Pretty Log where pretty = \case + 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 -> @@ -400,6 +418,125 @@ getHieDbLoc dir = do createDirectoryIfMissing True cDir pure (cDir db) +data SessionState = SessionState + { cradle_files :: !(IORef (HashSet FilePath)) + , error_loading_files :: !(IORef (HashSet FilePath)) + , hscEnvs :: !(Var HieMap) + , fileToFlags :: !(STM.Map (Maybe FilePath) (HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))) + , filesMap :: !(STM.Map NormalizedFilePath (Maybe FilePath)) + , pendingFileSet :: !(S.OrderedSet FilePath) + , version :: !(Var Int) + } + +-- | 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 :: SessionState -> FilePath -> IO () +addErrorLoadingFile state file = + atomicModifyIORef' (error_loading_files state) (\xs -> (Set.insert file xs, ())) + +addErrorLoadingFiles :: SessionState -> [FilePath] -> IO () +addErrorLoadingFiles = mapM_ . addErrorLoadingFile + +-- | Remove a file from the set of files with errors during loading +removeErrorLoadingFile :: SessionState -> FilePath -> IO () +removeErrorLoadingFile state file = + atomicModifyIORef' (error_loading_files state) (\xs -> (Set.delete file xs, ())) + +addCradleFiles :: SessionState -> HashSet FilePath -> IO () +addCradleFiles state files = + atomicModifyIORef' (cradle_files state) (\xs -> (files <> xs, ())) + +-- | Remove a file from the cradle files set +removeCradleFile :: SessionState -> FilePath -> IO () +removeCradleFile state file = + atomicModifyIORef' (cradle_files state) (\xs -> (Set.delete file xs, ())) + +-- | Clear error loading files and reset to empty set +clearErrorLoadingFiles :: SessionState -> IO () +clearErrorLoadingFiles state = + atomicModifyIORef' (error_loading_files state) (\_ -> (Set.empty, ())) + +-- | Clear cradle files and reset to empty set +clearCradleFiles :: SessionState -> IO () +clearCradleFiles state = + atomicModifyIORef' (cradle_files state) (\_ -> (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 (pendingFileSet state) + +-- | Add a file to the pending file set +addToPending :: SessionState -> FilePath -> STM () +addToPending state file = + S.insert file (pendingFileSet state) + +-- | Common pattern: Insert file flags, insert file mapping, and remove from pending +completeFileProcessing :: SessionState -> Maybe FilePath -> NormalizedFilePath -> FilePath -> (IdeResult HscEnvEq, DependencyInfo) -> IO () +completeFileProcessing state hieYaml ncfp file flags = do +-- remove cfp from pending files + addErrorLoadingFile state file + removeCradleFile state file + atomically $ do + insertFileFlags state hieYaml ncfp flags + insertFileMapping state hieYaml ncfp + removeFromPending state file + +-- | 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 $ Set.fromList <$> S.toUnOrderedList (pendingFileSet state) + +-- | Handle errors during session loading by recording file as having error and removing from pending +handleSessionError :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () +handleSessionError state hieYaml file e = do + dep <- getDependencyInfo $ maybe [] pure hieYaml + let ncfp = toNormalizedFilePath' file + let errorResult = (([renderPackageSetupException file e], Nothing), dep) + completeFileProcessing state hieYaml ncfp file errorResult + +-- | 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 <- readIORef (error_loading_files state) + old_files <- readIORef (cradle_files 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 + -- | Given a root directory, return a Shake 'Action' which setups an -- 'IdeGhcSession' given a file. -- Some of the many things this does: @@ -417,20 +554,20 @@ getHieDbLoc dir = do loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] - cradle_files <- newIORef [] - -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file - hscEnvs <- newVar Map.empty :: IO (Var HieMap) - -- Mapping from a Filepath to HscEnv - fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) - -- Mapping from a Filepath to its 'hie.yaml' location. - -- Should hold the same Filepaths as 'fileToFlags', otherwise - -- they are inconsistent. So, everywhere you modify 'fileToFlags', - -- you have to modify 'filesMap' as well. - filesMap <- newVar HM.empty :: IO (Var FilesMap) - -- Version of the mappings above - version <- newVar 0 + + -- Initialize SessionState + sessionState <- SessionState + <$> newIORef (Set.fromList []) -- cradle_files + <*> newIORef (Set.fromList []) -- error_loading_files + <*> newVar Map.empty -- hscEnvs + <*> STM.newIO -- fileToFlags + <*> STM.newIO -- filesMap + <*> S.newIO -- pendingFileSet + <*> newVar 0 -- version + biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) - let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) + 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 @@ -445,7 +582,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv } <- getShakeExtras let invalidateShakeCache = do - void $ modifyVar' version succ + void $ incrementVersion sessionState return $ toNoFileKey GhcSessionIO IdeOptions{ optTesting = IdeTesting optTesting @@ -502,7 +639,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- 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) - modifyVar hscEnvs $ \m -> do + modifyVar (hscEnvs sessionState) $ \m -> do -- Just deps if there's already an HscEnv -- Nothing is it's the first time we are making an HscEnv let oldDeps = Map.lookup hieYaml m @@ -543,7 +680,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO (IdeResult HscEnvEq,[FilePath]) + -> IO ((IdeResult HscEnvEq,DependencyInfo), HashSet FilePath, IO ()) session args@(hieYaml, _cfp, _opts, _libDir) = do (new_deps, old_deps) <- packageSetup args @@ -555,13 +692,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let new_cache = newComponentCache recorder optExtensions _cfp hscEnv all_target_details <- new_cache old_deps new_deps + 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, this_options) = case HM.lookup _cfp flags_map' of Just this -> (all_targets', flags_map', this) Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) - where all_targets' = concat all_target_details - flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + 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) @@ -572,31 +710,33 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ]) Nothing - void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map - void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) - -- 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 - keys2 <- invalidateShakeCache - restartShakeSession VFSUnmodified "new component" [] $ do - keys1 <- extendKnownTargets all_targets - return [keys1, keys2] + let newLoaded = 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 + forM_ newLoaded $ flip S.delete (pendingFileSet sessionState) -- Typecheck all files in the project on startup checkProject <- getCheckProject - unless (null new_deps || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - void $ shakeEnqueue extras $ 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 $ second Map.keys this_options - - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + -- 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 + let restart = restartShakeSession VFSUnmodified "new component" [] $ do + keys2 <- invalidateShakeCache + keys1 <- extendKnownTargets all_targets + unless (null new_deps || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + void $ shakeEnqueue extras $ 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] + return (this_options, newLoaded, restart) + + let consultCradle :: Maybe FilePath -> FilePath -> IO () consultCradle hieYaml cfp = do let lfpLog = makeRelative rootDir cfp logWith recorder Info $ LogCradlePath lfpLog @@ -609,11 +749,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- 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 <> ")" + + extraToLoads <- getExtraFilesToLoad sessionState cfp eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog - old_files <- readIORef cradle_files - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files + res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp extraToLoads addTag "result" (show res) return res @@ -622,23 +763,49 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- The cradle gave us some options so get to work turning them -- into and HscEnv. Right (opts, libDir, version) -> do + let ncfp = toNormalizedFilePath' cfp let compileTime = fullCompilerVersion case reverse $ readP_to_S parseVersion version of [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - atomicModifyIORef' cradle_files (\xs -> (cfp:xs,())) - session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) - | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) + (_results, allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) + pendingFiles <- getPendingFiles sessionState + let newLoaded = pendingFiles `Set.intersection` allNewLoaded + -- log new loaded files + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + -- remove all new loaded file from error loading files + mapM_ (removeErrorLoadingFile sessionState) (Set.toList allNewLoaded) + addCradleFiles sessionState newLoaded + restart + | otherwise -> do + -- Use the common pattern here: updateFileState + completeFileProcessing sessionState hieYaml ncfp cfp + (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing), mempty) -- Failure case, either a cradle error or the none cradle Left err -> do - dep_info <- getDependencyInfo (maybeToList hieYaml) - let ncfp = toNormalizedFilePath' cfp - let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - void $ modifyVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) - void $ modifyVar' filesMap $ HM.insert ncfp hieYaml - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) + -- what if the error to load file is one of old_files ? + let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err + old_files <- readIORef (cradle_files sessionState) + let errorToLoadNewFiles = attemptToLoadFiles `Set.difference` old_files + if not (null errorToLoadNewFiles) + then do + -- we are loading more files and failed, we need to retry + -- mark as less loaded files as failedLoadingFiles as possible + -- limitation is that when we are loading files, and the dependencies of old_files + -- are changed, and old_files are not valid anymore. + -- but they will still be in the old_files, and will not move to error_loading_files. + -- And make other files failed to load in batch mode. + addErrorLoadingFiles sessionState (Set.toList errorToLoadNewFiles) + -- retry without other files + logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) + consultCradle hieYaml cfp + else do + -- we are only loading this file and it failed + dep_info <- getDependencyInfo (maybeToList hieYaml ++ concatMap cradleErrorDependencies err) + let ncfp = toNormalizedFilePath' cfp + let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) + completeFileProcessing sessionState hieYaml ncfp cfp (res, dep_info) let -- | We allow users to specify a loading strategy. @@ -661,49 +828,97 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies let sessionOpts :: (Maybe FilePath, FilePath) - -> IO (IdeResult HscEnvEq, [FilePath]) + -> IO () sessionOpts (hieYaml, file) = do Extra.whenM didSessionLoadingPreferenceConfigChange $ do logWith recorder Info LogSessionLoadingChanged -- If the dependencies are out of date then clear both caches and start -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - modifyVar_ filesMap (const (return HM.empty)) + atomically $ resetFileMaps sessionState -- Don't even keep the name cache, we start from scratch here! - modifyVar_ hscEnvs (const (return Map.empty)) - - v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags - let cfp = toAbsolutePath file - case HM.lookup (toNormalizedFilePath' cfp) v of - Just (opts, old_di) -> do + modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) + -- cleanup error loading files and cradle files + clearErrorLoadingFiles sessionState + clearCradleFiles sessionState + + v <- atomically $ STM.lookup hieYaml (fileToFlags sessionState) + case v >>= HM.lookup (toNormalizedFilePath' file) of + Just (_opts, old_di) -> do deps_ok <- 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. - modifyVar_ fileToFlags (const (return Map.empty)) - modifyVar_ filesMap (const (return HM.empty)) + atomically $ resetFileMaps sessionState -- Keep the same name cache - modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) - consultCradle hieYaml cfp - else return (opts, Map.keys old_di) - Nothing -> consultCradle hieYaml cfp + modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) + consultCradle hieYaml file + -- if deps are ok, we can just remove the file from pending files + else atomically $ removeFromPending sessionState file + Nothing -> consultCradle hieYaml file + + let checkInCache ::NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) + checkInCache ncfp = runMaybeT $ do + cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState) + m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState) + MaybeT $ pure $ HM.lookup ncfp m -- The main function which gets options for a file. We only want one of these running -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + let getOptions :: FilePath -> IO () getOptions file = do - let ncfp = toNormalizedFilePath' (toAbsolutePath file) - cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap + let ncfp = toNormalizedFilePath' file + cachedHieYamlLocation <- atomically $ STM.lookup ncfp (filesMap sessionState) hieYaml <- cradleLoc file - sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> - return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) - + let hieLoc = join cachedHieYamlLocation <|> hieYaml + sessionOpts (hieLoc, file) `Safe.catch` handleSessionError sessionState hieLoc file + + let getOptionsLoop :: IO () + getOptionsLoop = do + -- Get the next file to load + absFile <- atomically $ S.readQueue (pendingFileSet sessionState) + logWith recorder Debug (LogGetOptionsLoop absFile) + getOptions absFile + getOptionsLoop + + -- | 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 + let lookupOrWaitCache :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) + lookupOrWaitCache absFile = do + let ncfp = toNormalizedFilePath' absFile + res <- atomically $ do + -- wait until target file is not in pendingFiles + Extra.whenM (S.lookup absFile (pendingFileSet sessionState)) STM.retry + -- check if in the cache + checkInCache ncfp + logWith recorder Debug $ LogLookupSessionCache absFile + updateDateRes <- case res of + Just r -> do + depOk <- checkDependencyInfo (snd r) + if depOk + then return $ Just r + else return Nothing + _ -> return Nothing + case updateDateRes of + Just r -> return r + Nothing -> do + -- if not ok, we need to reload the session + atomically $ addToPending sessionState absFile + lookupOrWaitCache absFile + + -- see Note [Serializing runs in separate thread] + -- Start the getOptionsLoop if the queue is empty + liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop returnWithVersion $ \file -> do - -- see Note [Serializing runs in separate thread] - awaitRunInThread que $ getOptions file + let absFile = toAbsolutePath file + second Map.keys <$> lookupOrWaitCache absFile -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the @@ -993,10 +1208,11 @@ setCacheDirs recorder CacheDirs{..} dflags = do type DependencyInfo = Map.Map FilePath (Maybe UTCTime) type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo] -- | Maps a "hie.yaml" location to all its Target Filepaths and options. -type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) +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 = HM.HashMap NormalizedFilePath (Maybe FilePath) +type FilesMap = STM.Map NormalizedFilePath (Maybe FilePath) + -- This is pristine information about a component data RawComponentInfo = RawComponentInfo diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index ac98ae453d..3e3ca38241 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -28,7 +28,7 @@ data CradleErrorDetails = Depicts the cradle error in a user-friendly way. -} renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic -renderCradleError (CradleError deps _ec ms) cradle nfp = +renderCradleError (CradleError deps _ec ms _attemptToLoadFiles) cradle nfp = let noDetails = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing in diff --git a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs new file mode 100644 index 0000000000..a2b0a76565 --- /dev/null +++ b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs @@ -0,0 +1,48 @@ +module Development.IDE.Session.OrderedSet where + +import Control.Concurrent.STM (STM, TQueue, flushTQueue, + newTQueueIO) +import Control.Concurrent.STM.TQueue (readTQueue, writeTQueue) +import Control.Monad (when) +import Data.Hashable (Hashable) +import qualified Focus +import qualified ListT as LT +import qualified StmContainers.Set as S +import StmContainers.Set (Set) + + +type OrderedSet a = (TQueue a, Set a) + +insert :: Hashable a => a -> OrderedSet a -> STM () +insert a (que, s) = do + (_, inserted) <- S.focus (Focus.testingIfInserts $ Focus.insert ()) a s + -- if already in the set + -- update the position of the element in the queue + when (not inserted) $ do + items <- filter (==a) <$> flushTQueue que + mapM_ (writeTQueue que) items + return () + writeTQueue que a + -- when que $ writeTQueue que a + +newIO :: Hashable a => IO (OrderedSet a) +newIO = do + que <- newTQueueIO + s <- S.newIO + return (que, s) + +readQueue :: Hashable a => OrderedSet a -> STM a +readQueue rs@(que, s) = do + f <- readTQueue que + b <- S.lookup f s + -- retry if no files are left in the queue + if b then return f else readQueue rs + +lookup :: Hashable a => a -> OrderedSet a -> STM Bool +lookup a (_, s) = S.lookup a s + +delete :: Hashable a => a -> OrderedSet a -> STM () +delete a (_, s) = S.delete a s + +toUnOrderedList :: Hashable a => OrderedSet a -> STM [a] +toUnOrderedList (_, s) = LT.toList $ S.listT s