Enable notification handlers only for Haskell files

Author: VeryMilkyJoe

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

@@ -23,6 +23,7 @@ import qualified Language.LSP.Server            as LSP
 import           Language.LSP.Types
 
 import qualified Data.Text                      as T
+import System.FilePath
 
 gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition))
 hover          :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover))
@@ -76,8 +77,11 @@ request
   -> LSP.LspM c (Either ResponseError b)
 request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do
     mbResult <- case uriToFilePath' uri of
-        Just path -> logAndRunRequest label getResults ide pos path
-        Nothing   -> pure Nothing
+        Just path
+          | takeExtension path `elem` [".hs", ".lhs"]
+          -> logAndRunRequest label getResults ide pos path
+          | otherwise -> pure Nothing
+        Nothing  -> pure Nothing
     pure $ Right $ maybe notFound found mbResult
 
 logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b

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

@@ -40,7 +40,7 @@ import           Ide.Plugin.Config                     (CheckParents (CheckOnClo
 import           Ide.Types
 import           System.FilePath                       (takeExtension)
 
-whenUriHaskellFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
+whenUriHaskellFile :: MonadIO m => Uri -> (NormalizedFilePath -> m ()) -> m ()
 whenUriHaskellFile uri act = whenJust maybeHaskellFile $ act . toNormalizedFilePath'
   where
     maybeHaskellFile = do

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

@@ -147,7 +147,7 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd
 extensiblePlugins :: [(PluginId, PluginDescriptor IdeState)] -> Plugin Config
 extensiblePlugins xs = mempty { P.pluginHandlers = handlers }
   where
-    getPluginDescriptor pid = fromJust $ lookup pid xs
+    getPluginDescriptor pid = lookup pid xs
     IdeHandlers handlers' = foldMap bakePluginId xs
     bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers
     bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map
@@ -159,20 +159,38 @@ extensiblePlugins xs = mempty { P.pluginHandlers = handlers }
       (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers'
       pure $ requestHandler m $ \ide params -> do
         config <- Ide.PluginUtils.getClientConfig
-        let fs = filter (\(pid,_) -> pluginEnabled m params (getPluginDescriptor pid) config) fs'
-        case nonEmpty fs of
-          Nothing -> pure $ Left $ ResponseError InvalidRequest
-            ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs))
+        -- for each pid, get plugin descriptor ([(Pid, Maybe PluginDesc)])
+        --   If plugin amiss, pure $ Left
+        -- zip fs' pluginDescs for pluginEnabled
+        let pluginInfo = map (\(pid,_) -> (pid, getPluginDescriptor pid)) fs'
+        cleanPluginInfo <- go pluginInfo []
+        case cleanPluginInfo of
+          Left err -> pure $ Left err
+          Right pluginInfos -> do
+            let fs = map snd $ filter (\((_, desc), _) -> pluginEnabled m params desc config) (zip pluginInfos fs')
+            case nonEmpty fs of
+              Nothing -> pure $ Left $ ResponseError InvalidRequest
+                ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs))
+                Nothing
+              Just fs -> do
+                let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e)
+                es <- runConcurrently msg (show m) fs ide params
+                let (errs,succs) = partitionEithers $ toList es
+                case nonEmpty succs of
+                  Nothing -> pure $ Left $ combineErrors errs
+                  Just xs -> do
+                    caps <- LSP.getClientCapabilities
+                    pure $ Right $ combineResponses m config caps params xs
+
+    go :: [(PluginId, Maybe (PluginDescriptor c))] -> [(PluginId, PluginDescriptor c)] -> LSP.LspM Config (Either ResponseError [(PluginId, PluginDescriptor c)])
+    go ((pid, Nothing):_) _ = pure $ Left $ ResponseError InvalidRequest
+            ("No plugindescriptor found for " <>  pidT <> ", available: ")
             Nothing
-          Just fs -> do
-            let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e)
-            es <- runConcurrently msg (show m) fs ide params
-            let (errs,succs) = partitionEithers $ toList es
-            case nonEmpty succs of
-              Nothing -> pure $ Left $ combineErrors errs
-              Just xs -> do
-                caps <- LSP.getClientCapabilities
-                pure $ Right $ combineResponses m config caps params xs
+      where
+        PluginId pidT = pid
+    go ((pid, Just desc):xs) ys = go xs (ys ++ [(pid, desc)])
+    go [] ys = pure $ Right ys
+
 -- ---------------------------------------------------------------------
 
 extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config

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

@@ -403,7 +403,7 @@ defaultPluginDescriptor plId =
     mempty
     mempty
     Nothing
-    ["hs", "lhs"]
+    [".hs", ".lhs"]
 
 defaultCabalPluginDescriptor :: PluginId -> PluginDescriptor ideState
 defaultCabalPluginDescriptor plId =
@@ -416,7 +416,7 @@ defaultCabalPluginDescriptor plId =
     mempty
     mempty
     Nothing
-    ["cabal"]
+    [".cabal"]
 
 newtype CommandId = CommandId T.Text
   deriving (Show, Read, Eq, Ord)