From d0091f1003ce1d8a770230c1c5a2b1a3e0996499 Mon Sep 17 00:00:00 2001 From: Luke Date: Tue, 12 Jun 2018 17:40:20 -0400 Subject: [PATCH 1/9] 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 https://github.com/Microsoft/vscode-languageserver-node/issues/333#issuecomment-379694610 --- haskell-ide-engine.cabal | 3 ++ src/Haskell/Ide/Engine/Transport/LspStdio.hs | 33 ++++++++++++++------ 2 files changed, 26 insertions(+), 10 deletions(-) diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index f2658d937..848b7cced 100644 --- a/haskell-ide-engine.cabal +++ b/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 diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index feb6d1812..d4b1bc23b 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/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))) } From 75d51008c848fd0396eebe169231f1d8cbca674a Mon Sep 17 00:00:00 2001 From: Luke Date: Wed, 13 Jun 2018 13:38:24 -0400 Subject: [PATCH 2/9] Add .DS_Store to .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 1853102ae..2691ec885 100644 --- a/.gitignore +++ b/.gitignore @@ -53,3 +53,4 @@ dist-newstyle/ dist/ tags test-logs/ +.DS_Store \ No newline at end of file From f79c888b802417cfa1bfe7cd4a78987040453a0b Mon Sep 17 00:00:00 2001 From: Luke Date: Wed, 13 Jun 2018 13:39:11 -0400 Subject: [PATCH 3/9] Add tests for command UUIDs --- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 17 +++--- submodules/haskell-lsp-test | 2 +- test/Functional.hs | 55 +++++++++++++++++++- test/TestUtils.hs | 10 ++-- 4 files changed, 70 insertions(+), 14 deletions(-) diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index d4b1bc23b..8cdb3377f 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -99,11 +99,7 @@ run 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) + commandUUIDs <- getCommandUUIDs rin <- atomically newTChan :: IO (TChan ReactorInput) @@ -137,6 +133,12 @@ run dispatcherProc cin _origDir captureFp = flip E.catches handlers $ do finalProc = L.removeAllHandlers ioExcept (e :: E.IOException) = print e >> return 1 someExcept (e :: E.SomeException) = print e >> return 1 + getCommandUUIDs = do + gen <- getStdGen + let commands = ["hare:demote", "applyrefact:applyOne"] + uuids :: [UUID] + uuids = randoms gen + return $ BM.fromList (zip commands uuids) -- --------------------------------------------------------------------- @@ -601,7 +603,10 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp commandUUIDs = liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req let params = req ^. J.params command' = params ^. J.command - command = fromMaybe command' $ BM.lookupR (fromJust $ fromText command') commandUUIDs + -- if this is a UUID then use the mapping for it + command = fromMaybe command' $ do + uuid <- fromText command' + BM.lookupR uuid commandUUIDs margs = params ^. J.arguments liftIO $ U.logs $ "ExecuteCommand mapped command " ++ show command' ++ " to " ++ show command diff --git a/submodules/haskell-lsp-test b/submodules/haskell-lsp-test index 7d0ddb802..bf93e7448 160000 --- a/submodules/haskell-lsp-test +++ b/submodules/haskell-lsp-test @@ -1 +1 @@ -Subproject commit 7d0ddb8022d9cccc68a99008dd55c1d39ddda3e7 +Subproject commit bf93e74482200ee189ca0be09970b9a34bb1511c diff --git a/test/Functional.hs b/test/Functional.hs index addf508fe..c4ed905b1 100644 --- a/test/Functional.hs +++ b/test/Functional.hs @@ -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,45 @@ 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" + + diags <- skipManyTill loggingNotification publishDiagnosticsNotification + liftIO $ diags ^? params `shouldBe` (Just $ PublishDiagnosticsParams + { _uri = testUri + , _diagnostics = List + [ Diagnostic + (Range (Position 9 6) (Position 10 18)) + (Just DsInfo) + (Just "Redundant do") + (Just "hlint") + "Redundant do\nFound:\n do putStrLn \"hello\"\nWhy not:\n putStrLn \"hello\"\n" + Nothing + ] + } + ) + + let args' = H.fromList [("pos", toJSON (Position 7 0)), ("file", toJSON testUri)] + args = List [Object args'] + _ <- sendRequest WorkspaceExecuteCommand (ExecuteCommandParams "hare:demote" (Just args)) + + executeRsp <- skipManyTill anyNotification response :: Session ExecuteCommandResponse + liftIO $ executeRsp ^. result `shouldBe` Just (Object H.empty) + + editReq <- request :: Session ApplyWorkspaceEditRequest + liftIO $ editReq ^. params . edit `shouldBe` WorkspaceEdit + ( Just + $ H.singleton testUri + $ List + [ TextEdit (Range (Position 6 0) (Position 7 6)) + " where\n bb = 5" + ] + ) + Nothing + 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 +183,14 @@ spec = ] ) Nothing + + describe "multi-server setup" $ + it "doesn't have clashing commands on two servers" $ do + List uuids1 <- getCommands + List uuids2 <- getCommands + liftIO $ mapM_ print [uuids1, uuids2] + liftIO $ forM_ (zip uuids1 uuids2) (uncurry shouldNotBe) + where getCommands = runSession hieCommand "test/testdata" $ do + rsp <- getInitializeResponse + let uuids = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands + return $ fromJust uuids diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 0a1da9741..05f20e1b6 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -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))) From 557697ade345d7bf894da0ea2b2e38db20777f86 Mon Sep 17 00:00:00 2001 From: Luke Date: Wed, 13 Jun 2018 15:35:06 -0400 Subject: [PATCH 4/9] Add code action functional tests --- haskell-ide-engine.cabal | 2 +- src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs | 10 +++--- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 1 - test/Functional.hs | 37 ++++++++++++++++---- test/TestUtils.hs | 2 +- test/testdata/ApplyRefact2.hs | 2 ++ 6 files changed, 40 insertions(+), 14 deletions(-) create mode 100644 test/testdata/ApplyRefact2.hs diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 848b7cced..8b3f58917 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -61,7 +61,7 @@ library , haskell-lsp >= 0.3.0 , haskell-src-exts , hie-plugin-api - , hlint >= 2.0.11 + , hlint >= 2.1.5 , hoogle >= 5.0.13 , hslogger , lens >= 4.15.2 diff --git a/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs b/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs index 5e32b9434..7263a3e35 100644 --- a/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs +++ b/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) = diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 8cdb3377f..8af3c4ef7 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -822,7 +822,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 diff --git a/test/Functional.hs b/test/Functional.hs index c4ed905b1..5c1dca4d1 100644 --- a/test/Functional.hs +++ b/test/Functional.hs @@ -185,12 +185,37 @@ spec = do Nothing describe "multi-server setup" $ - it "doesn't have clashing commands on two servers" $ do - List uuids1 <- getCommands - List uuids2 <- getCommands - liftIO $ mapM_ print [uuids1, uuids2] - liftIO $ forM_ (zip uuids1 uuids2) (uncurry shouldNotBe) - where getCommands = runSession hieCommand "test/testdata" $ do + 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" + \ No newline at end of file diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 05f20e1b6..fe315c58f 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -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 diff --git a/test/testdata/ApplyRefact2.hs b/test/testdata/ApplyRefact2.hs new file mode 100644 index 000000000..d97afdc88 --- /dev/null +++ b/test/testdata/ApplyRefact2.hs @@ -0,0 +1,2 @@ +main = undefined +foo x = id x \ No newline at end of file From 557720eb74c42c33c7226414118b68fb5824489f Mon Sep 17 00:00:00 2001 From: Luke Date: Wed, 13 Jun 2018 16:18:42 -0400 Subject: [PATCH 5/9] Remove duplicate test --- test/Functional.hs | 38 -------------------------------------- 1 file changed, 38 deletions(-) diff --git a/test/Functional.hs b/test/Functional.hs index 5c1dca4d1..a178ba4a1 100644 --- a/test/Functional.hs +++ b/test/Functional.hs @@ -135,44 +135,6 @@ spec = do executeRsp <- skipManyTill anyNotification response :: Session ExecuteCommandResponse liftIO $ executeRsp ^. result `shouldBe` Just (Object H.empty) - editReq <- request :: Session ApplyWorkspaceEditRequest - liftIO $ editReq ^. params . edit `shouldBe` WorkspaceEdit - ( Just - $ H.singleton testUri - $ List - [ TextEdit (Range (Position 6 0) (Position 7 6)) - " where\n bb = 5" - ] - ) - Nothing - 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" - - diags <- skipManyTill loggingNotification publishDiagnosticsNotification - liftIO $ diags ^? params `shouldBe` (Just $ PublishDiagnosticsParams - { _uri = testUri - , _diagnostics = List - [ Diagnostic - (Range (Position 9 6) (Position 10 18)) - (Just DsInfo) - (Just "Redundant do") - (Just "hlint") - "Redundant do\nFound:\n do putStrLn \"hello\"\nWhy not:\n putStrLn \"hello\"\n" - Nothing - ] - } - ) - - let args' = H.fromList [("pos", toJSON (Position 7 0)), ("file", toJSON testUri)] - args = List [Object args'] - _ <- sendRequest WorkspaceExecuteCommand (ExecuteCommandParams "hare:demote" (Just args)) - - executeRsp <- skipManyTill anyNotification response :: Session ExecuteCommandResponse - liftIO $ executeRsp ^. result `shouldBe` Just (Object H.empty) - editReq <- request :: Session ApplyWorkspaceEditRequest liftIO $ editReq ^. params . edit `shouldBe` WorkspaceEdit ( Just From bbe43302729816bbd390eda3167cf889cc68e2f3 Mon Sep 17 00:00:00 2001 From: Luke Date: Wed, 13 Jun 2018 16:27:45 -0400 Subject: [PATCH 6/9] Undo hlint version bump --- haskell-ide-engine.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 8b3f58917..848b7cced 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -61,7 +61,7 @@ library , haskell-lsp >= 0.3.0 , haskell-src-exts , hie-plugin-api - , hlint >= 2.1.5 + , hlint >= 2.0.11 , hoogle >= 5.0.13 , hslogger , lens >= 4.15.2 From 49ece1212ce6b193bf8621922714345ab85626be Mon Sep 17 00:00:00 2001 From: Luke Date: Wed, 13 Jun 2018 17:17:16 -0400 Subject: [PATCH 7/9] Only use one UUID per session --- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 23 +++++++++----------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 8af3c4ef7..9d8da84d9 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -134,10 +134,10 @@ run dispatcherProc cin _origDir captureFp = flip E.catches handlers $ do ioExcept (e :: E.IOException) = print e >> return 1 someExcept (e :: E.SomeException) = print e >> return 1 getCommandUUIDs = do - gen <- getStdGen - let commands = ["hare:demote", "applyrefact:applyOne"] - uuids :: [UUID] - uuids = randoms gen + uuid <- toText <$> randomIO + let commands :: [T.Text] + commands = ["hare:demote", "applyrefact:applyOne"] + uuids = map (T.append uuid . T.append ":") commands return $ BM.fromList (zip commands uuids) -- --------------------------------------------------------------------- @@ -148,7 +148,6 @@ type ReactorInput -- --------------------------------------------------------------------- - -- --------------------------------------------------------------------- -- | Callback from haskell-lsp core to convert the generic message to the @@ -346,7 +345,7 @@ 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 -> BM.Bimap T.Text UUID -> R void +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 @@ -400,7 +399,7 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp commandUUIDs = let options = J.object ["documentSelector" .= J.object [ "language" .= J.String "haskell"]] registrationsList = - [ J.Registration (toText $ commandUUIDs BM.! "hare:demote") J.WorkspaceExecuteCommand (Just options) + [ J.Registration (commandUUIDs BM.! "hare:demote") J.WorkspaceExecuteCommand (Just options) ] let registrations = J.RegistrationParams (J.List registrationsList) @@ -586,7 +585,7 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp commandUUIDs = 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 = toText $ commandUUIDs BM.! "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 @@ -604,9 +603,7 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp commandUUIDs = let params = req ^. J.params command' = params ^. J.command -- if this is a UUID then use the mapping for it - command = fromMaybe command' $ do - uuid <- fromText command' - BM.lookupR uuid commandUUIDs + command = fromMaybe command' (BM.lookupR command' commandUUIDs) margs = params ^. J.arguments liftIO $ U.logs $ "ExecuteCommand mapped command " ++ show command' ++ " to " ++ show command @@ -857,7 +854,7 @@ syncOptions = J.TextDocumentSyncOptions , J._save = Just $ J.SaveOptions $ Just False } -hieOptions :: [UUID] -> Core.Options +hieOptions :: [T.Text] -> Core.Options hieOptions commandUUIDs = def { Core.textDocumentSync = Just syncOptions , Core.completionProvider = Just (J.CompletionOptions (Just True) (Just ["."])) @@ -867,7 +864,7 @@ hieOptions commandUUIDs = -- -- 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 (map toText commandUUIDs))) + , Core.executeCommandProvider = Just (J.ExecuteCommandOptions (J.List commandUUIDs)) } From bee0bb472120e2fbc70489d9e085cf7c57b4fb85 Mon Sep 17 00:00:00 2001 From: Luke Date: Thu, 14 Jun 2018 01:45:47 -0400 Subject: [PATCH 8/9] Use processID to generate UUID --- haskell-ide-engine.cabal | 6 +++++- src/Haskell/Ide/Engine/Compat.hs | 16 ++++++++++++++++ src/Haskell/Ide/Engine/Transport/LspStdio.hs | 6 +++--- submodules/yi-rope | 1 + 4 files changed, 25 insertions(+), 4 deletions(-) create mode 100644 src/Haskell/Ide/Engine/Compat.hs create mode 160000 submodules/yi-rope diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 848b7cced..47abd9268 100644 --- a/haskell-ide-engine.cabal +++ b/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 @@ -80,7 +81,10 @@ library , 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 diff --git a/src/Haskell/Ide/Engine/Compat.hs b/src/Haskell/Ide/Engine/Compat.hs new file mode 100644 index 000000000..cc909d3b8 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 9d8da84d9..43823e5ab 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -49,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 @@ -134,9 +135,8 @@ run dispatcherProc cin _origDir captureFp = flip E.catches handlers $ do ioExcept (e :: E.IOException) = print e >> return 1 someExcept (e :: E.SomeException) = print e >> return 1 getCommandUUIDs = do - uuid <- toText <$> randomIO - let commands :: [T.Text] - commands = ["hare:demote", "applyrefact:applyOne"] + 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) diff --git a/submodules/yi-rope b/submodules/yi-rope new file mode 160000 index 000000000..7867909f4 --- /dev/null +++ b/submodules/yi-rope @@ -0,0 +1 @@ +Subproject commit 7867909f4f20952be051fd4252cca5bbfc80cf41 From 356e750850fea8fd559b963cc1073241e57822ac Mon Sep 17 00:00:00 2001 From: Luke Date: Thu, 14 Jun 2018 11:00:16 -0400 Subject: [PATCH 9/9] Update haskell-lsp-test --- stack-8.2.1.yaml | 1 + stack-8.2.2.yaml | 1 + submodules/haskell-lsp-test | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/stack-8.2.1.yaml b/stack-8.2.1.yaml index 95a520b03..86a5f82f5 100644 --- a/stack-8.2.1.yaml +++ b/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 diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml index 23378acf5..c46ad6697 100644 --- a/stack-8.2.2.yaml +++ b/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: diff --git a/submodules/haskell-lsp-test b/submodules/haskell-lsp-test index bf93e7448..67aa637f1 160000 --- a/submodules/haskell-lsp-test +++ b/submodules/haskell-lsp-test @@ -1 +1 @@ -Subproject commit bf93e74482200ee189ca0be09970b9a34bb1511c +Subproject commit 67aa637f19441d51d729c008bffb9c3dfb8cea0e