Merge pull request #629 from Bubba/command-uuids

Use UUIDs for commands

Author: alanz

.gitignore

@@ -53,3 +53,4 @@ dist-newstyle/
 dist/
 tags
 test-logs/
+.DS_Store

haskell-ide-engine.cabal

@@ -35,6 +35,7 @@ library
                        Haskell.Ide.Engine.Transport.JsonStdio
                        Haskell.Ide.Engine.Transport.LspStdio
                        Haskell.Ide.Engine.Types
+                       Haskell.Ide.Engine.Compat
   other-modules:       Paths_haskell_ide_engine
   build-depends:       Cabal >= 1.22
                      , Diff
@@ -43,6 +44,7 @@ library
                      , apply-refact
                      , async
                      , base >= 4.9 && < 5
+                     , bimap
                      , brittany
                      , bytestring
                      , cabal-helper >= 0.8.0.2
@@ -69,15 +71,20 @@ library
                      , mtl
                      , optparse-simple >= 0.0.3
                      , process
+                     , random
                      , sorted-list >= 0.2.1.0
                      , stm
                      , tagsoup
                      , text
                      , transformers
+                     , uuid
                      , vector
                      , yaml
                      , yi-rope
-
+  if os(windows)
+    build-depends:     win32
+  else
+    build-depends:     unix
   ghc-options:         -Wall -Wredundant-constraints
   if flag(pedantic)
      ghc-options:      -Werror

src/Haskell/Ide/Engine/Compat.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE CPP #-}
+module Haskell.Ide.Engine.Compat 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/Haskell/Ide/Engine/Plugin/ApplyRefact.hs

@@ -106,11 +106,11 @@ lintCmd' uri = pluginGetFile "lintCmd: " uri $ \fp -> do
               $ List (map hintToDiagnostic $ stripIgnores fs)
 
 runLintCmd :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea]
-runLintCmd fp args =
-  do (flags,classify,hint) <- liftIO $ argsSettings args
-     let myflags = flags { hseFlags = (hseFlags flags) { extensions = (EnableExtension TypeApplications:extensions (hseFlags flags))}}
-     res <- bimapExceptT parseErrorToDiagnostic id $ ExceptT $ parseModuleEx myflags fp Nothing
-     pure $ applyHints classify hint [res]
+runLintCmd fp args = do
+  (flags,classify,hint) <- liftIO $ argsSettings args
+  let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
+  res <- bimapExceptT parseErrorToDiagnostic id $ ExceptT $ parseModuleEx myflags fp Nothing
+  pure $ applyHints classify hint [res]
 
 parseErrorToDiagnostic :: Hlint.ParseError -> [Diagnostic]
 parseErrorToDiagnostic (Hlint.ParseError l msg contents) =

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
@@ -47,6 +49,7 @@ import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.Dispatcher
 import           Haskell.Ide.Engine.PluginUtils
 import           Haskell.Ide.Engine.Types
+import           Haskell.Ide.Engine.Compat
 import qualified Haskell.Ide.Engine.Plugin.HaRe        as HaRe
 import qualified Haskell.Ide.Engine.Plugin.GhcMod      as GhcMod
 import qualified Haskell.Ide.Engine.Plugin.ApplyRefact as ApplyRefact
@@ -64,6 +67,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 +99,11 @@ run
   -> IO Int
 run dispatcherProc cin _origDir captureFp = flip E.catches handlers $ do
 
+  -- TODO: Figure out how to test with random seeds
+  commandUUIDs <- getCommandUUIDs
+
   rin <- atomically newTChan :: IO (TChan ReactorInput)
+
   let dp lf = do
         cancelTVar  <- atomically $ newTVar S.empty
         wipTVar     <- atomically $ newTVar S.empty
@@ -105,7 +113,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,12 +128,17 @@ 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
   ioExcept (e :: E.IOException) = print e >> return 1
   someExcept (e :: E.SomeException) = print e >> return 1
+  getCommandUUIDs = do
+    uuid <- toText . fst . random . mkStdGen <$> getProcessID
+    let commands = ["hare:demote", "applyrefact:applyOne"]
+        uuids = map (T.append uuid . T.append ":") commands
+    return $ BM.fromList (zip commands uuids)
 
 -- ---------------------------------------------------------------------
 
@@ -135,7 +148,6 @@ type ReactorInput
 
 -- ---------------------------------------------------------------------
 
-
 -- ---------------------------------------------------------------------
 
 -- | Callback from haskell-lsp core to convert the generic message to the
@@ -333,8 +345,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 T.Text -> 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 +399,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 (commandUUIDs BM.! "hare:demote") J.WorkspaceExecuteCommand (Just options)
               ]
           let registrations = J.RegistrationParams (J.List registrationsList)
 
@@ -573,7 +585,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 = 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 +601,12 @@ 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
+              -- if this is a UUID then use the mapping for it
+              command = fromMaybe command' (BM.lookupR 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
@@ -804,7 +819,6 @@ requestDiagnostics tn cin file ver = do
     sendEmpty = publishDiagnostics maxToSend file Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])])
     maxToSend = maybe 50 maxNumberOfProblems mc
 
-  -- mc <- asks Core.config
   let sendHlint = maybe True hlintOn mc
   when sendHlint $ do
     -- get hlint diagnostics
@@ -840,8 +854,8 @@ syncOptions = J.TextDocumentSyncOptions
   , J._save              = Just $ J.SaveOptions $ Just False
   }
 
-hieOptions :: Core.Options
-hieOptions =
+hieOptions :: [T.Text] -> 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 +864,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 commandUUIDs))
       }
 
 

stack-8.2.1.yaml

@@ -39,6 +39,7 @@ extra-deps:
 - haddock-api-2.18.1
 - haddock-library-1.4.4
 - hlint-2.0.11
+- process-1.6.3.0
 - sorted-list-0.2.1.0
 - syz-0.2.0.0
 - yi-rope-0.11

stack-8.2.2.yaml

@@ -41,6 +41,7 @@ extra-deps:
 - syz-0.2.0.0
 - yi-rope-0.11
 - conduit-parse-0.2.1.0
+- process-1.6.3.0
 
 flags:
   haskell-ide-engine:

submodules/haskell-lsp-test

@@ -4,8 +4,10 @@ module Main where
 
 import Control.Monad.IO.Class
 import Control.Lens hiding (List)
+import Control.Monad
 import Data.Aeson
 import qualified Data.HashMap.Strict as H
+import Data.Maybe
 import Language.Haskell.LSP.Test
 import Language.Haskell.LSP.Types
 import qualified Language.Haskell.LSP.Types as LSP (error, id)
@@ -23,7 +25,7 @@ main = do
     cdAndDo "./test/testdata" $ hspec dispatchSpec
 
 spec :: Spec
-spec =
+spec = do
   describe "deferred responses" $ do
     it "do not affect hover requests" $ runSession hieCommand "test/testdata" $ do
       doc <- openDoc "FuncTest.hs" "haskell"
@@ -107,7 +109,7 @@ spec =
 
     it "returns hints as diagnostics" $ runSession hieCommand "test/testdata" $ do
       _ <- openDoc "FuncTest.hs" "haskell"
-      
+
       cwd <- liftIO getCurrentDirectory
       let testUri = filePathToUri $ cwd </> "test/testdata/FuncTest.hs"
 
@@ -143,3 +145,39 @@ spec =
                 ]
             )
             Nothing
+
+  describe "multi-server setup" $
+    it "doesn't have clashing commands on two servers" $ do
+      let getCommands = runSession hieCommand "test/testdata" $ do
+              rsp <- getInitializeResponse
+              let uuids = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands
+              return $ fromJust uuids
+      List uuids1 <- getCommands
+      List uuids2 <- getCommands
+      liftIO $ forM_ (zip uuids1 uuids2) (uncurry shouldNotBe)
+
+  describe "code actions" $
+    it "provide hlint suggestions" $ runSession hieCommand "test/testdata" $ do
+      doc <- openDoc "ApplyRefact2.hs" "haskell"
+      diagsRsp <- skipManyTill anyNotification notification :: Session PublishDiagnosticsNotification
+      let (List diags) = diagsRsp ^. params . diagnostics
+          reduceDiag = head diags
+
+      liftIO $ do
+        length diags `shouldBe` 2
+        reduceDiag ^. range `shouldBe` Range (Position 1 0) (Position 1 12)
+        reduceDiag ^. severity `shouldBe` Just DsInfo
+        reduceDiag ^. code `shouldBe` Just "Eta reduce"
+        reduceDiag ^. source `shouldBe` Just "hlint"
+
+      let r = Range (Position 0 0) (Position 99 99)
+          c = CodeActionContext (diagsRsp ^. params . diagnostics)
+      _ <- sendRequest TextDocumentCodeAction (CodeActionParams doc r c)
+      
+      rsp <- response :: Session CodeActionResponse
+      let (List cmds) = fromJust $ rsp ^. result
+          evaluateCmd = head cmds
+      liftIO $ do
+        length cmds `shouldBe` 1
+        evaluateCmd ^. title `shouldBe` "Apply hint:Evaluate"
+      

submodules/yi-rope

@@ -48,9 +48,9 @@ testOptions = GM.defaultOptions {
 cdAndDo :: FilePath -> IO a -> IO a
 cdAndDo path fn = do
   old <- getCurrentDirectory
-  r <- bracket (setCurrentDirectory path) (\_ -> setCurrentDirectory old)
-          $ \_ -> fn
-  return r
+  bracket (setCurrentDirectory path) (\_ -> setCurrentDirectory old)
+          $ const fn
+
 
 testCommand :: (ToJSON a, Typeable b, ToJSON b, Show b, Eq b) => IdePlugins -> IdeGhcM (IdeResult b) -> PluginId -> CommandName -> a -> (IdeResult b) -> IO ()
 testCommand testPlugins act plugin cmd arg res = do
@@ -82,7 +82,7 @@ withFileLogging logFile f = do
   when exists $ removeFile logPath
 
   Core.setupLogger (Just logPath) ["hie"] L.DEBUG
-  
+
   f
 
 -- ---------------------------------------------------------------------
@@ -103,7 +103,7 @@ files =
   ]
 
 stackYaml :: String
-stackYaml = 
+stackYaml =
 #if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)))
   "stack.yaml"
 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,2,0)))
@@ -118,7 +118,7 @@ stackYaml =
 
 -- | The command to execute the version of hie for the current compiler.
 hieCommand :: String
-hieCommand = "stack exec --stack-yaml=" ++ stackYaml ++ " hie -- --lsp"
+hieCommand = "stack exec --stack-yaml=" ++ stackYaml ++ " hie -- --lsp -d -l test-logs/functional-hie.log"
 
 -- |Choose a resolver based on the current compiler, otherwise HaRe/ghc-mod will
 -- not be able to load the files

test/Functional.hs

@@ -0,0 +1,2 @@
+main = undefined
+foo x = id x