78d4031 · ghcide · git.iko.soy

git.iko.soy/ghcide

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

commit78d4031f7cf119bf2a0d1fae6157d52d1fbd2063 authorAlan Zimmerman <alan.zimm@gmail.com> dateMon 27 Apr 2020, 11:59 (6 years ago) parent4f9c756

7 files changed+68−6

compare with master

unifiedsplit

.hlint.yaml+1 exe/Main.hs+2−1 ghcide.cabal+5−1 src/Development/IDE/Compat.hs+19 src/Development/IDE/Plugin.hs+24−1 src/Development/IDE/Plugin/CodeAction.hs+7−2 test/exe/Main.hs+10−1

.hlint.yaml+1

@@ -76,6 +76,7 @@

7676 - {name: ImplicitParams, within: []}

7777 - name: CPP

7878 within:

79+ - Development.IDE.Compat

7980 - Development.IDE.Core.FileStore

8081 - Development.IDE.Core.Compile

8182 - Development.IDE.GHC.Compat

exe/Main.hs+2−1

@@ -81,11 +81,12 @@ main = do

8181 whenJust argsCwd IO.setCurrentDirectory

8282

8383 dir <- IO.getCurrentDirectory

84+ command <- makeLspCommandId "typesignature.add"

8485

8586 let plugins = Completions.plugin <> CodeAction.plugin

8687 onInitialConfiguration = const $ Right ()

8788 onConfigurationChange = const $ Right ()

88− options = def { LSP.executeCommandCommands = Just ["typesignature.add"]

89+ options = def { LSP.executeCommandCommands = Just [command]

8990 , LSP.completionTriggerCharacters = Just "."

9091 }

9192

ghcide.cabal+5−1

@@ -74,7 +74,10 @@ library

7474 ghc-boot-th,

7575 ghc-boot,

7676 ghc >= 8.4

77− if !os(windows)

77+ if os(windows)

78+ build-depends:

79+ Win32

80+ else

7881 build-depends:

7982 unix

8083 c-sources:

@@ -100,6 +103,7 @@ library

100103 include-dirs:

101104 include

102105 exposed-modules:

106+ Development.IDE.Compat

103107 Development.IDE.Core.Debouncer

104108 Development.IDE.Core.FileStore

105109 Development.IDE.Core.IdeConfiguration

src/Development/IDE/Compat.hsnew file+19

@@ -0,0 +1,19 @@

1+{-# LANGUAGE CPP #-}

2+module Development.IDE.Compat

3+ (

4+ getProcessID

5+ ) where

7+#ifdef mingw32_HOST_OS

9+import qualified System.Win32.Process as P (getCurrentProcessId)

10+getProcessID :: IO Int

11+getProcessID = fromIntegral <$> P.getCurrentProcessId

12+

13+#else

14+

15+import qualified System.Posix.Process as P (getProcessID)

16+getProcessID :: IO Int

17+getProcessID = fromIntegral <$> P.getProcessID

18+

19+#endif

src/Development/IDE/Plugin.hs+24−1

@@ -1,11 +1,13 @@

2−module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules) where

2+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where

44import Data.Default

5+import qualified Data.Text as T

56import Development.Shake

67import Development.IDE.LSP.Server

89import Language.Haskell.LSP.Types

10+import Development.IDE.Compat

911import Development.IDE.Core.Rules

1012import qualified Language.Haskell.LSP.Core as LSP

1113import Language.Haskell.LSP.Messages

@@ -35,3 +37,24 @@ codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..}

3537 }

3638 where

3739 g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c

40+

41+-- | Prefix to uniquely identify commands sent to the client. This

42+-- has two parts

43+--

44+-- - A representation of the process id to make sure that a client has

45+-- unique commands if it is running multiple servers, since some

46+-- clients have a global command table and get confused otherwise.

47+--

48+-- - A string to identify ghcide, to ease integration into

49+-- haskell-language-server, which routes commands to plugins based

50+-- on that.

51+makeLspCommandId :: T.Text -> IO T.Text

52+makeLspCommandId command = do

53+ pid <- getPid

54+ return $ pid <> ":ghcide:" <> command

55+

56+-- | Get the operating system process id for the running server

57+-- instance. This should be the same for the lifetime of the instance,

58+-- and different from that of any other currently running instance.

59+getPid :: IO T.Text

60+getPid = T.pack . show <$> getProcessID

src/Development/IDE/Plugin/CodeAction.hs+7−2

@@ -92,13 +92,14 @@ codeLens

9292 -> CodeLensParams

9393 -> IO (Either ResponseError (List CodeLens))

9494codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

95+ commandId <- makeLspCommandId "typesignature.add"

9596 fmap (Right . List) $ case uriToFilePath' uri of

9697 Just (toNormalizedFilePath' -> filePath) -> do

9798 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

9899 diag <- getDiagnostics ideState

99100 hDiag <- getHiddenDiagnostics ideState

100101 pure

101− [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing

102+ [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing

102103 | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag

103104 , dFile == filePath

104105 , (title, tedit) <- suggestSignature False dDiag

@@ -113,7 +114,11 @@ executeAddSignatureCommand

113114 -> ExecuteCommandParams

114115 -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

115116executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

116− | _command == "typesignature.add"

117+ -- _command is prefixed with a process ID, because certain clients

118+ -- have a global command registry, and all commands must be

119+ -- unique. And there can be more than one ghcide instance running

120+ -- at a time against the same client.

121+ | T.isSuffixOf "typesignature.add" _command

117122 , Just (List [edit]) <- _arguments

118123 , Success wedit <- fromJSON edit

119124 = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

test/exe/Main.hs+10−1

@@ -108,7 +108,7 @@ initializeResponseTests = withResource acquire release tests where

108108 , chk "NO doc link" _documentLinkProvider Nothing

109109 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

110110 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

111− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

111+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

112112 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))

113113 , chk "NO experimental" _experimental Nothing

114114 ] where

@@ -124,6 +124,15 @@ initializeResponseTests = withResource acquire release tests where

124124 chk title getActual expected =

125125 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

126126

127+ che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree

128+ che title getActual _expected = testCase title doTest

129+ where

130+ doTest = do

131+ ir <- getInitializeResponse

132+ let Just (ExecuteCommandOptions {_commands = List [command]}) = getActual $ innerCaps ir

133+ True @=? (T.isSuffixOf "typesignature.add" command)

134+

135+

127136 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

128137 innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

129138 innerCaps _ = error "this test only expects inner capabilities"