WIP work with TH dependent files

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -266,6 +266,8 @@ type instance RuleResult GetFileContents = (FileVersion, Maybe Text)
 
 type instance RuleResult GetFileExists = Bool
 
+type instance RuleResult AddWatchedFile = Bool
+
 
 -- The Shake key type for getModificationTime queries
 newtype GetModificationTime = GetModificationTime_
@@ -490,6 +492,12 @@ instance Binary   GetClientSettings
 
 type instance RuleResult GetClientSettings = Hashed (Maybe Value)
 
+data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic)
+instance Hashable AddWatchedFile
+instance NFData   AddWatchedFile
+instance Binary   AddWatchedFile
+
+
 -- 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

ghcide/src/Development/IDE/Core/Rules.hs

@@ -151,6 +151,7 @@ import           Ide.Plugin.Properties                        (HasProperty,
 import           Ide.PluginUtils                              (configForPlugin)
 import           Ide.Types                                    (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),
                                                                PluginId)
+import Development.IDE.LSP.Notifications (registerFileWatches)
 
 -- | This is useful for rules to convert rules that can only produce errors or
 -- a result into the more general IdeResult type that supports producing
@@ -628,6 +629,7 @@ typeCheckRuleDefinition hsc pm = do
       r@(_, mtc) <- a
       forM_ mtc $ \tc -> do
         used_files <- liftIO $ readIORef $ tcg_dependent_files $ tmrTypechecked tc
+        void $ uses_ AddWatchedFile (map toNormalizedFilePath' used_files)
         void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)
       return r
 
@@ -1034,6 +1036,14 @@ writeHiFileAction hsc hiFile = do
         resetInterfaceStore extras $ toNormalizedFilePath' targetPath
         writeHiFile hsc hiFile
 
+addWatchedFileRule :: Rules ()
+addWatchedFileRule = defineNoDiagnostics $ \AddWatchedFile f -> do
+  ShakeExtras{lspEnv} <- getShakeExtras
+  case lspEnv of
+    Just env -> fmap Just $ liftIO $ LSP.runLspT env $
+      registerFileWatches [fromNormalizedFilePath f]
+    Nothing -> pure Nothing
+
 -- | A rule that wires per-file rules together
 mainRule :: Rules ()
 mainRule = do
@@ -1066,6 +1076,7 @@ mainRule = do
     persistentHieFileRule
     persistentDocMapRule
     persistentImportMapRule
+    addWatchedFileRule
 
 -- | Given the path to a module src file, this rule returns True if the
 -- corresponding `.hi` file is stable, that is, if it is newer

ghcide/src/Development/IDE/LSP/Notifications.hs

@@ -9,7 +9,8 @@
 module Development.IDE.LSP.Notifications
     ( whenUriFile
     , descriptor
-    ) where
+    , isWatchSupported
+    ,registerFileWatches) where
 
 import qualified Language.LSP.Server                   as LSP
 import           Language.LSP.Types
@@ -37,7 +38,8 @@ import           Development.IDE.Core.FileStore        (resetFileStore,
 import           Development.IDE.Core.OfInterest
 import           Development.IDE.Core.RuleTypes        (GetClientSettings (..))
 import           Development.IDE.Types.Shake           (toKey)
-import           Ide.Plugin.Config                     (CheckParents (CheckOnClose))
+import           Ide.Plugin.Config                     (CheckParents (CheckOnClose),
+                                                        Config)
 import           Ide.Types
 
 whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
@@ -109,17 +111,24 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers =
       liftIO $ shakeSessionInit ide
 
       --------- Set up file watchers ------------------------------------------------------------------------
-      clientCapabilities <- LSP.getClientCapabilities
-      let watchSupported = case () of
-            _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities
-              , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
-              , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
-              , Just True <- _dynamicRegistration
-                -> True
-              | otherwise -> False
+      opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
+        -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
+        -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
+        -- followed by a file with an extension 'hs'.
+        -- We use multiple watchers instead of one using '{}' because lsp-test doesn't
+        -- support that: https://github.com/bubba/lsp-test/issues/77
+      let globs = watchedGlobs opts
+      success <- registerFileWatches globs
+      unless success $
+        liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"
+  ]
+    }
+
+registerFileWatches :: [String] -> LSP.LspT Config IO Bool
+registerFileWatches globs = do
+      watchSupported <- isWatchSupported
       if watchSupported
       then do
-        opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
         let
           regParams    = RegistrationParams (List [SomeRegistration registration])
           -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).
@@ -138,9 +147,19 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers =
           watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }
           -- We use multiple watchers instead of one using '{}' because lsp-test doesn't
           -- support that: https://github.com/bubba/lsp-test/issues/77
-          watchers = [ watcher (Text.pack glob) | glob <- watchedGlobs opts ]
+          watchers = [ watcher (Text.pack glob) | glob <- globs ]
 
         void $ LSP.sendRequest SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response
-      else liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"
-  ]
-    }
+        return True
+      else return False
+
+isWatchSupported :: LSP.LspT Config IO Bool
+isWatchSupported = do
+      clientCapabilities <- LSP.getClientCapabilities
+      pure $ case () of
+            _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities
+              , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
+              , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
+              , Just True <- _dynamicRegistration
+                -> True
+              | otherwise -> False

ghcide/test/exe/Main.hs

@@ -4733,7 +4733,8 @@ dependentFileTest = testGroup "addDependentFile"
       test dir = do
         -- If the file contains B then no type error
         -- otherwise type error
-        liftIO $ writeFile (dir </> "dep-file.txt") "A"
+        let depFilePath = dir </> "dep-file.txt"
+        liftIO $ writeFile depFilePath "A"
         let fooContent = T.unlines
               [ "{-# LANGUAGE TemplateHaskell #-}"
               , "module Foo where"
@@ -4745,18 +4746,21 @@ dependentFileTest = testGroup "addDependentFile"
               , "               if f == \"B\" then [| 1 |] else lift f)"
               ]
         let bazContent = T.unlines ["module Baz where", "import Foo ()"]
-        _ <-createDoc "Foo.hs" "haskell" fooContent
+        _ <- createDoc "Foo.hs" "haskell" fooContent
         doc <- createDoc "Baz.hs" "haskell" bazContent
         expectDiagnostics
           [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]
         -- Now modify the dependent file
-        liftIO $ writeFile (dir </> "dep-file.txt") "B"
+        liftIO $ writeFile depFilePath "B"
+        sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
+          List [FileEvent (filePathToUri depFilePath) FcChanged ]
+
+        -- Modifying Baz will now trigger Foo to be rebuilt as well
         let change = TextDocumentContentChangeEvent
               { _range = Just (Range (Position 2 0) (Position 2 6))
               , _rangeLength = Nothing
               , _text = "f = ()"
               }
-        -- Modifying Baz will now trigger Foo to be rebuilt as well
         changeDoc doc [change]
         expectDiagnostics [("Foo.hs", [])]