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

Author: alanz

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

@@ -8,6 +8,7 @@
 
 module Development.IDE.LSP.Notifications
     ( setHandlersNotifications
+    , whenUriFile
     ) where
 
 import qualified Language.LSP.Server                   as LSP

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

@@ -1,5 +1,9 @@
 {-# LANGUAGE GADTs     #-}
 {-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Development.IDE.Plugin.HLS
     (
@@ -45,6 +49,7 @@ asGhcIdePlugin defaultConfig mp =
     mkPlugin rulesPlugins HLS.pluginRules <>
     mkPlugin executeCommandPlugins HLS.pluginCommands <>
     mkPlugin (extensiblePlugins defaultConfig)  HLS.pluginHandlers
+    mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers
     where
         ls = Map.toList (ipMap mp)
 
@@ -154,6 +159,34 @@ extensiblePlugins defaultConfig xs = Plugin mempty handlers
               Just xs -> do
                 caps <- LSP.getClientCapabilities
                 pure $ Right $ combineResponses m config caps params xs
+-- ---------------------------------------------------------------------
+
+extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config
+extensibleNotificationPlugins 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
+        liftIO $ logInfo (ideLogger ide) "extensibleNotificationPlugins handler entered"
+        config <- getClientConfig
+        let fs = filter (\(pid,_) -> pluginEnabledNotification m pid config) fs'
+        case nonEmpty fs of
+          Nothing -> do
+              liftIO $ logInfo (ideLogger ide) "extensibleNotificationPlugins no enabled plugins"
+              pure ()
+          -- We run the notifications in order, so the built-in ghcide
+          -- processing (which restarts the shake process) comes last
+          -- Just fs -> void $ runConcurrentlyNotification (show m) fs ide params
+          Just fs -> do
+              liftIO $ logInfo (ideLogger ide) $ "extensibleNotificationPlugins number of plugins:" <> T.pack (show (length fs))
+              mapM_ (\(_pid,f) -> f ide params) fs
+
+-- ---------------------------------------------------------------------
 
 runConcurrently
   :: MonadUnliftIO m
@@ -175,12 +208,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 (NonEmpty ())))]
+-- 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

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

@@ -62,6 +62,7 @@ data PluginDescriptor ideState =
                    , pluginRules    :: !(Rules ())
                    , pluginCommands :: ![PluginCommand ideState]
                    , pluginHandlers :: PluginHandlers ideState
+                   , pluginNotificationHandlers :: PluginNotificationHandlers ideState
                    }
 
 -- | Methods that can be handled by plugins.
@@ -180,18 +181,59 @@ instance PluginMethod TextDocumentRangeFormatting where
   pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid
   combineResponses _ _ _ _ (x :| _) = x
 
+-- ---------------------------------------------------------------------
+
+-- | Notifications that can be handled by plugins.
+-- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method
+class HasTracing (MessageParams m) => PluginNotification m where
+
+  -- | Parse the configuration to check if this plugin is enabled
+  pluginEnabledNotification :: SMethod m -> PluginId -> Config -> Bool
+
+instance PluginNotification TextDocumentDidOpen where
+    pluginEnabledNotification _ _ _ = True
+
+instance PluginNotification TextDocumentDidChange where
+    pluginEnabledNotification _ _ _ = True
+
+instance PluginNotification TextDocumentDidSave where
+    pluginEnabledNotification _ _ _ = True
+
+-- ---------------------------------------------------------------------
+
 -- | Methods which have a PluginMethod instance
 data IdeMethod (m :: Method FromClient Request) = PluginMethod m => IdeMethod (SMethod m)
 instance GEq IdeMethod where
   geq (IdeMethod a) (IdeMethod b) = geq a b
 instance GCompare IdeMethod where
   gcompare (IdeMethod a) (IdeMethod b) = gcompare a b
 
+-- | Methods which have a PluginMethod instance
+data IdeNotification (m :: Method FromClient Notification) = PluginNotification m => IdeNotification (SMethod m)
+instance GEq IdeNotification where
+  geq (IdeNotification a) (IdeNotification b) = geq a b
+instance GCompare IdeNotification where
+  gcompare (IdeNotification a) (IdeNotification b) = gcompare a b
+
 -- | Combine handlers for the
 newtype PluginHandler a (m :: Method FromClient Request)
   = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))
 
-newtype PluginHandlers a = PluginHandlers (DMap IdeMethod (PluginHandler a))
+newtype PluginNotificationHandler a (m :: Method FromClient Notification)
+  = PluginNotificationHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty ()))
+-- newtype PluginNotificationHandler a (m :: Method FromClient Notification)
+--   = PluginNotificationHandler (PluginNotificationMethodHandler a m)`
+
+{-
+From Zubin
+alanz_: I would say `newtype PluginNotificationHandler a (m :: Method FromClient Notification) = PluginNotificationHandler (PluginNotificationMethodHandler a m)`
+16:28 and `newtype PluginNotificationHandlers a = PluginNotificationHandlers (DMap SMethod (PluginNotificationHandler a))
+
+-}
+
+newtype PluginHandlers a             = PluginHandlers             (DMap IdeMethod       (PluginHandler a))
+newtype PluginNotificationHandlers a = PluginNotificationHandlers (DMap IdeNotification (PluginNotificationHandler a))
+-- newtype PluginNotificationHandlers a = PluginNotificationHandlers (DMap SMethod (PluginNotificationHandler a))
 
 instance Semigroup (PluginHandlers a) where
   (PluginHandlers a) <> (PluginHandlers b) = PluginHandlers $ DMap.unionWithKey go a b
@@ -202,8 +244,19 @@ instance Semigroup (PluginHandlers a) where
 instance Monoid (PluginHandlers a) where
   mempty = PluginHandlers mempty
 
+instance Semigroup (PluginNotificationHandlers a) where
+  (PluginNotificationHandlers a) <> (PluginNotificationHandlers b) = PluginNotificationHandlers $ DMap.unionWithKey go a b
+    where
+      go _ (PluginNotificationHandler f) (PluginNotificationHandler g) = PluginNotificationHandler $ \pid ide params ->
+        f pid ide params >> g pid ide params
+
+instance Monoid (PluginNotificationHandlers a) where
+  mempty = PluginNotificationHandlers mempty
+
 type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m))
 
+type PluginNotificationMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config ()
+
 -- | Make a handler for plugins with no extra data
 mkPluginHandler
   :: PluginMethod m
@@ -214,13 +267,25 @@ mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandl
   where
     f' pid ide params = pure <$> f ide pid params
 
+-- | Make a handler for plugins with no extra data
+mkPluginNotificationHandler
+  :: (PluginNotification m)
+  => SClientMethod (m :: Method FromClient Notification)
+  -> PluginNotificationMethodHandler ideState m
+  -> PluginNotificationHandlers ideState
+mkPluginNotificationHandler m f
+    = PluginNotificationHandlers $ DMap.singleton (IdeNotification m) (PluginNotificationHandler f')
+  where
+    f' pid ide params = pure <$> f ide pid params
+
 defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState
 defaultPluginDescriptor plId =
   PluginDescriptor
     plId
     mempty
     mempty
     mempty
+    mempty
 
 newtype CommandId = CommandId T.Text
   deriving (Show, Read, Eq, Ord)