Reload .cabal files when they are modified

Author: fendor

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

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
 

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}
 

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))

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
 

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

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

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
+

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"

plugins/hls-cabal-plugin/test/testdata/simple-reload/cabal.project

@@ -0,0 +1 @@
+packages: .