ExecuteCommand plugins work via pluginDescriptor

Demonstrated by adding missing pragmas derived from GHC error messages.

Author: alanz

exe/Main.hs

@@ -15,11 +15,7 @@ import Control.Concurrent.Extra
 import Control.Exception
 import Control.Monad.Extra
 import Control.Monad.IO.Class
--- import qualified Crypto.Hash.SHA1 as H
--- import Data.ByteString.Base16
--- import qualified Data.ByteString.Char8 as B
 import Data.Default
--- import Data.Functor ((<&>))
 import qualified Data.HashSet as HashSet
 import Data.List.Extra
 import qualified Data.Map.Strict as Map
@@ -44,23 +40,12 @@ import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import Development.IDE.Types.Options
 import Development.Shake (Action, Rules, action)
--- import           DynFlags
--- import GHC hiding (def)
--- import qualified GHC.Paths
 import HIE.Bios
 import qualified Language.Haskell.LSP.Core as LSP
--- import HIE.Bios.Cradle
--- import HIE.Bios.Environment
--- import HIE.Bios.Types
 import Ide.Plugin
--- import Ide.PluginDescriptors
 import Ide.Plugin.Config
--- import Ide.Plugin.Formatter
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types (LspId(IdInt))
--- import qualified Language.Haskell.LSP.Core as LSP
--- import Linker
--- import Paths_haskell_language_server
 import RuleTypes
 import Rules
 import qualified System.Directory.Extra as IO
@@ -126,8 +111,8 @@ idePlugins includeExamples
       -- , hsimportDescriptor    "hsimport"
       -- , liquidDescriptor      "liquid"
       -- , packageDescriptor     "package"
-      -- , pragmasDescriptor     "pragmas"
-        Floskell.descriptor "floskell"
+        Pragmas.descriptor  "pragmas"
+      , Floskell.descriptor "floskell"
       -- , genericDescriptor     "generic"
       -- , ghcmodDescriptor      "ghcmod"
       , Ormolu.descriptor   "ormolu"
@@ -172,7 +157,8 @@ main = do
     dir <- IO.getCurrentDirectory
 
     pid <- getPid
-    let plugins = idePlugins argsExamplePlugin
+    -- let plugins = idePlugins argsExamplePlugin
+    let plugins = idePlugins True
         options = def { LSP.executeCommandCommands = Just (commandIds pid)
                       , LSP.completionTriggerCharacters = Just "."
                       }

ghcide

@@ -30,7 +30,7 @@ import           Data.Maybe
 import qualified Data.Text                     as T
 import           Development.IDE.Core.Rules
 import           Development.IDE.LSP.Server
-import           Development.IDE.Plugin hiding (pluginCommands)
+import           Development.IDE.Plugin hiding (pluginCommands, pluginRules)
 import           Development.IDE.Types.Diagnostics as D
 import           Development.Shake hiding ( Diagnostic, command )
 import           GHC.Generics
@@ -53,6 +53,7 @@ import           Text.Regex.TDFA.Text()
 -- category ('Notifaction', 'Request' etc).
 asGhcIdePlugin :: IdePlugins -> Plugin Config
 asGhcIdePlugin mp =
+    mkPlugin rulesPlugins (Just . pluginRules) <>
     mkPlugin executeCommandPlugins (Just . pluginCommands) <>
     mkPlugin codeActionPlugins     pluginCodeActionProvider <>
     -- diagnostics from pluginDiagnosticProvider
@@ -66,7 +67,7 @@ asGhcIdePlugin mp =
 
         ls = Map.toList (ipMap mp)
 
-        mkPlugin :: ([(PluginId, b)] -> t) -> (PluginDescriptor -> Maybe b) -> t
+        mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor -> Maybe b) -> Plugin Config
         mkPlugin maker selector
             = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls
 
@@ -76,6 +77,11 @@ pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginI
 
 -- ---------------------------------------------------------------------
 
+rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config
+rulesPlugins rs = Plugin mempty rules mempty
+    where
+        rules = mconcat $ map snd rs
+
 codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config
 codeActionPlugins cas = Plugin mempty codeActionRules (codeActionHandlers cas)
 
@@ -286,9 +292,12 @@ runPluginCommand m p@(PluginId p') com@(CommandId com') arg =
           ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' <> ": " <> T.pack err) Nothing, Nothing)
         J.Success a -> do
             res <- f a
-            case res of
-                Left e ->  return (Left e,             Nothing)
-                Right r -> return (Right $ J.toJSON r, Nothing)
+            return res
+            -- case res of
+            --     Left e ->  return (Left e,             Nothing)
+            --     -- Right r -> return (Right $ J.toJSON r, Nothing)
+            --     Right r -> return r
+            --         -- return (Right J.Null, Just(WorkspaceApplyEdit, _ r))
 
 -- -----------------------------------------------------------
 

src/Ide/Plugin.hs

@@ -5,7 +5,8 @@
 -- | Provides code actions to add missing pragmas (whenever GHC suggests to)
 module Ide.Plugin.Pragmas
   (
-      codeAction
+      descriptor
+  ,   codeAction
   ,   commands
   ) where
 
@@ -18,19 +19,16 @@ import           Ide.Types
 import qualified GHC.Generics                    as Generics
 import qualified Language.Haskell.LSP.Types      as J
 import qualified Language.Haskell.LSP.Types.Lens as J
-
 import           Development.IDE.Types.Diagnostics as D
 import           Language.Haskell.LSP.Types
 
 -- ---------------------------------------------------------------------
 
-_pragmasDescriptor :: PluginId -> PluginDescriptor
-_pragmasDescriptor plId = PluginDescriptor
+descriptor :: PluginId -> PluginDescriptor
+descriptor plId = PluginDescriptor
   { pluginId = plId
   , pluginRules = mempty
-  , pluginCommands =
-      [ PluginCommand "addPragma" "add the given pragma" addPragmaCmd
-      ]
+  , pluginCommands = commands
   , pluginCodeActionProvider = Just codeActionProvider
   , pluginDiagnosticProvider = Nothing
   , pluginHoverProvider = Nothing
@@ -58,7 +56,9 @@ data AddPragmaParams = AddPragmaParams
 -- Pragma is added to the first line of the Uri.
 -- It is assumed that the pragma name is a valid pragma,
 -- thus, not validated.
-addPragmaCmd :: AddPragmaParams -> IO (Either ResponseError J.WorkspaceEdit)
+-- addPragmaCmd :: AddPragmaParams -> IO (Either ResponseError J.WorkspaceEdit)
+addPragmaCmd :: AddPragmaParams -> IO (Either ResponseError Value,
+                           Maybe (ServerMethod, ApplyWorkspaceEditParams))
 addPragmaCmd (AddPragmaParams uri pragmaName) = do
   let
     pos = J.Position 0 0
@@ -69,7 +69,7 @@ addPragmaCmd (AddPragmaParams uri pragmaName) = do
     res = J.WorkspaceEdit
       (Just $ H.singleton uri textEdits)
       Nothing
-  return $ Right res
+  return $ (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res))
 
 -- ---------------------------------------------------------------------
 
@@ -80,11 +80,12 @@ codeAction = codeActionProvider
 -- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'.
 codeActionProvider :: CodeActionProvider
 codeActionProvider _ plId docId _ (J.CodeActionContext (J.List diags) _monly) = do
-  cmds <- mapM mkCommand pragmas
+  -- cmds <- mapM mkCommand pragmas
+  cmds <- mapM mkCommand ("FooPragma":pragmas)
   return $ Right $ List cmds
   where
     -- Filter diagnostics that are from ghcmod
-    ghcDiags = filter (\d -> d ^. J.source == Just "bios") diags
+    ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags
     -- Get all potential Pragmas for all diagnostics.
     pragmas = concatMap (\d -> findPragma (d ^. J.message)) ghcDiags
     mkCommand pragmaName = do