Add a custom prefix to command IDs (#500)

* Add a custom prefix to command IDs

A client can run more than one instance of ghcide.  Some clients have a global
command registry, and all commands must be unique in that registry.

So to make the command ids unique, prefix them with the ghcide server process
id, as is done in haskell-ide-engine.

* Use same command naming scheme as in haskell-language-server

To ease interoperability

* Use makeLspCommandId for prefixing commands

This puts all the prefixing logic in one place.

* Add hlint exception for CPP in Development.IDE.Compat

* Bring in Win32 dependency for windows build

Author: alanz

.hlint.yaml

@@ -76,6 +76,7 @@
   - {name: ImplicitParams, within: []}
   - name: CPP
     within:
+    - Development.IDE.Compat
     - Development.IDE.Core.FileStore
     - Development.IDE.Core.Compile
     - Development.IDE.GHC.Compat

exe/Main.hs

@@ -81,11 +81,12 @@ main = do
     whenJust argsCwd IO.setCurrentDirectory
 
     dir <- IO.getCurrentDirectory
+    command <- makeLspCommandId "typesignature.add"
 
     let plugins = Completions.plugin <> CodeAction.plugin
         onInitialConfiguration = const $ Right ()
         onConfigurationChange  = const $ Right ()
-        options = def { LSP.executeCommandCommands = Just ["typesignature.add"]
+        options = def { LSP.executeCommandCommands = Just [command]
                       , LSP.completionTriggerCharacters = Just "."
                       }
 

ghcide.cabal

@@ -74,7 +74,10 @@ library
         ghc-boot-th,
         ghc-boot,
         ghc >= 8.4
-    if !os(windows)
+    if os(windows)
+      build-depends:
+        Win32
+    else
       build-depends:
         unix
       c-sources:
@@ -100,6 +103,7 @@ library
     include-dirs:
         include
     exposed-modules:
+        Development.IDE.Compat
         Development.IDE.Core.Debouncer
         Development.IDE.Core.FileStore
         Development.IDE.Core.IdeConfiguration

src/Development/IDE/Compat.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE CPP #-}
+module Development.IDE.Compat
+    (
+        getProcessID
+    ) where
+
+#ifdef mingw32_HOST_OS
+
+import qualified System.Win32.Process as P (getCurrentProcessId)
+getProcessID :: IO Int
+getProcessID = fromIntegral <$> P.getCurrentProcessId
+
+#else
+
+import qualified System.Posix.Process as P (getProcessID)
+getProcessID :: IO Int
+getProcessID = fromIntegral <$> P.getProcessID
+
+#endif

src/Development/IDE/Plugin.hs

@@ -1,11 +1,13 @@
 
-module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules) where
+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where
 
 import Data.Default
+import qualified Data.Text as T
 import Development.Shake
 import Development.IDE.LSP.Server
 
 import           Language.Haskell.LSP.Types
+import Development.IDE.Compat
 import Development.IDE.Core.Rules
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.Messages
@@ -35,3 +37,24 @@ codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..}
     }
     where
       g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c
+
+-- | Prefix to uniquely identify commands sent to the client.  This
+-- has two parts
+--
+-- - A representation of the process id to make sure that a client has
+--   unique commands if it is running multiple servers, since some
+--   clients have a global command table and get confused otherwise.
+--
+-- - A string to identify ghcide, to ease integration into
+--   haskell-language-server, which routes commands to plugins based
+--   on that.
+makeLspCommandId :: T.Text -> IO T.Text
+makeLspCommandId command = do
+    pid <- getPid
+    return $ pid <> ":ghcide:" <> command
+
+-- | Get the operating system process id for the running server
+-- instance. This should be the same for the lifetime of the instance,
+-- and different from that of any other currently running instance.
+getPid :: IO T.Text
+getPid = T.pack . show <$> getProcessID

src/Development/IDE/Plugin/CodeAction.hs

@@ -92,13 +92,14 @@ codeLens
     -> CodeLensParams
     -> IO (Either ResponseError (List CodeLens))
 codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
+    commandId <- makeLspCommandId "typesignature.add"
     fmap (Right . List) $ case uriToFilePath' uri of
       Just (toNormalizedFilePath' -> filePath) -> do
         _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
         diag <- getDiagnostics ideState
         hDiag <- getHiddenDiagnostics ideState
         pure
-          [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
+          [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing
           | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag
           , dFile == filePath
           , (title, tedit) <- suggestSignature False dDiag
@@ -113,7 +114,11 @@ executeAddSignatureCommand
     -> ExecuteCommandParams
     -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
 executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
-    | _command == "typesignature.add"
+    -- _command is prefixed with a process ID, because certain clients
+    -- have a global command registry, and all commands must be
+    -- unique. And there can be more than one ghcide instance running
+    -- at a time against the same client.
+    | T.isSuffixOf "typesignature.add" _command
     , Just (List [edit]) <- _arguments
     , Success wedit <- fromJSON edit
     = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

test/exe/Main.hs

@@ -108,7 +108,7 @@ initializeResponseTests = withResource acquire release tests where
     , chk "NO doc link"               _documentLinkProvider  Nothing
     , chk "NO color"                         _colorProvider (Just $ ColorOptionsStatic False)
     , chk "NO folding range"          _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
-    , chk "   execute command"      _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
+    , che "   execute command"      _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
     , chk "   workspace"                         _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
     , chk "NO experimental"                   _experimental  Nothing
     ] where
@@ -124,6 +124,15 @@ initializeResponseTests = withResource acquire release tests where
       chk title getActual expected =
         testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
 
+      che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree
+      che title getActual _expected = testCase title doTest
+        where
+            doTest = do
+                ir <- getInitializeResponse
+                let Just (ExecuteCommandOptions {_commands = List [command]}) = getActual $ innerCaps ir
+                True @=? (T.isSuffixOf "typesignature.add" command)
+
+
   innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
   innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
   innerCaps  _ = error "this test only expects inner capabilities"