diff --git a/cabal.project b/cabal.project index 08d743c24e..a6b3ae2b57 100644 --- a/cabal.project +++ b/cabal.project @@ -6,6 +6,8 @@ packages: ./ghcide ./hls-plugin-api ./hls-test-utils +-- ../../hie-bios + index-state: 2024-10-21T00:00:00Z @@ -46,3 +48,11 @@ constraints: if impl(ghc >= 9.9) -- https://github.com/haskell/haskell-language-server/issues/4324 benchmarks: False + +-- add github bois repo +-- use the batch load branch + +source-repository-package + type: git + location: https://github.com/soulomoon/hie-bios.git + tag: 45cfe1f4e1bac53e6d6f0cc98c3e8031d85c8e24 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a1d778ab0e..3037d7e38c 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -68,6 +68,7 @@ import Development.IDE.Types.Options import GHC.ResponseFile import qualified HIE.Bios as HieBios import HIE.Bios.Environment hiding (getCacheDir) +import qualified HIE.Bios.Flags as HieBios import HIE.Bios.Types hiding (Log) import qualified HIE.Bios.Types as HieBios import Ide.Logger (Pretty (pretty), @@ -102,7 +103,6 @@ import Data.HashSet (HashSet) 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 qualified Development.IDE.GHC.Compat.Util as Compat @@ -119,6 +119,7 @@ import qualified System.Random as Random import System.Random (RandomGen) import Text.ParserCombinators.ReadP (readP_to_S) +import Data.Tuple (swap) import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types @@ -126,6 +127,7 @@ import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State + data Log = LogSettingInitialDynFlags | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) @@ -139,15 +141,19 @@ data Log | LogMakingNewHscEnv ![UnitId] | LogDLLLoadError !String | LogCradlePath !FilePath + | LogCradlePaths ![FilePath] + | LogCradleOpts !(ComponentOptions, FilePath, String) | LogCradleNotFound !FilePath | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath, String)) | LogCradle !(Cradle Void) | LogNoneCradleFound FilePath + | LogNoneCradleFounds (NE.NonEmpty FilePath) | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log | LogSessionLoadingChanged deriving instance Show Log + instance Pretty Log where pretty = \case LogNoneCradleFound path -> @@ -204,6 +210,8 @@ instance Pretty Log where "Error dynamically loading libm.so.6:" <+> pretty errorString LogCradlePath path -> "Cradle path:" <+> pretty path + LogCradlePaths path -> + "Cradle paths:" <+> pretty path LogCradleNotFound path -> vcat [ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "." @@ -218,6 +226,10 @@ instance Pretty Log where LogHieBios msg -> pretty msg LogSessionLoadingChanged -> "Session Loading config changed, reloading the full session." + LogNoneCradleFounds files -> + "None cradle found for files:" <+> pretty files <> ", ignoring the files" + LogCradleOpts (opts, root, prefix) -> + "Cradle options:" <+> pretty (componentOptions opts) <+> ", root:" <+> pretty root <+> ", prefix:" <+> pretty prefix -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -424,7 +436,7 @@ 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 [] + cradle_files <- newIORef $ Set.empty -- 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 @@ -435,6 +447,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- you have to modify 'filesMap' as well. filesMap <- newVar HM.empty :: IO (Var FilesMap) -- Version of the mappings above + pendingFilesTQueue <- newTQueueIO version <- newVar 0 biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) @@ -446,7 +459,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- e.g. see https://github.com/haskell/ghcide/issues/126 let res' = toAbsolutePath <$> res return $ normalise <$> res' - + -- loadCradle in batch + let cradleLocs :: [FilePath] -> IO [(Maybe FilePath)] + cradleLocs = mapM cradleLoc return $ do clientConfig <- getClientConfigAction extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv @@ -454,7 +469,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let invalidateShakeCache = do void $ modifyVar' version succ return $ toNoFileKey GhcSessionIO - IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject , optExtensions @@ -464,7 +478,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- files in the project so that `knownFiles` can learn about them and -- we can generate a complete module graph let extendKnownTargets newTargets = do - knownTargets <- concatForM newTargets $ \TargetDetails{..} -> + knownTargets <- concatForM newTargets $ \TargetDetails{..} -> case targetTarget of TargetFile f -> do -- If a target file has multiple possible locations, then we @@ -493,16 +507,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do writeTVar knownTargetsVar known' pure hasUpdate for_ hasUpdate $ \x -> - logWith recorder Debug $ LogKnownFilesUpdated (targetMap x) + logWith recorder Info $ LogKnownFilesUpdated (targetMap x) return $ toNoFileKey GetKnownTargets -- Create a new HscEnv from a hieYaml root and a set of options - let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) + let packageSetup :: (Maybe FilePath, [NormalizedFilePath], ComponentOptions, FilePath) -> IO ([ComponentInfo], [ComponentInfo]) - packageSetup (hieYaml, cfp, opts, libDir) = do + packageSetup (hieYaml, cfps, opts, libDir) = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir - newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir + newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfps opts (hsc_dflags hscEnv) rootDir let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv @@ -517,7 +531,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- We will modify the unitId and DynFlags used for -- compilation but these are the true source of -- information. - new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newTargetDfs + new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets (head cfps) opts dep_info) newTargetDfs all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps -- Get all the unit-ids for things in this component _inplace = map rawComponentUnitId $ NE.toList all_deps @@ -549,102 +563,104 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO (IdeResult HscEnvEq,[FilePath]) - session args@(hieYaml, _cfp, _opts, _libDir) = do - (new_deps, old_deps) <- packageSetup args + let restartSession all_targets new_deps = do + restartShakeSession VFSUnmodified "new component" [] $ do + keys2 <- invalidateShakeCache + keys1 <- extendKnownTargets all_targets + return [keys1, keys2] + + -- Typecheck all files in the project on startup + checkProject <- getCheckProject + unless (null new_deps || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (nub $ 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' <>) + let session :: (Maybe FilePath, [NormalizedFilePath], ComponentOptions, FilePath) + -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq,[FilePath]))], ([TargetDetails], [ComponentInfo])) + session args@(hieYaml, cfps, _opts, _libDir) = do + (new_deps, old_deps) <- packageSetup args -- 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 <- emptyHscEnv ideNc _libDir - let new_cache = newComponentCache recorder optExtensions _cfp hscEnv - all_target_details <- new_cache old_deps new_deps - + all_target_details <- newComponentCache recorder optExtensions cfps hscEnv old_deps new_deps + let all_targets' = concat all_target_details + flags_map' = HM.fromList (concatMap toFlagsMap all_targets') 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') + let buildErrorTarget _cfp = Left (this_target_details, error_flag) + where + error_flag = (this_error_env, this_dep_info) 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" ] - + let findTargets _cfp = case HM.lookup _cfp flags_map' of + Just flag -> Right flag + Nothing -> buildErrorTarget _cfp + let (results, all_targets, this_flags_map) = foldr acc ([], all_targets', flags_map') $ cfps + where acc fp (rs, ts, m) = case findTargets fp of + Right flag -> ((fp, second Map.keys flag):rs, ts, m) + Left (t, error_flag) -> ((fp, second Map.keys error_flag):rs, t:ts, HM.insert fp error_flag m) 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] + return (results, (all_targets, new_deps)) - -- 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]) - consultCradle hieYaml cfp = do - let lfpLog = makeRelative rootDir cfp - logWith recorder Info $ LogCradlePath lfpLog - when (isNothing hieYaml) $ - logWith recorder Warning $ LogCradleNotFound lfpLog - cradle <- loadCradle recorder hieYaml rootDir - when optTesting $ 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 <> ")" - 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 - addTag "result" (show res) - return res - - logWith recorder Debug $ LogSessionLoadingResult eopts + let buildError (hieYaml, cradle, err) cfp = 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 (ncfp, (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err)) + + let eoptsHscEnv (hieYaml, cfps, cradle, eopts) = case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. Right (opts, libDir, version) -> do + logWith recorder Info $ LogCradleOpts (opts, libDir, version) 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),[]) + atomicModifyIORef' cradle_files (\xs -> (Set.fromList cfps<>xs,())) + fmap (fmap Just) $ session (hieYaml, toNormalizedFilePath' <$> cfps, opts, libDir) + | otherwise -> return ([(toNormalizedFilePath' cfp, (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing), [])) | cfp <- cfps], Nothing) -- 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) + errors <- mapM (buildError (hieYaml, cradle, err)) cfps + return (errors, Nothing) + + let + consultCradles [] = return [] + consultCradles hyCfpList@(h:hs) = do + let lfpLogs = map (makeRelative rootDir . snd) hyCfpList + logWith recorder Info $ LogCradlePaths lfpLogs + cradles <- mapM (\hf@(hieYaml, _) -> do c <- loadCradle recorder hieYaml rootDir; return (c,hf)) (h:|hs) + when optTesting $ mRunLspT lspEnv $ mapM_ (\(_, cfp) -> sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)) hyCfpList + let progMsg = "Setting up " <> T.intercalate "," (T.pack . takeBaseName . cradleRootDir <$> NE.toList (fmap fst cradles)) + <> " (for " <> T.intercalate "," (T.pack <$> lfpLogs) <> ")" + eoptsList <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ + do old_files <- readIORef cradle_files + res <- cradleToOptsAndLibDirs recorder (sessionLoading clientConfig) cradles (Set.toList old_files) + return res + mapM (\(cr, hieYaml, fps, eopts) -> eoptsHscEnv (hieYaml, NE.toList fps, cr, eopts)) eoptsList let -- | We allow users to specify a loading strategy. @@ -664,20 +680,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) pure (loadingConfig /= sessionLoading clientConfig) - -- 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]) - 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)) - -- Don't even keep the name cache, we start from scratch here! - modifyVar_ hscEnvs (const (return Map.empty)) - + let readSessionOptsFromCache (hieYaml, file) = do v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags let cfp = toAbsolutePath file case HM.lookup (toNormalizedFilePath' cfp) v of @@ -691,37 +694,87 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do modifyVar_ filesMap (const (return HM.empty)) -- 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 + return $ Left (hieYaml, file) + else return $ Right (file, (opts, Map.keys old_di)) + Nothing -> return $ Left (hieYaml, file) + + let sessionOptsList :: [(Maybe FilePath, FilePath)] -> IO (Map.Map FilePath (IdeResult HscEnvEq, [FilePath])) + sessionOptsList yamlFiles = do + cached <- mapM readSessionOptsFromCache yamlFiles + let (toConsults, cachedResults) = partitionEithers cached + results <- consultCradles toConsults + let envs = map (first fromNormalizedFilePath) $ concatMap (fst) results + let mergeDeps (x, y) (a, b) = (x <> a, y <> b) + let (tgs, deps) = foldr mergeDeps ([], []) $ mapMaybe snd results + -- restart session if we have new results + Extra.whenM (return $ notNull toConsults) (restartSession tgs deps) + let consultMap = Map.fromList envs + let cachedMap = Map.fromList cachedResults + return $ consultMap <> cachedMap + + let getOptionsList :: [FilePath] -> IO (Map.Map FilePath (IdeResult HscEnvEq, [FilePath])) + getOptionsList files = do + let ncfps = toNormalizedFilePath' <$> files + cachedHieYamlLocations <- mapM (\ncfp -> HM.lookup ncfp <$> readVar filesMap) ncfps + hieYamls <- cradleLocs files + let yamlFiles = zip (zipWith (\x y -> join x <|> y) cachedHieYamlLocations hieYamls) files + sessionOptsList yamlFiles + -- 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]) - getOptions file = do - let ncfp = toNormalizedFilePath' (toAbsolutePath file) - cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap + let getOptionsBatch :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + getOptionsBatch file = do + pendingFiles <- atomically $ flushTQueue pendingFilesTQueue hieYaml <- cradleLoc file - sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> + logWith recorder Debug LogSettingInitialDynFlags + results <- getOptionsList (Set.toList $ Set.fromList $ file : pendingFiles) + return (results Map.! file) `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do -- see Note [Serializing runs in separate thread] - awaitRunInThread que $ getOptions file + atomically $ writeTQueue pendingFilesTQueue $ toAbsolutePath file + awaitRunInThread que $ getOptionsBatch file --- | 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 + +-- how we do batch loading of cradles depends on the the type of cradle we are using +cradleToOptsAndLibDirs :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> NE.NonEmpty (Cradle Void, (Maybe FilePath, FilePath)) -> [FilePath] + -> IO [(Cradle Void, Maybe FilePath, NE.NonEmpty FilePath, Either [CradleError] (ComponentOptions, FilePath, String))] +cradleToOptsAndLibDirs recorder loadConfig cradleFiles old_fps = do + cradleRes <- HieBios.getCompilerOptionsInBatch loadStyle (second swap <$> cradleFiles) + mapM (\(cfps@((c,(_,h)):|_), crr) -> collectBiosResult'' recorder (c, h) (fst . snd <$> cfps) crr) cradleRes + where + loadStyle = case loadConfig of + PreferSingleComponentLoading -> LoadFile + PreferMultiComponentLoading -> LoadWithContext old_fps + collectBiosResult'' recorder (cradle, hieYaml) files cradleRes = do + result <- collectBiosResult' recorder cradle files cradleRes + return (cradle, hieYaml, files, result) + collectBiosResult' :: Recorder (WithPriority Log) -> Cradle Void -> NE.NonEmpty FilePath -> CradleLoadResult a2 -> IO (Either [CradleError] (a2, FilePath, String)) + collectBiosResult' recorder cradle files cradleRes = + 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 $ LogNoneCradleFounds files + return (Left []) + CradleFail err -> return (Left [err]) + CradleNone -> do + logWith recorder Info $ LogNoneCradleFounds files + return (Left []) + + +collectBiosResult :: Recorder (WithPriority Log) -> Cradle Void -> FilePath -> CradleLoadResult a2 -> IO (Either [CradleError] (a2, FilePath, String)) +collectBiosResult recorder cradle file cradleRes = case cradleRes of CradleSuccess r -> do -- Now get the GHC lib dir @@ -734,12 +787,23 @@ cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do CradleNone -> do logWith recorder Info $ LogNoneCradleFound file return (Left []) - CradleFail err -> return (Left [err]) CradleNone -> do logWith recorder Info $ LogNoneCradleFound file return (Left []) +-- | 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 + collectBiosResult recorder cradle file cradleRes where loadStyle = case loadConfig of PreferSingleComponentLoading -> LoadFile @@ -856,12 +920,12 @@ checkHomeUnitsClosed' ue home_id_set newComponentCache :: Recorder (WithPriority Log) -> [String] -- ^ File extensions to consider - -> NormalizedFilePath -- ^ Path to file that caused the creation of this component + -> [NormalizedFilePath] -- ^ Path to file that caused the creation of this component -> HscEnv -- ^ An empty HscEnv -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components -> IO [ [TargetDetails] ] -newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do +newComponentCache recorder exts cfps hsc_env old_cis new_cis = do let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) -- When we have multiple components with the same uid, -- prefer the new one over the old. @@ -876,7 +940,7 @@ newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do Compat.initUnits dfs hsc_env let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') - multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs + multi_errs = concatMap (\err -> [(ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) cfp . T.pack . Compat.printWithoutUniques) err | cfp <- cfps]) closure_errs bad_units = OS.fromList $ concat $ do x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs DriverHomePackagesNotClosed us <- pure x @@ -1094,12 +1158,12 @@ addUnit unit_str = liftEwM $ do -- | Throws if package flags are unsatisfiable setOptions :: GhcMonad m - => NormalizedFilePath + => [NormalizedFilePath] -> ComponentOptions -> DynFlags -> FilePath -- ^ root dir, see Note [Root Directory] -> m (NonEmpty (DynFlags, [GHC.Target])) -setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do +setOptions cfps (ComponentOptions theOpts compRoot _) dflags rootDir = do ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) case NE.nonEmpty units of Just us -> initMulti us @@ -1122,9 +1186,9 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do -- -- If we don't end up with a target for the current file in the end, then -- we will report it as an error for that file - let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp) - let special_target = Compat.mkSimpleTarget df abs_fp - pure $ (df, special_target : targets) :| [] + let abs_fps = toAbsolute rootDir . fromNormalizedFilePath <$> cfps + let special_targets = Compat.mkSimpleTarget df <$> abs_fps + pure $ (df, special_targets <> targets) :| [] where initMulti unitArgFiles = forM unitArgFiles $ \f -> do @@ -1166,6 +1230,7 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do dflags'' return (dflags''', targets) + setIgnoreInterfacePragmas :: DynFlags -> DynFlags setIgnoreInterfacePragmas df = gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges @@ -1212,7 +1277,8 @@ instance Exception PackageSetupException showPackageSetupException :: PackageSetupException -> String showPackageSetupException GhcVersionMismatch{..} = unwords - ["ghcide compiled against GHC" + [ + "ghcide compiled against GHC" ,showVersion compileTime ,"but currently using" ,showVersion runTime