add rule to session loader

soulomoon · soulomoon · commit 299734862049 · 2024-05-21T21:00:08.000+08:00
diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs
@@ -134,9 +134,12 @@ import           GHC.Unit.State
 import           Language.LSP.Protocol.Types          (NormalizedUri (NormalizedUri),
                                                        toNormalizedFilePath)
 #endif
+import qualified Development.IDE.Core.Shake           as SHake
 
 data Log
+
   = LogSettingInitialDynFlags
+  | LogShake SHake.Log
   | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void)
   | LogGetInitialGhcLibDirDefaultCradleNone
   | LogHieDbRetry !Int !Int !Int !SomeException
@@ -157,6 +160,7 @@ data Log
   | LogSessionLoadingChanged
 deriving instance Show Log
 
+
 instance Pretty Log where
   pretty = \case
     LogNoneCradleFound path ->
@@ -227,6 +231,7 @@ instance Pretty Log where
     LogHieBios msg -> pretty msg
     LogSessionLoadingChanged ->
       "Session Loading config changed, reloading the full session."
+    LogShake msg -> pretty msg
 
 -- | Bump this version number when making changes to the format of the data stored in hiedb
 hiedbDataVersion :: String
@@ -440,10 +445,10 @@ getHieDbLoc dir = do
 -- 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.
-loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession)
+loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Rules (), Action IdeGhcSession)
 loadSession recorder = loadSessionWithOptions recorder def
 
-loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)
+loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Rules (), Action IdeGhcSession)
 loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
   let toAbsolutePath = toAbsolute rootDir
   cradle_files <- newIORef []
@@ -463,7 +468,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
   biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig))
   let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)
 
-  return $ do
+  let cradleLocRule :: Rules ()
+      cradleLocRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do
+            res <- liftIO $ HieBios.findCradle $ fromNormalizedFilePath file
+            -- 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
+            -- todo make it absolute
+            return $ Just (normalise . toAbsolutePath  <$> res)
+
+  return $ (cradleLocRule, do
     clientConfig <- getClientConfigAction
     extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv
                       } <- getShakeExtras
@@ -612,30 +626,30 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
           keys2 <- liftIO $ invalidateShakeCache
 
           -- todo this should be moving out of the session function
-          restart <- liftIO $ async $ restartShakeSession VFSUnmodified "new component" [] $ do
-            keys1 <- extendKnownTargets all_targets
-            return [keys1, keys2]
+          restart <- liftIO $ async $ do
+            restartShakeSession VFSUnmodified "new component" [] $ do
+                keys1 <- extendKnownTargets all_targets
+                return [keys1, keys2]
+            -- Typecheck all files in the project on startup
+            checkProject <- liftIO $ getCheckProject
+            liftIO $ 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' <>)
           UnliftIO.wait restart
-
-
-          -- Typecheck all files in the project on startup
-          checkProject <- liftIO $ getCheckProject
-          liftIO $ 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 :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath])
         consultCradle cfp = do
-           hieYaml <- use_ CradleLoc cfp
+           hieYamlOld <- use_ CradleLoc cfp
+           cachedHieYamlLocation <- join <$> liftIO (HM.lookup cfp <$> readVar filesMap)
+           let hieYaml =  fromMaybe cachedHieYamlLocation (Just hieYamlOld)
            let lfpLog = makeRelative rootDir (fromNormalizedFilePath cfp)
            logWith recorder Info $ LogCradlePath lfpLog
            when (isNothing hieYaml) $
@@ -701,7 +715,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
     let sessionOpts :: NormalizedFilePath
                     -> Action (IdeResult HscEnvEq, [FilePath])
         sessionOpts file = do
-          hieYaml <- use_ CradleLoc file
+          hieYamlOld <- use_ CradleLoc file
+          cachedHieYamlLocation <- join <$> liftIO (HM.lookup file <$> readVar filesMap)
+          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
@@ -737,15 +753,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
 
     let getOptions :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath])
         getOptions file = do
-            -- cachedHieYamlLocation <- liftIO $ HM.lookup file <$> readVar filesMap
             -- CradleLoc already cached
             hieYaml <- use_ CradleLoc file
             sessionOpts file `Safe.catch` \e ->
                 return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml)
 
+
     returnWithVersion $ \file -> do
       opts <- UnliftIO.withMVar cradleLock $ const $ getOptions file
-      pure $ (fmap . fmap) toAbsolutePath opts
+      pure $ (fmap . fmap) toAbsolutePath opts)
 
 
 -- | Run the specific cradle on a specific FilePath via hie-bios.
@@ -1074,6 +1090,9 @@ type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath)
 -- if some new file4 should be in hie1.yaml,
     -- we need to recompute the hie1.yaml
 
+-- hieRule file
+-- get corresponding hie.yaml
+
 
 
 -- This is pristine information about a component
diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs
@@ -193,14 +193,6 @@ data Log
   | LogTypecheckedFOI !NormalizedFilePath
   deriving Show
 
-cradleLocRule :: Recorder (WithPriority Log) -> Rules ()
-cradleLocRule recorder = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do
-      res <- liftIO $ findCradle $ fromNormalizedFilePath file
-      -- 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
-      -- todo make it absolute
-      return $ Just $ normalise <$>  res
 
 instance Pretty Log where
   pretty = \case
@@ -1229,7 +1221,6 @@ mainRule recorder RulesConfig{..} = do
     addIdeGlobal $ CompiledLinkables linkables
     rebuildCountVar <- liftIO $ newTVarIO 0
     addIdeGlobal $ RebuildCounter rebuildCountVar
-    cradleLocRule recorder
     getParsedModuleRule recorder
     getParsedModuleWithCommentsRule recorder
     getLocatedImportsRule recorder
diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs
@@ -337,7 +337,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                           -- TODO: should probably catch/log/rethrow at top level instead
                           `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing)
 
-                  sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath
+                  (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath
                   config <- LSP.runLspT env LSP.getConfig
                   let def_options = argsIdeOptions config sessionLoader
 
@@ -356,7 +356,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                       (cmapWithPrio LogService recorder)
                       argsDefaultHlsConfig
                       argsHlsPlugins
-                      rules
+                      (rules <> sessionLoaderRule)
                       (Just env)
                       debouncer
                       ideOptions
@@ -408,14 +408,14 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
             putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
             when (n > 0) $ putStrLn $ "  (" ++ intercalate ", " (catMaybes ucradles) ++ ")"
             putStrLn "\nStep 3/4: Initializing the IDE"
-            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir
+            (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir
             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
                 ideOptions = def_options
                         { optCheckParents = pure NeverCheck
                         , optCheckProject = pure False
                         , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
                         }
-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty dir
+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins (rules <> sessionLoaderRule) Nothing debouncer ideOptions hiedb hieChan mempty dir
             shakeSessionInit (cmapWithPrio LogShake recorder) ide
             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
 
@@ -446,14 +446,14 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
           let root = argsProjectRoot
           dbLoc <- getHieDbLoc root
           runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
-            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "."
+            (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "."
             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
                 ideOptions = def_options
                     { optCheckParents = pure NeverCheck
                     , optCheckProject = pure False
                     , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
                     }
-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty root
+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins (rules <> sessionLoaderRule) Nothing debouncer ideOptions hiedb hieChan mempty root
             shakeSessionInit (cmapWithPrio LogShake recorder) ide
             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
             c ide
