Skip to content

Commit

Permalink
cleanup
Browse files Browse the repository at this point in the history
  • Loading branch information
@soulomoon
soulomoon committed May 21, 2024
1 parent 6c4a848 commit eda4227
Show file tree
Hide file tree
Showing 2 changed files with 33 additions and 17 deletions.
45 changes: 28 additions & 17 deletions ghcide/session-loader/Development/IDE/Session.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -61,7 +61,7 @@ import qualified Development.IDE.GHC.Compat.Core as GHC
import Development.IDE.GHC.Compat.Env hiding (Logger)
import Development.IDE.GHC.Compat.Units (UnitId)
import Development.IDE.GHC.Util
import Development.IDE.Graph (Action)
import Development.IDE.Graph (Action, alwaysRerun)
import qualified Development.IDE.Session.Implicit as GhcIde
import Development.IDE.Session.VersionCheck
import Development.IDE.Types.Diagnostics
Expand Down Expand Up @@ -134,6 +134,7 @@ import GHC.Unit.State
import Language.LSP.Protocol.Types (NormalizedUri (NormalizedUri),
toNormalizedFilePath)
#endif
import Development.IDE (RuleResult)
import qualified Development.IDE.Core.Shake as SHake

data Log
Expand Down Expand Up @@ -448,6 +449,9 @@ getHieDbLoc dir = do
loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Rules (), Action IdeGhcSession)
loadSession recorder = loadSessionWithOptions recorder def

type instance RuleResult HieYaml = (HashMap
NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))

loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Rules (), Action IdeGhcSession)
loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
let toAbsolutePath = toAbsolute rootDir
Expand All @@ -461,13 +465,25 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
-- they are inconsistent. So, everywhere you modify 'fileToFlags',
-- you have to modify 'filesMap' as well.
filesMap <- newVar HM.empty :: IO (Var FilesMap)

let clearCache = do
modifyVar_ hscEnvs $ \_ -> pure Map.empty
modifyVar_ fileToFlags $ \_ -> pure Map.empty
modifyVar_ filesMap $ \_ -> pure HM.empty

-- Version of the mappings above
version <- newVar 0
cradleLock <- newMVar ()
-- putMVar cradleLock ()
biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig))
let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)

let hieYamlRule :: Rules ()
hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml hieYaml -> do
alwaysRerun
v <- Map.findWithDefault HM.empty (Just $ fromNormalizedFilePath hieYaml) <$> (liftIO $ readVar fileToFlags)
return $ Just v

let cradleLocRule :: Rules ()
cradleLocRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do
res <- liftIO $ HieBios.findCradle $ fromNormalizedFilePath file
Expand All @@ -477,19 +493,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
-- todo make it absolute
return $ Just (normalise . toAbsolutePath <$> res)

return $ (cradleLocRule, do
clientConfig <- getClientConfigAction
extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv
} <- getShakeExtras
let invalidateShakeCache = do
let invalidateShakeCache = do
void $ modifyVar' version succ
return $ toNoFileKey GhcSessionIO

return $ (cradleLocRule <> hieYamlRule, do

Check warning on line 500 in ghcide/session-loader/Development/IDE/Session.hs

View workflow job for this annotation

GitHub Actions / Hlint check run 

Suggestion in loadSessionWithOptions in module Development.IDE.Session: Redundant $ ▫︎ Found: "return\n $ (cradleLocRule <> hieYamlRule, \n do clientConfig <- getClientConfigAction\n ShakeExtras {restartShakeSession, ideNc, knownTargetsVar,\n lspEnv} <- getShakeExtras\n IdeOptions {optTesting = IdeTesting optTesting,\n optCheckProject = getCheckProject, optExtensions} <- getIdeOptions\n let extendKnownTargets newTargets\n = do knownTargets <- concatForM newTargets\n $ \\ TargetDetails {..}\n -> case targetTarget of\n TargetFile f\n -> do fs <- filterM\n (IO.doesFileExist\n . fromNormalizedFilePath)\n targetLocations\n pure\n $ map\n (\\ fp\n -> (TargetFile fp, Set.singleton fp))\n (nubOrd (f : fs))\n TargetModule _\n -> do found <- filterM\n (IO.doesFileExist\n . fromNormalizedFilePath)\n targetLocations\n return [(targetTarget, Set.fromList found)]\n hasUpdate <- atomically\n $ do known <- readTVar knownTargetsVar\n let known'\n = flip mapHashed known\n $ \\ k\n -> HM.unionWith (<>) k\n $ HM.fromList knownTargets\n hasUpdate\n = if known /= known' then\n Just (unhashed known')\n else\n Nothing\n writeTVar knownTargetsVar known'\n pure hasUpdate\n for_ hasUpdate\n $ \\ x -> logWith recorder Debug $ LogKnownFilesUpdated x\n return $ toNoFileKey GetKnownTargets\n let packageSetup ::\n (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)\n -> IO ([ComponentInfo], [ComponentInfo])\n packageSetup (hieYaml, cfp, opts, libDir)\n = do hscEnv <- emptyHscEnv ideNc libDir\n newTargetDfs <- evalGhcEnv hscEnv\n $ setOptions cfp opts (hsc_dflags hscEnv) rootDir\n let deps = componentDependencies opts ++ maybeToList hieYaml\n dep_info <- getDependencyInfo deps\n modifyVar hscEnvs\n $ \\ m\n -> do let oldDeps = Map.lookup hieYaml m\n let new_deps\n = fmap\n (\\ (df, targets)\n -> RawComponentInfo\n (homeUnitId_ df) df targets cfp opts dep_info)\n newTargetDfs\n all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps\n _inplace = map rawComponentUnitId $ NE.toList all_deps\n all_deps' <- forM all_deps\n $ \\ RawComponentInfo {..}\n -> do let (df2, uids)\n = _removeInplacePackages\n fakeUid _inplace\n rawComponentDynFlags\n let prefix = show rawComponentUnitId\n let hscComponents = sort $ map show uids\n cacheDirOpts\n = hscComponents\n ++ componentOptions opts\n cacheDirs <- liftIO\n $ getCacheDirs\n prefix cacheDirOpts\n processed_df <- setCacheDirs\n recorder cacheDirs df2\n pure\n $ ComponentInfo\n {componentUnitId = rawComponentUnitId,\n componentDynFlags = processed_df,\n componentInternalUnits = uids,\n componentTargets = rawComponentTargets,\n componentFP = rawComponentFP,\n componentCOptions = rawComponentCOptions,\n componentDependencyInfo = rawComponentDependencyInfo}\n let (new, old) = NE.splitAt (NE.length new_deps) all_deps'\n pure (Map.insert hieYaml (NE.toList all_deps) m, (new, old))\n let session ::\n (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)\n -> Action (IdeResult HscEnvEq, [FilePath])\n session args@(hieYaml, _cfp, _opts, _libDir)\n = do (new_deps, old_deps) <- liftIO $ packageSetup args\n hscEnv <- liftIO $ emptyHscEnv ideNc _libDir\n let new_cache\n = newComponentCache recorder optExtensions hieYaml _cfp hscEnv\n all_target_details <- liftIO $ new_cache old_deps new_deps rootDir\n this_dep_info <- liftIO $ getDependencyInfo $ maybeToList hieYaml\n let (all_targets, this_flags_map, this_options)\n = case HM.lookup _cfp flags_map' of\n Just this -> (all_targets', flags_map', this)\n Nothing\n -> (this_target_details : all_targets', \n HM.insert _cfp this_flags flags_map', this_flags)\n where\n all_targets' = concat all_target_details\n flags_map' = HM.fromList (concatMap toFlagsMap all_targets')\n this_target_details\n = TargetDetails\n (TargetFile _cfp) this_error_env this_dep_info [_cfp]\n this_flags = (this_error_env, this_dep_info)\n this_error_env = ([this_error], Nothing)\n this_error\n = ideErrorWithSource\n (Just \"cradle\") (Just DiagnosticSeverity_Error) _cfp\n $ T.unlines\n [\"No cradle target found. Is this file listed in the targets of your cradle?\",\n \"If you are usin
clientConfig <- getClientConfigAction
ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv
} <- getShakeExtras

IdeOptions{ optTesting = IdeTesting optTesting
, optCheckProject = getCheckProject
, optExtensions
} <- getIdeOptions

-- relatively stand alone
-- 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
Expand Down Expand Up @@ -722,28 +740,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
let hieYaml = fromMaybe cachedHieYamlLocation (Just hieYamlOld)
-- this cased a recompilation of the whole project
-- this can be turned in to shake
liftIO$Extra.whenM didSessionLoadingPreferenceConfigChange $ do
liftIO $ Extra.whenM didSessionLoadingPreferenceConfigChange $ do
logWith recorder Info LogSessionLoadingChanged
-- If the dependencies are out of date then clear both caches and start
-- again.
liftIO$ modifyVar_ fileToFlags (const (return Map.empty))
liftIO$modifyVar_ filesMap (const (return HM.empty))
-- Don't even keep the name cache, we start from scratch here!
liftIO$modifyVar_ hscEnvs (const (return Map.empty))

clearCache
-- fileToFlags is caching
v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readVar fileToFlags)
case HM.lookup file v of
Just (opts, old_di) -> do
deps_ok <- liftIO$checkDependencyInfo old_di
deps_ok <- liftIO $ checkDependencyInfo old_di
if not deps_ok
then do
-- If the dependencies are out of date then clear both caches and start
-- again.
liftIO$modifyVar_ fileToFlags (const (return Map.empty))
liftIO$modifyVar_ filesMap (const (return HM.empty))
-- Keep the same name cache
liftIO$modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml )
liftIO $ clearCache

Check warning on line 757 in ghcide/session-loader/Development/IDE/Session.hs

View workflow job for this annotation

GitHub Actions / Hlint check run 

Suggestion in loadSessionWithOptions in module Development.IDE.Session: Redundant $ ▫︎ Found: "liftIO $ clearCache" ▫︎ Perhaps: "liftIO clearCache"
consultCradle file
else return (opts, Map.keys old_di)
Nothing -> consultCradle file
Expand Down
5 changes: 5 additions & 0 deletions ghcide/src/Development/IDE/Core/RuleTypes.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -497,6 +497,11 @@ instance Hashable CradleLoc
instance NFData CradleLoc
type instance RuleResult CradleLoc = Maybe FilePath

data HieYaml = HieYaml deriving (Eq, Show, Typeable, Generic)
instance Hashable HieYaml
instance NFData HieYaml


-- A local rule type to get caching. We want to use newCache, but it has
-- thread killed exception issues, so we lift it to a full rule.
-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
Expand Down

0 comments on commit eda4227

Please sign in to comment.