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 diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index f2658d937..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 @@ -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 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/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 feb6d1812..43823e5ab 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 @@ -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)) } 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 7d0ddb802..67aa637f1 160000 --- a/submodules/haskell-lsp-test +++ b/submodules/haskell-lsp-test @@ -1 +1 @@ -Subproject commit 7d0ddb8022d9cccc68a99008dd55c1d39ddda3e7 +Subproject commit 67aa637f19441d51d729c008bffb9c3dfb8cea0e 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 diff --git a/test/Functional.hs b/test/Functional.hs index addf508fe..a178ba4a1 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,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" + \ No newline at end of file diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 0a1da9741..fe315c58f 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))) @@ -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