Add ability for plugins to handle file change notifications (#1588)

* Provide pluginNotificationhandlers too

Like pluginHandlers, but for notifications

At present the last one in the chain wins, so if one is set it
overrides the one built into ghcide

* Fix handling of config

* run the handlers in parallel

* add missing instances

* Extract ghcide notification handlers to an HLS plugin

This is required to allow for user defined notification handlers, otherwise
HLS plugins will overwrite the ghcide handlers and nothing will work

* Update hls-plugin-api/src/Ide/Types.hs

Co-authored-by: wz1000 <zubin.duggal@gmail.com>

* bump version numbers to track breaking changes

* hlint pragma

* fixup! Update hls-plugin-api/src/Ide/Types.hs

* relax depends constraints

* redundant import

* fixup! Update hls-plugin-api/src/Ide/Types.hs

* clean up

* run notification handlers sequentially

* Drop PluginNotification (redundant)

* sort out tracing

Co-authored-by: Alan Zimmerman <alanzimm@fb.com>
Co-authored-by: wz1000 <zubin.duggal@gmail.com>

exe/Plugins.hs

@@ -89,7 +89,6 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
                    then basePlugins ++ examplePlugins
                    else basePlugins
     basePlugins =
-      GhcIde.descriptors ++
 #if pragmas
       Pragmas.descriptor  "pragmas" :
 #endif
@@ -135,7 +134,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
 #if splice
       Splice.descriptor "splice" :
 #endif
-      []
+    -- The ghcide descriptors should come last so that the notification handlers
+    -- (which restart the Shake build) run after everything else
+      GhcIde.descriptors
     examplePlugins =
       [Example.descriptor  "eg"
       ,Example2.descriptor "eg2"

ghcide/ghcide.cabal

@@ -58,7 +58,7 @@ library
         haddock-library ^>= 1.10.0,
         hashable,
         hie-compat ^>= 0.1.0.0,
-        hls-plugin-api ^>= 1.0.0.0,
+        hls-plugin-api ^>= 1.1.0.0,
         lens,
         hiedb == 0.3.0.1,
         lsp-types == 1.1.*,

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

@@ -41,7 +41,6 @@ import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.Shake
 import           Development.IDE.Core.Tracing
 import           Development.IDE.LSP.HoverDefinition
-import           Development.IDE.LSP.Notifications
 import           Development.IDE.Types.Logger
 
 import           System.IO.Unsafe                      (unsafeInterleaveIO)
@@ -100,7 +99,6 @@ runLanguageServer options getHieDbLoc onConfigurationChange userHandlers getIdeS
     let ideHandlers = mconcat
           [ setIdeHandlers
           , userHandlers
-          , setHandlersNotifications -- absolutely critical, join them with user notifications
           ]
 
     -- Send everything over a channel, since you need to wait until after initialise before

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

@@ -7,7 +7,8 @@
 {-# LANGUAGE RankNTypes            #-}
 
 module Development.IDE.LSP.Notifications
-    ( setHandlersNotifications
+    ( whenUriFile
+    , descriptor
     ) where
 
 import qualified Language.LSP.Server                   as LSP
@@ -37,15 +38,15 @@ import           Development.IDE.Core.FileStore        (resetFileStore,
                                                         typecheckParents)
 import           Development.IDE.Core.OfInterest
 import           Ide.Plugin.Config                     (CheckParents (CheckOnClose))
-
+import           Ide.Types
 
 whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
 whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'
 
-setHandlersNotifications :: LSP.Handlers (ServerM c)
-setHandlersNotifications = mconcat
-  [ notificationHandler LSP.STextDocumentDidOpen $
-      \ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do
+descriptor :: PluginId -> PluginDescriptor IdeState
+descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat
+  [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $
+      \ide _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do
       updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List [])
       whenUriFile _uri $ \file -> do
           -- We don't know if the file actually exists, or if the contents match those on disk
@@ -54,32 +55,32 @@ setHandlersNotifications = mconcat
           setFileModified ide False file
           logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri
 
-  , notificationHandler LSP.STextDocumentDidChange $
-      \ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do
+  , mkPluginNotificationHandler LSP.STextDocumentDidChange $
+      \ide _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do
         updatePositionMapping ide identifier changes
         whenUriFile _uri $ \file -> do
           modifyFilesOfInterest ide (M.insert file Modified{firstOpen=False})
           setFileModified ide False file
         logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri
 
-  , notificationHandler LSP.STextDocumentDidSave $
-      \ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do
+  , mkPluginNotificationHandler LSP.STextDocumentDidSave $
+      \ide _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do
         whenUriFile _uri $ \file -> do
             modifyFilesOfInterest ide (M.insert file OnDisk)
             setFileModified ide True file
         logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri
 
-  , notificationHandler LSP.STextDocumentDidClose $
-        \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do
+  , mkPluginNotificationHandler LSP.STextDocumentDidClose $
+        \ide _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do
           whenUriFile _uri $ \file -> do
               modifyFilesOfInterest ide (M.delete file)
               -- Refresh all the files that depended on this
               checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide)
               when (checkParents >= CheckOnClose) $ typecheckParents ide file
               logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri
 
-  , notificationHandler LSP.SWorkspaceDidChangeWatchedFiles $
-      \ide (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do
+  , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $
+      \ide _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do
         -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and
         -- what we do with them
         let msg = Text.pack $ show fileEvents
@@ -88,22 +89,22 @@ setHandlersNotifications = mconcat
         resetFileStore ide fileEvents
         setSomethingModified ide
 
-  , notificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $
-      \ide (DidChangeWorkspaceFoldersParams events) -> liftIO $ do
+  , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $
+      \ide _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do
         let add       = S.union
             substract = flip S.difference
         modifyWorkspaceFolders ide
           $ add       (foldMap (S.singleton . parseWorkspaceFolder) (_added   events))
           . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))
 
-  , notificationHandler LSP.SWorkspaceDidChangeConfiguration $
-      \ide (DidChangeConfigurationParams cfg) -> liftIO $ do
+  , mkPluginNotificationHandler LSP.SWorkspaceDidChangeConfiguration $
+      \ide _ (DidChangeConfigurationParams cfg) -> liftIO $ do
         let msg = Text.pack $ show cfg
         logDebug (ideLogger ide) $ "Configuration changed: " <> msg
         modifyClientSettings ide (const $ Just cfg)
         setSomethingModified ide
 
-  , notificationHandler LSP.SInitialized $ \ide _ -> do
+  , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ -> do
       clientCapabilities <- LSP.getClientCapabilities
       let watchSupported = case () of
             _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities
@@ -138,3 +139,4 @@ setHandlersNotifications = mconcat
         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"
   ]
+    }

ghcide/src/Development/IDE/Plugin/HLS.hs

@@ -1,5 +1,7 @@
-{-# LANGUAGE GADTs     #-}
-{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds         #-}
 
 module Development.IDE.Plugin.HLS
     (
@@ -8,6 +10,7 @@ module Development.IDE.Plugin.HLS
 
 import           Control.Exception            (SomeException)
 import           Control.Monad
+import           Control.Monad.IO.Class
 import qualified Data.Aeson                   as J
 import           Data.Bifunctor
 import           Data.Dependent.Map           (DMap)
@@ -24,6 +27,7 @@ import           Development.IDE.Core.Shake
 import           Development.IDE.Core.Tracing
 import           Development.IDE.LSP.Server
 import           Development.IDE.Plugin
+import           Development.IDE.Types.Logger
 import           Development.Shake            (Rules)
 import           Ide.Plugin.Config
 import           Ide.PluginUtils              (getClientConfig)
@@ -44,7 +48,8 @@ asGhcIdePlugin :: Config -> IdePlugins IdeState -> Plugin Config
 asGhcIdePlugin defaultConfig mp =
     mkPlugin rulesPlugins HLS.pluginRules <>
     mkPlugin executeCommandPlugins HLS.pluginCommands <>
-    mkPlugin (extensiblePlugins defaultConfig)  HLS.pluginHandlers
+    mkPlugin (extensiblePlugins defaultConfig) HLS.pluginHandlers <>
+    mkPlugin (extensibleNotificationPlugins defaultConfig) HLS.pluginNotificationHandlers
     where
         ls = Map.toList (ipMap mp)
 
@@ -154,6 +159,31 @@ extensiblePlugins defaultConfig xs = Plugin mempty handlers
               Just xs -> do
                 caps <- LSP.getClientCapabilities
                 pure $ Right $ combineResponses m config caps params xs
+-- ---------------------------------------------------------------------
+
+extensibleNotificationPlugins :: Config -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config
+extensibleNotificationPlugins defaultConfig xs = Plugin mempty handlers
+  where
+    IdeNotificationHandlers handlers' = foldMap bakePluginId xs
+    bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers
+    bakePluginId (pid,PluginNotificationHandlers hs) = IdeNotificationHandlers $ DMap.map
+      (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,f pid)])
+      hs
+    handlers = mconcat $ do
+      (IdeNotification m :=> IdeNotificationHandler fs') <- DMap.assocs handlers'
+      pure $ notificationHandler m $ \ide params -> do
+        config <- fromMaybe defaultConfig <$> Ide.PluginUtils.getClientConfig
+        let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) fs'
+        case nonEmpty fs of
+          Nothing -> do
+              liftIO $ logInfo (ideLogger ide) "extensibleNotificationPlugins no enabled plugins"
+              pure ()
+          Just fs -> do
+            -- We run the notifications in order, so the core ghcide provider
+            -- (which restarts the shake process) hopefully comes last
+              mapM_ (\(pid,f) -> otTracedProvider pid (fromString $ show m) $ f ide params) fs
+
+-- ---------------------------------------------------------------------
 
 runConcurrently
   :: MonadUnliftIO m
@@ -175,12 +205,25 @@ combineErrors xs  = ResponseError InternalError (T.pack (show xs)) Nothing
 newtype IdeHandler (m :: J.Method FromClient Request)
   = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))]
 
+-- | Combine the 'PluginHandler' for all plugins
+newtype IdeNotificationHandler (m :: J.Method FromClient Notification)
+  = IdeNotificationHandler [(PluginId, IdeState -> MessageParams m -> LSP.LspM Config ())]
+-- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()`
+
 -- | Combine the 'PluginHandlers' for all plugins
-newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler)
+newtype IdeHandlers             = IdeHandlers             (DMap IdeMethod       IdeHandler)
+newtype IdeNotificationHandlers = IdeNotificationHandlers (DMap IdeNotification IdeNotificationHandler)
 
 instance Semigroup IdeHandlers where
   (IdeHandlers a) <> (IdeHandlers b) = IdeHandlers $ DMap.unionWithKey go a b
     where
-      go _ (IdeHandler a) (IdeHandler b) = IdeHandler (a ++ b)
+      go _ (IdeHandler a) (IdeHandler b) = IdeHandler (a <> b)
 instance Monoid IdeHandlers where
   mempty = IdeHandlers mempty
+
+instance Semigroup IdeNotificationHandlers where
+  (IdeNotificationHandlers a) <> (IdeNotificationHandlers b) = IdeNotificationHandlers $ DMap.unionWithKey go a b
+    where
+      go _ (IdeNotificationHandler a) (IdeNotificationHandler b) = IdeNotificationHandler (a <> b)
+instance Monoid IdeNotificationHandlers where
+  mempty = IdeNotificationHandlers mempty

ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs

@@ -1,29 +1,31 @@
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings     #-}
 
 -- | Exposes the ghcide features as an HLS plugin
 module Development.IDE.Plugin.HLS.GhcIde
   (
     descriptors
   ) where
-import Development.IDE
-import Development.IDE.LSP.HoverDefinition
-import Development.IDE.LSP.Outline
-import Ide.Types
-import Language.LSP.Types
-import Language.LSP.Server (LspM)
-import Text.Regex.TDFA.Text()
-import qualified Development.IDE.Plugin.CodeAction as CodeAction
-import qualified Development.IDE.Plugin.Completions as Completions
-import qualified Development.IDE.Plugin.TypeLenses as TypeLenses
-import Control.Monad.IO.Class
+import           Control.Monad.IO.Class
+import           Development.IDE
+import           Development.IDE.LSP.HoverDefinition
+import qualified Development.IDE.LSP.Notifications   as Notifications
+import           Development.IDE.LSP.Outline
+import qualified Development.IDE.Plugin.CodeAction   as CodeAction
+import qualified Development.IDE.Plugin.Completions  as Completions
+import qualified Development.IDE.Plugin.TypeLenses   as TypeLenses
+import           Ide.Types
+import           Language.LSP.Server                 (LspM)
+import           Language.LSP.Types
+import           Text.Regex.TDFA.Text                ()
 
 descriptors :: [PluginDescriptor IdeState]
 descriptors =
   [ descriptor "ghcide-hover-and-symbols",
     CodeAction.descriptor "ghcide-code-actions",
     Completions.descriptor "ghcide-completions",
-    TypeLenses.descriptor "ghcide-type-lenses"
+    TypeLenses.descriptor "ghcide-type-lenses",
+    Notifications.descriptor "ghcide-core"
   ]
 
 -- ---------------------------------------------------------------------

haskell-language-server.cabal

@@ -60,7 +60,7 @@ library
     , lsp
     , hie-bios
     , hiedb
-    , hls-plugin-api        ^>= 1.0.0.0
+    , hls-plugin-api        >= 1.0 && < 1.2
     , hslogger
     , optparse-applicative
     , optparse-simple
@@ -380,7 +380,7 @@ common hls-test-utils
     , data-default
     , lsp
     , hie-bios
-    , hls-plugin-api        ^>= 1.0.0.0
+    , hls-plugin-api        >= 1.0 && < 1.2
     , hslogger
     , hspec
     , hspec-core

hls-plugin-api/hls-plugin-api.cabal

@@ -1,6 +1,6 @@
 cabal-version: 2.2
 name:          hls-plugin-api
-version:       1.0.0.0
+version:       1.1.0.0
 synopsis:      Haskell Language Server API for plugin communication
 description:
   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>