From 1782380b12f0432c504fc3189588b674cfa6797a Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 7 Jun 2025 14:54:14 +0200 Subject: [PATCH] Reload .cabal files when they are modified --- .../session-loader/Development/IDE/Session.hs | 2 +- ghcide/src/Development/IDE/Core/FileStore.hs | 31 +++++++- ghcide/src/Development/IDE/Core/RuleTypes.hs | 8 ++ ghcide/src/Development/IDE/Core/Rules.hs | 9 ++- haskell-language-server.cabal | 1 + .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 14 +++- plugins/hls-cabal-plugin/test/Main.hs | 73 +++++++++++++++++-- plugins/hls-cabal-plugin/test/Utils.hs | 9 +++ .../test/testdata/simple-reload/Main.hs | 9 +++ .../test/testdata/simple-reload/cabal.project | 1 + .../test/testdata/simple-reload/hie.yaml | 2 + .../simple-reload/simple-reload.cabal | 14 ++++ 12 files changed, 162 insertions(+), 11 deletions(-) create mode 100644 plugins/hls-cabal-plugin/test/testdata/simple-reload/Main.hs create mode 100644 plugins/hls-cabal-plugin/test/testdata/simple-reload/cabal.project create mode 100644 plugins/hls-cabal-plugin/test/testdata/simple-reload/hie.yaml create mode 100644 plugins/hls-cabal-plugin/test/testdata/simple-reload/simple-reload.cabal diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index fb777338b3..dde1cfdea5 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -499,7 +499,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do hscEnv <- emptyHscEnv ideNc libDir newTargetDfs <- evalGhcEnv hscEnv $ setOptions optHaddockParse cfp opts (hsc_dflags hscEnv) rootDir let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- getDependencyInfo deps + dep_info <- getDependencyInfo (fmap toAbsolutePath 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 diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 7dad386ece..e545ec7b14 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -78,7 +78,6 @@ import System.FilePath import System.IO.Error import System.IO.Unsafe - data Log = LogCouldNotIdentifyReverseDeps !NormalizedFilePath | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) @@ -147,6 +146,29 @@ getModificationTimeImpl missingFileDiags file = do then return (Nothing, ([], Nothing)) else return (Nothing, ([diag], Nothing)) + +getPhysicalModificationTimeRule :: Recorder (WithPriority Log) -> Rules () +getPhysicalModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetPhysicalModificationTime file -> + getPhysicalModificationTimeImpl file + +getPhysicalModificationTimeImpl + :: NormalizedFilePath + -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) +getPhysicalModificationTimeImpl file = do + let file' = fromNormalizedFilePath file + let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) + + alwaysRerun + + liftIO $ fmap wrap (getModTime file') + `catch` \(e :: IOException) -> do + let err | isDoesNotExistError e = "File does not exist: " ++ file' + | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e + diag = ideErrorText file (T.pack err) + if isDoesNotExistError e + then return (Nothing, ([], Nothing)) + else return (Nothing, ([diag], Nothing)) + -- | Interface files cannot be watched, since they live outside the workspace. -- But interface files are private, in that only HLS writes them. -- So we implement watching ourselves, and bypass the need for alwaysRerun. @@ -170,7 +192,11 @@ resetFileStore ideState changes = mask $ \_ -> do case c of LSP.FileChangeType_Changed -- already checked elsewhere | not $ HM.member nfp fois - -> atomically $ deleteValue (shakeExtras ideState) GetModificationTime nfp + -> + atomically $ do + ks <- deleteValue (shakeExtras ideState) GetModificationTime nfp + vs <- deleteValue (shakeExtras ideState) GetPhysicalModificationTime nfp + pure $ ks ++ vs _ -> pure [] @@ -233,6 +259,7 @@ getVersionedTextDoc doc = do fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () fileStoreRules recorder isWatched = do getModificationTimeRule recorder + getPhysicalModificationTimeRule recorder getFileContentsRule recorder addWatchedFileRule recorder isWatched diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 63122d4025..a13e6de14c 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} @@ -319,6 +320,13 @@ instance Hashable GetModificationTime where instance NFData GetModificationTime +data GetPhysicalModificationTime = GetPhysicalModificationTime + deriving (Generic, Show, Eq) + deriving anyclass (Hashable, NFData) + +-- | Get the modification time of a file on disk, ignoring any version in the VFS. +type instance RuleResult GetPhysicalModificationTime = FileVersion + pattern GetModificationTime :: GetModificationTime pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 071ecafc41..c123c9d4a8 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -183,6 +183,7 @@ data Log | LogLoadingHieFileFail !FilePath !SomeException | LogLoadingHieFileSuccess !FilePath | LogTypecheckedFOI !NormalizedFilePath + | LogDependencies !NormalizedFilePath [FilePath] deriving Show instance Pretty Log where @@ -207,6 +208,11 @@ instance Pretty Log where <+> "the HLS version being used, the plugins enabled, and if possible the codebase and file which" <+> "triggered this warning." ] + LogDependencies nfp deps -> + vcat + [ "Add dependency" <+> pretty (fromNormalizedFilePath nfp) + , nest 2 $ pretty deps + ] templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries" @@ -715,7 +721,8 @@ loadGhcSession recorder ghcSessionDepsConfig = do let nfp = toNormalizedFilePath' fp itExists <- getFileExists nfp when itExists $ void $ do - use_ GetModificationTime nfp + use_ GetPhysicalModificationTime nfp + logWith recorder Logger.Info $ LogDependencies file deps mapM_ addDependency deps let cutoffHash = LBS.toStrict $ B.encode (hash (snd val)) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index dc4cb246d0..096cf04a31 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -318,6 +318,7 @@ test-suite hls-cabal-plugin-tests , haskell-language-server:hls-cabal-plugin , hls-test-utils == 2.11.0.0 , lens + , lsp , lsp-types , text diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 78db726f77..7a2c53ee25 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} module Ide.Plugin.Cabal (descriptor, haskellInteractionDescriptor, Log (..)) where @@ -145,7 +146,7 @@ descriptor recorder plId = \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocSaved _uri - restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" $ + restartCabalShakeSessionPhysical (shakeExtras ide) vfs file "(saved)" $ OfInterest.addFileOfInterest ofInterestRecorder ide file OnDisk , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do @@ -180,7 +181,16 @@ restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> Stri restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession - return (toKey GetModificationTime file : keys) + return (toKey GetModificationTime file:keys) + +-- | Just like 'restartCabalShakeSession', but records that the 'file' has been changed on disk. +-- So, any action that can only work with on-disk modifications may depend on the 'GetPhysicalModificationTime' +-- rule to get re-run if the file changes on disk. +restartCabalShakeSessionPhysical :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () +restartCabalShakeSessionPhysical shakeExtras vfs file actionMsg actionBetweenSession = do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + keys <- actionBetweenSession + return (toKey GetModificationTime file:toKey GetPhysicalModificationTime file:keys) -- ---------------------------------------------------------------- -- Code Actions diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index a390d8982a..43794e753d 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Main ( main, @@ -17,14 +19,19 @@ import qualified Data.ByteString as BS import Data.Either (isRight) import Data.List.Extra (nubOrdOn) import qualified Data.Maybe as Maybe +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as Text import Definition (gotoDefinitionTests) +import Development.IDE.Test import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion) import qualified Ide.Plugin.Cabal.Parse as Lib import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Message as L import Outline (outlineTests) import System.FilePath import Test.Hls +import Test.Hls.FileSystem import Utils main :: IO () @@ -40,6 +47,7 @@ main = do , codeActionTests , gotoDefinitionTests , hoverTests + , reloadOnCabalChangeTests ] -- ------------------------------------------------------------------------ @@ -128,11 +136,6 @@ pluginTests = _ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n" newDiags <- cabalCaptureKick liftIO $ newDiags @?= [] - , runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" "simple-cabal" $ do - hsDoc <- openDoc "A.hs" "haskell" - expectNoMoreDiagnostics 1 hsDoc "typechecking" - cabalDoc <- openDoc "simple-cabal.cabal" "cabal" - expectNoMoreDiagnostics 1 cabalDoc "parsing" ] ] -- ---------------------------------------------------------------------------- @@ -262,3 +265,63 @@ hoverOnDependencyTests = testGroup "Hover Dependency" h <- getHover doc pos liftIO $ assertBool ("Found hover `" <> show h <> "`") $ Maybe.isNothing h closeDoc doc + +-- ---------------------------------------------------------------------------- +-- Reloading of Haskell files on .cabal changes +-- ---------------------------------------------------------------------------- + +simpleCabalVft :: [FileTree] +simpleCabalVft = + [ copy "hie.yaml" + , copy "simple-reload.cabal" + , copy "Main.hs" + ] + +simpleCabalFs :: VirtualFileTree +simpleCabalFs = mkVirtualFileTree + (testDataDir "simple-reload") + simpleCabalVft + +-- Slow tests +reloadOnCabalChangeTests :: TestTree +reloadOnCabalChangeTests = testGroup "Reload on .cabal changes" + [ runCabalTestCaseSessionVft "Change warnings when .cabal file changes" simpleCabalFs $ do + _ <- openDoc "Main.hs" "haskell" + expectDiagnostics [("Main.hs", [(DiagnosticSeverity_Warning, (8, 0), "Top-level binding with no type signature", Just "GHC-38417")])] + waitForAllProgressDone + cabalDoc <- openDoc "simple-reload.cabal" "cabal" + skipManyTill anyMessage cabalKickDone + saveDoc cabalDoc + [trimming| + cabal-version: 3.4 + name: simple-reload + version: 0.1.0.0 + -- copyright: + build-type: Simple + + common warnings + ghc-options: -Wall -Wno-missing-signatures + + executable simple-reload + import: warnings + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + |] + + expectDiagnostics [("Main.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of \8216Data.List\8217 is redundant", Nothing)])] + ] + +-- | Persists the given contents to the 'TextDocumentIdentifier' on disk +-- and sends the @textDocument/didSave@ notification. +saveDoc :: TextDocumentIdentifier -> Text -> Session () +saveDoc docId t = do + -- I couldn't figure out how to get the virtual file contents, so we write it + -- to disk and send the 'SMethod_TextDocumentDidSave' notification + case uriToFilePath (docId ^. L.uri) of + Nothing -> pure () + Just fp -> do + liftIO $ Text.writeFile fp t + + let params = DidSaveTextDocumentParams docId Nothing + sendNotification L.SMethod_TextDocumentDidSave params diff --git a/plugins/hls-cabal-plugin/test/Utils.hs b/plugins/hls-cabal-plugin/test/Utils.hs index 2733f94fd0..0264fec2c6 100644 --- a/plugins/hls-cabal-plugin/test/Utils.hs +++ b/plugins/hls-cabal-plugin/test/Utils.hs @@ -14,6 +14,7 @@ import qualified Ide.Plugin.Cabal import Ide.Plugin.Cabal.Completion.Types import System.FilePath import Test.Hls +import Test.Hls.FileSystem (VirtualFileTree) cabalPlugin :: PluginTestDescriptor Ide.Plugin.Cabal.Log @@ -57,6 +58,13 @@ runCabalSession :: FilePath -> Session a -> IO a runCabalSession subdir = failIfSessionTimeout . runSessionWithServer def cabalPlugin (testDataDir subdir) +runCabalTestCaseSessionVft :: TestName -> VirtualFileTree -> Session () -> TestTree +runCabalTestCaseSessionVft title vft = testCase title . runCabalSessionVft vft + +runCabalSessionVft :: VirtualFileTree -> Session a -> IO a +runCabalSessionVft vft = + failIfSessionTimeout . runSessionWithServerInTmpDir def cabalPlugin vft + runHaskellAndCabalSession :: FilePath -> Session a -> IO a runHaskellAndCabalSession subdir = failIfSessionTimeout . runSessionWithServer def (cabalPlugin <> cabalHaskellPlugin) (testDataDir subdir) @@ -82,3 +90,4 @@ cabalCaptureKick = captureKickDiagnostics cabalKickStart cabalKickDone -- | list comparison where the order in the list is irrelevant (@?==) :: (HasCallStack, Ord a, Show a) => [a] -> [a] -> Assertion (@?==) l1 l2 = sort l1 @?= sort l2 + diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-reload/Main.hs b/plugins/hls-cabal-plugin/test/testdata/simple-reload/Main.hs new file mode 100644 index 0000000000..5f0cdfad80 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-reload/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Data.List -- Intentionally unused import, used in the testcase + +main :: IO () +main = foo + +-- Missing signature +foo = putStrLn "Hello, World" diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-reload/cabal.project b/plugins/hls-cabal-plugin/test/testdata/simple-reload/cabal.project new file mode 100644 index 0000000000..e6fdbadb43 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-reload/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-reload/hie.yaml b/plugins/hls-cabal-plugin/test/testdata/simple-reload/hie.yaml new file mode 100644 index 0000000000..04cd24395e --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-reload/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/plugins/hls-cabal-plugin/test/testdata/simple-reload/simple-reload.cabal b/plugins/hls-cabal-plugin/test/testdata/simple-reload/simple-reload.cabal new file mode 100644 index 0000000000..359940aebc --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/simple-reload/simple-reload.cabal @@ -0,0 +1,14 @@ +cabal-version: 3.4 +name: simple-reload +version: 0.1.0.0 +-- copyright: +build-type: Simple + +common warnings + ghc-options: -Wall -Wno-unused-imports + +executable simple-reload + import: warnings + main-is: Main.hs + build-depends: base + default-language: Haskell2010