Make commands unique UUIDs so that we can run multiple servers on one…

… client

This is used when a client has more than one project
microsoft/vscode-languageserver-node#333 (comment)

haskell-ide-engine.cabal

@@ -43,6 +43,7 @@ library
                      , apply-refact
                      , async
                      , base >= 4.9 && < 5
+                     , bimap
                      , brittany
                      , bytestring
                      , cabal-helper >= 0.8.0.2
@@ -69,11 +70,13 @@ library
                      , mtl
                      , optparse-simple >= 0.0.3
                      , process
+                     , random
                      , sorted-list >= 0.2.1.0
                      , stm
                      , tagsoup
                      , text
                      , transformers
+                     , uuid
                      , vector
                      , yaml
                      , yi-rope

src/Haskell/Ide/Engine/Transport/LspStdio.hs

@@ -26,6 +26,7 @@ import           Control.Monad.STM
 import           Control.Monad.Reader
 import qualified Data.Aeson as J
 import           Data.Aeson ( (.=), (.:), (.:?), (.!=) )
+import qualified Data.Bimap as BM
 import qualified Data.ByteString.Lazy as BL
 import           Data.Char (isUpper, isAlphaNum)
 import           Data.Default
@@ -38,6 +39,7 @@ import qualified Data.Set as S
 import qualified Data.SortedList as SL
 import qualified Data.Text as T
 import           Data.Text.Encoding
+import           Data.UUID
 import qualified Data.Vector as V
 import qualified GhcModCore               as GM
 import qualified GhcMod.Monad.Types       as GM
@@ -64,6 +66,7 @@ import qualified Language.Haskell.LSP.Types            as J
 import qualified Language.Haskell.LSP.Utility          as U
 import           System.Exit
 import qualified System.Log.Logger as L
+import           System.Random
 import qualified Yi.Rope as Yi
 
 import Name
@@ -95,7 +98,15 @@ run
   -> IO Int
 run dispatcherProc cin _origDir captureFp = flip E.catches handlers $ do
 
+  -- TODO: Figure out how to test with random seeds
+  gen <- getStdGen
+  let commands = ["hare:demote", "applyrefact:applyOne"]
+      uuids :: [UUID]
+      uuids = randoms gen
+      commandUUIDs = BM.fromList (zip commands uuids)
+
   rin <- atomically newTChan :: IO (TChan ReactorInput)
+
   let dp lf = do
         cancelTVar  <- atomically $ newTVar S.empty
         wipTVar     <- atomically $ newTVar S.empty
@@ -105,7 +116,7 @@ run dispatcherProc cin _origDir captureFp = flip E.catches handlers $ do
               , wipReqsTVar    = wipTVar
               , docVersionTVar = versionTVar
               }
-        let reactorFunc = flip runReaderT lf $ reactor dispatcherEnv cin rin
+        let reactorFunc = flip runReaderT lf $ reactor dispatcherEnv cin rin commandUUIDs
 
         let errorHandler :: ErrorHandler
             errorHandler lid code e =
@@ -120,7 +131,7 @@ run dispatcherProc cin _origDir captureFp = flip E.catches handlers $ do
         return Nothing
 
   flip E.finally finalProc $ do
-    CTRL.run (getConfig, dp) (hieHandlers rin) hieOptions captureFp
+    CTRL.run (getConfig, dp) (hieHandlers rin) (hieOptions (BM.elems commandUUIDs)) captureFp
  where
   handlers  = [E.Handler ioExcept, E.Handler someExcept]
   finalProc = L.removeAllHandlers
@@ -333,8 +344,8 @@ sendErrorLog msg = reactorSend' (`Core.sendErrorLogS` msg)
 -- | The single point that all events flow through, allowing management of state
 -- to stitch replies and requests together from the two asynchronous sides: lsp
 -- server and hie dispatcher
-reactor :: forall void. DispatcherEnv -> TChan (PluginRequest R) -> TChan ReactorInput -> R void
-reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp = do
+reactor :: forall void. DispatcherEnv -> TChan (PluginRequest R) -> TChan ReactorInput -> BM.Bimap T.Text UUID -> R void
+reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp commandUUIDs = do
   let
     makeRequest req@(GReq _ _ Nothing (Just lid) _ _) = liftIO $ atomically $ do
       modifyTVar wipTVar (S.insert lid)
@@ -387,7 +398,7 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp = do
           let
             options = J.object ["documentSelector" .= J.object [ "language" .= J.String "haskell"]]
             registrationsList =
-              [ J.Registration "hare:demote" J.WorkspaceExecuteCommand (Just options)
+              [ J.Registration (toText $ commandUUIDs BM.! "hare:demote") J.WorkspaceExecuteCommand (Just options)
               ]
           let registrations = J.RegistrationParams (J.List registrationsList)
 
@@ -573,7 +584,7 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp = do
                  title :: T.Text
                  title = "Apply hint:" <> head (T.lines m)
                  -- NOTE: the cmd needs to be registered via the InitializeResponse message. See hieOptions above
-                 cmd = "applyrefact:applyOne"
+                 cmd = toText $ commandUUIDs BM.! "applyrefact:applyOne"
                  -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
                  args = J.Array $ V.singleton $ J.toJSON $ ApplyRefact.AOP doc start code
                  cmdparams = Just args
@@ -589,9 +600,11 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp = do
         ReqExecuteCommand req -> do
           liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req
           let params = req ^. J.params
-              command = params ^. J.command
+              command' = params ^. J.command
+              command = fromMaybe command' $ BM.lookupR (fromJust $ fromText command') commandUUIDs
               margs = params ^. J.arguments
 
+          liftIO $ U.logs $ "ExecuteCommand mapped command " ++ show command' ++ " to " ++ show command
 
           --liftIO $ U.logs $ "reactor:ExecuteCommandRequest:margs=" ++ show margs
           let cmdparams = case margs of
@@ -840,8 +853,8 @@ syncOptions = J.TextDocumentSyncOptions
   , J._save              = Just $ J.SaveOptions $ Just False
   }
 
-hieOptions :: Core.Options
-hieOptions =
+hieOptions :: [UUID] -> Core.Options
+hieOptions commandUUIDs =
   def { Core.textDocumentSync       = Just syncOptions
       , Core.completionProvider     = Just (J.CompletionOptions (Just True) (Just ["."]))
       -- As of 2018-05-24, vscode needs the commands to be registered
@@ -850,7 +863,7 @@ hieOptions =
       --
       -- Hopefully the end May 2018 vscode release will stabilise
       -- this, it is a major rework of the machinery anyway.
-      , Core.executeCommandProvider = Just (J.ExecuteCommandOptions (J.List ["applyrefact:applyOne","hare:demote"]))
+      , Core.executeCommandProvider = Just (J.ExecuteCommandOptions (J.List (map toText commandUUIDs)))
       }