diff --git a/cabal.project b/cabal.project index 7194a02f25..ab760fde64 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,6 @@ packages: ./plugins/hls-retrie-plugin ./plugins/hls-haddock-comments-plugin ./plugins/hls-splice-plugin - tests: true package * @@ -25,7 +24,7 @@ package ghcide write-ghc-environment-files: never -index-state: 2021-02-08T19:11:03Z +index-state: 2021-02-15T19:11:03Z allow-newer: active:base, diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 40699c9b75..1829f648ff 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -98,6 +98,7 @@ - default: false - {name: [-Wno-missing-signatures, -Wno-orphans, -Wno-overlapping-patterns, -Wno-incomplete-patterns, -Wno-missing-fields, -Wno-unused-matches]} - {name: [-Wno-dodgy-imports,-Wno-incomplete-uni-patterns], within: [Main, Development.IDE.GHC.Compat, Development.Benchmark.Rules]} + - {name: [-Wno-deprecations, -Wno-unticked-promoted-constructors], within: [Main, Experiments]} # - modules: # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' # - {name: Control.Arrow, within: []} # Certain modules are banned entirely diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index 966320acc4..f0581e1d49 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide/bench/lib/Experiments.hs @@ -1,7 +1,9 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} module Experiments ( Bench(..) @@ -23,16 +25,16 @@ import Control.Applicative.Combinators (skipManyTill) import Control.Exception.Safe (IOException, handleAny, try) import Control.Monad.Extra import Control.Monad.IO.Class -import Data.Aeson (Value(Null)) +import Data.Aeson (Value(Null), toJSON) import Data.List import Data.Maybe import qualified Data.Text as T import Data.Version import Development.IDE.Plugin.Test import Experiments.Types -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Capabilities import Numeric.Natural import Options.Applicative import System.Directory @@ -79,13 +81,13 @@ experiments = isJust <$> getHover doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} -> - not . null <$> getDefinitions doc (fromJust identifierP), + either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "getDefinition after edit" $ \docs -> do forM_ docs $ \DocumentPositions{..} -> changeDoc doc [charEdit stringLiteralP] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> - not . null <$> getDefinitions doc (fromJust identifierP), + either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc, @@ -148,7 +150,7 @@ experiments = ( \docs -> do Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml" liftIO $ appendFile hieYaml "##\n" - sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] forM_ docs $ \DocumentPositions{..} -> changeDoc doc [charEdit stringLiteralP] @@ -163,7 +165,7 @@ experiments = (\docs -> do Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml" liftIO $ appendFile hieYaml "##\n" - sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP) ) @@ -359,7 +361,9 @@ waitForProgressDone :: Session () waitForProgressDone = loop where loop = do - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -393,8 +397,9 @@ runBench runSess b = handleAny (\e -> print e >> return badRun) else do output (showDuration t) -- Wait for the delayed actions to finish - waitId <- sendRequest (CustomClientMethod "test") WaitForShakeQueue - (td, resp) <- duration $ skipManyTill anyMessage $ responseForId waitId + let m = SCustomMethod "test" + waitId <- sendRequest m (toJSON WaitForShakeQueue) + (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId case resp of ResponseMessage{_result=Right Null} -> do loop (userWaits+t) (delayedWork+td) (n -1) @@ -562,7 +567,7 @@ searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do checkDefinitions pos = do defs <- getDefinitions doc pos case defs of - [Location uri _] -> return $ uri /= _uri + (InL [Location uri _]) -> return $ uri /= _uri _ -> return False checkCompletions pos = not . null <$> getCompletions doc pos diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 1898824bc0..bcd93bca25 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -112,8 +112,8 @@ main = do , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling , optTesting = IdeTesting argsTesting , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} - , optCheckParents = checkParents config - , optCheckProject = checkProject config + , optCheckParents = pure $ checkParents config + , optCheckProject = pure $ checkProject config } } diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 38c1c56ff4..29f5813970 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -46,6 +46,8 @@ library data-default, deepseq, directory, + dependent-map, + dependent-sum, dlist, extra >= 1.7.4, fuzzy, @@ -55,12 +57,12 @@ library Glob, haddock-library >= 1.8, hashable, - haskell-lsp-types == 0.23.*, - haskell-lsp == 0.23.*, hie-compat, hls-plugin-api >= 0.7.1, lens, hiedb == 0.3.0.1, + lsp-types == 1.1.*, + lsp == 1.1.*, mtl, network-uri, parallel, @@ -88,7 +90,9 @@ library vector, bytestring-encoding, opentelemetry >=0.6.1, - heapsize ==0.3.* + heapsize ==0.3.*, + unliftio, + unliftio-core if flag(ghc-lib) build-depends: ghc-lib >= 8.8, @@ -131,6 +135,9 @@ library TupleSections TypeApplications ViewPatterns + DataKinds + TypeOperators + KindSignatures hs-source-dirs: src @@ -160,7 +167,6 @@ library Development.IDE.LSP.HoverDefinition Development.IDE.LSP.LanguageServer Development.IDE.LSP.Outline - Development.IDE.LSP.Protocol Development.IDE.LSP.Server Development.IDE.Spans.Common Development.IDE.Spans.Documentation @@ -205,9 +211,8 @@ library Development.IDE.LSP.Notifications Development.IDE.Plugin.CodeAction.PositionIndexed Development.IDE.Plugin.Completions.Logic - Development.IDE.Plugin.HLS.Formatter Development.IDE.Types.Action - ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns + ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors executable ghcide-test-preprocessor default-language: Haskell2010 @@ -285,8 +290,8 @@ executable ghcide safe-exceptions, ghc, hashable, - haskell-lsp, - haskell-lsp-types, + lsp, + lsp-types, heapsize, hie-bios, hls-plugin-api, @@ -346,12 +351,12 @@ test-suite ghcide-tests ghcide, ghc-typelits-knownnat, haddock-library, - haskell-lsp, - haskell-lsp-types, + lsp, + lsp-types, hls-plugin-api, network-uri, lens, - lsp-test >= 0.12.0.0 && < 0.13, + lsp-test == 0.13.0.0, optparse-applicative, process, QuickCheck, @@ -372,7 +377,7 @@ test-suite ghcide-tests record-hasfield hs-source-dirs: test/cabal test/exe test/src bench/lib include-dirs: include - ghc-options: -threaded -Wall -Wno-name-shadowing -O0 + ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors main-is: Main.hs other-modules: Development.IDE.Test @@ -408,7 +413,7 @@ executable ghcide-bench extra, filepath, ghcide, - lsp-test >= 0.12.0.0 && < 0.13, + lsp-test == 0.13.0.0, optparse-applicative, process, safe-exceptions, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index f9e3f40125..b15adf694e 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -60,9 +60,8 @@ import qualified HIE.Bios as HieBios import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types import Hie.Implicit.Cradle (loadImplicitHieCradle) -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types +import Language.LSP.Server +import Language.LSP.Types import System.Directory import qualified System.Directory.Extra as IO import System.FilePath @@ -208,12 +207,11 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) return $ do - extras@ShakeExtras{logger, eventer, restartShakeSession, - withIndefiniteProgress, ideNc, knownTargetsVar + extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv } <- getShakeExtras IdeOptions{ optTesting = IdeTesting optTesting - , optCheckProject = checkProject + , optCheckProject = getCheckProject , optCustomDynFlags , optExtensions } <- getIdeOptions @@ -358,6 +356,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do restartShakeSession [] -- Typecheck all files in the project on startup + checkProject <- getCheckProject unless (null cs || not checkProject) $ do cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs) void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do @@ -376,17 +375,19 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do lfp <- flip makeRelative cfp <$> getCurrentDirectory logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) - when (isNothing hieYaml) $ eventer $ notifyUserImplicitCradle lfp + when (isNothing hieYaml) $ mRunLspT lspEnv $ + sendNotification SWindowShowMessage $ notifyUserImplicitCradle lfp cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml - when optTesting $ eventer $ notifyCradleLoaded lfp + when optTesting $ mRunLspT lspEnv $ + sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp) -- Display a user friendly progress message here: They probably don't know what a cradle is let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfp <> ")" - eopts <- withIndefiniteProgress progMsg NotCancellable $ - cradleToOptsAndLibDir cradle cfp + eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $ + cradleToOptsAndLibDir cradle cfp logDebug logger $ T.pack ("Session loading result: " <> show eopts) case eopts of @@ -796,24 +797,12 @@ getCacheDirsDefault prefix opts = do cacheDir :: String cacheDir = "ghcide" -notifyUserImplicitCradle:: FilePath -> FromServerMessage -notifyUserImplicitCradle fp = - NotShowMessage $ - NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtInfo $ - "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " - <> T.pack fp <> - ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n" <> - "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." - -notifyCradleLoaded :: FilePath -> FromServerMessage -notifyCradleLoaded fp = - NotCustomServer $ - NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $ - toJSON fp - -cradleLoadedMethod :: T.Text -cradleLoadedMethod = "ghcide/cradle/loaded" - +notifyUserImplicitCradle:: FilePath -> ShowMessageParams +notifyUserImplicitCradle fp =ShowMessageParams MtWarning $ + "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " + <> T.pack fp <> + ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n"<> + "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ---------------------------------------------------------------------------------------------------- data PackageSetupException diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index b34fff2c95..2ce4934cf3 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -48,7 +48,7 @@ import Outputable hiding ((<>)) import HieDb -import Language.Haskell.LSP.Types (DiagnosticTag(..)) +import Language.LSP.Types (DiagnosticTag(..)) import LoadIface (loadModuleInterface) import DriverPhases @@ -106,8 +106,8 @@ import HeaderInfo import Maybes (orElse) import qualified Data.HashMap.Strict as HashMap -import qualified Language.Haskell.LSP.Messages as LSP -import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Server as LSP import Control.Concurrent.STM hiding (orElse) import Control.Concurrent.Extra import Data.Functor @@ -521,9 +521,9 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do -- If the hash in the pending list doesn't match the current hash, then skip Just pendingHash -> pendingHash /= hash unless newerScheduled $ do - tok <- pre + pre addRefsFromLoaded db targetPath (RealFile $ fromNormalizedFilePath srcPath) hash hf - post tok + post where mod_location = ms_location mod_summary targetPath = Compat.ml_hie_file mod_location @@ -531,46 +531,42 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do -- Get a progress token to report progress and update it for the current file pre = do - tok <- modifyVar indexProgressToken $ \case - x@(Just tok) -> pure (x, tok) + tok <- modifyVar indexProgressToken $ fmap dupe . \case + x@(Just _) -> pure x -- Create a token if we don't already have one Nothing -> do - u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> newUnique - lspId <- getLspId se - eventer se $ LSP.ReqWorkDoneProgressCreate $ - LSP.fmServerWorkDoneProgressCreateRequest lspId $ - LSP.WorkDoneProgressCreateParams { _token = u } - eventer se $ LSP.NotWorkDoneProgressBegin $ - LSP.fmServerWorkDoneProgressBeginNotification - LSP.ProgressParams - { _token = u - , _value = LSP.WorkDoneProgressBeginParams - { _title = "Indexing references from:" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } + case lspEnv se of + Nothing -> pure Nothing + Just env -> LSP.runLspT env $ do + u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + -- TODO: Wait for the progress create response to use the token + _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) + LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $ + LSP.Begin $ LSP.WorkDoneProgressBeginParams + { _title = "Indexing references from:" + , _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing } - pure (Just u, u) + pure (Just u) + (!done, !remaining) <- atomically $ do done <- readTVar indexCompleted remaining <- HashMap.size <$> readTVar indexPending pure (done, remaining) + let progress = " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..." - eventer se $ LSP.NotWorkDoneProgressReport $ - LSP.fmServerWorkDoneProgressReportNotification - LSP.ProgressParams - { _token = tok - , _value = LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Just $ T.pack (show srcPath) <> progress - , _percentage = Nothing - } - } - pure tok + + whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $ + LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ + LSP.Report $ LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Just $ T.pack (show srcPath) <> progress + , _percentage = Nothing + } -- Report the progress once we are done indexing this file - post tok = do + post = do mdone <- atomically $ do -- Remove current element from pending pending <- stateTVar indexPending $ @@ -579,23 +575,20 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do -- If we are done, report and reset completed whenMaybe (HashMap.null pending) $ swapTVar indexCompleted 0 - when (coerce $ ideTesting se) $ - eventer se $ LSP.NotCustomServer $ - LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath srcPath) - case mdone of - Nothing -> pure () - Just done -> - modifyVar_ indexProgressToken $ \_ -> do - eventer se $ LSP.NotWorkDoneProgressEnd $ - LSP.fmServerWorkDoneProgressEndNotification - LSP.ProgressParams - { _token = tok - , _value = LSP.WorkDoneProgressEndParams - { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files" - } - } - -- We are done with the current indexing cycle, so destroy the token - pure Nothing + whenJust (lspEnv se) $ \env -> LSP.runLspT env $ + when (coerce $ ideTesting se) $ + LSP.sendNotification (LSP.SCustomMethod "ghcide/reference/ready") $ + toJSON $ fromNormalizedFilePath srcPath + whenJust mdone $ \done -> + modifyVar_ indexProgressToken $ \tok -> do + whenJust (lspEnv se) $ \env -> LSP.runLspT env $ + whenJust tok $ \tok -> + LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ + LSP.End $ LSP.WorkDoneProgressEndParams + { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files" + } + -- We are done with the current indexing cycle, so destroy the token + pure Nothing writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 5ddb39d32f..54763a71ad 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -26,7 +26,9 @@ import Development.IDE.Types.Options import Development.Shake import Development.Shake.Classes import GHC.Generics -import Language.Haskell.LSP.Types.Capabilities +import Language.LSP.Server hiding (getVirtualFile) +import Language.LSP.Types +import Language.LSP.Types.Capabilities import qualified System.Directory as Dir import qualified System.FilePath.Glob as Glob @@ -148,8 +150,18 @@ watchedGlobs opts = [ "**/*." ++ extIncBoot | ext <- optExtensions opts, extIncB -- | Installs the 'getFileExists' rules. -- Provides a fast implementation if client supports dynamic watched files. -- Creates a global state as a side effect in that case. -fileExistsRules :: ClientCapabilities -> VFSHandle -> Rules () -fileExistsRules ClientCapabilities{_workspace} vfs = do +fileExistsRules :: Maybe (LanguageContextEnv c) -> VFSHandle -> Rules () +fileExistsRules lspEnv vfs = do + supportsWatchedFiles <- case lspEnv of + Just lspEnv' -> liftIO $ runLspT lspEnv' $ do + ClientCapabilities {_workspace} <- getClientCapabilities + case () of + _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace + , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles + , Just True <- _dynamicRegistration + -> pure True + _ -> pure False + Nothing -> pure False -- Create the global always, although it should only be used if we have fast rules. -- But there's a chance someone will send unexpected notifications anyway, -- e.g. https://github.com/haskell/ghcide/issues/599 @@ -159,12 +171,9 @@ fileExistsRules ClientCapabilities{_workspace} vfs = do opts <- liftIO $ getIdeOptionsIO extras let globs = watchedGlobs opts - case () of - _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace - , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles - , Just True <- _dynamicRegistration - -> fileExistsRulesFast globs vfs - | otherwise -> fileExistsRulesSlow vfs + if supportsWatchedFiles + then fileExistsRulesFast globs vfs + else fileExistsRulesSlow vfs -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. fileExistsRulesFast :: [String] -> VFSHandle -> Rules () diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 94333714e7..3ec9069331 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -59,8 +59,9 @@ import qualified System.Posix.Error as Posix import qualified Development.IDE.Types.Logger as L -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.VFS +import Language.LSP.Server hiding (getVirtualFile) +import qualified Language.LSP.Server as LSP +import Language.LSP.VFS makeVFSHandle :: IO VFSHandle makeVFSHandle = do @@ -77,9 +78,9 @@ makeVFSHandle = do Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs } -makeLSPVFSHandle :: LspFuncs c -> VFSHandle -makeLSPVFSHandle lspFuncs = VFSHandle - { getVirtualFile = getVirtualFileFunc lspFuncs +makeLSPVFSHandle :: LanguageContextEnv c -> VFSHandle +makeLSPVFSHandle lspEnv = VFSHandle + { getVirtualFile = runLspT lspEnv . LSP.getVirtualFile , setVirtualFileContents = Nothing } @@ -200,7 +201,8 @@ setFileModified :: IdeState -> IO () setFileModified state saved nfp = do ideOptions <- getIdeOptionsIO $ shakeExtras state - let checkParents = case optCheckParents ideOptions of + doCheckParents <- optCheckParents ideOptions + let checkParents = case doCheckParents of AlwaysCheck -> True CheckOnSaveAndClose -> saved _ -> False diff --git a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs index a9bfe088a1..6a396ca81d 100644 --- a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs +++ b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs @@ -21,7 +21,7 @@ import Data.Aeson.Types (Value) import Development.IDE.Core.Shake import Development.IDE.Types.Location import Development.Shake -import Language.Haskell.LSP.Types +import Language.LSP.Types import System.FilePath (isRelative) -- | Lsp client relevant configuration details diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index c046ae513f..5b04d720b9 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -104,7 +104,8 @@ kick = do -- Update the exports map for non FOIs -- We can skip this if checkProject is True, assuming they never change under our feet. - IdeOptions{ optCheckProject = checkProject } <- getIdeOptions + IdeOptions{ optCheckProject = doCheckProject } <- getIdeOptions + checkProject <- liftIO doCheckProject ifaces <- if checkProject then return Nothing else runMaybeT $ do deps <- MaybeT $ sequence <$> uses GetDependencies files hiResults <- lift $ uses GetModIface (nubOrd $ foldMap transitiveModuleDeps deps) diff --git a/ghcide/src/Development/IDE/Core/PositionMapping.hs b/ghcide/src/Development/IDE/Core/PositionMapping.hs index adea5dc9b3..e4604ad24b 100644 --- a/ghcide/src/Development/IDE/Core/PositionMapping.hs +++ b/ghcide/src/Development/IDE/Core/PositionMapping.hs @@ -24,7 +24,7 @@ module Development.IDE.Core.PositionMapping import Control.Monad import qualified Data.Text as T -import Language.Haskell.LSP.Types +import Language.LSP.Types import Data.List import Data.Algorithm.Diff import Data.Bifunctor diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 2f7f817f8b..6efdc1ac9a 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -38,7 +38,7 @@ import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Import.FindImports (ArtifactsLocation) import Data.ByteString (ByteString) -import Language.Haskell.LSP.Types (NormalizedFilePath) +import Language.LSP.Types (NormalizedFilePath) import TcRnMonad (TcGblEnv) import qualified Data.ByteString.Char8 as BS import Development.IDE.Types.Options (IdeGhcSession) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index c7f67c2b29..d66bd412a5 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -98,10 +98,9 @@ import Development.Shake hiding (Diagnostic) import Development.IDE.Core.RuleTypes import qualified Data.ByteString.Char8 as BS import Development.IDE.Core.PositionMapping -import Language.Haskell.LSP.Types (DocumentHighlight (..), SymbolInformation(..)) -import Language.Haskell.LSP.VFS -import qualified Language.Haskell.LSP.Messages as LSP -import qualified Language.Haskell.LSP.Types as LSP +import Language.LSP.Types (DocumentHighlight (..), SymbolInformation(..), SMethod(SCustomMethod)) +import qualified Language.LSP.Server as LSP +import Language.LSP.VFS import qualified GHC.LanguageExtensions as LangExt import HscTypes hiding (TargetModule, TargetFile) @@ -595,9 +594,9 @@ getHieAstRuleDefinition f hsc tmr = do isFoi <- use_ IsFileOfInterest f diagsWrite <- case isFoi of IsFOI Modified{firstOpen = False} -> do - when (coerce $ ideTesting se) $ - liftIO $ eventer se $ LSP.NotCustomServer $ - LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath f) + when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ + LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + toJSON $ fromNormalizedFilePath f pure [] _ | Just asts <- masts -> do source <- getSourceFileSource f @@ -827,9 +826,9 @@ getModIfaceFromDiskAndIndexRule = defineEarlyCutoff $ \GetModIfaceFromDiskAndInd | hash == HieDb.modInfoHash (HieDb.hieModInfo row) , hie_loc == HieDb.hieModuleHieFile row -> do -- All good, the db has indexed the file - when (coerce $ ideTesting se) $ - liftIO $ eventer se $ LSP.NotCustomServer $ - LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath f) + when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ + LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + toJSON $ fromNormalizedFilePath f -- Not in db, must re-index _ -> do ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $ diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index f2f19fc319..c105285158 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -25,9 +25,9 @@ import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest import Development.IDE.Types.Logger as Logger import Development.Shake -import qualified Language.Haskell.LSP.Messages as LSP -import qualified Language.Haskell.LSP.Types as LSP -import qualified Language.Haskell.LSP.Types.Capabilities as LSP +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as LSP +import Ide.Plugin.Config import Development.IDE.Core.Shake import Control.Monad @@ -37,12 +37,8 @@ import Control.Monad -- Exposed API -- | Initialise the Compiler Service. -initialise :: LSP.ClientCapabilities - -> Rules () - -> IO LSP.LspId - -> (LSP.FromServerMessage -> IO ()) - -> WithProgressFunc - -> WithIndefiniteProgressFunc +initialise :: Rules () + -> Maybe (LSP.LanguageContextEnv Config) -> Logger -> Debouncer LSP.NormalizedUri -> IdeOptions @@ -50,13 +46,9 @@ initialise :: LSP.ClientCapabilities -> HieDb -> IndexQueue -> IO IdeState -initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer options vfs hiedb hiedbChan = +initialise mainRule lspEnv logger debouncer options vfs hiedb hiedbChan = shakeOpen - getLspId - toDiags - wProg - wIndefProg - caps + lspEnv logger debouncer (optShakeProfiling options) @@ -70,7 +62,7 @@ initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer opti addIdeGlobal $ GlobalIdeOptions options fileStoreRules vfs ofInterestRules - fileExistsRules caps vfs + fileExistsRules lspEnv vfs mainRule writeProfile :: IdeState -> FilePath -> IO () diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4ec054b60b..a3985e3600 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PolyKinds #-} -- | A Shake implementation of the compiler service. -- @@ -39,6 +40,7 @@ module Development.IDE.Core.Shake( BadDependency(..), define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, getDiagnostics, + mRunLspT, mRunLspTCallback, getHiddenDiagnostics, IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction, getIdeGlobalExtras, @@ -48,7 +50,6 @@ module Development.IDE.Core.Shake( garbageCollect, knownTargets, setPriority, - sendEvent, ideLogger, actionLogger, FileVersion(..), @@ -97,7 +98,7 @@ import Development.IDE.Types.Logger hiding (Priority) import Development.IDE.Types.KnownTargets import Development.IDE.Types.Shake import qualified Development.IDE.Types.Logger as Logger -import Language.Haskell.LSP.Diagnostics +import Language.LSP.Diagnostics import qualified Data.SortedList as SL import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports @@ -107,19 +108,17 @@ import Control.Concurrent.Async import Control.Concurrent.Extra import Control.Concurrent.STM import Control.DeepSeq -import Control.Exception.Extra import System.Time.Extra import Data.Typeable -import qualified Language.Haskell.LSP.Core as LSP -import qualified Language.Haskell.LSP.Messages as LSP -import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as LSP import System.FilePath hiding (makeRelative) import qualified Development.Shake as Shake import Control.Monad.Extra import Data.Time import GHC.Generics import System.IO.Unsafe -import Language.Haskell.LSP.Types +import Language.LSP.Types import qualified Control.Monad.STM as STM import Control.Monad.IO.Class import Control.Monad.Reader @@ -127,17 +126,21 @@ import Control.Monad.Trans.Maybe import Data.Traversable import Data.Hashable import Development.IDE.Core.Tracing -import Language.Haskell.LSP.VFS +import Language.LSP.VFS import Data.IORef import NameCache import UniqSupply import PrelInfo -import Language.Haskell.LSP.Types.Capabilities +import Language.LSP.Types.Capabilities import OpenTelemetry.Eventlog import GHC.Fingerprint import HieDb.Types +import Control.Exception.Extra hiding (bracket_) +import UnliftIO.Exception (bracket_) +import Ide.Plugin.Config +import Data.Default -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -156,7 +159,8 @@ type IndexQueue = TQueue (HieDb -> IO ()) -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras - {eventer :: LSP.FromServerMessage -> IO () + { --eventer :: LSP.FromServerMessage -> IO () + lspEnv :: Maybe (LSP.LanguageContextEnv Config) ,debouncer :: Debouncer NormalizedUri ,logger :: Logger ,globals :: Var (HMap.HashMap TypeRep Dynamic) @@ -174,15 +178,10 @@ data ShakeExtras = ShakeExtras ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int) -- ^ How many rules are running for each file ,progressUpdate :: ProgressEvent -> IO () - -- ^ The generator for unique Lsp identifiers ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,session :: MVar ShakeSession -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component - ,withProgress :: WithProgressFunc - -- ^ Report progress about some long running operation (on top of the progress shown by 'lspShakeProgress') - ,withIndefiniteProgress :: WithIndefiniteProgressFunc - -- ^ Same as 'withProgress', but for processes that do not report the percentage complete ,restartShakeSession :: [DelayedAction ()] -> IO () ,ideNc :: IORef NameCache -- | A mapping of module name to known target (or candidate targets, if missing) @@ -197,12 +196,11 @@ data ShakeExtras = ShakeExtras , persistentKeys :: Var (HMap.HashMap Key GetStalePersistent) -- ^ Registery for functions that compute/get "stale" results for the rule -- (possibly from disk) - , getLspId :: IO LspId , vfs :: VFSHandle } type WithProgressFunc = forall a. - T.Text -> LSP.ProgressCancellable -> ((LSP.Progress -> IO ()) -> IO a) -> IO a + T.Text -> LSP.ProgressCancellable -> ((LSP.ProgressAmount -> IO ()) -> IO a) -> IO a type WithIndefiniteProgressFunc = forall a. T.Text -> LSP.ProgressCancellable -> IO a -> IO a @@ -452,11 +450,7 @@ seqValue v b = case v of Failed _ -> b -- | Open a 'IdeState', should be shut using 'shakeShut'. -shakeOpen :: IO LSP.LspId - -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler - -> WithProgressFunc - -> WithIndefiniteProgressFunc - -> ClientCapabilities +shakeOpen :: Maybe (LSP.LanguageContextEnv Config) -> Logger -> Debouncer NormalizedUri -> Maybe FilePath @@ -468,8 +462,9 @@ shakeOpen :: IO LSP.LspId -> ShakeOptions -> Rules () -> IO IdeState -shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilities logger debouncer +shakeOpen lspEnv logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo + inProgress <- newVar HMap.empty us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) @@ -497,6 +492,8 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilitie actionQueue <- newQueue + let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv + pure (ShakeExtras{..}, cancel progressAsync) (shakeDbM, shakeClose) <- shakeOpenDatabase @@ -526,7 +523,7 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilitie case v of KickCompleted -> STM.retry KickStarted -> return () - asyncReporter <- async lspShakeProgress + asyncReporter <- async $ mRunLspT lspEnv lspShakeProgress progressLoopReporting asyncReporter progressLoopReporting asyncReporter = do atomically $ do @@ -537,54 +534,55 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilitie cancel asyncReporter progressLoopIdle + lspShakeProgress :: LSP.LspM config () lspShakeProgress = do -- first sleep a bit, so we only show progress messages if it's going to take -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) - unless testing $ sleep 0.1 - lspId <- getLspId - u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique - eventer $ LSP.ReqWorkDoneProgressCreate $ - LSP.fmServerWorkDoneProgressCreateRequest lspId $ - LSP.WorkDoneProgressCreateParams { _token = u } - bracket_ (start u) (stop u) (loop u Nothing) + liftIO $ unless testing $ sleep 0.1 + u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + + void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate + LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ()) + + bracket_ + (start u) + (stop u) + (loop u Nothing) where - start id = eventer $ LSP.NotWorkDoneProgressBegin $ - LSP.fmServerWorkDoneProgressBeginNotification + start id = LSP.sendNotification LSP.SProgress $ LSP.ProgressParams { _token = id - , _value = WorkDoneProgressBeginParams + , _value = LSP.Begin $ WorkDoneProgressBeginParams { _title = "Processing" , _cancellable = Nothing , _message = Nothing , _percentage = Nothing } } - stop id = eventer $ LSP.NotWorkDoneProgressEnd $ - LSP.fmServerWorkDoneProgressEndNotification + stop id = LSP.sendNotification LSP.SProgress LSP.ProgressParams { _token = id - , _value = WorkDoneProgressEndParams + , _value = LSP.End WorkDoneProgressEndParams { _message = Nothing } } sample = 0.1 loop id prev = do - sleep sample - current <- readVar inProgress + liftIO $ sleep sample + current <- liftIO $ readVar inProgress let done = length $ filter (== 0) $ HMap.elems current let todo = HMap.size current let next = Just $ T.pack $ show done <> "/" <> show todo when (next /= prev) $ - eventer $ LSP.NotWorkDoneProgressReport $ - LSP.fmServerWorkDoneProgressReportNotification - LSP.ProgressParams - { _token = id - , _value = LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = next - , _percentage = Nothing - } - } + LSP.sendNotification LSP.SProgress $ + LSP.ProgressParams + { _token = id + , _value = LSP.Report $ LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = next + , _percentage = Nothing + } + } loop id next shakeProfile :: IdeState -> FilePath -> IO () @@ -648,9 +646,8 @@ shakeRestart IdeState{..} acts = notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () notifyTestingLogMessage extras msg = do (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras - let notif = LSP.NotLogMessage $ LSP.NotificationMessage "2.0" LSP.WindowLogMessage - $ LSP.LogMessageParams LSP.MtLog msg - when isTestMode $ eventer extras notif + let notif = LSP.LogMessageParams LSP.MtLog msg + when isTestMode $ mRunLspT (lspEnv extras) $ LSP.sendNotification LSP.SWindowLogMessage notif -- | Enqueue an action in the existing 'ShakeSession'. @@ -742,6 +739,18 @@ instantiateDelayedAction (DelayedAction _ s p a) = do d' = DelayedAction (Just u) s p a' return (b, d') +mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () +mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f +mRunLspT Nothing _ = pure () + +mRunLspTCallback :: Monad m + => Maybe (LSP.LanguageContextEnv c) + -> (LSP.LspT c m a -> LSP.LspT c m a) + -> m a + -> m a +mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) +mRunLspTCallback Nothing _ g = g + getDiagnostics :: IdeState -> IO [FileDiagnostic] getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do val <- readVar diagnostics @@ -1027,7 +1036,7 @@ updateFileDiagnostics :: MonadIO m -> ShakeExtras -> [(ShowDiagnostic,Diagnostic)] -- ^ current results -> m () -updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do +updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do modTime <- (currentValue . fst =<<) <$> getValues state GetModificationTime fp let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current uri = filePathToUri' fp @@ -1048,26 +1057,19 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published registerEvent debouncer delay uri $ do mask_ $ modifyVar_ publishedDiagnostics $ \published -> do let lastPublish = HMap.lookupDefault [] uri published - when (lastPublish /= newDiags) $ - eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags + when (lastPublish /= newDiags) $ case lspEnv of + Nothing -> -- Print an LSP event. + logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags + Just env -> LSP.runLspT env $ + LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ + LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags) pure $! HMap.insert uri newDiags published -publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage -publishDiagnosticsNotification uri diags = - LSP.NotPublishDiagnostics $ - LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams uri (List diags) - newtype Priority = Priority Double setPriority :: Priority -> Action () setPriority (Priority p) = reschedule p -sendEvent :: LSP.FromServerMessage -> Action () -sendEvent e = do - ShakeExtras{eventer} <- getShakeExtras - liftIO $ eventer e - ideLogger :: IdeState -> Logger ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index b61aa99eb1..9cb407c813 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} #include "ghc-api-version.h" module Development.IDE.Core.Tracing ( otTracedHandler @@ -28,11 +27,11 @@ import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), GhcSessionIO (GhcSessionIO)) import Development.IDE.Types.Logger (logInfo, Logger, logDebug) import Development.IDE.Types.Shake (ValueWithDiagnostics(..), Key (..), Value, Values) -import Development.Shake (Action, actionBracket, liftIO) +import Development.Shake (Action, actionBracket) import Ide.PluginUtils (installSigUsr1Handler) import Foreign.Storable (Storable (sizeOf)) import HeapSize (recursiveSize, runHeapsize) -import Language.Haskell.LSP.Types (NormalizedFilePath, +import Language.LSP.Types (NormalizedFilePath, fromNormalizedFilePath) import Numeric.Natural (Natural) import OpenTelemetry.Eventlog (SpanInFlight, Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan, @@ -42,20 +41,24 @@ import Data.ByteString (ByteString) import Data.Text.Encoding (encodeUtf8) import Ide.Types (PluginId (..)) import Development.IDE.Types.Location (Uri (..)) +import Control.Monad.IO.Unlift -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. otTracedHandler - :: String -- ^ Message type + :: MonadUnliftIO m + => String -- ^ Message type -> String -- ^ Message label - -> (SpanInFlight -> IO a) - -> IO a + -> (SpanInFlight -> m a) + -> m a otTracedHandler requestType label act = let !name = if null label then requestType else requestType <> ":" <> show label -- Add an event so all requests can be quickly seen in the viewer without searching - in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act sp) + in do + runInIO <- askRunInIO + liftIO $ withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> runInIO (act sp)) otSetUri :: SpanInFlight -> Uri -> IO () otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t) @@ -81,14 +84,15 @@ otTracedAction key file success act = actionBracket return res) #if MIN_GHC_API_VERSION(8,8,0) -otTracedProvider :: PluginId -> ByteString -> IO a -> IO a +otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a #else -otTracedProvider :: PluginId -> String -> IO a -> IO a +otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a #endif -otTracedProvider (PluginId pluginName) provider act = - withSpan (provider <> " provider") $ \sp -> do +otTracedProvider (PluginId pluginName) provider act = do + runInIO <- askRunInIO + liftIO $ withSpan (provider <> " provider") $ \sp -> do setTag sp "plugin" (encodeUtf8 pluginName) - act + runInIO act startTelemetry :: Bool -> Logger -> Var Values -> IO () startTelemetry allTheTime logger stateRef = do diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index fe34a3b28c..a8e7a7638f 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -55,8 +55,8 @@ import Generics.SYB import Ide.PluginUtils import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities) +import Language.LSP.Types +import Language.LSP.Types.Capabilities (ClientCapabilities) import Outputable (Outputable, ppr, showSDoc) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) import Parser (parseIdentifier) diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 7ff1bc8e4d..202ed784e8 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE ExplicitNamespaces #-} module Development.IDE.GHC.Warnings(withWarnings) where @@ -12,7 +13,7 @@ import qualified Data.Text as T import Development.IDE.Types.Diagnostics import Development.IDE.GHC.Error -import Language.Haskell.LSP.Types (NumberOrString (StringValue)) +import Language.LSP.Types (type (|?)(..)) -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some @@ -36,7 +37,7 @@ withWarnings diagSource action = do return (reverse $ concat warns, res) attachReason :: WarnReason -> Diagnostic -> Diagnostic -attachReason wr d = d{_code = StringValue <$> showReason wr} +attachReason wr d = d{_code = InR <$> showReason wr} where showReason = \case NoReason -> Nothing diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 8a09b5a3f3..9843a11da8 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -1,42 +1,39 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 - +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} -- | Display information on hover. module Development.IDE.LSP.HoverDefinition - ( setHandlersDefinition - , setHandlersTypeDefinition - , setHandlersDocHighlight - , setHandlersReferences - , setHandlersWsSymbols + ( setIdeHandlers -- * For haskell-language-server , hover , gotoDefinition , gotoTypeDefinition ) where +import Control.Monad.IO.Class import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.LSP.Server import Development.IDE.Types.Location import Development.IDE.Types.Logger -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.Types import qualified Data.Text as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams) -hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) -gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams) -documentHighlight :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (List DocumentHighlight)) -gotoDefinition = request "Definition" getDefinition (MultiLoc []) MultiLoc -gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (MultiLoc []) MultiLoc +gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition)) +hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover)) +gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition)) +documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight)) +gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List) hover = request "Hover" getAtPoint Nothing foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List -references :: IdeState -> ReferenceParams -> IO (Either ResponseError (List Location)) -references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _) = +references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location)) +references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $ case uriToFilePath' uri of Just path -> do let filePath = toNormalizedFilePath' path @@ -46,8 +43,8 @@ references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _) = Right . List <$> (runAction "references" ide $ refsAtPoint filePath pos) Nothing -> pure $ Left $ ResponseError InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing -wsSymbols :: IdeState -> WorkspaceSymbolParams -> IO (Either ResponseError (List SymbolInformation)) -wsSymbols ide (WorkspaceSymbolParams query _) = do +wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError (List SymbolInformation)) +wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do logDebug (ideLogger ide) $ "Workspace symbols request: " <> query runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . maybe (List []) List <$> workspaceSymbols query @@ -55,18 +52,17 @@ foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover foundHover (mbRange, contents) = Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange -setHandlersDefinition, setHandlersTypeDefinition, setHandlersDocHighlight, - setHandlersReferences, setHandlersWsSymbols :: PartialHandlers c -setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition} -setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x -> - return x {LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition} -setHandlersDocHighlight = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.documentHighlightHandler = withResponse RspDocumentHighlights $ const documentHighlight} -setHandlersReferences = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.referencesHandler = withResponse RspFindReferences $ const references} -setHandlersWsSymbols = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.workspaceSymbolHandler = withResponse RspWorkspaceSymbols $ const wsSymbols} +setIdeHandlers :: LSP.Handlers (ServerM c) +setIdeHandlers = mconcat + [ requestHandler STextDocumentDefinition $ \ide DefinitionParams{..} -> + gotoDefinition ide TextDocumentPositionParams{..} + , requestHandler STextDocumentTypeDefinition $ \ide TypeDefinitionParams{..} -> + gotoTypeDefinition ide TextDocumentPositionParams{..} + , requestHandler STextDocumentDocumentHighlight $ \ide DocumentHighlightParams{..} -> + documentHighlight ide TextDocumentPositionParams{..} + , requestHandler STextDocumentReferences references + , requestHandler SWorkspaceSymbol wsSymbols + ] -- | Respond to and log a hover or go-to-definition request request @@ -76,8 +72,8 @@ request -> (a -> b) -> IdeState -> TextDocumentPositionParams - -> IO (Either ResponseError b) -request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do + -> LSP.LspM c (Either ResponseError b) +request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do mbResult <- case uriToFilePath' uri of Just path -> logAndRunRequest label getResults ide pos path Nothing -> pure Nothing diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index a4972f6873..bc5780e1b1 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -1,8 +1,10 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. + -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync -- This version removes the daml: handling @@ -10,46 +12,42 @@ module Development.IDE.LSP.LanguageServer ( runLanguageServer ) where -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities +import Language.LSP.Types import Development.IDE.LSP.Server import qualified Development.IDE.GHC.Util as Ghcide -import qualified Language.Haskell.LSP.Control as LSP -import qualified Language.Haskell.LSP.Core as LSP -import Control.Concurrent.Chan -import Control.Concurrent.Extra -import Control.Concurrent.Async +import qualified Language.LSP.Server as LSP +import Control.Concurrent.Extra (newBarrier, signalBarrier, waitBarrier) import Control.Concurrent.STM -import Control.Exception.Safe -import Data.Default import Data.Maybe +import Data.Aeson (Value) import qualified Data.Set as Set import qualified Data.Text as T import GHC.IO.Handle (hDuplicate) import System.IO import Control.Monad.Extra +import UnliftIO.Exception +import UnliftIO.Async +import UnliftIO.Concurrent +import Control.Monad.IO.Class +import Control.Monad.Reader +import Ide.Types (traceWithSpan) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake import Development.IDE.LSP.HoverDefinition import Development.IDE.LSP.Notifications -import Development.IDE.LSP.Outline import Development.IDE.Types.Logger import Development.IDE.Core.FileStore import Development.IDE.Core.Tracing -import Language.Haskell.LSP.Core (LspFuncs(..)) -import Language.Haskell.LSP.Messages runLanguageServer :: forall config. (Show config) => LSP.Options - -> PartialHandlers config - -> (InitializeRequest -> Either T.Text config) - -> (DidChangeConfigurationNotification -> Either T.Text config) - -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities - -> WithProgressFunc -> WithIndefiniteProgressFunc -> IO (Maybe config) -> Maybe FilePath -> IO IdeState) + -> (IdeState -> Value -> IO (Either T.Text config)) + -> LSP.Handlers (ServerM config) + -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> IO IdeState) -> IO () -runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do +runLanguageServer options onConfigurationChange userHandlers getIdeState = do -- Move stdout to another file descriptor and duplicate stderr -- to stdout. This guards against stray prints from corrupting the JSON-RPC -- message stream. @@ -64,10 +62,6 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat -- the language server tests without the redirection. putStr " " >> hFlush stdout - -- Send everything over a channel, since you need to wait until after initialise before - -- LspFuncs is available - clientMsgChan :: Chan (Message config) <- newChan - -- These barriers are signaled when the threads reading from these chans exit. -- This should not happen but if it does, we will make sure that the whole server -- dies and can be restarted instead of losing threads silently. @@ -80,16 +74,6 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat -- The set of requests that have been cancelled and are also in pendingRequests cancelledRequests <- newTVarIO Set.empty - let withResponse wrap f = Just $ \r@RequestMessage{_id, _method} -> do - atomically $ modifyTVar pendingRequests (Set.insert _id) - writeChan clientMsgChan $ Response r wrap f - let withNotification old f = Just $ \r@NotificationMessage{_method} -> - writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r)) - let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id, _method} -> do - atomically $ modifyTVar pendingRequests (Set.insert _id) - writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f - let withInitialize f = Just $ \r -> - writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x) let cancelRequest reqId = atomically $ do queued <- readTVar pendingRequests -- We want to avoid that the list of cancelled requests @@ -105,160 +89,106 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat let waitForCancel reqId = atomically $ do cancelled <- readTVar cancelledRequests unless (reqId `Set.member` cancelled) retry - let PartialHandlers parts = - initializeRequestHandler <> - setHandlersIgnore <> -- least important - setHandlersDefinition <> setHandlersTypeDefinition <> - setHandlersDocHighlight <> setHandlersReferences <> setHandlersWsSymbols <> - setHandlersOutline <> - userHandlers <> - setHandlersNotifications <> -- absolutely critical, join them with user notifications - cancelHandler cancelRequest <> - exitHandler exit - -- Cancel requests are special since they need to be handled - -- out of order to be useful. Existing handlers are run afterwards. - handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def - let initializeCallbacks = LSP.InitializeCallbacks - { LSP.onInitialConfiguration = onInitialConfig - , LSP.onConfigurationChange = onConfigChange - , LSP.onStartup = handleInit exit clearReqId waitForCancel clientMsgChan + let ideHandlers = mconcat + [ setIdeHandlers + , userHandlers + , setHandlersNotifications -- absolutely critical, join them with user notifications + ] + + -- Send everything over a channel, since you need to wait until after initialise before + -- LspFuncs is available + clientMsgChan :: Chan ReactorMessage <- newChan + + let asyncHandlers = mconcat + [ ideHandlers + , cancelHandler cancelRequest + , exitHandler exit + ] + -- Cancel requests are special since they need to be handled + -- out of order to be useful. Existing handlers are run afterwards. + + + let serverDefinition = LSP.ServerDefinition + { LSP.onConfigurationChange = \v -> do + (_chan, ide) <- ask + liftIO $ onConfigurationChange ide v + , LSP.doInitialize = handleInit exit clearReqId waitForCancel clientMsgChan + , LSP.staticHandlers = asyncHandlers + , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO + , LSP.options = modifyOptions options } void $ waitAnyCancel =<< traverse async - [ void $ LSP.runWithHandles + [ void $ LSP.runServerWithHandles stdin newStdout - initializeCallbacks - handlers - (modifyOptions options) - Nothing + serverDefinition , void $ waitBarrier clientMsgBarrier ] - where - handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err) - handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do - ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities - withProgress withIndefiniteProgress config rootPath + where + handleInit + :: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage + -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) + handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do + liftIO $ traceWithSpan sp params + let root = LSP.resRootPath env + ide <- liftIO $ getIdeState env (makeLSPVFSHandle env) root + + let initConfig = parseConfiguration params + liftIO $ logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig + liftIO $ registerIdeConfiguration (shakeExtras ide) initConfig _ <- flip forkFinally (const exitClientMsg) $ forever $ do msg <- readChan clientMsgChan -- We dispatch notifications synchronously and requests asynchronously -- This is to ensure that all file edits and config changes are applied before a request is handled case msg of - Notification x@NotificationMessage{_params, _method} act -> - otTracedHandler "Notification" (show _method) $ \sp -> do - traceWithSpan sp _params - catch (act lspFuncs ide _params) $ \(e :: SomeException) -> - logError (ideLogger ide) $ T.pack $ - "Unexpected exception on notification, please report!\n" ++ - "Message: " ++ show x ++ "\n" ++ - "Exception: " ++ show e - Response x@RequestMessage{_id, _method, _params} wrap act -> void $ async $ - otTracedHandler "Request" (show _method) $ \sp -> do - traceWithSpan sp _params - checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ - \case - Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e) - Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r) - ResponseAndRequest x@RequestMessage{_id, _method, _params} wrap wrapNewReq act -> void $ async $ - otTracedHandler "Request" (show _method) $ \sp -> do - traceWithSpan sp _params - checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ - \(res, newReq) -> do - case res of - Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e) - Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r) - whenJust newReq $ \(rm, newReqParams) -> do - reqId <- getNextReqId - sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams - InitialParams x@RequestMessage{_id, _method, _params} act -> - otTracedHandler "Initialize" (show _method) $ \sp -> do - traceWithSpan sp _params - catch (act lspFuncs ide _params) $ \(e :: SomeException) -> - logError (ideLogger ide) $ T.pack $ - "Unexpected exception on InitializeRequest handler, please report!\n" ++ - "Message: " ++ show x ++ "\n" ++ - "Exception: " ++ show e - pure Nothing - - checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k = - flip finally (clearReqId _id) $ + ReactorNotification act -> do + catch act $ \(e :: SomeException) -> + logError (ideLogger ide) $ T.pack $ + "Unexpected exception on notification, please report!\n" ++ + "Exception: " ++ show e + ReactorRequest _id act k -> void $ async $ + checkCancelled ide clearReqId waitForCancel _id act k + pure $ Right (env,ide) + + checkCancelled + :: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId + -> IO () -> (ResponseError -> IO ()) -> IO () + checkCancelled ide clearReqId waitForCancel _id act k = + flip finally (liftIO $ clearReqId _id) $ catch (do -- We could optimize this by first checking if the id -- is in the cancelled set. However, this is unlikely to be a -- bottleneck and the additional check might hide -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params + cancelOrRes <- race (liftIO $ waitForCancel _id) act case cancelOrRes of Left () -> do - logDebug (ideLogger ide) $ T.pack $ - "Cancelled request " <> show _id - sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left - $ ResponseError RequestCancelled "" Nothing - Right res -> k res + liftIO $ logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id + k $ ResponseError RequestCancelled "" Nothing + Right res -> pure res ) $ \(e :: SomeException) -> do - logError (ideLogger ide) $ T.pack $ + liftIO $ logError (ideLogger ide) $ T.pack $ "Unexpected exception on request, please report!\n" ++ - "Message: " ++ show msg ++ "\n" ++ "Exception: " ++ show e - sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left - $ ResponseError InternalError (T.pack $ show e) Nothing + k $ ResponseError InternalError (T.pack $ show e) Nothing -initializeRequestHandler :: PartialHandlers config -initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{ - LSP.initializeRequestHandler = withInitialize initHandler - } - -initHandler - :: LSP.LspFuncs c - -> IdeState - -> InitializeParams - -> IO () -initHandler _ ide params = do - let initConfig = parseConfiguration params - logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig - registerIdeConfiguration (shakeExtras ide) initConfig --- | Things that get sent to us, but we don't deal with. --- Set them to avoid a warning in VS Code output. -setHandlersIgnore :: PartialHandlers config -setHandlersIgnore = PartialHandlers $ \_ x -> return x - {LSP.responseHandler = none - } - where none = Just $ const $ return () +cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) +cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} -> + liftIO $ cancelRequest (SomeLspId _id) -cancelHandler :: (LspId -> IO ()) -> PartialHandlers config -cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x - {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do - cancelRequest _id - whenJust (LSP.cancelNotificationHandler x) ($ msg) - } - -exitHandler :: IO () -> PartialHandlers c -exitHandler exit = PartialHandlers $ \_ x -> return x - {LSP.exitNotificationHandler = Just $ const exit} - --- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety --- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer) -data Message c - = forall m req resp . (Show m, Show req, HasTracing req) => - Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) - | -- | Used for cases in which we need to send not only a response, - -- but also an additional request to the client. - -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request. - forall m rm req resp newReqParams newReqBody. (Show m, Show rm, Show req, HasTracing req) => - ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) - | forall m req . (Show m, Show req, HasTracing req) => - Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ()) - | -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler. - InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ()) +exitHandler :: IO () -> LSP.Handlers (ServerM c) +exitHandler exit = LSP.notificationHandler SExit (const $ liftIO exit) modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS } where - tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing} + tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ InR $ SaveOptions Nothing} origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing + diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index c464d0210b..451702dbdd 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -3,27 +3,27 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} module Development.IDE.LSP.Notifications ( setHandlersNotifications ) where -import Development.IDE.LSP.Server -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as LSP -import qualified Language.Haskell.LSP.Messages as LSP -import qualified Language.Haskell.LSP.Types.Capabilities as LSP +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Capabilities as LSP import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Service +import Development.IDE.LSP.Server import Development.IDE.Core.Shake import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options import Control.Monad.Extra -import qualified Data.Aeson as A import Data.Foldable as F import Data.Maybe import qualified Data.HashMap.Strict as M @@ -34,115 +34,111 @@ import Development.IDE.Core.FileStore (setSomethingModified, setFile import Development.IDE.Core.FileExists (modifyFileExists, watchedGlobs) import Development.IDE.Core.OfInterest import Ide.Plugin.Config (CheckParents(CheckOnClose)) +import Control.Monad.IO.Class whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' -setHandlersNotifications :: PartialHandlers c -setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x - {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $ - \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do - updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) - whenUriFile _uri $ \file -> do - -- We don't know if the file actually exists, or if the contents match those on disk - -- For example, vscode restores previously unsaved contents on open - modifyFilesOfInterest ide (M.insert file Modified{firstOpen=True}) - setFileModified ide False file - logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri - - ,LSP.didChangeTextDocumentNotificationHandler = withNotification (LSP.didChangeTextDocumentNotificationHandler x) $ - \_ ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> do - updatePositionMapping ide identifier changes - whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.insert file Modified{firstOpen=False}) - setFileModified ide False file - logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri - - ,LSP.didSaveTextDocumentNotificationHandler = withNotification (LSP.didSaveTextDocumentNotificationHandler x) $ - \_ ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri}) -> do - whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.insert file OnDisk) - setFileModified ide True file - logInfo (ideLogger ide) $ "Saved text document: " <> getUri _uri - - ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $ - \_ ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do - whenUriFile _uri $ \file -> do - modifyFilesOfInterest ide (M.delete file) - -- Refresh all the files that depended on this - IdeOptions{optCheckParents} <- getIdeOptionsIO $ shakeExtras ide - when (optCheckParents >= CheckOnClose) $ typecheckParents ide file - logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri - ,LSP.didChangeWatchedFilesNotificationHandler = withNotification (LSP.didChangeWatchedFilesNotificationHandler x) $ - \_ ide (DidChangeWatchedFilesParams fileEvents) -> do - -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and - -- what we do with them - let events = - mapMaybe - (\(FileEvent uri ev) -> - (, ev /= FcDeleted) . toNormalizedFilePath' - <$> LSP.uriToFilePath uri - ) - ( F.toList fileEvents ) - let msg = Text.pack $ show events - logDebug (ideLogger ide) $ "Files created or deleted: " <> msg - modifyFileExists ide events - setSomethingModified ide - - ,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $ - \_ ide (DidChangeWorkspaceFoldersParams events) -> do - let add = S.union - substract = flip S.difference - modifyWorkspaceFolders ide - $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) - . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) - - ,LSP.didChangeConfigurationParamsHandler = withNotification (LSP.didChangeConfigurationParamsHandler x) $ - \_ ide (DidChangeConfigurationParams cfg) -> do - let msg = Text.pack $ show cfg - logInfo (ideLogger ide) $ "Configuration changed: " <> msg - modifyClientSettings ide (const $ Just cfg) - setSomethingModified ide - - -- Initialized handler, good time to dynamically register capabilities - ,LSP.initializedHandler = withNotification (LSP.initializedHandler x) $ \lsp@LSP.LspFuncs{..} ide _ -> do - let watchSupported = case () of - _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities - , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace - , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles - , Just True <- _dynamicRegistration - -> True - | otherwise -> False - - if watchSupported - then registerWatcher lsp ide - else logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling" - - } - where - registerWatcher LSP.LspFuncs{..} ide = do - lspId <- getNextReqId - opts <- getIdeOptionsIO $ shakeExtras ide - let - req = RequestMessage "2.0" lspId ClientRegisterCapability regParams - regParams = RegistrationParams (List [registration]) - -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't). - -- We could also use something like a random UUID, as some other servers do, but this works for - -- our purposes. - registration = Registration "globalFileWatches" - WorkspaceDidChangeWatchedFiles - (Just (A.toJSON regOptions)) - regOptions = - DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers } - -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind - watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True} - -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is - -- The patterns will be something like "**/.hs", i.e. "any number of directory segments, - -- followed by a file with an extension 'hs'. - watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind } - -- We use multiple watchers instead of one using '{}' because lsp-test doesn't - -- support that: https://github.com/bubba/lsp-test/issues/77 - watchers = [ watcher glob | glob <- watchedGlobs opts ] - - sendFunc $ LSP.ReqRegisterCapability req +setHandlersNotifications :: LSP.Handlers (ServerM c) +setHandlersNotifications = mconcat + [ notificationHandler LSP.STextDocumentDidOpen $ + \ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do + updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) + whenUriFile _uri $ \file -> do + -- We don't know if the file actually exists, or if the contents match those on disk + -- For example, vscode restores previously unsaved contents on open + modifyFilesOfInterest ide (M.insert file Modified{firstOpen=True}) + setFileModified ide False file + logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri + + , notificationHandler LSP.STextDocumentDidChange $ + \ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do + updatePositionMapping ide identifier changes + whenUriFile _uri $ \file -> do + modifyFilesOfInterest ide (M.insert file Modified{firstOpen=False}) + setFileModified ide False file + logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri + + , notificationHandler LSP.STextDocumentDidSave $ + \ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do + whenUriFile _uri $ \file -> do + modifyFilesOfInterest ide (M.insert file OnDisk) + setFileModified ide True file + logInfo (ideLogger ide) $ "Saved text document: " <> getUri _uri + + , notificationHandler LSP.STextDocumentDidClose $ + \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do + whenUriFile _uri $ \file -> do + modifyFilesOfInterest ide (M.delete file) + -- Refresh all the files that depended on this + checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide) + when (checkParents >= CheckOnClose) $ typecheckParents ide file + logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri + + , notificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ + \ide (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do + -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and + -- what we do with them + let events = + mapMaybe + (\(FileEvent uri ev) -> + (, ev /= FcDeleted) . toNormalizedFilePath' + <$> LSP.uriToFilePath uri + ) + ( F.toList fileEvents ) + let msg = Text.pack $ show events + logInfo (ideLogger ide) $ "Files created or deleted: " <> msg + modifyFileExists ide events + setSomethingModified ide + + , notificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $ + \ide (DidChangeWorkspaceFoldersParams events) -> liftIO $ do + let add = S.union + substract = flip S.difference + modifyWorkspaceFolders ide + $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) + . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) + + , notificationHandler LSP.SWorkspaceDidChangeConfiguration $ + \ide (DidChangeConfigurationParams cfg) -> liftIO $ do + let msg = Text.pack $ show cfg + logInfo (ideLogger ide) $ "Configuration changed: " <> msg + modifyClientSettings ide (const $ Just cfg) + setSomethingModified ide + + , notificationHandler LSP.SInitialized $ \ide _ -> do + clientCapabilities <- LSP.getClientCapabilities + let watchSupported = case () of + _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities + , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace + , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles + , Just True <- _dynamicRegistration + -> True + | otherwise -> False + if watchSupported + then do + opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide + let + regParams = RegistrationParams (List [SomeRegistration registration]) + -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't). + -- We could also use something like a random UUID, as some other servers do, but this works for + -- our purposes. + registration = Registration "globalFileWatches" + SWorkspaceDidChangeWatchedFiles + regOptions + regOptions = + DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers } + -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind + watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True} + -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is + -- The patterns will be something like "**/.hs", i.e. "any number of directory segments, + -- followed by a file with an extension 'hs'. + watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind } + -- We use multiple watchers instead of one using '{}' because lsp-test doesn't + -- support that: https://github.com/bubba/lsp-test/issues/77 + watchers = [ watcher (Text.pack glob) | glob <- watchedGlobs opts ] + + void $ LSP.sendRequest SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response + else liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling" + ] diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 6e8e38596f..a968dca983 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-} #include "ghc-api-version.h" module Development.IDE.LSP.Outline - ( setHandlersOutline - -- * For haskell-language-server - , moduleOutline + ( moduleOutline ) where -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types +import Language.LSP.Types +import Language.LSP.Server (LspM) +import Control.Monad.IO.Class import Data.Functor import Data.Generics import Data.Maybe @@ -23,26 +24,20 @@ import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error ( realSrcSpanToRange ) -import Development.IDE.LSP.Server import Development.IDE.Types.Location import Outputable ( Outputable , ppr , showSDocUnsafe ) -setHandlersOutline :: PartialHandlers c -setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x - { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline - } - moduleOutline - :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult) -moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri } - = case uriToFilePath uri of + :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) +moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } + = liftIO $ case uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) pure $ Right $ case mb_decls of - Nothing -> DSDocumentSymbols (List []) + Nothing -> InL (List []) Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls @@ -64,10 +59,10 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI } ] in - DSDocumentSymbols (List allSymbols) + InL (List allSymbols) - Nothing -> pure $ Right $ DSDocumentSymbols (List []) + Nothing -> pure $ Right $ InL (List []) documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) diff --git a/ghcide/src/Development/IDE/LSP/Protocol.hs b/ghcide/src/Development/IDE/LSP/Protocol.hs deleted file mode 100644 index 1c1870e2c4..0000000000 --- a/ghcide/src/Development/IDE/LSP/Protocol.hs +++ /dev/null @@ -1,23 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE PatternSynonyms #-} - -module Development.IDE.LSP.Protocol - ( pattern EventFileDiagnostics - ) where - -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Location -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types - ----------------------------------------------------------------------------------------------------- --- Pretty printing ----------------------------------------------------------------------------------------------------- - --- | Pattern synonym to make it a bit more convenient to match on diagnostics --- in things like damlc test. -pattern EventFileDiagnostics :: FilePath -> [Diagnostic] -> FromServerMessage -pattern EventFileDiagnostics fp diags <- - NotPublishDiagnostics - (NotificationMessage _ _ (PublishDiagnosticsParams (uriToFilePath' -> Just fp) (List diags))) diff --git a/ghcide/src/Development/IDE/LSP/Server.hs b/ghcide/src/Development/IDE/LSP/Server.hs index a129267975..5c95b7be0c 100644 --- a/ghcide/src/Development/IDE/LSP/Server.hs +++ b/ghcide/src/Development/IDE/LSP/Server.hs @@ -5,81 +5,57 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} module Development.IDE.LSP.Server - ( WithMessage(..) - , PartialHandlers(..) - , HasTracing(..) - ,setUriAnd) where + ( ReactorMessage(..) + , ReactorChan + , ServerM + , requestHandler + , notificationHandler + ) where + +import Language.LSP.Server (LspM, Handlers) +import Language.LSP.Types +import qualified Language.LSP.Server as LSP +import Development.IDE.Core.Shake +import UnliftIO.Chan +import Control.Monad.Reader +import Ide.Types (HasTracing, traceWithSpan) +import Development.IDE.Core.Tracing + +data ReactorMessage + = ReactorNotification (IO ()) + | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ()) + +type ReactorChan = Chan ReactorMessage +type ServerM c = ReaderT (ReactorChan, IdeState) (LspM c) + +requestHandler + :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) => + SMethod m + -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m))) + -> Handlers (ServerM c) +requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do + st@(chan,ide) <- ask + env <- LSP.getLspEnv + let resp' = flip runReaderT st . resp + trace x = otTracedHandler "Request" (show _method) $ \sp -> do + traceWithSpan sp _params + x + writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) + +notificationHandler + :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) => + SMethod m + -> (IdeState -> MessageParams m -> LspM c ()) + -> Handlers (ServerM c) +notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do + (chan,ide) <- ask + env <- LSP.getLspEnv + let trace x = otTracedHandler "Notification" (show _method) $ \sp -> do + traceWithSpan sp _params + x + writeChan chan $ ReactorNotification (trace $ LSP.runLspT env $ k ide _params) -import Control.Lens ((^.)) -import Data.Default - -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Core as LSP -import qualified Language.Haskell.LSP.Messages as LSP -import Language.Haskell.LSP.Types.Lens (HasTextDocument (textDocument), HasUri (uri)) -import Development.IDE.Core.Service -import Data.Aeson (Value) -import Development.IDE.Core.Tracing (otSetUri) -import OpenTelemetry.Eventlog (SpanInFlight, setTag) -import Data.Text.Encoding (encodeUtf8) - -data WithMessage c = WithMessage - {withResponse :: forall m req resp . (Show m, Show req, HasTracing req) => - (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response - (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work - Maybe (LSP.Handler (RequestMessage m req resp)) - ,withNotification :: forall m req . (Show m, Show req, HasTracing req) => - Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler - (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work - Maybe (LSP.Handler (NotificationMessage m req)) - ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody . - (Show m, Show rm, Show req, Show newReqParams, Show newReqBody, HasTracing req) => - (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response - (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req - (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work - Maybe (LSP.Handler (RequestMessage m req resp)) - , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ()) - -> Maybe (LSP.Handler InitializeRequest) - } - -newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers) - -instance Default (PartialHandlers c) where - def = PartialHandlers $ \_ x -> pure x - -instance Semigroup (PartialHandlers c) where - PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w - -instance Monoid (PartialHandlers c) where - mempty = def - -class HasTracing a where - traceWithSpan :: SpanInFlight -> a -> IO () - traceWithSpan _ _ = pure () - -instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where - traceWithSpan sp a = otSetUri sp (a ^. textDocument . uri) - -instance HasTracing Value -instance HasTracing ExecuteCommandParams -instance HasTracing DidChangeWatchedFilesParams -instance HasTracing DidChangeWorkspaceFoldersParams -instance HasTracing DidChangeConfigurationParams -instance HasTracing InitializeParams -instance HasTracing (Maybe InitializedParams) -instance HasTracing WorkspaceSymbolParams where - traceWithSpan sp (WorkspaceSymbolParams query _) = setTag sp "query" (encodeUtf8 query) - -setUriAnd :: - (HasTextDocument params a, HasUri a Uri) => - (lspFuncs -> ide -> params -> IO res) -> - lspFuncs -> - SpanInFlight -> - ide -> - params -> - IO res -setUriAnd k lf sp ide params = do - otSetUri sp (params ^. textDocument . uri) - k lf ide params diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 5def0316be..4164ce201f 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -45,18 +45,13 @@ import Development.IDE.Core.Shake ( ) import Development.IDE.Core.Tracing (measureMemory) import Development.IDE.LSP.LanguageServer (runLanguageServer) -import Development.IDE.LSP.Protocol import Development.IDE.Plugin ( - Plugin (pluginHandler, pluginRules), + Plugin (pluginHandlers, pluginRules), ) import Development.IDE.Plugin.HLS (asGhcIdePlugin) import Development.IDE.Session (SessionLoadingOptions, defaultLoadingOptions, loadSessionWithOptions, setInitialDynFlags) -import Development.IDE.Types.Diagnostics ( - ShowDiagnostic (ShowDiag), - showDiagnosticsColored, - ) import Development.IDE.Types.Location (toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger, logInfo) +import Development.IDE.Types.Logger (Logger) import Development.IDE.Types.Options ( IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress), @@ -66,14 +61,10 @@ import Development.IDE.Types.Options ( import Development.IDE.Types.Shake (Key (Key)) import Development.Shake (action) import HIE.Bios.Cradle (findCradle) -import Ide.Plugin.Config (CheckParents (NeverCheck), Config, getInitialConfig, getConfigFromNotification) +import Ide.Plugin.Config (CheckParents (NeverCheck), Config, getConfigFromNotification) import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins) import Ide.Types (IdePlugins) -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages (FromServerMessage) -import Language.Haskell.LSP.Types ( - LspId (IdInt), - ) +import qualified Language.LSP.Server as LSP import qualified System.Directory.Extra as IO import System.Exit (ExitCode (ExitFailure), exitWith) import System.FilePath (takeExtension, takeFileName) @@ -123,15 +114,14 @@ defaultMain Arguments{..} = do hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin options = argsLspOptions { LSP.executeCommandCommands = Just hlsCommands } - argsOnConfigChange = getConfigFromNotification argsDefaultHlsConfig - argsGetInitialConfig = getInitialConfig argsDefaultHlsConfig + argsOnConfigChange _ide = pure . getConfigFromNotification argsDefaultHlsConfig case argFiles of Nothing -> do t <- offsetTime hPutStrLn stderr "Starting LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runLanguageServer options (pluginHandler plugins) argsGetInitialConfig argsOnConfigChange $ \getLspId event vfs caps wProg wIndefProg getConfig rootPath -> do + runLanguageServer options argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t @@ -144,19 +134,16 @@ defaultMain Arguments{..} = do `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath - config <- getConfig + config <- LSP.runLspT env LSP.getConfig let options = (argsIdeOptions config sessionLoader) { optReportProgress = clientSupportsProgress caps } rules = argsRules >> pluginRules plugins + caps = LSP.resClientCapabilities env debouncer <- newAsyncDebouncer initialise - caps rules - getLspId - event - wProg - wIndefProg + (Just env) argsLogger debouncer options @@ -186,13 +173,12 @@ defaultMain Arguments{..} = do putStrLn "\nStep 3/4: Initializing the IDE" vfs <- makeVFSHandle debouncer <- newAsyncDebouncer - let dummyWithProg _ _ f = f (const (pure ())) sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir let options = (argsIdeOptions Nothing sessionLoader) - { optCheckParents = NeverCheck - , optCheckProject = False + { optCheckParents = pure NeverCheck + , optCheckProject = pure False } - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent argsLogger) dummyWithProg (const (const id)) argsLogger debouncer options vfs argsHiedb argsHieChan + ide <- initialise mainRule Nothing argsLogger debouncer options vfs argsHiedb argsHieChan putStrLn "\nStep 4/4: Type checking the files" setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') files @@ -237,10 +223,3 @@ expandFiles = concatMapM $ \x -> do when (null files) $ fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x return files - --- | Print an LSP event. -showEvent :: Logger -> FromServerMessage -> IO () -showEvent _ (EventFileDiagnostics _ []) = return () -showEvent argsLogger (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) = - logInfo argsLogger $ showDiagnosticsColored $ map (file,ShowDiag,) diags -showEvent argsLogger e = logInfo argsLogger $ T.pack $ show e diff --git a/ghcide/src/Development/IDE/Plugin.hs b/ghcide/src/Development/IDE/Plugin.hs index f8822ece32..046f4e56e3 100644 --- a/ghcide/src/Development/IDE/Plugin.hs +++ b/ghcide/src/Development/IDE/Plugin.hs @@ -1,22 +1,21 @@ -module Development.IDE.Plugin - ( Plugin(..) - ) where +module Development.IDE.Plugin ( Plugin(..) ) where import Data.Default import Development.Shake -import Development.IDE.LSP.Server +import Development.IDE.LSP.Server +import qualified Language.LSP.Server as LSP data Plugin c = Plugin {pluginRules :: Rules () - ,pluginHandler :: PartialHandlers c + ,pluginHandlers :: LSP.Handlers (ServerM c) } instance Default (Plugin c) where - def = Plugin mempty def + def = Plugin mempty mempty instance Semigroup (Plugin c) where - Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2) + Plugin x1 h1 <> Plugin x2 h2 = Plugin (x1<>x2) (h1 <> h2) instance Monoid (Plugin c) where mempty = def diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 82bdb9b3e5..3ee947af84 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -2,7 +2,9 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} #include "ghc-api-version.h" -- | Go to the definition of a variable. @@ -14,6 +16,7 @@ module Development.IDE.Plugin.CodeAction ) where import Control.Monad (join, guard) +import Control.Monad.IO.Class import Development.IDE.GHC.Compat import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes @@ -29,9 +32,9 @@ import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Data.HashMap.Strict as Map -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.VFS -import Language.Haskell.LSP.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.VFS +import Language.LSP.Types import qualified Data.Rope.UTF16 as Rope import Data.Char import Data.Maybe @@ -70,20 +73,18 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginRules = mempty, - pluginCodeActionProvider = Just codeAction + pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction } -- | Generate code actions. codeAction - :: LSP.LspFuncs c - -> IdeState + :: IdeState -> PluginId - -> TextDocumentIdentifier - -> Range - -> CodeActionContext - -> IO (Either ResponseError (List CAResult)) -codeAction lsp state _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do - contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri + -> CodeActionParams + -> LSP.LspM c (Either ResponseError (List (Command |? CodeAction))) +codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do + contents <- LSP.getVirtualFile $ toNormalizedUri uri + liftIO $ do let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state @@ -110,9 +111,9 @@ codeAction lsp state _ (TextDocumentIdentifier uri) _range CodeActionContext{_di <> caRemoveInvalidExports parsedModule text diag xs uri pure $ Right $ List actions' -mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> CAResult +mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) mkCA title diags edit = - CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) (Just edit) Nothing + InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) Nothing Nothing (Just edit) Nothing rewrite :: Maybe DynFlags -> @@ -258,7 +259,7 @@ isUnusedImportedId suggestDisableWarning :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestDisableWarning pm contents Diagnostic{..} - | Just (StringValue (T.stripPrefix "-W" -> Just w)) <- _code = + | Just (InR (T.stripPrefix "-W" -> Just w)) <- _code = pure ( "Disable \"" <> w <> "\" warnings" , [TextEdit (endOfModuleHeader pm contents) $ "{-# OPTIONS_GHC -Wno-" <> w <> " #-}\n"] @@ -284,7 +285,7 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmod = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] | otherwise = [] -caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [CAResult] +caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] caRemoveRedundantImports m contents digs ctxDigs uri | Just pm <- m, r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs, @@ -299,16 +300,18 @@ caRemoveRedundantImports m contents digs ctxDigs uri removeSingle title tedit diagnostic = mkCA title [diagnostic] WorkspaceEdit{..} where _changes = Just $ Map.singleton uri $ List tedit _documentChanges = Nothing - removeAll tedit = CACodeAction CodeAction {..} where + removeAll tedit = InR $ CodeAction{..} where _changes = Just $ Map.singleton uri $ List tedit _title = "Remove all redundant imports" _kind = Just CodeActionQuickFix _diagnostics = Nothing _documentChanges = Nothing _edit = Just WorkspaceEdit{..} + _isPreferred = Nothing _command = Nothing + _disabled = Nothing -caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [CAResult] +caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] caRemoveInvalidExports m contents digs ctxDigs uri | Just pm <- m, Just txt <- contents, @@ -332,7 +335,7 @@ caRemoveInvalidExports m contents digs ctxDigs uri | otherwise = Nothing removeSingle (_, _, []) = Nothing - removeSingle (title, diagnostic, ranges) = Just $ CACodeAction CodeAction{..} where + removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges _changes = Just $ Map.singleton uri $ List tedit _title = title @@ -341,8 +344,10 @@ caRemoveInvalidExports m contents digs ctxDigs uri _documentChanges = Nothing _edit = Just WorkspaceEdit{..} _command = Nothing + _isPreferred = Nothing + _disabled = Nothing removeAll [] = Nothing - removeAll ranges = Just $ CACodeAction CodeAction {..} where + removeAll ranges = Just $ InR $ CodeAction{..} where tedit = concatMap (\r -> [TextEdit r ""]) ranges _changes = Just $ Map.singleton uri $ List tedit _title = "Remove all redundant exports" @@ -351,6 +356,8 @@ caRemoveInvalidExports m contents digs ctxDigs uri _documentChanges = Nothing _edit = Just WorkspaceEdit{..} _command = Nothing + _isPreferred = Nothing + _disabled = Nothing suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} @@ -701,7 +708,7 @@ processHoleSuggestions mm = (holeSuggestions, refSuggestions) Valid refinement hole fits include fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers) fromJust (_ :: Maybe LSP.Handlers) - haskell-lsp-types-0.22.0.0:Language.Haskell.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams + haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams LSP.Handlers) T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers) (_ :: LSP.Handlers) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 86c1defd4d..201b5030d3 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -34,7 +34,7 @@ import FieldLabel (flLabel) import GhcPlugins (sigPrec, mkRealSrcLoc) import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) -import Language.Haskell.LSP.Types +import Language.LSP.Types import OccName import Outputable (ppr, showSDocUnsafe, showSDoc) import Retrie.GHC (rdrNameOcc, unpackFS, mkRealSrcSpan, realSrcSpanEnd) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs index 622e942e5a..424e05368c 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -12,7 +12,7 @@ where import Data.Char import Data.List -import Language.Haskell.LSP.Types +import Language.LSP.Types type PositionIndexed a = [(Position, a)] @@ -137,4 +137,4 @@ extendToIncludePreviousNewlineIfPossible indexedString range then Nothing -- didn't find any space else case xs of (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys) - _ -> Just pos \ No newline at end of file + _ -> Just pos diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index ee1d61fa7f..a672b5aea8 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} #include "ghc-api-version.h" @@ -7,16 +8,17 @@ module Development.IDE.Plugin.Completions , LocalCompletions(..) , NonLocalCompletions(..) ) where -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Core as LSP -import qualified Language.Haskell.LSP.VFS as VFS import Control.Monad +import Control.Monad.Extra import Control.Monad.Trans.Maybe import Data.Aeson import Data.List (find) import Data.Maybe import qualified Data.Text as T +import Language.LSP.Types +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.VFS as VFS import Development.Shake.Classes import Development.Shake import GHC.Generics @@ -42,10 +44,10 @@ import Development.IDE.Import.DependencyInformation descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = produceCompletions, - pluginCompletionProvider = Just (getCompletionsLSP plId), - pluginCommands = [extendImportCommand] - } + { pluginRules = produceCompletions + , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP + , pluginCommands = [extendImportCommand] + } produceCompletions :: Rules () produceCompletions = do @@ -115,20 +117,19 @@ instance Binary NonLocalCompletions -- | Generate code actions. getCompletionsLSP - :: PluginId - -> LSP.LspFuncs Config - -> IdeState + :: IdeState + -> PluginId -> CompletionParams - -> IO (Either ResponseError CompletionResponseResult) -getCompletionsLSP plId lsp ide + -> LSP.LspM Config (Either ResponseError (ResponseResult TextDocumentCompletion)) +getCompletionsLSP ide plId CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position ,_context=completionContext} = do - contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri + contents <- LSP.getVirtualFile $ toNormalizedUri uri fmap Right $ case (contents, uriToFilePath' uri) of (Just cnts, Just path) -> do let npath = toNormalizedFilePath' path - (ideOpts, compls) <- runIdeAction "Completion" (shakeExtras ide) $ do + (ideOpts, compls) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide localCompls <- useWithStaleFast LocalCompletions npath nonLocalCompls <- useWithStaleFast NonLocalCompletions npath @@ -140,16 +141,16 @@ getCompletionsLSP plId lsp ide pfix <- VFS.getCompletionPrefix position cnts case (pfix, completionContext) of (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) - -> return (Completions $ List []) + -> return (InL $ List []) (Just pfix', _) -> do let clientCaps = clientCapabilities $ shakeExtras ide - config <- getClientConfig lsp + config <- getClientConfig let snippets = WithSnippets . completionSnippetsOn $ config - allCompletions <- getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps snippets - pure $ Completions (List allCompletions) - _ -> return (Completions $ List []) - _ -> return (Completions $ List []) - _ -> return (Completions $ List []) + allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps snippets + pure $ InL (List allCompletions) + _ -> return (InL $ List []) + _ -> return (InL $ List []) + _ -> return (InL $ List []) ---------------------------------------------------------------------------------------------------- @@ -158,16 +159,18 @@ extendImportCommand = PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler extendImportHandler :: CommandFunction IdeState ExtendImport -extendImportHandler _lsp ideState edit = do - res <- runMaybeT $ extendImportHandler' ideState edit - return (Right Null, res) +extendImportHandler ideState edit = do + res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit + whenJust res $ \wedit -> + void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ Right Null -extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (ServerMethod, ApplyWorkspaceEditParams) +extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO WorkspaceEdit extendImportHandler' ideState ExtendImport {..} | Just fp <- uriToFilePath doc, nfp <- toNormalizedFilePath' fp = do - (ms, ps, imps) <- MaybeT $ + (ms, ps, imps) <- MaybeT $ liftIO $ runAction "extend import" ideState $ runMaybeT $ do -- We want accurate edits, so do not use stale data here @@ -178,11 +181,9 @@ extendImportHandler' ideState ExtendImport {..} wantedModule = mkModuleName (T.unpack importName) wantedQual = mkModuleName . T.unpack <$> importQual imp <- liftMaybe $ find (isWantedModule wantedModule wantedQual) imps - wedit <- - liftEither $ - rewriteToWEdit df doc (annsA ps) $ - extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp - return (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit) + liftEither $ + rewriteToWEdit df doc (annsA ps) $ + extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp | otherwise = mzero diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 4a4990be8f..b8832bab93 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -34,9 +34,9 @@ import Pair import Coercion #endif -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities -import qualified Language.Haskell.LSP.VFS as VFS +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import qualified Language.LSP.VFS as VFS import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping import Development.IDE.Plugin.Completions.Types @@ -203,7 +203,7 @@ mkCompl T.intercalate sectionSeparator docs' mkAdditionalEditsCommand :: PluginId -> ExtendImport -> IO Command -mkAdditionalEditsCommand pId edits = +mkAdditionalEditsCommand pId edits = pure $ mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs index 528ab1baf2..eabc8fcbfd 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs @@ -13,7 +13,9 @@ import Development.IDE.Spans.Common import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import GHC.Generics (Generic) -import Language.Haskell.LSP.Types (CompletionItemKind, Uri) +import Language.LSP.Types (CompletionItemKind, Uri) + +-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs data Backtick = Surrounded | LeftSide deriving (Eq, Ord, Show) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index b11913136b..1cb03b8116 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -1,67 +1,55 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} module Development.IDE.Plugin.HLS ( asGhcIdePlugin ) where -import Control.Exception(SomeException, catch) -import Control.Lens ((^.)) +import Control.Exception(SomeException) import Control.Monad import qualified Data.Aeson as J -import qualified Data.DList as DList import Data.Either import qualified Data.List as List import qualified Data.Map as Map -import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.Shake import Development.IDE.LSP.Server import Development.IDE.Plugin -import Development.IDE.Plugin.HLS.Formatter -import GHC.Generics import Ide.Plugin.Config import Ide.Types as HLS -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as J -import qualified Language.Haskell.LSP.Types.Capabilities as C -import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting) -import qualified Language.Haskell.LSP.VFS as VFS +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as J +import Language.LSP.Types import Text.Regex.TDFA.Text() import Development.Shake (Rules) -import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID) +import Ide.PluginUtils (getClientConfig) import Development.IDE.Core.Tracing -import Development.IDE.Types.Logger (logDebug) -import Control.Concurrent.Async (mapConcurrently) +import UnliftIO.Async (forConcurrently) +import UnliftIO.Exception (catchAny) +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Sum +import Data.List.NonEmpty (nonEmpty,NonEmpty,toList) +import UnliftIO (MonadUnliftIO) +import Data.String +import Data.Bifunctor -- --------------------------------------------------------------------- +-- --- | Map a set of plugins to the underlying ghcide engine. Main point is --- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message --- category ('Notifaction', 'Request' etc). +-- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config asGhcIdePlugin mp = - mkPlugin rulesPlugins (Just . HLS.pluginRules) <> - mkPlugin executeCommandPlugins (Just . pluginCommands) <> - mkPlugin codeActionPlugins pluginCodeActionProvider <> - mkPlugin codeLensPlugins pluginCodeLensProvider <> - -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider - mkPlugin hoverPlugins pluginHoverProvider <> - mkPlugin symbolsPlugins pluginSymbolsProvider <> - mkPlugin formatterPlugins pluginFormattingProvider <> - mkPlugin completionsPlugins pluginCompletionProvider <> - mkPlugin renamePlugins pluginRenameProvider + mkPlugin rulesPlugins HLS.pluginRules <> + mkPlugin executeCommandPlugins HLS.pluginCommands <> + mkPlugin extensiblePlugins HLS.pluginHandlers where - justs (p, Just x) = [(p, x)] - justs (_, Nothing) = [] - ls = Map.toList (ipMap mp) - mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> Maybe b) -> Plugin Config + mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config mkPlugin maker selector = - case concatMap (\(pid, p) -> justs (pid, selector p)) ls of + case map (second selector) ls of -- If there are no plugins that provide a descriptor, use mempty to -- create the plugin – otherwise we we end up declaring handlers for -- capabilities that there are no plugins for @@ -75,418 +63,123 @@ rulesPlugins rs = Plugin rules mempty where rules = foldMap snd rs -codeActionPlugins :: [(PluginId, CodeActionProvider IdeState)] -> Plugin Config -codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) - -codeActionRules :: Rules () -codeActionRules = mempty - -codeActionHandlers :: [(PluginId, CodeActionProvider IdeState)] -> PartialHandlers Config -codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.codeActionHandler - = withResponse RspCodeAction (makeCodeAction cas) - } - -makeCodeAction :: [(PluginId, CodeActionProvider IdeState)] - -> LSP.LspFuncs Config -> IdeState - -> CodeActionParams - -> IO (Either ResponseError (List CAResult)) -makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do - let caps = LSP.clientCapabilities lf - unL (List ls) = ls - makeAction (pid,provider) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcCodeActionsOn - then otTracedProvider pid "codeAction" $ provider lf ideState pid docId range context - else return $ Right (List []) - r <- mapConcurrently makeAction cas - let actions = filter wasRequested . foldMap unL $ rights r - res <- send caps actions - return $ Right res - where - wasRequested :: CAResult -> Bool - wasRequested (CACommand _) = True - wasRequested (CACodeAction ca) - | Nothing <- only context = True - | Just (List allowed) <- only context - , Just caKind <- ca ^. kind = caKind `elem` allowed - | otherwise = False - - wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult) - wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd) - wrapCodeAction caps (CACodeAction action) = do - - let (C.ClientCapabilities _ textDocCaps _ _) = caps - let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport - - case literalSupport of - Nothing -> do - let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))] - cmd <- mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams) - return $ Just (CACommand cmd) - Just _ -> return $ Just (CACodeAction action) - - send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult) - send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions - -data FallbackCodeActionParams = - FallbackCodeActionParams - { fallbackWorkspaceEdit :: Maybe WorkspaceEdit - , fallbackCommand :: Maybe Command - } - deriving (Generic, J.ToJSON, J.FromJSON) - --- ----------------------------------------------------------- - -codeLensPlugins :: [(PluginId, CodeLensProvider IdeState)] -> Plugin Config -codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas) - -codeLensRules :: Rules () -codeLensRules = mempty - -codeLensHandlers :: [(PluginId, CodeLensProvider IdeState)] -> PartialHandlers Config -codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.codeLensHandler - = withResponse RspCodeLens (makeCodeLens cas) - } - -makeCodeLens :: [(PluginId, CodeLensProvider IdeState)] - -> LSP.LspFuncs Config - -> IdeState - -> CodeLensParams - -> IO (Either ResponseError (List CodeLens)) -makeCodeLens cas lf ideState params = do - logDebug (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ - let - makeLens (pid, provider) = do - pluginConfig <- getPluginConfig lf pid - r <- if pluginEnabled pluginConfig plcCodeLensOn - then otTracedProvider pid "codeLens" $ provider lf ideState pid params - else return $ Right (List []) - return (pid, r) - breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)]) - breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls) - where - doOneLeft (pid, Left err) = [(pid,err)] - doOneLeft (_, Right _) = [] - - doOneRight (pid, Right a) = [(pid,a)] - doOneRight (_, Left _) = [] - - r <- mapConcurrently makeLens cas - case breakdown r of - ([],[]) -> return $ Right $ List [] - (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing - (_,rs) -> return $ Right $ List (concatMap (\(_,List cs) -> cs) rs) - --- ----------------------------------------------------------- +-- --------------------------------------------------------------------- executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) -executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> PartialHandlers Config -executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{ - LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs) - } - -makeExecuteCommands :: [(PluginId, [PluginCommand IdeState])] -> LSP.LspFuncs Config -> ExecuteCommandProvider IdeState -makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do - let - pluginMap = Map.fromList ecs - parseCmdId :: T.Text -> Maybe (PluginId, CommandId) - parseCmdId x = case T.splitOn ":" x of - [plugin, command] -> Just (PluginId plugin, CommandId command) - [_, plugin, command] -> Just (PluginId plugin, CommandId command) - _ -> Nothing - - execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) - execCmd (ExecuteCommandParams cmdId args _) = do - -- The parameters to the HIE command are always the first element - let cmdParams :: J.Value - cmdParams = case args of - Just (J.List (x:_)) -> x - _ -> J.Null - - case parseCmdId cmdId of - -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions - Just ("hls", "fallbackCodeAction") -> - case J.fromJSON cmdParams of - J.Success (FallbackCodeActionParams mEdit mCmd) -> do - - -- Send off the workspace request if it has one - forM_ mEdit $ \edit -> do - let eParams = J.ApplyWorkspaceEditParams edit - reqId <- LSP.getNextReqId lf - LSP.sendFunc lf $ ReqApplyWorkspaceEdit $ RequestMessage "2.0" reqId WorkspaceApplyEdit eParams - - case mCmd of - -- If we have a command, continue to execute it - Just (J.Command _ innerCmdId innerArgs) - -> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing) - Nothing -> return (Right J.Null, Nothing) - - J.Error _str -> return (Right J.Null, Nothing) - - -- Just an ordinary HIE command - Just (plugin, cmd) -> runPluginCommand pluginMap lf ide plugin cmd cmdParams - - -- Couldn't parse the command identifier - _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing) - - execCmd - - --- ----------------------------------------------------------- -wrapUnhandledExceptions :: - (a -> IO (Either ResponseError J.Value, Maybe b)) -> - a -> IO (Either ResponseError J.Value, Maybe b) -wrapUnhandledExceptions action input = - catch (action input) $ \(e::SomeException) -> do - let resp = ResponseError InternalError (T.pack $ show e) Nothing - return (Left resp, Nothing) - - --- | Runs a plugin command given a PluginId, CommandId and --- arguments in the form of a JSON object. -runPluginCommand :: Map.Map PluginId [PluginCommand IdeState] - -> LSP.LspFuncs Config - -> IdeState - -> PluginId - -> CommandId - -> J.Value - -> IO (Either ResponseError J.Value, - Maybe (ServerMethod, ApplyWorkspaceEditParams)) -runPluginCommand m lf ide p@(PluginId p') com@(CommandId com') arg = - case Map.lookup p m of - Nothing -> return - (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing) - Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> return (Left $ - ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' - <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing) - Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> return (Left $ - ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' - <> ": " <> T.pack err - <> "\narg = " <> T.pack (show arg)) Nothing, Nothing) - J.Success a -> f lf ide a - --- ----------------------------------------------------------- - -mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command -mkLspCommand plid cn title args' = do - pid <- T.pack . show <$> getProcessID - let cmdId = mkLspCmdId pid plid cn - let args = List <$> args' - return $ Command title cmdId args - -mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text -mkLspCmdId pid (PluginId plid) (CommandId cid) - = pid <> ":" <> plid <> ":" <> cid - --- --------------------------------------------------------------------- - -hoverPlugins :: [(PluginId, HoverProvider IdeState)] -> Plugin Config -hoverPlugins hs = Plugin hoverRules (hoverHandlers hs) - -hoverRules :: Rules () -hoverRules = mempty - -hoverHandlers :: [(PluginId, HoverProvider IdeState)] -> PartialHandlers Config -hoverHandlers hps = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)} - -makeHover :: [(PluginId, HoverProvider IdeState)] - -> LSP.LspFuncs Config -> IdeState - -> TextDocumentPositionParams - -> IO (Either ResponseError (Maybe Hover)) -makeHover hps lf ideState params - = do - let - makeHover(pid,p) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcHoverOn - then otTracedProvider pid "hover" $ p ideState params - else return $ Right Nothing - mhs <- mapConcurrently makeHover hps - -- TODO: We should support ServerCapabilities and declare that - -- we don't support hover requests during initialization if we - -- don't have any hover providers - -- TODO: maybe only have provider give MarkedString and - -- work out range here? - let hs = catMaybes (rights mhs) - r = listToMaybe $ mapMaybe (^. range) hs - h = case foldMap (^. contents) hs of - HoverContentsMS (List []) -> Nothing - hh -> Just $ Hover hh r - return $ Right h - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -symbolsPlugins :: [(PluginId, SymbolsProvider IdeState)] -> Plugin Config -symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs) - -symbolsRules :: Rules () -symbolsRules = mempty - -symbolsHandlers :: [(PluginId, SymbolsProvider IdeState)] -> PartialHandlers Config -symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x -> - return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)} - -makeSymbols :: [(PluginId, SymbolsProvider IdeState)] - -> LSP.LspFuncs Config - -> IdeState - -> DocumentSymbolParams - -> IO (Either ResponseError DSResult) -makeSymbols sps lf ideState params - = do - let uri' = params ^. textDocument . uri - (C.ClientCapabilities _ tdc _ _) = LSP.clientCapabilities lf - supportsHierarchy = Just True == (tdc >>= C._documentSymbol >>= C._hierarchicalDocumentSymbolSupport) - convertSymbols :: [DocumentSymbol] -> DSResult - convertSymbols symbs - | supportsHierarchy = DSDocumentSymbols $ List symbs - | otherwise = DSSymbolInformation (List $ concatMap (go Nothing) symbs) - where - go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation] - go parent ds = - let children' :: [SymbolInformation] - children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children)) - loc = Location uri' (ds ^. range) - name' = ds ^. name - si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent - in [si] <> children' - - makeSymbols (pid,p) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcSymbolsOn - then otTracedProvider pid "symbols" $ p lf ideState params - else return $ Right [] - mhs <- mapConcurrently makeSymbols sps - case rights mhs of - [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs - hs -> return $ Right $ convertSymbols $ concat hs - - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -renamePlugins :: [(PluginId, RenameProvider IdeState)] -> Plugin Config -renamePlugins providers = Plugin rules handlers +executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) +executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd where - rules = mempty - handlers = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.renameHandler = withResponse RspRename (renameWith providers)} + pluginMap = Map.fromList ecs + + parseCmdId :: T.Text -> Maybe (PluginId, CommandId) + parseCmdId x = case T.splitOn ":" x of + [plugin, command] -> Just (PluginId plugin, CommandId command) + [_, plugin, command] -> Just (PluginId plugin, CommandId command) + _ -> Nothing + + -- The parameters to the HLS command are always the first element + + execCmd ide (ExecuteCommandParams _ cmdId args) = do + let cmdParams :: J.Value + cmdParams = case args of + Just (J.List (x:_)) -> x + _ -> J.Null + case parseCmdId cmdId of + -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions + Just ("hls", "fallbackCodeAction") -> + case J.fromJSON cmdParams of + J.Success (FallbackCodeActionParams mEdit mCmd) -> do + + -- Send off the workspace request if it has one + forM_ mEdit $ \edit -> + LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + + case mCmd of + -- If we have a command, continue to execute it + Just (J.Command _ innerCmdId innerArgs) + -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) + Nothing -> return $ Right J.Null + + J.Error _str -> return $ Right J.Null + + -- Just an ordinary HIE command + Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams + + -- Couldn't parse the command identifier + _ -> return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing + + runPluginCommand ide p@(PluginId p') com@(CommandId com') arg = + case Map.lookup p pluginMap of + Nothing -> return + (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing) + Just xs -> case List.find ((com ==) . commandId) xs of + Nothing -> return $ Left $ + ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' + <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing + Just (PluginCommand _ _ f) -> case J.fromJSON arg of + J.Error err -> return $ Left $ + ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' + <> ": " <> T.pack err + <> "\narg = " <> T.pack (show arg)) Nothing + J.Success a -> f ide a -renameWith :: - [(PluginId, RenameProvider IdeState)] -> - LSP.LspFuncs Config -> - IdeState -> - RenameParams -> - IO (Either ResponseError WorkspaceEdit) -renameWith providers lspFuncs state params = do - let - makeAction (pid,p) = do - pluginConfig <- getPluginConfig lspFuncs pid - if pluginEnabled pluginConfig plcRenameOn - then otTracedProvider pid "rename" $ p lspFuncs state params - else return $ Right $ WorkspaceEdit Nothing Nothing - -- TODO:AZ: we need to consider the right way to combine possible renamers - results <- mapConcurrently makeAction providers - case partitionEithers results of - (errors, []) -> return $ Left $ responseError $ T.pack $ show errors - (_, edits) -> return $ Right $ mconcat edits - --- --------------------------------------------------------------------- -- --------------------------------------------------------------------- -formatterPlugins :: [(PluginId, FormattingProvider IdeState IO)] -> Plugin Config -formatterPlugins providers - = Plugin formatterRules - (formatterHandlers (Map.fromList (("none",noneProvider):providers))) - -formatterRules :: Rules () -formatterRules = mempty - -formatterHandlers :: Map.Map PluginId (FormattingProvider IdeState IO) -> PartialHandlers Config -formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.documentFormattingHandler - = withResponse RspDocumentFormatting (formatting providers) - , LSP.documentRangeFormattingHandler - = withResponse RspDocumentRangeFormatting (rangeFormatting providers) - } - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -completionsPlugins :: [(PluginId, CompletionProvider IdeState)] -> Plugin Config -completionsPlugins cs = Plugin completionsRules (completionsHandlers cs) - -completionsRules :: Rules () -completionsRules = mempty - -completionsHandlers :: [(PluginId, CompletionProvider IdeState)] -> PartialHandlers Config -completionsHandlers cps = PartialHandlers $ \WithMessage{..} x -> - return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)} - -makeCompletions :: [(PluginId, CompletionProvider IdeState)] - -> LSP.LspFuncs Config - -> IdeState - -> CompletionParams - -> IO (Either ResponseError CompletionResponseResult) -makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt) - = do - mprefix <- getPrefixAtPos lf doc pos - maxCompletions <- maxCompletions <$> getClientConfig lf - - let - combine :: [CompletionResponseResult] -> CompletionResponseResult - combine cs = go True mempty cs - - go !comp acc [] = - CompletionList (CompletionListType comp (List $ DList.toList acc)) - go comp acc (Completions (List ls) : rest) = - go comp (acc <> DList.fromList ls) rest - go comp acc (CompletionList (CompletionListType comp' (List ls)) : rest) = - go (comp && comp') (acc <> DList.fromList ls) rest - - makeAction :: - (PluginId, CompletionProvider IdeState) -> - IO (Either ResponseError CompletionResponseResult) - makeAction (pid, p) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcCompletionOn - then otTracedProvider pid "completions" $ p lf ideState params - else return $ Right $ Completions $ List [] - - case mprefix of - Nothing -> return $ Right $ Completions $ List [] - Just _prefix -> do - mhs <- mapConcurrently makeAction sps - case rights mhs of - [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs - hs -> return $ Right $ snd $ consumeCompletionResponse maxCompletions $ combine hs - --- | Crops a completion response. Returns the final number of completions and the cropped response -consumeCompletionResponse :: Int -> CompletionResponseResult -> (Int, CompletionResponseResult) -consumeCompletionResponse limit it@(CompletionList (CompletionListType _ (List xx))) = - case splitAt limit xx of - -- consumed all the items, return the result as is - (_, []) -> (limit - length xx, it) - -- need to crop the response, set the 'isIncomplete' flag - (xx', _) -> (0, CompletionList (CompletionListType isIncompleteResponse (List xx'))) -consumeCompletionResponse n (Completions (List xx)) = - consumeCompletionResponse n (CompletionList (CompletionListType isCompleteResponse (List xx))) - --- boolean disambiguators -isCompleteResponse, isIncompleteResponse :: Bool -isIncompleteResponse = True -isCompleteResponse = False - -getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo) -getPrefixAtPos lf uri pos = do - mvf <- LSP.getVirtualFileFunc lf (J.toNormalizedUri uri) - case mvf of - Just vf -> VFS.getCompletionPrefix pos vf - Nothing -> return Nothing +extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config +extensiblePlugins xs = Plugin mempty handlers + where + IdeHandlers handlers' = foldMap bakePluginId xs + bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers + bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map + (\(PluginHandler f) -> IdeHandler [(pid,f pid)]) + hs + handlers = mconcat $ do + (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers' + pure $ requestHandler m $ \ide params -> do + config <- getClientConfig + let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs' + case nonEmpty fs of + Nothing -> pure $ Left $ ResponseError InvalidRequest + ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs)) + Nothing + Just fs -> do + let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e) + es <- runConcurrently msg (show m) fs ide params + let (errs,succs) = partitionEithers $ toList es + case nonEmpty succs of + Nothing -> pure $ Left $ combineErrors errs + Just xs -> do + caps <- LSP.getClientCapabilities + pure $ Right $ combineResponses m config caps params xs + +runConcurrently + :: MonadUnliftIO m + => (SomeException -> PluginId -> T.Text) + -> String -- ^ label + -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) + -> a + -> b + -> m (NonEmpty (Either ResponseError d)) +runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do + f a b + `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) + +combineErrors :: [ResponseError] -> ResponseError +combineErrors [x] = x +combineErrors xs = ResponseError InternalError (T.pack (show xs)) Nothing + +-- | Combine the 'PluginHandler' for all plugins +newtype IdeHandler (m :: J.Method FromClient Request) + = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] + +-- | Combine the 'PluginHandlers' for all plugins +newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler) + +instance Semigroup IdeHandlers where + (IdeHandlers a) <> (IdeHandlers b) = IdeHandlers $ DMap.unionWithKey go a b + where + go _ (IdeHandler a) (IdeHandler b) = IdeHandler (a ++ b) +instance Monoid IdeHandlers where + mempty = IdeHandlers mempty diff --git a/ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs b/ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs deleted file mode 100644 index 84fb9c47f2..0000000000 --- a/ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs +++ /dev/null @@ -1,70 +0,0 @@ - -module Development.IDE.Plugin.HLS.Formatter - ( - formatting - , rangeFormatting - ) -where - -import qualified Data.Map as Map -import qualified Data.Text as T -import Development.IDE -import Ide.PluginUtils -import Ide.Types -import Ide.Plugin.Config -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Types -import Text.Regex.TDFA.Text() - --- --------------------------------------------------------------------- - -formatting :: Map.Map PluginId (FormattingProvider IdeState IO) - -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams - -> IO (Either ResponseError (List TextEdit)) -formatting providers lf ideState - (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress) - = doFormatting lf providers ideState FormatText uri params - --- --------------------------------------------------------------------- - -rangeFormatting :: Map.Map PluginId (FormattingProvider IdeState IO) - -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams - -> IO (Either ResponseError (List TextEdit)) -rangeFormatting providers lf ideState - (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress) - = doFormatting lf providers ideState (FormatRange range) uri params - --- --------------------------------------------------------------------- - -doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IdeState IO) - -> IdeState -> FormattingType -> Uri -> FormattingOptions - -> IO (Either ResponseError (List TextEdit)) -doFormatting lf providers ideState ft uri params = do - mc <- LSP.config lf - let mf = maybe "none" formattingProvider mc - case Map.lookup (PluginId mf) providers of - Just provider -> - case uriToFilePath uri of - Just (toNormalizedFilePath -> fp) -> do - (_, mb_contents) <- runAction "Formatter" ideState $ getFileContents fp - case mb_contents of - Just contents -> do - logDebug (ideLogger ideState) $ T.pack $ - "Formatter.doFormatting: contents=" ++ show contents -- AZ - provider lf ideState ft contents fp params - Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri - Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri - Nothing -> return $ Left $ responseError $ mconcat - [ "Formatter plugin: no formatter found for:[" - , mf - , "]" - , if mf == "brittany" - then T.unlines - [ "\nThe haskell-language-server must be compiled with the agpl flag to provide Brittany." - , "Stack users add 'agpl: true' in the flags section of the 'stack.yaml' file." - , "The 'haskell-language-server.cabal' file already has this flag enabled by default." - , "For more information see: https://github.com/haskell/haskell-language-server/issues/269" - ] - else "" - ] - diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index 01a8028c31..636c2c6287 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -9,13 +9,14 @@ module Development.IDE.Plugin.HLS.GhcIde import Development.IDE import Development.IDE.LSP.HoverDefinition import Development.IDE.LSP.Outline -import Ide.PluginUtils import Ide.Types -import Language.Haskell.LSP.Types +import Language.LSP.Types +import Language.LSP.Server (LspM) import Text.Regex.TDFA.Text() import qualified Development.IDE.Plugin.CodeAction as CodeAction import qualified Development.IDE.Plugin.Completions as Completions import qualified Development.IDE.Plugin.TypeLenses as TypeLenses +import Control.Monad.IO.Class descriptors :: [PluginDescriptor IdeState] descriptors = @@ -29,25 +30,19 @@ descriptors = descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginHoverProvider = Just hover' - , pluginSymbolsProvider = Just symbolsProvider + { pluginHandlers = mkPluginHandler STextDocumentHover hover' + <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider } -- --------------------------------------------------------------------- -hover' :: HoverProvider IdeState -hover' ideState params = do - logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ - hover ideState params +hover' :: IdeState -> PluginId -> HoverParams -> LspM c (Either ResponseError (Maybe Hover)) +hover' ideState _ HoverParams{..} = do + liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ + hover ideState TextDocumentPositionParams{..} -- --------------------------------------------------------------------- -symbolsProvider :: SymbolsProvider IdeState -symbolsProvider ls ide params = do - ds <- moduleOutline ls ide params - case ds of - Right (DSDocumentSymbols (List ls)) -> return $ Right ls - Right (DSSymbolInformation (List _si)) -> - return $ Left $ responseError "GhcIde.symbolsProvider: DSSymbolInformation deprecated" - Left err -> return $ Left err +symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) +symbolsProvider ide _ params = moduleOutline ide params -- --------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index d2d9c58764..7af6dc966a 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DerivingStrategies #-} -- | A plugin that adds custom messages for use in tests module Development.IDE.Plugin.Test @@ -10,6 +11,7 @@ module Development.IDE.Plugin.Test ) where import Control.Monad.STM +import Control.Monad.IO.Class import Data.Aeson import Data.Aeson.Types import Data.CaseInsensitive (CI, original) @@ -17,14 +19,12 @@ import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.Types.HscEnvEq (HscEnvEq(hscEnv)) -import Development.IDE.LSP.Server import Development.IDE.Plugin +import Development.IDE.LSP.Server import Development.IDE.Types.Action import GHC.Generics (Generic) import GhcPlugins (HscEnv(hsc_dflags)) -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types +import Language.LSP.Types import System.Time.Extra import Development.IDE.Core.RuleTypes import Control.Monad @@ -36,7 +36,7 @@ import Data.String import Development.IDE.Types.Location (fromUri) import Control.Concurrent (threadDelay) import Ide.Types -import qualified Language.Haskell.LSP.Core as LSP +import qualified Language.LSP.Server as LSP data TestRequest = BlockSeconds Seconds -- ^ :: Null @@ -53,42 +53,39 @@ newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool} plugin :: Plugin c plugin = Plugin { pluginRules = return (), - pluginHandler = PartialHandlers $ \WithMessage{..} x -> return x { - customRequestHandler = withResponse RspCustomServer requestHandler' - } + pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler' } where - requestHandler' lsp ide req + testRequestHandler' ide req | Just customReq <- parseMaybe parseJSON req - = requestHandler lsp ide customReq + = testRequestHandler ide customReq | otherwise = return $ Left $ ResponseError InvalidRequest "Cannot parse request" Nothing -requestHandler :: LspFuncs c - -> IdeState + +testRequestHandler :: IdeState -> TestRequest - -> IO (Either ResponseError Value) -requestHandler lsp _ (BlockSeconds secs) = do - sendFunc lsp $ NotCustomServer $ - NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/request") $ - toJSON secs - sleep secs + -> LSP.LspM c (Either ResponseError Value) +testRequestHandler _ (BlockSeconds secs) = do + LSP.sendNotification (SCustomMethod "ghcide/blocking/request") $ + toJSON secs + liftIO $ sleep secs return (Right Null) -requestHandler _ s (GetInterfaceFilesDir fp) = do +testRequestHandler s (GetInterfaceFilesDir fp) = liftIO $ do let nfp = toNormalizedFilePath fp sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp let hiPath = hiDir $ hsc_dflags $ hscEnv sess return $ Right (toJSON hiPath) -requestHandler _ s GetShakeSessionQueueCount = do +testRequestHandler s GetShakeSessionQueueCount = liftIO $ do n <- atomically $ countQueue $ actionQueue $ shakeExtras s return $ Right (toJSON n) -requestHandler _ s WaitForShakeQueue = do +testRequestHandler s WaitForShakeQueue = liftIO $ do atomically $ do n <- countQueue $ actionQueue $ shakeExtras s when (n>0) retry return $ Right Null -requestHandler _ s (WaitForIdeRule k file) = do +testRequestHandler s (WaitForIdeRule k file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp let res = WaitForIdeRuleResult <$> success @@ -120,9 +117,7 @@ blockCommandDescriptor plId = (defaultPluginDescriptor plId) { } blockCommandHandler :: CommandFunction state ExecuteCommandParams -blockCommandHandler lsp _ideState _params - = do - LSP.sendFunc lsp $ NotCustomServer $ - NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null - threadDelay maxBound - return (Right Null, Nothing) +blockCommandHandler _ideState _params = do + LSP.sendNotification (SCustomMethod "ghcide/blocking/command") Null + liftIO $ threadDelay maxBound + return (Right Null) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 40a86e5705..546a931d76 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -6,6 +6,7 @@ module Development.IDE.Plugin.TypeLenses ) where +import Control.Monad.IO.Class import Data.Aeson.Types (Value (..), toJSON) import qualified Data.HashMap.Strict as Map import qualified Data.Text as T @@ -24,22 +25,23 @@ import Ide.Types ( CommandFunction, CommandId (CommandId), PluginCommand (PluginCommand), - PluginDescriptor (pluginCodeLensProvider, pluginCommands), + PluginDescriptor(..), PluginId, defaultPluginDescriptor, + mkPluginHandler ) -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.Types ( ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), CodeLens (CodeLens), CodeLensParams (CodeLensParams, _textDocument), Diagnostic (..), List (..), ResponseError, - ServerMethod (WorkspaceApplyEdit), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit), + SMethod(..) ) import Text.Regex.TDFA ((=~)) @@ -49,19 +51,18 @@ typeLensCommandId = "typesignature.add" descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginCodeLensProvider = Just codeLensProvider, + { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider, pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] } codeLensProvider :: - LSP.LspFuncs c -> IdeState -> PluginId -> CodeLensParams -> - IO (Either ResponseError (List CodeLens)) -codeLensProvider _lsp ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do + LSP.LspM c (Either ResponseError (List CodeLens)) +codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do fmap (Right . List) $ case uriToFilePath' uri of - Just (toNormalizedFilePath' -> filePath) -> do + Just (toNormalizedFilePath' -> filePath) -> liftIO $ do _ <- runAction "codeLens" ideState (use TypeCheck filePath) diag <- getDiagnostics ideState hDiag <- getHiddenDiagnostics ideState @@ -76,12 +77,13 @@ codeLensProvider _lsp ideState pId CodeLensParams {_textDocument = TextDocumentI generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> IO CodeLens generateLens pId _range title edit = do - cId <- mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) + let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) return $ CodeLens _range (Just cId) Nothing commandHandler :: CommandFunction IdeState WorkspaceEdit -commandHandler _lsp _ideState wedit = - return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) +commandHandler _ideState wedit = do + _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ Right Null suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])] suggestSignature isQuickFix Diagnostic {_range = _range@Range {..}, ..} diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index bd45d9ee2a..8007e839a7 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -22,7 +22,7 @@ module Development.IDE.Spans.AtPoint ( import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans() import Development.IDE.Types.Location -import Language.Haskell.LSP.Types +import Language.LSP.Types -- compiler and infrastructure import Development.IDE.GHC.Compat diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 540ebea44c..0addce67a5 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -35,7 +35,7 @@ import SrcLoc (RealLocated) import GhcMonad import Packages import Name -import Language.Haskell.LSP.Types (getUri, filePathToUri) +import Language.LSP.Types (getUri, filePathToUri) import TcRnTypes import ExtractDocs import NameEnv @@ -212,8 +212,8 @@ lookupHtmlForModule mkDocPath df m = do go pkgDocDir = map (mkDocPath pkgDocDir) mns ui = moduleUnitId m -- try to locate html file from most to least specific name e.g. - -- first Language.Haskell.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html - -- then Language.Haskell.LSP.Types.html and Language-Haskell-LSP-Types.html etc. + -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html + -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc. mns = do chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m -- The file might use "." or "-" as separator diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 1c196568d4..a9de39d43f 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -20,12 +20,12 @@ import Control.DeepSeq import Data.Maybe as Maybe import qualified Data.Text as T import Data.Text.Prettyprint.Doc -import Language.Haskell.LSP.Types as LSP (DiagnosticSource, +import Language.LSP.Types as LSP (DiagnosticSource, DiagnosticSeverity(..) , Diagnostic(..) , List(..) ) -import Language.Haskell.LSP.Diagnostics +import Language.LSP.Diagnostics import Data.Text.Prettyprint.Doc.Render.Text import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color) diff --git a/ghcide/src/Development/IDE/Types/Location.hs b/ghcide/src/Development/IDE/Types/Location.hs index 9c1c12ad49..182a8412f7 100644 --- a/ghcide/src/Development/IDE/Types/Location.hs +++ b/ghcide/src/Development/IDE/Types/Location.hs @@ -26,12 +26,12 @@ module Development.IDE.Types.Location ) where import Control.Applicative -import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..)) +import Language.LSP.Types (Location(..), Range(..), Position(..)) import Control.Monad import Data.Hashable (Hashable(hash)) import Data.String import FastString -import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.LSP.Types as LSP import SrcLoc as GHC import Text.ParserCombinators.ReadP as ReadP import Data.Maybe (fromMaybe) diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index fefd956b59..6ec8509d53 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -17,12 +17,11 @@ module Development.IDE.Types.Options , OptHaddockParse(..) ,optShakeFiles) where -import Data.Default import Development.Shake import Development.IDE.Types.HscEnvEq (HscEnvEq) import GHC hiding (parseModule, typecheckModule) import GhcPlugins as GHC hiding (fst3, (<>)) -import qualified Language.Haskell.LSP.Types.Capabilities as LSP +import qualified Language.LSP.Types.Capabilities as LSP import qualified Data.Text as T import Development.IDE.Types.Diagnostics import Control.DeepSeq (NFData(..)) @@ -72,9 +71,9 @@ data IdeOptions = IdeOptions -- features such as diagnostics and go-to-definition, in -- situations in which they would become unavailable because of -- the presence of type errors, holes or unbound variables. - , optCheckProject :: !Bool + , optCheckProject :: IO Bool -- ^ Whether to typecheck the entire project on load - , optCheckParents :: CheckParents + , optCheckParents :: IO CheckParents -- ^ When to typecheck reverse dependencies of a file , optHaddockParse :: OptHaddockParse -- ^ Whether to return result of parsing module with Opt_Haddock. @@ -133,8 +132,8 @@ defaultIdeOptions session = IdeOptions ,optKeywords = haskellKeywords ,optDefer = IdeDefer True ,optTesting = IdeTesting False - ,optCheckProject = checkProject def - ,optCheckParents = checkParents def + ,optCheckProject = pure True + ,optCheckParents = pure CheckOnSaveAndClose ,optHaddockParse = HaddockParse ,optCustomDynFlags = id } diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index d1244847cf..7cfdcaf161 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -28,7 +28,7 @@ import Development.IDE.Types.Location import Development.Shake (RuleResult, ShakeException (shakeExceptionInner)) import Development.Shake.Classes import GHC.Generics -import Language.Haskell.LSP.Types +import Language.LSP.Types import Development.IDE.Core.PositionMapping data Value v diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 13befffe3d..a3c5e0f523 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -5,7 +5,12 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} #include "ghc-api-version.h" module Main (main) where @@ -15,7 +20,7 @@ import Control.Exception (bracket_, catch) import qualified Control.Lens as Lens import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (FromJSON, Value, toJSON,fromJSON) +import Data.Aeson (toJSON,fromJSON) import qualified Data.Aeson as A import qualified Data.Binary as Binary import Data.Default @@ -29,7 +34,6 @@ import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent, PositionRes import Development.IDE.Core.Shake (Q(..)) import Development.IDE.GHC.Util import qualified Data.Text as T -import Data.Typeable import Development.IDE.Plugin.Completions.Types (extendImportCommandId) import Development.IDE.Plugin.TypeLenses (typeLensCommandId) import Development.IDE.Spans.Common @@ -50,12 +54,11 @@ import Development.IDE.Types.Location import Development.Shake (getDirectoryFilesIO) import Ide.Plugin.Config import qualified Experiments as Bench -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities -import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message) -import Language.Haskell.LSP.VFS (applyChange) +import Language.LSP.Test +import Language.LSP.Types hiding (mkRange) +import Language.LSP.Types.Capabilities +import qualified Language.LSP.Types.Lens as Lsp (diagnostics, params, message) +import Language.LSP.VFS (applyChange) import Network.URI import System.Environment.Blank (unsetEnv, getEnv, setEnv) import System.FilePath @@ -66,7 +69,7 @@ import System.Exit (ExitCode(ExitSuccess)) import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc) import System.Info.Extra (isWindows) import Test.QuickCheck -import Test.QuickCheck.Instances () +-- import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.Ingredients.Rerun @@ -76,21 +79,31 @@ import System.Time.Extra import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) import Development.IDE.Plugin.Test (TestRequest (BlockSeconds, GetInterfaceFilesDir), WaitForIdeRuleResult (..), blockCommandId) import Control.Monad.Extra (whenJust) -import qualified Language.Haskell.LSP.Types.Lens as L +import qualified Language.LSP.Types.Lens as L import Control.Lens ((^.)) import Data.Functor import Data.Tuple.Extra +waitForProgressBegin :: Session () +waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just () + _ -> Nothing + +waitForProgressDone :: Session () +waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + _ -> Nothing + main :: IO () main = do -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" [ testSession "open close" $ do doc <- createDoc "Testing.hs" "haskell" "" - void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest) - void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification) + void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate) + waitForProgressBegin closeDoc doc - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + waitForProgressDone , initializeResponseTests , completionTests , cppTests @@ -130,50 +143,50 @@ initializeResponseTests = withResource acquire release tests where -- response. Currently the server advertises almost no capabilities -- at all, in some cases failing to announce capabilities that it -- actually does provide! Hopefully this will change ... - tests :: IO InitializeResponse -> TestTree + tests :: IO (ResponseMessage Initialize) -> TestTree tests getInitializeResponse = testGroup "initialize response capabilities" [ chk " text doc sync" _textDocumentSync tds - , chk " hover" _hoverProvider (Just True) - , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing) - , chk "NO signature help" _signatureHelpProvider Nothing - , chk " goto definition" _definitionProvider (Just True) - , chk " goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic True) + , chk " hover" _hoverProvider (Just $ InL True) + , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False)) + , chk "NO signature help" _signatureHelpProvider Nothing + , chk " goto definition" _definitionProvider (Just $ InL True) + , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) -- BUG in lsp-test, this test fails, just change the accepted response -- for now - , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic True) - , chk " find references" _referencesProvider (Just True) - , chk " doc highlight" _documentHighlightProvider (Just True) - , chk " doc symbol" _documentSymbolProvider (Just True) - , chk " workspace symbol" _workspaceSymbolProvider (Just True) - , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True - , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing - , chk "NO doc formatting" _documentFormattingProvider Nothing + , chk "NO goto implementation" _implementationProvider (Just $ InL False) + , chk " find references" _referencesProvider (Just $ InL True) + , chk " doc highlight" _documentHighlightProvider (Just $ InL True) + , chk " doc symbol" _documentSymbolProvider (Just $ InL True) + , chk " workspace symbol" _workspaceSymbolProvider (Just True) + , chk " code action" _codeActionProvider (Just $ InL True) + , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) + , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) , chk "NO doc range formatting" - _documentRangeFormattingProvider Nothing + _documentRangeFormattingProvider (Just $ InL False) , chk "NO doc formatting on typing" - _documentOnTypeFormattingProvider Nothing - , chk "NO renaming" _renameProvider (Just $ RenameOptionsStatic False) - , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False) - , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False) + _documentOnTypeFormattingProvider Nothing + , chk "NO renaming" _renameProvider (Just $ InL False) + , chk "NO doc link" _documentLinkProvider Nothing + , chk "NO color" _colorProvider (Just $ InL False) + , chk "NO folding range" _foldingRangeProvider (Just $ InL False) , che " execute command" _executeCommandProvider [blockCommandId, extendImportCommandId, typeLensCommandId] - , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )})) - , chk "NO experimental" _experimental Nothing + , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) + , chk "NO experimental" _experimental Nothing ] where - tds = Just (TDSOptions (TextDocumentSyncOptions + tds = Just (InL (TextDocumentSyncOptions { _openClose = Just True , _change = Just TdSyncIncremental , _willSave = Nothing , _willSaveWaitUntil = Nothing - , _save = Just (SaveOptions {_includeText = Nothing})})) + , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) - chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree chk title getActual expected = testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir - che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree che title getActual expected = testCase title doTest where doTest = do @@ -181,15 +194,14 @@ initializeResponseTests = withResource acquire release tests where let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands + innerCaps :: ResponseMessage Initialize -> ServerCapabilities + innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" - innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner - innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c - innerCaps _ = error "this test only expects inner capabilities" - - acquire :: IO InitializeResponse + acquire :: IO (ResponseMessage Initialize) acquire = run initializeResponse - release :: InitializeResponse -> IO () + release :: ResponseMessage Initialize -> IO () release = const $ pure () @@ -209,8 +221,8 @@ diagnosticTests = testGroup "diagnostics" , testSessionWait "introduce syntax error" $ do let content = T.unlines [ "module Testing where" ] doc <- createDoc "Testing.hs" "haskell" content - void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest) - void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification) + void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate) + waitForProgressBegin let change = TextDocumentContentChangeEvent { _range = Just (Range (Position 0 15) (Position 0 18)) , _rangeLength = Nothing @@ -488,9 +500,8 @@ diagnosticTests = testGroup "diagnostics" in filePathToUri (joinDrive (lower drive) suffix) let itemA = TextDocumentItem uriA "haskell" 0 aContent let a = TextDocumentIdentifier uriA - sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA) - diagsNot <- skipManyTill anyMessage diagnostic - let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification) + sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA) + NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic -- Check that if we put a lower-case drive in for A.A -- the diagnostics for A.B will also be lower-case. liftIO $ fileUri @?= uriB @@ -728,7 +739,7 @@ watchedFilesTests = testGroup "watched files" [ testSession' "workspace files" $ \sessionDir -> do liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification + watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics -- Expect 1 subscription: we only ever send one liftIO $ length watchedFileRegs @?= 1 @@ -737,7 +748,7 @@ watchedFilesTests = testGroup "watched files" tmpDir <- liftIO getTemporaryDirectory liftIO $ writeFile (sessionDir "hie.yaml") ("cradle: {direct: {arguments: [\"-i" <> tmpDir <> "\", \"A\", \"WatchedFilesMissingModule\"]}}") _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification + watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics -- Expect 1 subscription: we only ever send one liftIO $ length watchedFileRegs @?= 1 @@ -804,7 +815,7 @@ renameActionTests = testGroup "rename actions" doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20)) - [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] + [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] executeCodeAction fixTypo contentAfterAction <- documentContents doc let expectedContentAfterAction = T.unlines @@ -827,7 +838,7 @@ typeWildCardActionTests = testGroup "type wildcard actions" doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands , "Use type signature" `T.isInfixOf` actionTitle ] executeCodeAction addSignature @@ -847,7 +858,7 @@ typeWildCardActionTests = testGroup "type wildcard actions" doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands , "Use type signature" `T.isInfixOf` actionTitle ] executeCodeAction addSignature @@ -870,7 +881,7 @@ typeWildCardActionTests = testGroup "type wildcard actions" doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands , "Use type signature" `T.isInfixOf` actionTitle ] executeCodeAction addSignature @@ -1102,7 +1113,7 @@ removeImportTests = testGroup "remove import actions" ] where caWithTitle t = \case - CACodeAction a@CodeAction{_title} -> guard (_title == t) >> Just a + InR a@CodeAction{_title} -> guard (_title == t) >> Just a _ -> Nothing extendImportTests :: TestTree @@ -1358,7 +1369,7 @@ extendImportTests = testGroup "extend import actions" codeActionTitle CodeAction{_title=x} = x template setUpModules moduleUnderTest range expectedTitles expectedContentB = do - sendNotification WorkspaceDidChangeConfiguration + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams $ toJSON def{checkProject = overrideCheckProject}) @@ -1366,12 +1377,12 @@ extendImportTests = testGroup "extend import actions" mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) _ <- waitForDiagnostics - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + waitForProgressDone actionsOrCommands <- getCodeActions docB range let codeActions = filter (T.isPrefixOf "Add" . codeActionTitle) - [ca | CACodeAction ca <- actionsOrCommands] + [ca | InR ca <- actionsOrCommands] actualTitles = codeActionTitle <$> codeActions -- Note that we are not testing the order of the actions, as the -- order of the expected actions indicates which one we'll execute @@ -1461,7 +1472,7 @@ suggestImportTests = testGroup "suggest import actions" cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}" liftIO $ writeFileUTF8 (dir "hie.yaml") cradle doc <- createDoc "Test.hs" "haskell" before - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + waitForProgressDone _diags <- waitForDiagnostics -- there isn't a good way to wait until the whole project is checked atm when waitForCheckProject $ liftIO $ sleep 0.5 @@ -1475,7 +1486,7 @@ suggestImportTests = testGroup "suggest import actions" contentAfterAction <- documentContents doc liftIO $ after @=? contentAfterAction else - liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= [] + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= [] suggestImportDisambiguationTests :: TestTree suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions" @@ -1525,13 +1536,13 @@ suggestImportDisambiguationTests = testGroup "suggest import disambiguation acti assertBool "EVec.fromList must not be suggested" $ "Replace with qualified: EVec.fromList" `notElem` [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions + | InR CodeAction { _title = actionTitle } <- actions ] liftIO $ assertBool "EVec.++ must not be suggested" $ "Replace with qualified: EVec.++" `notElem` [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions + | InR CodeAction { _title = actionTitle } <- actions ] , testGroup "fromList" [ testCase "EVec" $ @@ -1578,8 +1589,7 @@ suggestImportDisambiguationTests = testGroup "suggest import disambiguation acti liftIO $ mapM_ (\fp -> copyFile (hidingDir fp) $ dir fp) $ file : auxFiles doc <- openDoc file "haskell" - void (skipManyTill anyMessage message - :: Session WorkDoneProgressEndNotification) + waitForProgressDone void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] contents <- documentContents doc let range = Range (Position 0 0) (Position (length $ T.lines contents) 0) @@ -1744,7 +1754,7 @@ suggestHideShadowTests = liftIO $ cas @?= [] testMultiCodeActions testName actionNames start end origin expected = helper testName start end origin expected $ \cas -> do - let r = [ca | (CACodeAction ca) <- cas, ca ^. L.title `elem` actionNames] + let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames] liftIO $ (length r == length actionNames) @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset" @@ -1754,9 +1764,9 @@ suggestHideShadowTests = void $ createDoc "C.hs" "haskell" $ T.unlines docC doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) void waitForDiagnostics - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + waitForProgressDone cas <- getCodeActions doc (Range (Position (line1 + length header) col1) (Position (line2 + length header) col2)) - void $ k [x | x@(CACodeAction ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] + void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] contentAfter <- documentContents doc liftIO $ contentAfter @?= T.unlines (header <> expected) header = @@ -1822,8 +1832,8 @@ disableWarningTests = liftIO $ expectedContent @=? contentAfterAction where caResultToCodeAct = \case - CACommand _ -> Nothing - CACodeAction c -> Just c + InL _ -> Nothing + InR c -> Just c insertNewDefinitionTests :: TestTree insertNewDefinitionTests = testGroup "insert new definition actions" @@ -1839,8 +1849,8 @@ insertNewDefinitionTests = testGroup "insert new definition actions" ] docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') _ <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions docB (R 1 0 1 50) liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" executeCodeAction action @@ -1863,8 +1873,8 @@ insertNewDefinitionTests = testGroup "insert new definition actions" ] docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') _ <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions docB (R 1 0 1 50) liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" executeCodeAction action @@ -2181,8 +2191,8 @@ fixConstructorImportTests = testGroup "fix import actions" _docA <- createDoc "ModuleA.hs" "haskell" contentA docB <- createDoc "ModuleB.hs" "haskell" contentB _diags <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions docB range liftIO $ expectedAction @=? actionTitle executeCodeAction action @@ -2201,7 +2211,7 @@ importRenameActionTests = testGroup "import rename actions" doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16)) - let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] + let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] executeCodeAction changeToMap contentAfterAction <- documentContents doc let expectedContentAfterAction = T.unlines @@ -2580,7 +2590,7 @@ removeRedundantConstraintsTests = let $ all isDisableWarningAction actionsOrCommands where isDisableWarningAction = \case - CACodeAction CodeAction{_title} -> "Disable" `T.isPrefixOf` _title && "warnings" `T.isSuffixOf` _title + InR CodeAction{_title} -> "Disable" `T.isPrefixOf` _title && "warnings" `T.isSuffixOf` _title _ -> False in testGroup "remove redundant function constraints" @@ -2911,7 +2921,7 @@ exportTemplate mRange initialContent expectedAction expectedContents = do contentAfterAction <- documentContents doc liftIO $ content @=? contentAfterAction Nothing -> - liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == expectedAction ] @?= [] + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= [] removeExportTests :: TestTree removeExportTests = testGroup "remove export actions" @@ -3105,7 +3115,7 @@ addSigLensesTests = let doc <- createDoc "Sigs.hs" "haskell" originalCode [CodeLens {_command = Just c}] <- getCodeLenses doc executeCommand c - modifiedCode <- getDocumentEdit doc + modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) liftIO $ expectedCode @=? modifiedCode in testGroup "add signature" @@ -3125,9 +3135,11 @@ addSigLensesTests = let ] ] -checkDefs :: [Location] -> Session [Expect] -> Session () -checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where +linkToLocation :: [LocationLink] -> [Location] +linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) +checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session () +checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where check (ExpectRange expectedRange) = do assertNDefinitionsFound 1 defs assertRangeCorrect (head defs) expectedRange @@ -3154,6 +3166,7 @@ canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> findDefinitionAndHoverTests :: TestTree findDefinitionAndHoverTests = let + tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> Session [Expect] -> String -> TestTree tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do -- Dirty the cache to check that definitions work even in the presence of iface files @@ -3165,7 +3178,7 @@ findDefinitionAndHoverTests = let closeDoc fooDoc doc <- openTestDataDoc (dir sourceFilePath) - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + waitForProgressDone found <- get doc pos check found targetRange @@ -3622,7 +3635,7 @@ completionCommandTest :: completionCommandTest name src pos wanted expected = testSession name $ do docId <- createDoc "A.hs" "haskell" (T.unlines src) _ <- waitForDiagnostics - compls <- getCompletions docId pos + compls <- skipManyTill anyMessage (getCompletions docId pos) let wantedC = find ( \case CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x _ -> False @@ -3635,10 +3648,10 @@ completionCommandTest name src pos wanted expected = testSession name $ do executeCommand c if src /= expected then do - modifiedCode <- getDocumentEdit docId + modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) liftIO $ modifiedCode @?= T.unlines expected else do - expectMessages @ApplyWorkspaceEditRequest 1 $ \edit -> + expectMessages SWorkspaceApplyEdit 1 $ \edit -> liftIO $ assertFailure $ "Expected no edit but got: " <> show edit completionNoCommandTest :: @@ -3986,7 +3999,7 @@ highlightTests = testGroup "highlight" doc <- createDoc "A.hs" "haskell" source _ <- waitForDiagnostics highlights <- getHighlights doc (Position 3 2) - liftIO $ highlights @?= + liftIO $ highlights @?= List [ DocumentHighlight (R 2 0 2 3) (Just HkRead) , DocumentHighlight (R 3 0 3 3) (Just HkWrite) , DocumentHighlight (R 4 6 4 9) (Just HkRead) @@ -3996,7 +4009,7 @@ highlightTests = testGroup "highlight" doc <- createDoc "A.hs" "haskell" source _ <- waitForDiagnostics highlights <- getHighlights doc (Position 2 8) - liftIO $ highlights @?= + liftIO $ highlights @?= List [ DocumentHighlight (R 2 7 2 10) (Just HkRead) , DocumentHighlight (R 3 11 3 14) (Just HkRead) ] @@ -4004,7 +4017,7 @@ highlightTests = testGroup "highlight" doc <- createDoc "A.hs" "haskell" source _ <- waitForDiagnostics highlights <- getHighlights doc (Position 6 5) - liftIO $ highlights @?= + liftIO $ highlights @?= List [ DocumentHighlight (R 6 4 6 7) (Just HkWrite) , DocumentHighlight (R 6 10 6 13) (Just HkRead) , DocumentHighlight (R 7 12 7 15) (Just HkRead) @@ -4013,7 +4026,7 @@ highlightTests = testGroup "highlight" doc <- createDoc "A.hs" "haskell" recsource _ <- waitForDiagnostics highlights <- getHighlights doc (Position 4 15) - liftIO $ highlights @?= + liftIO $ highlights @?= List -- Span is just the .. on 8.10, but Rec{..} before #if MIN_GHC_API_VERSION(8,10,0) [ DocumentHighlight (R 4 8 4 10) (Just HkWrite) @@ -4023,7 +4036,7 @@ highlightTests = testGroup "highlight" , DocumentHighlight (R 4 14 4 20) (Just HkRead) ] highlights <- getHighlights doc (Position 3 17) - liftIO $ highlights @?= + liftIO $ highlights @?= List [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) -- Span is just the .. on 8.10, but Rec{..} before #if MIN_GHC_API_VERSION(8,10,0) @@ -4347,13 +4360,13 @@ loadCradleOnlyonce = testGroup "load cradle only once" implicit dir = test dir test _dir = do doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" - msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) + msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) liftIO $ length msgs @?= 1 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) liftIO $ length msgs @?= 0 _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) liftIO $ length msgs @?= 0 retryFailedCradle :: TestTree @@ -4432,7 +4445,7 @@ dependentFileTest = testGroup "addDependentFile" cradleLoadedMessage :: Session FromServerMessage cradleLoadedMessage = satisfy $ \case - NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod + FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod _ -> False cradleLoadedMethod :: T.Text @@ -4553,7 +4566,7 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d -- Change y from Int to B changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] -- save so that we can that the error propogates to A - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams bdoc) + sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) -- Check that the error propogates to A expectDiagnostics @@ -4561,10 +4574,11 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d -- Check that we wrote the interfaces for B when we saved - lid <- sendRequest (CustomClientMethod "hidir") $ GetInterfaceFilesDir bPath - res <- skipManyTill anyMessage $ responseForId lid + let m = SCustomMethod "test" + lid <- sendRequest m $ toJSON $ GetInterfaceFilesDir bPath + res <- skipManyTill anyMessage $ responseForId m lid liftIO $ case res of - ResponseMessage{_result=Right hidir} -> do + ResponseMessage{_result=Right (A.fromJSON -> A.Success hidir)} -> do hi_exists <- doesFileExist $ hidir "B.hi" assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res @@ -4730,8 +4744,8 @@ asyncTests = testGroup "async" [ testSession "command" $ do -- Execute a command that will block forever - let req = ExecuteCommandParams blockCommandId Nothing Nothing - void $ sendRequest WorkspaceExecuteCommand req + let req = ExecuteCommandParams Nothing blockCommandId Nothing + void $ sendRequest SWorkspaceExecuteCommand req -- Load a file and check for code actions. Will only work if the command is run asynchronously doc <- createDoc "A.hs" "haskell" $ T.unlines [ "{-# OPTIONS -Wmissing-signatures #-}" @@ -4739,13 +4753,13 @@ asyncTests = testGroup "async" ] void waitForDiagnostics actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0)) - liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? + liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? [ "add signature: foo :: a -> a" , "Disable \"missing-signatures\" warnings" ] , testSession "request" $ do -- Execute a custom request that will block for 1000 seconds - void $ sendRequest (CustomClientMethod "test") $ BlockSeconds 1000 + void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000 -- Load a file and check for code actions. Will only work if the request is run asynchronously doc <- createDoc "A.hs" "haskell" $ T.unlines [ "{-# OPTIONS -Wmissing-signatures #-}" @@ -4753,7 +4767,7 @@ asyncTests = testGroup "async" ] void waitForDiagnostics actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0)) - liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? + liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? [ "add signature: foo :: a -> a" , "Disable \"missing-signatures\" warnings" ] @@ -4763,13 +4777,14 @@ asyncTests = testGroup "async" clientSettingsTest :: TestTree clientSettingsTest = testGroup "client settings handling" [ testSession "ghcide restarts shake session on config changes" $ do - void $ skipManyTill anyMessage $ message @RegisterCapabilityRequest - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) + void $ skipManyTill anyMessage $ message SClientRegisterCapability + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) nots <- skipManyTill anyMessage $ count 3 loggingNotification isMessagePresent "Restarting build session" (map getLogMessage nots) ] - where getLogMessage (NotLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg + where getLogMessage :: FromServerMessage -> T.Text + getLogMessage (FromServerMess SWindowLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg getLogMessage _ = "" isMessagePresent expectedMsg actualMsgs = liftIO $ @@ -4897,7 +4912,7 @@ data IncludeDeclaration = YesIncludeDeclaration | NoExcludeDeclaration -getReferences' :: SymbolLocation -> IncludeDeclaration -> Session [Location] +getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location) getReferences' (file, l, c) includeDeclaration = do doc <- openDoc file "haskell" getReferences doc (Position l c) $ toBool includeDeclaration @@ -4910,10 +4925,11 @@ referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "reference -- Initial Index docid <- openDoc thisDoc "haskell" let + loop :: [FilePath] -> Session () loop [] = pure () loop docs = do doc <- skipManyTill anyMessage $ satisfyMaybe $ \case - NotCustomServer (NotificationMessage _ (CustomServerMethod "ghcide/reference/ready") fp) -> do + FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do A.Success fp' <- pure $ fromJSON fp find (fp' ==) docs _ -> Nothing @@ -4927,7 +4943,7 @@ referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "reference referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree referenceTest name loc includeDeclaration expected = referenceTestSession name (fst3 loc) docs $ \dir -> do - actual <- getReferences' loc includeDeclaration + List actual <- getReferences' loc includeDeclaration liftIO $ actual `expectSameLocations` map (first3 (dir )) expected where docs = map fst3 expected @@ -4970,18 +4986,18 @@ testSessionWait name = testSession name . -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. ( >> expectNoMoreDiagnostics 0.5) -pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction +pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> IO CodeAction pickActionWithTitle title actions = do assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches) return $ head matches where titles = [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions + | InR CodeAction { _title = actionTitle } <- actions ] matches = [ action - | CACodeAction action@CodeAction { _title = actionTitle } <- actions + | InR action@CodeAction { _title = actionTitle } <- actions , title == actionTitle ] @@ -5063,12 +5079,12 @@ findCodeActions' op errMsg doc range expectedTitles = do let matches = sequence [ listToMaybe [ action - | CACodeAction action@CodeAction { _title = actionTitle } <- actions + | InR action@CodeAction { _title = actionTitle } <- actions , expectedTitle `op` actionTitle] | expectedTitle <- expectedTitles] let msg = show [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions + | InR CodeAction { _title = actionTitle } <- actions ] ++ " " <> errMsg <> " " ++ show expectedTitles @@ -5284,13 +5300,13 @@ nthLine i r | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r) | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r -getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value] -getWatchedFilesSubscriptionsUntil = do - msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end) +getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] +getWatchedFilesSubscriptionsUntil m = do + msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m) return [ args | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs - , Registration _id WorkspaceDidChangeWatchedFiles args <- regs + , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs ] -- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index b473105543..22ae46da46 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -2,6 +2,8 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} module Development.IDE.Test ( Cursor @@ -20,6 +22,7 @@ module Development.IDE.Test , waitForAction ) where +import qualified Data.Aeson as A import Control.Applicative.Combinators import Control.Lens hiding (List) import Control.Monad @@ -27,18 +30,15 @@ import Control.Monad.IO.Class import Data.Bifunctor (second) import qualified Data.Map.Strict as Map import qualified Data.Text as T -import Language.Haskell.LSP.Test hiding (message) -import qualified Language.Haskell.LSP.Test as LspTest -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens as Lsp +import Language.LSP.Test hiding (message) +import qualified Language.LSP.Test as LspTest +import Language.LSP.Types +import Language.LSP.Types.Lens as Lsp import System.Time.Extra import Test.Tasty.HUnit import System.Directory (canonicalizePath) import Data.Maybe (fromJust) -import Development.IDE.Plugin.Test (WaitForIdeRuleResult, TestRequest(WaitForIdeRule)) -import Data.Aeson (FromJSON) -import Data.Typeable (Typeable) - +import Development.IDE.Plugin.Test (WaitForIdeRuleResult, TestRequest(..)) -- | (0-based line number, 0-based column number) type Cursor = (Int, Int) @@ -70,7 +70,7 @@ requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) -- if any diagnostic messages arrive in that period expectNoMoreDiagnostics :: Seconds -> Session () expectNoMoreDiagnostics timeout = - expectMessages @PublishDiagnosticsNotification timeout $ \diagsNot -> do + expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do let fileUri = diagsNot ^. params . uri actual = diagsNot ^. params . diagnostics liftIO $ @@ -79,31 +79,29 @@ expectNoMoreDiagnostics timeout = <> " got " <> show actual -expectMessages :: (FromJSON msg, Typeable msg) => Seconds -> (msg -> Session ()) -> Session () -expectMessages timeout handle = do +expectMessages :: SMethod m -> Seconds -> (ServerMessage m -> Session ()) -> Session () +expectMessages m timeout handle = do -- Give any further diagnostic messages time to arrive. liftIO $ sleep timeout -- Send a dummy message to provoke a response from the server. -- This guarantees that we have at least one message to -- process, so message won't block or timeout. - void $ sendRequest (CustomClientMethod "non-existent-method") () - handleMessages + let cm = SCustomMethod "test" + i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount + go cm i where - handleMessages = (LspTest.message >>= handle) <|> handleCustomMethodResponse <|> ignoreOthers - ignoreOthers = void anyMessage >> handleMessages - -handleCustomMethodResponse :: Session () -handleCustomMethodResponse = - -- the CustomClientMethod triggers a RspCustomServer - -- handle that and then exit - void (LspTest.message :: Session CustomResponse) + go cm i = handleMessages + where + handleMessages = (LspTest.message m >>= handle) <|> (void $ responseForId cm i) <|> ignoreOthers + ignoreOthers = void anyMessage >> handleMessages flushMessages :: Session () flushMessages = do - void $ sendRequest (CustomClientMethod "non-existent-method") () - handleCustomMethodResponse <|> ignoreOthers + let cm = SCustomMethod "non-existent-method" + i <- sendRequest cm A.Null + void (responseForId cm i) <|> ignoreOthers cm i where - ignoreOthers = void anyMessage >> flushMessages + ignoreOthers cm i = skipManyTill anyMessage (responseForId cm i) >> flushMessages -- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics, -- only that existing diagnostics have been cleared. @@ -115,7 +113,7 @@ expectDiagnostics = expectDiagnosticsWithTags . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) -unwrapDiagnostic :: PublishDiagnosticsNotification -> (Uri, List Diagnostic) +unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics -> (Uri, List Diagnostic) unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) expectDiagnosticsWithTags :: [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () @@ -180,8 +178,8 @@ checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do canonicalizeUri :: Uri -> IO Uri canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) -diagnostic :: Session PublishDiagnosticsNotification -diagnostic = LspTest.message +diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) +diagnostic = LspTest.message STextDocumentPublishDiagnostics standardizeQuotes :: T.Text -> T.Text standardizeQuotes msg = let @@ -193,6 +191,11 @@ standardizeQuotes msg = let waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) waitForAction key TextDocumentIdentifier{_uri} = do - waitId <- sendRequest (CustomClientMethod "test") (WaitForIdeRule key _uri) - ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId waitId - return _result + let cm = SCustomMethod "test" + waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri) + ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId + return $ do + e <- _result + case A.fromJSON e of + A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing + A.Success a -> pure a diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 9eb9f0ef69..49fbd7cc40 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -66,7 +66,7 @@ library , ghc , ghcide >=0.7.5 , gitrev - , haskell-lsp ^>=0.23 + , lsp , hls-plugin-api >=0.7 , hie-bios , hiedb @@ -79,12 +79,13 @@ library , sqlite-simple , unordered-containers - ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing + ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror default-language: Haskell2010 + default-extensions: DataKinds, TypeOperators -- Plugin flags are designed for 'cabal install haskell-language-server': -- - Packaged plugins should be manual:False @@ -306,6 +307,7 @@ executable haskell-language-server -- disable idle GC -- increase nursery size "-with-rtsopts=-I0 -A128M" + -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror @@ -323,7 +325,7 @@ executable haskell-language-server , ghcide , hashable , haskell-language-server - , haskell-lsp ^>=0.23 + , lsp , hie-bios , hiedb , lens @@ -344,6 +346,7 @@ executable haskell-language-server include-dirs: include default-language: Haskell2010 + default-extensions: DataKinds, TypeOperators executable haskell-language-server-wrapper import: agpl, common-deps @@ -386,14 +389,14 @@ common hls-test-utils , blaze-markup , containers , data-default - , haskell-lsp + , lsp , hie-bios , hls-plugin-api >=0.6 , hslogger , hspec , hspec-core , lens - , lsp-test >=0.12.0.0 + , lsp-test == 0.13.0.0 , stm , tasty-expected-failure , tasty-hunit @@ -461,8 +464,9 @@ test-suite func-test Ide.Plugin.Tactic.TestTypes Ide.Plugin.Eval.Types + default-extensions: OverloadedStrings ghc-options: - -Wall -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N + -Wall -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror -Wredundant-constraints diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index d70ab59752..008c05c980 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -37,7 +37,7 @@ library , containers , data-default , Diff - , haskell-lsp ^>=0.23 + , lsp ^>=1.1.0 , hashable , hslogger , lens @@ -46,6 +46,10 @@ library , shake >=0.17.5 , text , unordered-containers + , dependent-map + , dependent-sum + , dlist + , opentelemetry if os(windows) build-depends: @@ -54,9 +58,10 @@ library build-depends: unix - ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing + ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror default-language: Haskell2010 + default-extensions: DataKinds, KindSignatures, TypeOperators diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index ef3b799d37..9ae6ac16e5 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -6,9 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Ide.Plugin.Config - ( - getInitialConfig - , getConfigFromNotification + ( getConfigFromNotification , Config(..) , parseConfig , PluginConfig(..) @@ -21,7 +19,6 @@ import qualified Data.Aeson.Types as A import Data.Aeson hiding ( Error ) import Data.Default import qualified Data.Text as T -import Language.Haskell.LSP.Types import qualified Data.Map as Map import GHC.Generics (Generic) @@ -29,21 +26,12 @@ import GHC.Generics (Generic) -- | Given a DidChangeConfigurationNotification message, this function returns the parsed -- Config object if possible. -getConfigFromNotification :: Config -> DidChangeConfigurationNotification -> Either T.Text Config -getConfigFromNotification defaultValue (NotificationMessage _ _ (DidChangeConfigurationParams p)) = +getConfigFromNotification :: Config -> A.Value -> Either T.Text Config +getConfigFromNotification defaultValue p = case A.parse (parseConfig defaultValue) p of A.Success c -> Right c A.Error err -> Left $ T.pack err --- | Given an InitializeRequest message, this function returns the parsed --- Config object if possible. Otherwise, it returns the default configuration -getInitialConfig :: Config -> InitializeRequest -> Either T.Text Config -getInitialConfig defaultValue (RequestMessage _ _ _ InitializeParams{_initializationOptions = Nothing }) = Right defaultValue -getInitialConfig defaultValue (RequestMessage _ _ _ InitializeParams{_initializationOptions = Just opts}) = - case A.parse (parseConfig defaultValue) opts of - A.Success c -> Right c - A.Error err -> Left $ T.pack err - -- --------------------------------------------------------------------- data CheckParents -- Note that ordering of constructors is meaningful and must be monotonically @@ -55,7 +43,6 @@ data CheckParents deriving stock (Eq, Ord, Show, Generic) deriving anyclass (FromJSON, ToJSON) - -- | We (initially anyway) mirror the hie configuration, so that existing -- clients can simply switch executable and not have any nasty surprises. There -- will be surprises relating to config options being ignored, initially though. diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index f22be647b2..92da82629b 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} module Ide.PluginUtils ( WithDeletions(..), getProcessID, @@ -18,6 +18,7 @@ module Ide.PluginUtils fullRange, mkLspCommand, mkLspCmdId, + getPid, allLspCmdIds,allLspCmdIds',installSigUsr1Handler, subRange) where @@ -28,22 +29,14 @@ import qualified Data.HashMap.Strict as H import Data.Maybe import qualified Data.Text as T import Ide.Types -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as J -import Language.Haskell.LSP.Types.Capabilities - -#ifdef mingw32_HOST_OS -import qualified System.Win32.Process as P (getCurrentProcessId) -#else -import System.Posix.Signals -import qualified System.Posix.Process as P (getProcessID) -#endif -import qualified Data.Aeson as J +import Language.LSP.Types +import qualified Language.LSP.Types as J +import Language.LSP.Types.Capabilities + import qualified Data.Default import qualified Data.Map.Strict as Map import Ide.Plugin.Config -import qualified Language.Haskell.LSP.Core as LSP -import Control.Monad (void) +import Language.LSP.Server -- --------------------------------------------------------------------- @@ -129,7 +122,7 @@ diffText' supports (f,fText) f2Text withDeletions = where diff = diffTextEdit fText f2Text withDeletions h = H.singleton f diff - docChanges = J.List [docEdit] + docChanges = J.List [InL docEdit] docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) diff -- --------------------------------------------------------------------- @@ -139,7 +132,7 @@ clientSupportsDocumentChanges caps = let ClientCapabilities mwCaps _ _ _ = caps supports = do wCaps <- mwCaps - WorkspaceEditClientCapabilities mDc <- _workspaceEdit wCaps + WorkspaceEditClientCapabilities mDc _ _ <- _workspaceEdit wCaps mDc in fromMaybe False supports @@ -150,12 +143,6 @@ pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins --- --------------------------------------------------------------------- - -responseError :: T.Text -> ResponseError -responseError txt = ResponseError InvalidParams txt Nothing - - -- --------------------------------------------------------------------- -- | Returns the current client configuration. It is not wise to permanently -- cache the returned value of this function, as clients can at runitime change @@ -163,8 +150,8 @@ responseError txt = ResponseError InvalidParams txt Nothing -- -- If no custom configuration has been set by the client, this function returns -- our own defaults. -getClientConfig :: LSP.LspFuncs Config -> IO Config -getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf +getClientConfig :: MonadLsp Config m => m Config +getClientConfig = fromMaybe Data.Default.def <$> getConfig -- --------------------------------------------------------------------- @@ -174,22 +161,11 @@ getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf -- -- If no custom configuration has been set by the client, this function returns -- our own defaults. -getPluginConfig :: LSP.LspFuncs Config -> PluginId -> IO PluginConfig -getPluginConfig lf plugin = do - config <- getClientConfig lf +getPluginConfig :: MonadLsp Config m => PluginId -> m PluginConfig +getPluginConfig plugin = do + config <- getClientConfig return $ configForPlugin config plugin -configForPlugin :: Config -> PluginId -> PluginConfig -configForPlugin config (PluginId plugin) - = Map.findWithDefault Data.Default.def plugin (plugins config) - --- --------------------------------------------------------------------- - --- | Checks that a given plugin is both enabled and the specific feature is --- enabled -pluginEnabled :: PluginConfig -> (PluginConfig -> Bool) -> Bool -pluginEnabled pluginConfig f = plcGlobalOn pluginConfig && f pluginConfig - -- --------------------------------------------------------------------- extractRange :: Range -> T.Text -> T.Text @@ -242,32 +218,3 @@ allLspCmdIds pid commands = concat $ map go commands where go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds -mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command -mkLspCommand plid cn title args' = do - pid <- getPid - let cmdId = mkLspCmdId pid plid cn - let args = List <$> args' - return $ Command title cmdId args - -mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text -mkLspCmdId pid (PluginId plid) (CommandId cid) - = pid <> ":" <> plid <> ":" <> cid - --- | Get the operating system process id for the running server --- instance. This should be the same for the lifetime of the instance, --- and different from that of any other currently running instance. -getPid :: IO T.Text -getPid = T.pack . show <$> getProcessID - -getProcessID :: IO Int -installSigUsr1Handler :: IO () -> IO () - -#ifdef mingw32_HOST_OS -getProcessID = fromIntegral <$> P.getCurrentProcessId -installSigUsr1Handler _ = return () - -#else -getProcessID = fromIntegral <$> P.getProcessID - -installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing -#endif diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index ed083fcf60..f99ab309c0 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -1,40 +1,55 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} module Ide.Types - ( - IdePlugins(..) - , PluginDescriptor(..) - , defaultPluginDescriptor - , PluginCommand(..) - , PluginId(..) - , CommandId(..) - , DiagnosticProvider(..) - , DiagnosticProviderFunc(..) - , SymbolsProvider - , FormattingType(..) - , FormattingProvider - , noneProvider - , HoverProvider - , CodeActionProvider - , CodeLensProvider - , CommandFunction - , ExecuteCommandProvider - , CompletionProvider - , RenameProvider - , WithSnippets(..) - ) where - + where + +#ifdef mingw32_HOST_OS +import qualified System.Win32.Process as P (getCurrentProcessId) +#else +import System.Posix.Signals +import qualified System.Posix.Process as P (getProcessID) +#endif import Data.Aeson hiding (defaultOptions) +import GHC.Generics import qualified Data.Map as Map -import qualified Data.Set as S import Data.String import qualified Data.Text as T -import Development.Shake +import Development.Shake hiding (command) import Ide.Plugin.Config -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Types +import Language.LSP.Types +import Language.LSP.VFS +import Language.LSP.Types.Lens as J hiding (id) +import Language.LSP.Types.Capabilities +import Language.LSP.Server (LspM, getVirtualFile) import Text.Regex.TDFA.Text() +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.List.NonEmpty (NonEmpty(..), toList) +import Data.GADT.Compare +import Data.Maybe +import Data.Semigroup +import Control.Lens ((^.)) +import qualified Data.DList as DList +import qualified Data.Default +import System.IO.Unsafe +import Control.Monad +import OpenTelemetry.Eventlog +import Data.Text.Encoding (encodeUtf8) -- --------------------------------------------------------------------- @@ -44,49 +59,169 @@ newtype IdePlugins ideState = IdePlugins -- --------------------------------------------------------------------- data PluginDescriptor ideState = - PluginDescriptor { pluginId :: !PluginId - , pluginRules :: !(Rules ()) - , pluginCommands :: ![PluginCommand ideState] - , pluginCodeActionProvider :: !(Maybe (CodeActionProvider ideState)) - , pluginCodeLensProvider :: !(Maybe (CodeLensProvider ideState)) - , pluginDiagnosticProvider :: !(Maybe DiagnosticProvider) - -- ^ TODO: diagnostics are generally provided via rules, - -- this is probably redundant. - , pluginHoverProvider :: !(Maybe (HoverProvider ideState)) - , pluginSymbolsProvider :: !(Maybe (SymbolsProvider ideState)) - , pluginFormattingProvider :: !(Maybe (FormattingProvider ideState IO)) - , pluginCompletionProvider :: !(Maybe (CompletionProvider ideState)) - , pluginRenameProvider :: !(Maybe (RenameProvider ideState)) + PluginDescriptor { pluginId :: !PluginId + , pluginRules :: !(Rules ()) + , pluginCommands :: ![PluginCommand ideState] + , pluginHandlers :: PluginHandlers ideState } +-- | Methods that can be handled by plugins. +-- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method +-- Only methods for which we know how to combine responses can be instances of 'PluginMethod' +class HasTracing (MessageParams m) => PluginMethod m where + + -- | Parse the configuration to check if this plugin is enabled + pluginEnabled :: SMethod m -> PluginId -> Config -> Bool + + -- | How to combine responses from different plugins + combineResponses + :: SMethod m + -> Config -- ^ IDE Configuration + -> ClientCapabilities + -> MessageParams m + -> NonEmpty (ResponseResult m) -> ResponseResult m + + default combineResponses :: Semigroup (ResponseResult m) + => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m + combineResponses _method _config _caps _params = sconcat + +instance PluginMethod TextDocumentCodeAction where + pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn + combineResponses _method _config (ClientCapabilities _ textDocCaps _ _) (CodeActionParams _ _ _ _ context) resps = + fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps + where + + compat :: (Command |? CodeAction) -> (Command |? CodeAction) + compat x@(InL _) = x + compat x@(InR action) + | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport + = x + | otherwise = InL cmd + where + cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams) + cmdParams = [toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))] + + wasRequested :: (Command |? CodeAction) -> Bool + wasRequested (InL _) = True + wasRequested (InR ca) + | Nothing <- _only context = True + | Just (List allowed) <- _only context + , Just caKind <- ca ^. kind = caKind `elem` allowed + | otherwise = False + +instance PluginMethod TextDocumentCodeLens where + pluginEnabled _ = pluginEnabledConfig plcCodeLensOn +instance PluginMethod TextDocumentRename where + pluginEnabled _ = pluginEnabledConfig plcRenameOn +instance PluginMethod TextDocumentHover where + pluginEnabled _ = pluginEnabledConfig plcHoverOn + combineResponses _ _ _ _ (catMaybes . toList -> hs) = h + where + r = listToMaybe $ mapMaybe (^. range) hs + h = case foldMap (^. contents) hs of + HoverContentsMS (List []) -> Nothing + hh -> Just $ Hover hh r + +instance PluginMethod TextDocumentDocumentSymbol where + pluginEnabled _ = pluginEnabledConfig plcSymbolsOn + combineResponses _ _ (ClientCapabilities _ tdc _ _) params xs = res + where + uri' = params ^. textDocument . uri + supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport) + dsOrSi = fmap toEither xs + res + | supportsHierarchy = InL $ sconcat $ fmap (either id (fmap siToDs)) dsOrSi + | otherwise = InR $ sconcat $ fmap (either (List . concatMap dsToSi) id) dsOrSi + siToDs (SymbolInformation name kind dep (Location _uri range) cont) + = DocumentSymbol name cont kind dep range range Nothing + dsToSi = go Nothing + go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation] + go parent ds = + let children' :: [SymbolInformation] + children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children)) + loc = Location uri' (ds ^. range) + name' = ds ^. name + si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent + in [si] <> children' + +instance PluginMethod TextDocumentCompletion where + pluginEnabled _ = pluginEnabledConfig plcCompletionOn + combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs + where + limit = maxCompletions conf + combine :: [List CompletionItem |? CompletionList] -> ((List CompletionItem) |? CompletionList) + combine cs = go True mempty cs + + go !comp acc [] = + InR (CompletionList comp (List $ DList.toList acc)) + go comp acc (InL (List ls) : rest) = + go comp (acc <> DList.fromList ls) rest + go comp acc (InR (CompletionList comp' (List ls)) : rest) = + go (comp && comp') (acc <> DList.fromList ls) rest + + -- boolean disambiguators + isCompleteResponse, isIncompleteResponse :: Bool + isIncompleteResponse = True + isCompleteResponse = False + + consumeCompletionResponse limit it@(InR (CompletionList _ (List xx))) = + case splitAt limit xx of + -- consumed all the items, return the result as is + (_, []) -> (limit - length xx, it) + -- need to crop the response, set the 'isIncomplete' flag + (xx', _) -> (0, InR (CompletionList isIncompleteResponse (List xx'))) + consumeCompletionResponse n (InL (List xx)) = + consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx))) + +instance PluginMethod TextDocumentFormatting where + pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid + combineResponses _ _ _ _ (x :| _) = x + +instance PluginMethod TextDocumentRangeFormatting where + pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid + combineResponses _ _ _ _ (x :| _) = x + +-- | Methods which have a PluginMethod instance +data IdeMethod (m :: Method FromClient Request) = PluginMethod m => IdeMethod (SMethod m) +instance GEq IdeMethod where + geq (IdeMethod a) (IdeMethod b) = geq a b +instance GCompare IdeMethod where + gcompare (IdeMethod a) (IdeMethod b) = gcompare a b + +-- | Combine handlers for the +newtype PluginHandler a (m :: Method FromClient Request) + = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))) + +newtype PluginHandlers a = PluginHandlers (DMap IdeMethod (PluginHandler a)) + +instance Semigroup (PluginHandlers a) where + (PluginHandlers a) <> (PluginHandlers b) = PluginHandlers $ DMap.unionWithKey go a b + where + go _ (PluginHandler f) (PluginHandler g) = PluginHandler $ \pid ide params -> + (<>) <$> f pid ide params <*> g pid ide params + +instance Monoid (PluginHandlers a) where + mempty = PluginHandlers mempty + +type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m)) + +-- | Make a handler for plugins with no extra data +mkPluginHandler + :: PluginMethod m + => SClientMethod m + -> PluginMethodHandler ideState m + -> PluginHandlers ideState +mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler f') + where + f' pid ide params = pure <$> f ide pid params + defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState defaultPluginDescriptor plId = PluginDescriptor plId mempty mempty - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - --- instance Show PluginCommand where --- show (PluginCommand i _ _) = "PluginCommand { name = " ++ show i ++ " }" - --- newtype CommandId = CommandId T.Text --- deriving (Show, Read, Eq, Ord) --- instance IsString CommandId where --- fromString = CommandId . T.pack - --- data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => --- PluginCommand { commandId :: CommandId --- , commandDesc :: T.Text --- , commandFunc :: a -> IO (Either ResponseError b) --- } + mempty newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord) @@ -99,107 +234,146 @@ data PluginCommand ideState = forall a. (FromJSON a) => , commandFunc :: CommandFunction ideState a } - -- --------------------------------------------------------------------- -type CommandFunction ideState a = LSP.LspFuncs Config - -> ideState - -> a - -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) +type CommandFunction ideState a + = ideState + -> a + -> LspM Config (Either ResponseError Value) -type CodeActionProvider ideState = LSP.LspFuncs Config - -> ideState - -> PluginId - -> TextDocumentIdentifier - -> Range - -> CodeActionContext - -> IO (Either ResponseError (List CAResult)) +newtype WithSnippets = WithSnippets Bool + +-- --------------------------------------------------------------------- + +newtype PluginId = PluginId T.Text + deriving (Show, Read, Eq, Ord) +instance IsString PluginId where + fromString = PluginId . T.pack -type CompletionProvider ideState = LSP.LspFuncs Config - -> ideState - -> CompletionParams - -> IO (Either ResponseError CompletionResponseResult) +configForPlugin :: Config -> PluginId -> PluginConfig +configForPlugin config (PluginId plugin) + = Map.findWithDefault Data.Default.def plugin (plugins config) +-- | Checks that a given plugin is both enabled and the specific feature is +-- enabled +pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginId -> Config -> Bool +pluginEnabledConfig f pid config = plcGlobalOn pluginConfig && f pluginConfig + where + pluginConfig = configForPlugin config pid +-- --------------------------------------------------------------------- -type CodeLensProvider ideState = LSP.LspFuncs Config - -> ideState - -> PluginId - -> CodeLensParams - -> IO (Either ResponseError (List CodeLens)) +-- | Format the given Text as a whole or only a @Range@ of it. +-- Range must be relative to the text to format. +-- To format the whole document, read the Text from the file and use 'FormatText' +-- as the FormattingType. +data FormattingType = FormatText + | FormatRange Range -type RenameProvider ideState = LSP.LspFuncs Config - -> ideState - -> RenameParams - -> IO (Either ResponseError WorkspaceEdit) -type DiagnosticProviderFuncSync - = DiagnosticTrigger -> Uri - -> IO (Either ResponseError (Map.Map Uri (S.Set Diagnostic))) +type FormattingMethod m = + ( J.HasOptions (MessageParams m) FormattingOptions + , J.HasTextDocument (MessageParams m) TextDocumentIdentifier + , ResponseResult m ~ List TextEdit + ) + +type FormattingHandler a + = a + -> FormattingType + -> T.Text + -> NormalizedFilePath + -> FormattingOptions + -> LspM Config (Either ResponseError (List TextEdit)) + +mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a +mkFormattingHandlers f = mkPluginHandler STextDocumentFormatting (provider STextDocumentFormatting) + <> mkPluginHandler STextDocumentRangeFormatting (provider STextDocumentRangeFormatting) + where + provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m + provider m ide _pid params + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do + mf <- getVirtualFile $ toNormalizedUri uri + case mf of + Just vf -> do + let typ = case m of + STextDocumentFormatting -> FormatText + STextDocumentRangeFormatting -> FormatRange (params ^. J.range) + _ -> error "mkFormattingHandlers: impossible" + f ide typ (virtualFileText vf) nfp opts + Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri + + | otherwise = pure $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri + where + uri = params ^. J.textDocument . J.uri + opts = params ^. J.options -type DiagnosticProviderFuncAsync - = DiagnosticTrigger -> Uri - -> (Map.Map Uri (S.Set Diagnostic) -> IO ()) - -> IO (Either ResponseError ()) +-- --------------------------------------------------------------------- -data DiagnosticProviderFunc - = DiagnosticProviderSync DiagnosticProviderFuncSync - | DiagnosticProviderAsync DiagnosticProviderFuncAsync +responseError :: T.Text -> ResponseError +responseError txt = ResponseError InvalidParams txt Nothing +-- --------------------------------------------------------------------- -data DiagnosticProvider = DiagnosticProvider - { dpTrigger :: S.Set DiagnosticTrigger -- AZ:should this be a NonEmptyList? - , dpFunc :: DiagnosticProviderFunc - } +data FallbackCodeActionParams = + FallbackCodeActionParams + { fallbackWorkspaceEdit :: Maybe WorkspaceEdit + , fallbackCommand :: Maybe Command + } + deriving (Generic, ToJSON, FromJSON) -data DiagnosticTrigger = DiagnosticOnOpen - | DiagnosticOnChange - | DiagnosticOnSave - deriving (Show,Ord,Eq) +-- --------------------------------------------------------------------- --- type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover]) -type HoverProvider ideState = ideState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) +otSetUri :: SpanInFlight -> Uri -> IO () +otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t) -type SymbolsProvider ideState = LSP.LspFuncs Config - -> ideState - -> DocumentSymbolParams - -> IO (Either ResponseError [DocumentSymbol]) +class HasTracing a where + traceWithSpan :: SpanInFlight -> a -> IO () + traceWithSpan _ _ = pure () -type ExecuteCommandProvider ideState = ideState - -> ExecuteCommandParams - -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) +instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where + traceWithSpan sp a = otSetUri sp (a ^. J.textDocument . J.uri) -newtype WithSnippets = WithSnippets Bool +instance HasTracing Value +instance HasTracing ExecuteCommandParams +instance HasTracing DidChangeWatchedFilesParams +instance HasTracing DidChangeWorkspaceFoldersParams +instance HasTracing DidChangeConfigurationParams +instance HasTracing InitializeParams +instance HasTracing (Maybe InitializedParams) +instance HasTracing WorkspaceSymbolParams where + traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query) -- --------------------------------------------------------------------- -newtype PluginId = PluginId T.Text - deriving (Show, Read, Eq, Ord) -instance IsString PluginId where - fromString = PluginId . T.pack +{-# NOINLINE pROCESS_ID #-} +pROCESS_ID :: T.Text +pROCESS_ID = unsafePerformIO getPid --- --------------------------------------------------------------------- +mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command +mkLspCommand plid cn title args' = Command title cmdId args + where + cmdId = mkLspCmdId pROCESS_ID plid cn + args = List <$> args' +mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text +mkLspCmdId pid (PluginId plid) (CommandId cid) + = pid <> ":" <> plid <> ":" <> cid --- | Format the given Text as a whole or only a @Range@ of it. --- Range must be relative to the text to format. --- To format the whole document, read the Text from the file and use 'FormatText' --- as the FormattingType. -data FormattingType = FormatText - | FormatRange Range +-- | Get the operating system process id for the running server +-- instance. This should be the same for the lifetime of the instance, +-- and different from that of any other currently running instance. +getPid :: IO T.Text +getPid = T.pack . show <$> getProcessID + +getProcessID :: IO Int +installSigUsr1Handler :: IO () -> IO () + +#ifdef mingw32_HOST_OS +getProcessID = fromIntegral <$> P.getCurrentProcessId +installSigUsr1Handler _ = return () +#else +getProcessID = fromIntegral <$> P.getProcessID --- | To format a whole document, the 'FormatText' @FormattingType@ can be used. --- It is required to pass in the whole Document Text for that to happen, an empty text --- and file uri, does not suffice. -type FormattingProvider ideState m - = LSP.LspFuncs Config - -> ideState - -> FormattingType -- ^ How much to format - -> T.Text -- ^ Text to format - -> NormalizedFilePath -- ^ location of the file being formatted - -> FormattingOptions -- ^ Options for the formatter - -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting - -noneProvider :: FormattingProvider ideState IO -noneProvider _ _ _ _ _ _ = return $ Right (List []) +installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing +#endif diff --git a/plugins/default/src/Ide/Plugin/Brittany.hs b/plugins/default/src/Ide/Plugin/Brittany.hs index 37eedd18b0..e8ee6bd97e 100644 --- a/plugins/default/src/Ide/Plugin/Brittany.hs +++ b/plugins/default/src/Ide/Plugin/Brittany.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} module Ide.Plugin.Brittany where - + import Control.Exception (bracket_) import Control.Lens import Control.Monad.IO.Class @@ -9,14 +11,14 @@ import Data.Maybe (mapMaybe, maybeToList) import Data.Semigroup import Data.Text (Text) import qualified Data.Text as T -import Development.IDE +import Development.IDE hiding (pluginHandlers) import Development.IDE.GHC.Compat (topDir, ModSummary(ms_hspp_opts)) import qualified DynFlags as D import qualified EnumSet as S import GHC.LanguageExtensions.Type import Language.Haskell.Brittany -import Language.Haskell.LSP.Types as J -import qualified Language.Haskell.LSP.Types.Lens as J +import Language.LSP.Types as J +import qualified Language.LSP.Types.Lens as J import Ide.PluginUtils import Ide.Types import System.FilePath @@ -24,28 +26,26 @@ import System.Environment (setEnv, unsetEnv) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginFormattingProvider = Just provider + { pluginHandlers = mkFormattingHandlers provider } -- | Formatter provider of Brittany. -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. -provider - :: FormattingProvider IdeState IO -provider _lf ide typ contents nfp opts = do --- text uri formatType opts = pluginGetFile "brittanyCmd: " uri $ \fp -> do - confFile <- liftIO $ getConfFile nfp - let (range, selectedContents) = case typ of - FormatText -> (fullRange contents, contents) - FormatRange r -> (normalize r, extractRange r contents) - (modsum, _) <- runAction "brittany" ide $ use_ GetModSummary nfp - let dflags = ms_hspp_opts modsum - let withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key) - where key = "GHC_EXACTPRINT_GHC_LIBDIR" - res <- withRuntimeLibdir $ formatText dflags confFile opts selectedContents - case res of - Left err -> return $ Left $ responseError (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) - Right newText -> return $ Right $ J.List [TextEdit range newText] +provider :: FormattingHandler IdeState +provider ide typ contents nfp opts = liftIO $ do + confFile <- getConfFile nfp + let (range, selectedContents) = case typ of + FormatText -> (fullRange contents, contents) + FormatRange r -> (normalize r, extractRange r contents) + (modsum, _) <- runAction "brittany" ide $ use_ GetModSummary nfp + let dflags = ms_hspp_opts modsum + let withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key) + where key = "GHC_EXACTPRINT_GHC_LIBDIR" + res <- withRuntimeLibdir $ formatText dflags confFile opts selectedContents + case res of + Left err -> return $ Left $ responseError (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) + Right newText -> return $ Right $ J.List [TextEdit range newText] -- | Primitive to format text with the given option. -- May not throw exceptions but return a Left value. diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 3b2dc7555e..625d7ced56 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.Example ( @@ -29,8 +30,10 @@ import Development.IDE.Core.Shake (getDiagnostics, getHiddenDiagnostics) import GHC.Generics import Ide.PluginUtils import Ide.Types -import Language.Haskell.LSP.Types +import Language.LSP.Types +import Language.LSP.Server import Text.Regex.TDFA.Text() +import Control.Monad.IO.Class -- --------------------------------------------------------------------- @@ -38,17 +41,17 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginRules = exampleRules , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] - , pluginCodeActionProvider = Just codeAction - , pluginCodeLensProvider = Just codeLens - , pluginHoverProvider = Just hover - , pluginSymbolsProvider = Just symbols - , pluginCompletionProvider = Just completion + , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction + <> mkPluginHandler STextDocumentCodeLens codeLens + <> mkPluginHandler STextDocumentHover hover + <> mkPluginHandler STextDocumentDocumentSymbol symbols + <> mkPluginHandler STextDocumentCompletion completion } -- --------------------------------------------------------------------- -hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) -hover = request "Hover" blah (Right Nothing) foundHover +hover :: PluginMethodHandler IdeState TextDocumentHover +hover ide _ HoverParams{..} = liftIO $ request "Hover" blah (Right Nothing) foundHover ide TextDocumentPositionParams{..} blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) blah _ (Position line col) @@ -99,8 +102,8 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) -- --------------------------------------------------------------------- -- | Generate code actions. -codeAction :: CodeActionProvider IdeState -codeAction _lf state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do +codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction +codeAction state _pid (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs}) = liftIO $ do let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri Just (ParsedModule{},_) <- runIdeAction "example" (shakeExtras state) $ useWithStaleFast GetParsedModule nfp let @@ -109,12 +112,12 @@ codeAction _lf state _pid (TextDocumentIdentifier uri) _range CodeActionContext{ "-- TODO1 added by Example Plugin directly\n"] edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing pure $ Right $ List - [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] + [ InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) Nothing Nothing (Just edit) Nothing] -- --------------------------------------------------------------------- -codeLens :: CodeLensProvider IdeState -codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do +codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens +codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = liftIO $ do logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do @@ -128,7 +131,7 @@ codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier u -- edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing range = Range (Position 3 0) (Position 4 0) let cmdParams = AddTodoParams uri "do abc" - cmd <- mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams]) + cmd = mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams]) pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] Nothing -> pure $ Right $ List [] @@ -141,7 +144,7 @@ data AddTodoParams = AddTodoParams deriving (Show, Eq, Generic, ToJSON, FromJSON) addTodoCmd :: CommandFunction IdeState AddTodoParams -addTodoCmd _lf _ide (AddTodoParams uri todoText) = do +addTodoCmd _ide (AddTodoParams uri todoText) = do let pos = Position 3 0 textEdits = List @@ -151,7 +154,8 @@ addTodoCmd _lf _ide (AddTodoParams uri todoText) = do res = WorkspaceEdit (Just $ Map.singleton uri textEdits) Nothing - return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ()) + return $ Right Null -- --------------------------------------------------------------------- @@ -170,7 +174,7 @@ request -> IdeState -> TextDocumentPositionParams -> IO (Either ResponseError b) -request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do +request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do mbResult <- case uriToFilePath' uri of Just path -> logAndRunRequest label getResults ide pos path Nothing -> pure Nothing @@ -187,9 +191,9 @@ logAndRunRequest label getResults ide pos path = do -- --------------------------------------------------------------------- -symbols :: SymbolsProvider IdeState -symbols _lf _ide (DocumentSymbolParams _doc _mt) - = pure $ Right [r] +symbols :: PluginMethodHandler IdeState TextDocumentDocumentSymbol +symbols _ide _pid (DocumentSymbolParams _ _ _doc) + = pure $ Right $ InL $ List [r] where r = DocumentSymbol name detail kind deprecation range selR chList name = "Example_symbol_name" @@ -202,9 +206,9 @@ symbols _lf _ide (DocumentSymbolParams _doc _mt) -- --------------------------------------------------------------------- -completion :: CompletionProvider IdeState -completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) - = pure $ Right $ Completions $ List [r] +completion :: PluginMethodHandler IdeState TextDocumentCompletion +completion _ide _pid (CompletionParams _doc _pos _ _ _mctxt) + = pure $ Right $ InL $ List [r] where r = CompletionItem label kind tags detail documentation deprecated preselect sortText filterText insertText insertTextFormat diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs index 0c7f7a684c..b7f28779ce 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.Example2 ( @@ -28,8 +29,10 @@ import Development.IDE.Core.Shake import GHC.Generics import Ide.PluginUtils import Ide.Types -import Language.Haskell.LSP.Types +import Language.LSP.Types +import Language.LSP.Server import Text.Regex.TDFA.Text() +import Control.Monad.IO.Class -- --------------------------------------------------------------------- @@ -37,17 +40,17 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginRules = exampleRules , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] - , pluginCodeActionProvider = Just codeAction - , pluginCodeLensProvider = Just codeLens - , pluginHoverProvider = Just hover - , pluginSymbolsProvider = Just symbols - , pluginCompletionProvider = Just completion + , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction + <> mkPluginHandler STextDocumentCodeLens codeLens + <> mkPluginHandler STextDocumentHover hover + <> mkPluginHandler STextDocumentDocumentSymbol symbols + <> mkPluginHandler STextDocumentCompletion completion } -- --------------------------------------------------------------------- -hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) -hover = request "Hover" blah (Right Nothing) foundHover +hover :: PluginMethodHandler IdeState TextDocumentHover +hover ide _ HoverParams{..} = liftIO $ request "Hover" blah (Right Nothing) foundHover ide TextDocumentPositionParams{..} blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) blah _ (Position line col) @@ -98,20 +101,20 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) -- --------------------------------------------------------------------- -- | Generate code actions. -codeAction :: CodeActionProvider IdeState -codeAction _lf _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do +codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction +codeAction _state _pid (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs}) = do let title = "Add TODO2 Item" tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) "-- TODO2 added by Example2 Plugin directly\n"] edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing pure $ Right $ List - [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] + [ InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) Nothing Nothing (Just edit) Nothing ] -- --------------------------------------------------------------------- -codeLens :: CodeLensProvider IdeState -codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do +codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens +codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = liftIO $ do logInfo (ideLogger ideState) "Example2.codeLens entered (ideLogger)" -- AZ case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do @@ -122,7 +125,7 @@ codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier u title = "Add TODO2 Item via Code Lens" range = Range (Position 3 0) (Position 4 0) let cmdParams = AddTodoParams uri "do abc" - cmd <- mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams]) + cmd = mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams]) pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] Nothing -> pure $ Right $ List [] @@ -135,7 +138,7 @@ data AddTodoParams = AddTodoParams deriving (Show, Eq, Generic, ToJSON, FromJSON) addTodoCmd :: CommandFunction IdeState AddTodoParams -addTodoCmd _lf _ide (AddTodoParams uri todoText) = do +addTodoCmd _ide (AddTodoParams uri todoText) = do let pos = Position 5 0 textEdits = List @@ -145,7 +148,8 @@ addTodoCmd _lf _ide (AddTodoParams uri todoText) = do res = WorkspaceEdit (Just $ Map.singleton uri textEdits) Nothing - return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ()) + return $ Right Null -- --------------------------------------------------------------------- @@ -164,7 +168,7 @@ request -> IdeState -> TextDocumentPositionParams -> IO (Either ResponseError b) -request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do +request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do mbResult <- case uriToFilePath' uri of Just path -> logAndRunRequest label getResults ide pos path Nothing -> pure Nothing @@ -181,9 +185,9 @@ logAndRunRequest label getResults ide pos path = do -- --------------------------------------------------------------------- -symbols :: SymbolsProvider IdeState -symbols _lf _ide (DocumentSymbolParams _doc _mt) - = pure $ Right [r] +symbols :: PluginMethodHandler IdeState TextDocumentDocumentSymbol +symbols _ide _ (DocumentSymbolParams _ _ _doc) + = pure $ Right $ InL $ List [r] where r = DocumentSymbol name detail kind deprecation range selR chList name = "Example2_symbol_name" @@ -196,9 +200,9 @@ symbols _lf _ide (DocumentSymbolParams _doc _mt) -- --------------------------------------------------------------------- -completion :: CompletionProvider IdeState -completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) - = pure $ Right $ Completions $ List [r] +completion :: PluginMethodHandler IdeState TextDocumentCompletion +completion _ide _pid (CompletionParams _doc _pos _ _ _mctxt) + = pure $ Right $ InL $ List [r] where r = CompletionItem label kind tags detail documentation deprecated preselect sortText filterText insertText insertTextFormat diff --git a/plugins/default/src/Ide/Plugin/Floskell.hs b/plugins/default/src/Ide/Plugin/Floskell.hs index 24837400c6..711b373be3 100644 --- a/plugins/default/src/Ide/Plugin/Floskell.hs +++ b/plugins/default/src/Ide/Plugin/Floskell.hs @@ -11,18 +11,19 @@ where import qualified Data.ByteString.Lazy as BS import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Development.IDE as D +import Development.IDE as D hiding (pluginHandlers) import Floskell import Ide.PluginUtils import Ide.Types -import Language.Haskell.LSP.Types +import Language.LSP.Types import Text.Regex.TDFA.Text() +import Control.Monad.IO.Class -- --------------------------------------------------------------------- descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginFormattingProvider = Just provider + { pluginHandlers = mkFormattingHandlers provider } -- --------------------------------------------------------------------- @@ -30,8 +31,8 @@ descriptor plId = (defaultPluginDescriptor plId) -- | Format provider of Floskell. -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. -provider :: FormattingProvider IdeState IO -provider _lf _ideState typ contents fp _ = do +provider :: FormattingHandler IdeState +provider _ideState typ contents fp _ = liftIO $ do let file = fromNormalizedFilePath fp config <- findConfigOrDefault file let (range, selectedContents) = case typ of diff --git a/plugins/default/src/Ide/Plugin/Fourmolu.hs b/plugins/default/src/Ide/Plugin/Fourmolu.hs index 38ed809575..95c0943f4c 100644 --- a/plugins/default/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/default/src/Ide/Plugin/Fourmolu.hs @@ -15,37 +15,37 @@ import System.FilePath import Control.Lens ((^.)) import qualified Data.Text as T -import Development.IDE as D +import Development.IDE as D hiding (pluginHandlers) import qualified DynFlags as D import qualified EnumSet as S import GHC (DynFlags, moduleNameString) import GHC.LanguageExtensions.Type (Extension (Cpp)) import GhcPlugins (HscEnv (hsc_dflags)) -import Ide.PluginUtils (responseError, makeDiffTextEdit) -import Language.Haskell.LSP.Messages (FromServerMessage (ReqShowMessage)) +import Ide.PluginUtils (makeDiffTextEdit) import Ide.Types -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens +import Language.LSP.Server +import Language.LSP.Types +import Language.LSP.Types.Lens import "fourmolu" Ormolu +import Control.Monad.IO.Class -- --------------------------------------------------------------------- descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginFormattingProvider = Just provider + { pluginHandlers = mkFormattingHandlers provider } -- --------------------------------------------------------------------- -provider :: FormattingProvider IdeState IO -provider lf ideState typ contents fp fo = withIndefiniteProgress lf title Cancellable $ do - ghc <- runAction "Fourmolu" ideState $ use GhcSession fp +provider :: FormattingHandler IdeState +provider ideState typ contents fp fo = withIndefiniteProgress title Cancellable $ do + ghc <- liftIO $ runAction "Fourmolu" ideState $ use GhcSession fp fileOpts <- case hsc_dflags . hscEnv <$> ghc of Nothing -> return [] - Just df -> convertDynFlags df + Just df -> liftIO $ convertDynFlags df let format printerOpts = mapLeft (responseError . ("Fourmolu: " <>) . T.pack . show) @@ -62,29 +62,22 @@ provider lf ideState typ contents fp fo = withIndefiniteProgress lf title Cancel defaultPrinterOpts } - loadConfigFile fp' >>= \case - ConfigLoaded file opts -> do + liftIO (loadConfigFile fp') >>= \case + ConfigLoaded file opts -> liftIO $ do putStrLn $ "Loaded Fourmolu config from: " <> file format opts - ConfigNotFound searchDirs -> do + ConfigNotFound searchDirs -> liftIO $ do putStrLn . unlines $ ("No " ++ show configFileName ++ " found in any of:") : map (" " ++) searchDirs format mempty ConfigParseError f (_, err) -> do - sendFunc lf . ReqShowMessage $ - RequestMessage - { _jsonrpc = "" - , _id = IdString "fourmolu" - , _method = WindowShowMessageRequest - , _params = - ShowMessageRequestParams - { _xtype = MtError - , _message = errorMessage - , _actions = Nothing - } - } + sendNotification SWindowShowMessage $ + ShowMessageParams + { _xtype = MtError + , _message = errorMessage + } return . Left $ responseError errorMessage where errorMessage = "Failed to load " <> T.pack f <> ": " <> T.pack err diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs index d12d541acf..73eb27d160 100644 --- a/plugins/default/src/Ide/Plugin/ModuleName.hs +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-unused-imports -Wno-unticked-promoted-constructors #-} {- | Keep the module name in sync with its file path. @@ -15,6 +15,7 @@ module Ide.Plugin.ModuleName ( ) where import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad import Data.Aeson ( ToJSON (toJSON), Value (Null), @@ -57,32 +58,10 @@ import GHC ( unLoc, ) import Ide.PluginUtils (mkLspCmdId, getProcessID) -import Ide.Types ( - CommandFunction, - PluginCommand (..), - PluginDescriptor (..), - PluginId (..), - defaultPluginDescriptor, - ) -import Language.Haskell.LSP.Core ( - LspFuncs, - getVirtualFileFunc, - ) -import Language.Haskell.LSP.Types ( - ApplyWorkspaceEditParams (..), - CodeLens (CodeLens), - CodeLensParams (CodeLensParams), - Command (Command), - ServerMethod (..), - TextDocumentIdentifier ( - TextDocumentIdentifier - ), - TextEdit (TextEdit), - Uri, - WorkspaceEdit (..), - uriToNormalizedFilePath, - ) -import Language.Haskell.LSP.VFS (virtualFileText) +import Ide.Types +import Language.LSP.Server +import Language.LSP.Types +import Language.LSP.VFS (virtualFileText) import System.Directory (canonicalizePath) import System.FilePath ( dropExtension, @@ -94,7 +73,7 @@ import System.FilePath ( descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginCodeLensProvider = Just codeLens + { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLens , pluginCommands = [PluginCommand editCommandName editCommandName command] } @@ -109,25 +88,20 @@ asCodeLens cid Replace{..} = Nothing -- | Generate code lenses -codeLens :: - LspFuncs c -> - IdeState -> - PluginId -> - CodeLensParams -> - IO (Either a2 (List CodeLens)) -codeLens lsp state pluginId (CodeLensParams (TextDocumentIdentifier uri) _) = +codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens +codeLens state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do do - pid <- pack . show <$> getProcessID - Right . List . maybeToList . (asCodeLens (mkLspCmdId pid pluginId editCommandName) <$>) <$> action lsp state uri + pid <- liftIO $ pack . show <$> getProcessID + Right . List . maybeToList . (asCodeLens (mkLspCmdId pid pluginId editCommandName) <$>) <$> action state uri -- | (Quasi) Idempotent command execution: recalculate action to execute on command request command :: CommandFunction IdeState Uri -command lsp state uri = do - actMaybe <- action lsp state uri - return - ( Right Null - , (\act -> (WorkspaceApplyEdit, ApplyWorkspaceEditParams $ asEdit act)) <$> actMaybe - ) +command state uri = do + actMaybe <- action state uri + case actMaybe of + Nothing -> pure () + Just act -> void $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing (asEdit act)) (\_ -> pure ()) + return (Right Null) -- | A source code change data Action = Replace {aUri :: Uri, aRange :: Range, aTitle :: Text, aCode :: Text} deriving (Show) @@ -141,17 +115,17 @@ asTextEdits :: Action -> [TextEdit] asTextEdits Replace{..} = [TextEdit aRange aCode] -- | Required action (that can be converted to either CodeLenses or CodeActions) -action :: LspFuncs c -> IdeState -> Uri -> IO (Maybe Action) -action lsp state uri = +action :: IdeState -> Uri -> LspM c (Maybe Action) +action state uri = traceAs "action" <$> do let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri let Just fp = uriToFilePath' uri - contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri + contents <- getVirtualFile $ toNormalizedUri uri let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents - correctNameMaybe <- traceAs "correctName" <$> pathModuleName state nfp fp - statedNameMaybe <- traceAs "statedName" <$> codeModuleName state nfp + correctNameMaybe <- liftIO $ traceAs "correctName" <$> pathModuleName state nfp fp + statedNameMaybe <- liftIO $ traceAs "statedName" <$> codeModuleName state nfp let act = Replace uri let todo = case (correctNameMaybe, statedNameMaybe) of diff --git a/plugins/default/src/Ide/Plugin/Ormolu.hs b/plugins/default/src/Ide/Plugin/Ormolu.hs index f70175c385..bafee34f50 100644 --- a/plugins/default/src/Ide/Plugin/Ormolu.hs +++ b/plugins/default/src/Ide/Plugin/Ormolu.hs @@ -12,7 +12,7 @@ where import Control.Exception import qualified Data.Text as T -import Development.IDE +import Development.IDE hiding (pluginHandlers) import qualified DynFlags as D import qualified EnumSet as S import GHC @@ -20,24 +20,24 @@ import GHC.LanguageExtensions.Type import GhcPlugins (HscEnv (hsc_dflags)) import Ide.PluginUtils import Ide.Types -import Language.Haskell.LSP.Core (LspFuncs (withIndefiniteProgress), - ProgressCancellable (Cancellable)) -import Language.Haskell.LSP.Types +import Language.LSP.Server +import Language.LSP.Types import "ormolu" Ormolu import System.FilePath (takeFileName) import Text.Regex.TDFA.Text () +import Control.Monad.IO.Class -- --------------------------------------------------------------------- descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginFormattingProvider = Just provider + { pluginHandlers = mkFormattingHandlers provider } -- --------------------------------------------------------------------- -provider :: FormattingProvider IdeState IO -provider lf ideState typ contents fp _ = withIndefiniteProgress lf title Cancellable $ do +provider :: FormattingHandler IdeState +provider ideState typ contents fp _ = withIndefiniteProgress title Cancellable $ liftIO $ do let fromDyn :: DynFlags -> IO [DynOption] fromDyn df = diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index 2d113ce248..f1a3fc4926 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -15,23 +15,24 @@ import qualified Data.HashMap.Strict as H import qualified Data.Text as T import Development.IDE as D import Ide.Types -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as J -import qualified Language.Haskell.LSP.Types.Lens as J +import Language.LSP.Types +import qualified Language.LSP.Types as J +import qualified Language.LSP.Types.Lens as J import Control.Monad (join) import Development.IDE.GHC.Compat -import qualified Language.Haskell.LSP.Core as LSP -import qualified Language.Haskell.LSP.VFS as VFS +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.VFS as VFS import qualified Text.Fuzzy as Fuzzy import Data.List.Extra (nubOrd) +import Control.Monad.IO.Class -- --------------------------------------------------------------------- descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginCodeActionProvider = Just codeActionProvider - , pluginCompletionProvider = Just completion + { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider + <> mkPluginHandler STextDocumentCompletion completion } -- --------------------------------------------------------------------- @@ -54,8 +55,8 @@ mkPragmaEdit uri pragmaName = res where -- --------------------------------------------------------------------- -- | Offer to add a missing Language Pragma to the top of a file. -- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'. -codeActionProvider :: CodeActionProvider IdeState -codeActionProvider _ state _plId docId _ (J.CodeActionContext (J.List diags) _monly) = do +codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider state _plId (CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) = liftIO $ do let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' pm <- fmap join $ runAction "addPragma" state $ getParsedModule `traverse` mFile let dflags = ms_hspp_opts . pm_mod_summary <$> pm @@ -66,7 +67,7 @@ codeActionProvider _ state _plId docId _ (J.CodeActionContext (J.List diags) _mo where mkCodeAction pragmaName = do let - codeAction = J.CACodeAction $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) (Just edit) Nothing + codeAction = InR $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing Nothing (Just edit) Nothing title = "Add \"" <> pragmaName <> "\"" edit = mkPragmaEdit (docId ^. J.uri) pragmaName return codeAction @@ -128,22 +129,22 @@ allPragmas = -- --------------------------------------------------------------------- -completion :: CompletionProvider IdeState -completion lspFuncs _ide complParams = do +completion :: PluginMethodHandler IdeState TextDocumentCompletion +completion _ide _ complParams = do let (TextDocumentIdentifier uri) = complParams ^. J.textDocument position = complParams ^. J.position - contents <- LSP.getVirtualFileFunc lspFuncs $ toNormalizedUri uri - fmap Right $ case (contents, uriToFilePath' uri) of + contents <- LSP.getVirtualFile $ toNormalizedUri uri + fmap (Right . InL) $ case (contents, uriToFilePath' uri) of (Just cnts, Just _path) -> result <$> VFS.getCompletionPrefix position cnts where result (Just pfix) | "{-# LANGUAGE" `T.isPrefixOf` VFS.fullLine pfix - = Completions $ List $ map buildCompletion + = List $ map buildCompletion (Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas) | otherwise - = Completions $ List [] - result Nothing = Completions $ List [] + = List [] + result Nothing = List [] buildCompletion p = CompletionItem { _label = p, @@ -163,4 +164,4 @@ completion lspFuncs _ide complParams = do _command = Nothing, _xdata = Nothing } - _ -> return $ Completions $ List [] + _ -> return $ List [] diff --git a/plugins/default/src/Ide/Plugin/StylishHaskell.hs b/plugins/default/src/Ide/Plugin/StylishHaskell.hs index bc3f7b25fa..1b18da0681 100644 --- a/plugins/default/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/default/src/Ide/Plugin/StylishHaskell.hs @@ -10,32 +10,33 @@ where import Control.Monad.IO.Class import Data.Text (Text) import qualified Data.Text as T -import Development.IDE +import Development.IDE hiding (pluginHandlers) import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts)) import qualified DynFlags as D import qualified EnumSet as ES import GHC.LanguageExtensions.Type import Ide.PluginUtils import Ide.Types -import Language.Haskell.LSP.Types as J import Language.Haskell.Stylish +import Language.LSP.Types as J + import System.Directory import System.FilePath descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginFormattingProvider = Just provider + { pluginHandlers = mkFormattingHandlers provider } -- | Formatter provider of stylish-haskell. -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. -provider :: FormattingProvider IdeState IO -provider _lf ide typ contents fp _opts = do - (ms_hspp_opts -> dyn, _) <- runAction "stylish-haskell" ide $ use_ GetModSummary fp +provider :: FormattingHandler IdeState +provider ide typ contents fp _opts = do + (ms_hspp_opts -> dyn, _) <- liftIO $ runAction "stylish-haskell" ide $ use_ GetModSummary fp let file = fromNormalizedFilePath fp config <- liftIO $ loadConfigFrom file - mergedConfig <- getMergedConfig dyn config + mergedConfig <- liftIO $ getMergedConfig dyn config let (range, selectedContents) = case typ of FormatText -> (fullRange contents, contents) FormatRange r -> (normalize r, extractRange r contents) diff --git a/plugins/hls-class-plugin/hls-class-plugin.cabal b/plugins/hls-class-plugin/hls-class-plugin.cabal index 90bf2fd26b..9d79596788 100644 --- a/plugins/hls-class-plugin/hls-class-plugin.cabal +++ b/plugins/hls-class-plugin/hls-class-plugin.cabal @@ -20,7 +20,7 @@ library build-depends: aeson , base >=4.12 && <5 , containers - , haskell-lsp + , lsp , hls-plugin-api , ghc , ghc-exactprint @@ -32,3 +32,5 @@ library , unordered-containers default-language: Haskell2010 + default-extensions: DataKinds, TypeOperators + ghc-options: -Wno-unticked-promoted-constructors diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 9b79690d69..97f64a0597 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -22,8 +22,8 @@ import Data.List import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T -import Development.IDE -import Development.IDE.Core.PositionMapping (fromCurrentRange) +import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.PositionMapping (fromCurrentRange, toCurrentRange) import Development.IDE.GHC.Compat hiding (getLoc) import Development.IDE.Spans.AtPoint import qualified GHC.Generics as Generics @@ -33,9 +33,9 @@ import Ide.Types import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers (parseDecl) import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, Parens) -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as J +import Language.LSP.Server +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as J import SrcLoc import TcEnv import TcRnMonad @@ -43,7 +43,7 @@ import TcRnMonad descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands = commands - , pluginCodeActionProvider = Just codeAction + , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction } commands :: [PluginCommand IdeState] @@ -60,25 +60,28 @@ data AddMinimalMethodsParams = AddMinimalMethodsParams deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) addMethodPlaceholders :: CommandFunction IdeState AddMinimalMethodsParams -addMethodPlaceholders lf state AddMinimalMethodsParams{..} = fmap (fromMaybe errorResult) . runMaybeT $ do - docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri - pm <- MaybeT . runAction "classplugin" state $ use GetParsedModule docPath - let - ps = pm_parsed_source pm - anns = relativiseApiAnns ps (pm_annotations pm) - old = T.pack $ exactPrint ps anns - - (hsc_dflags . hscEnv -> df) <- MaybeT . runAction "classplugin" state $ use GhcSessionDeps docPath - List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup - let - (ps', (anns', _), _) = runTransform (mergeAnns (mergeAnnList mAnns) anns) (addMethodDecls ps mDecls) - new = T.pack $ exactPrint ps' anns' - - pure (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams (workspaceEdit caps old new))) +addMethodPlaceholders state AddMinimalMethodsParams{..} = do + caps <- getClientCapabilities + medit <- liftIO $ runMaybeT $ do + docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri + pm <- MaybeT . runAction "classplugin" state $ use GetParsedModule docPath + let + ps = pm_parsed_source pm + anns = relativiseApiAnns ps (pm_annotations pm) + old = T.pack $ exactPrint ps anns + + (hsc_dflags . hscEnv -> df) <- MaybeT . runAction "classplugin" state $ use GhcSessionDeps docPath + List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup + let + (ps', (anns', _), _) = runTransform (mergeAnns (mergeAnnList mAnns) anns) (addMethodDecls ps mDecls) + new = T.pack $ exactPrint ps' anns' + + pure (workspaceEdit caps old new) + forM_ medit $ \edit -> + sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + pure (Right Null) where - errorResult = (Right Null, Nothing) - caps = clientCapabilities lf indent = 2 makeMethodDecl df mName = @@ -126,8 +129,8 @@ addMethodPlaceholders lf state AddMinimalMethodsParams{..} = fmap (fromMaybe err -- | -- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is -- sensitive to the format of diagnostic messages from GHC. -codeAction :: CodeActionProvider IdeState -codeAction _ state plId docId _ context = fmap (fromMaybe errorResult) . runMaybeT $ do +codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction +codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri actions <- join <$> mapM (mkActions docPath) methodDiags pure . Right . List $ actions @@ -147,8 +150,7 @@ codeAction _ state plId docId _ context = fmap (fromMaybe errorResult) . runMayb range = diag ^. J.range mkAction methodGroup - = mkCodeAction title - <$> mkLspCommand plId "addMinimalMethodPlaceholders" title (Just cmdParams) + = pure $ mkCodeAction title $ mkLspCommand plId "addMinimalMethodPlaceholders" title (Just cmdParams) where title = mkTitle methodGroup cmdParams = mkCmdParams methodGroup @@ -160,8 +162,8 @@ codeAction _ state plId docId _ context = fmap (fromMaybe errorResult) . runMayb mkCmdParams methodGroup = [toJSON (AddMinimalMethodsParams uri range (List methodGroup))] mkCodeAction title - = CACodeAction - . CodeAction title (Just CodeActionQuickFix) (Just (List [])) Nothing + = InR + . CodeAction title (Just CodeActionQuickFix) (Just (List [])) Nothing Nothing Nothing . Just findClassIdentifier docPath range = do diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 1909f33f68..3704e34c11 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -51,8 +51,8 @@ library , ghc-paths , ghcide >=0.7.3.0 , hashable - , haskell-lsp - , haskell-lsp-types + , lsp + , lsp-types , hls-plugin-api >=0.7 , lens , megaparsec >=0.9 @@ -67,10 +67,12 @@ library , time , transformers , unordered-containers + , unliftio - ghc-options: -Wall -Wno-name-shadowing + ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror default-language: Haskell2010 + default-extensions: DataKinds, TypeOperators diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index e20a2f9e32..6f97f20da5 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -15,12 +15,14 @@ import Ide.Types ( PluginDescriptor (..), PluginId, defaultPluginDescriptor, + mkPluginHandler ) +import Language.LSP.Types -- |Plugin descriptor descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginCodeLensProvider = Just CL.codeLens + { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens , pluginCommands = [CL.evalCommand] } diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs index 35cc58fc5b..d1b78e5136 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -24,7 +24,7 @@ import Ide.Plugin.Eval.Types ( import InteractiveEval (runDecls) import Unsafe.Coerce (unsafeCoerce) import Control.Lens ((^.)) -import Language.Haskell.LSP.Types.Lens (start, line) +import Language.LSP.Types.Lens (start, line) -- | Return the ranges of the expression and result parts of the given test testRanges :: Test -> (Range, Range) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 53c5197f65..2b31039fb7 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -30,7 +30,8 @@ import Control.Arrow (second, (>>>)) import qualified Control.Exception as E import Control.Monad ( void, - when, guard + when, guard, + join ) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except @@ -59,17 +60,11 @@ import Development.IDE GetParsedModuleWithComments (..), HscEnvEq, IdeState, - List (List), - NormalizedFilePath, - Range (Range), - Uri, evalGhcEnv, - fromNormalizedFilePath, hscEnvWithImportPaths, runAction, textToStringBuffer, toNormalizedFilePath', - toNormalizedUri, uriToFilePath', useWithStale_, prettyPrint, @@ -166,41 +161,10 @@ import Ide.Plugin.Eval.Util response', timed, ) -import Ide.PluginUtils (mkLspCommand) import Ide.Types - ( CodeLensProvider, - CommandFunction, - CommandId, - PluginCommand (PluginCommand), - ) -import Language.Haskell.LSP.Core - ( LspFuncs - ( getVirtualFileFunc, - withIndefiniteProgress - ), - ProgressCancellable - ( Cancellable - ), - ) -import Language.Haskell.LSP.Types - ( ApplyWorkspaceEditParams - ( ApplyWorkspaceEditParams - ), - CodeLens (CodeLens), - CodeLensParams - ( CodeLensParams, - _textDocument - ), - Command (_arguments, _title), - Position (..), - ServerMethod - ( WorkspaceApplyEdit - ), - TextDocumentIdentifier (..), - TextEdit (TextEdit), - WorkspaceEdit (WorkspaceEdit), - ) -import Language.Haskell.LSP.VFS (virtualFileText) +import Language.LSP.Server +import Language.LSP.Types +import Language.LSP.VFS (virtualFileText) import Outputable ( nest, ppr, @@ -211,21 +175,21 @@ import Outputable ) import System.FilePath (takeFileName) import System.IO (hClose) -import System.IO.Temp (withSystemTempFile) +import UnliftIO.Temporary (withSystemTempFile) import Util (OverridingBool (Never)) import Development.IDE.Core.PositionMapping (toCurrentRange) import qualified Data.DList as DL import Control.Lens ((^.), _1, (%~), (<&>), _3) -import Language.Haskell.LSP.Types.Lens (line, end) -import Control.Exception (try) +import Language.LSP.Types.Lens (line, end) import CmdLineParser import qualified Development.IDE.GHC.Compat as SrcLoc +import Control.Exception (try) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} -codeLens :: CodeLensProvider IdeState -codeLens _lsp st plId CodeLensParams{_textDocument} = +codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens +codeLens st plId CodeLensParams{_textDocument} = let dbg = logWith st perf = timed dbg in perf "codeLens" $ @@ -271,7 +235,7 @@ codeLens _lsp st plId CodeLensParams{_textDocument} = -- Extract tests from source code let Sections{..} = commentsToSections isLHS comments tests = testsBySection nonSetupSections - cmd <- liftIO $ mkLspCommand plId evalCommandName "Evaluate=..." (Just []) + cmd = mkLspCommand plId evalCommandName "Evaluate=..." (Just []) let lenses = [ CodeLens testRange (Just cmd') Nothing | (section, ident, test) <- tests @@ -313,16 +277,17 @@ evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd type EvalId = Int runEvalCmd :: CommandFunction IdeState EvalParams -runEvalCmd lsp st EvalParams{..} = +runEvalCmd st EvalParams{..} = let dbg = logWith st perf = timed dbg + cmd :: ExceptT String (LspM c) WorkspaceEdit cmd = do let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections let TextDocumentIdentifier{_uri} = module_ fp <- handleMaybe "uri" $ uriToFilePath' _uri let nfp = toNormalizedFilePath' fp - mdlText <- moduleText lsp _uri + mdlText <- moduleText _uri session <- runGetSession st nfp @@ -341,7 +306,7 @@ runEvalCmd lsp st EvalParams{..} = (Just (textToStringBuffer mdlText, now)) -- Setup environment for evaluation - hscEnv' <- withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> ExceptT . (either Left id <$>) . gStrictTry . evalGhcEnv session $ do + hscEnv' <- ExceptT $ fmap join $ withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> liftIO . gStrictTry . evalGhcEnv session $ do env <- getSession -- Install the module pragmas and options @@ -413,9 +378,9 @@ runEvalCmd lsp st EvalParams{..} = let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)] let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing - return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits) + return workspaceEdits in perf "evalCmd" $ - withIndefiniteProgress lsp "Evaluating" Cancellable $ + withIndefiniteProgress "Evaluating" Cancellable $ response' cmd addFinalReturn :: Text -> [TextEdit] -> [TextEdit] @@ -432,14 +397,12 @@ finalReturn txt = p = Position l c in TextEdit (Range p p) "\n" -moduleText :: (IsString e, MonadIO m) => LspFuncs c -> Uri -> ExceptT e m Text -moduleText lsp uri = +moduleText :: (IsString e, MonadLsp c m) => Uri -> ExceptT e m Text +moduleText uri = handleMaybeM "mdlText" $ - liftIO $ - (virtualFileText <$>) - <$> getVirtualFileFunc - lsp - (toNormalizedUri uri) + (virtualFileText <$>) + <$> getVirtualFile + (toNormalizedUri uri) testsBySection :: [Section] -> [(Section, EvalId, Test)] testsBySection sections = diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index b77d2b7bc9..968f2df7a5 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -32,7 +32,7 @@ import Development.IDE (Position, Range (Range)) import Development.IDE.Types.Location (Position (..)) import GHC.Generics import Ide.Plugin.Eval.Types -import Language.Haskell.LSP.Types.Lens +import Language.LSP.Types.Lens ( character, end, line, diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs index 1c709cfb29..f1c70c1acd 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Option.hs @@ -6,7 +6,6 @@ module Ide.Plugin.Eval.Parse.Option ( parseSetFlags, ) where -import Control.Monad.Combinators (many) import Text.Megaparsec.Char import Text.Megaparsec import Data.Void (Void) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 5118181534..d50b665278 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -38,7 +38,7 @@ import Data.String (IsString (..)) import Development.IDE (Range) import GHC.Generics (Generic) import qualified Text.Megaparsec as P -import Language.Haskell.LSP.Types (TextDocumentIdentifier) +import Language.LSP.Types (TextDocumentIdentifier) -- | A thing with a location attached. data Located l a = Located {location :: l, located :: a} diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs index 5acb4a11f8..1f573a58ac 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -15,7 +15,6 @@ module Ide.Plugin.Eval.Util ( logWith, ) where -import Control.Monad (join) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except ( @@ -36,10 +35,8 @@ import Development.IDE ( import Exception (ExceptionMonad, SomeException (..), evaluate, gcatch) import GHC.Exts (toList) import GHC.Stack (HasCallStack, callStack, srcLocFile, srcLocStartCol, srcLocStartLine) -import Language.Haskell.LSP.Types ( - ErrorCode (InternalError), - ResponseError (ResponseError), - ) +import Language.LSP.Server +import Language.LSP.Types import Outputable ( Outputable (ppr), ppr, @@ -50,6 +47,7 @@ import System.Time.Extra ( duration, showDuration, ) +import UnliftIO.Exception (catchAny) asS :: Outputable a => a -> String asS = showSDocUnsafe . ppr @@ -93,14 +91,16 @@ response = fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) . runExceptT -response' :: ExceptT String IO a -> IO (Either ResponseError Value, Maybe a) +response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError Value) response' act = do - res <- gStrictTry $ runExceptT act - case join res of - Left e -> - return - (Left (ResponseError InternalError (fromString e) Nothing), Nothing) - Right a -> return (Right Null, Just a) + res <- runExceptT act + `catchAny` showErr + case res of + Left e -> + return $ Left (ResponseError InternalError (fromString e) Nothing) + Right a -> do + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) + return $ Right Null gStrictTry :: ExceptionMonad m => m b -> m (Either String b) gStrictTry op = diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index 2ed23e04f1..8222208b67 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -2,37 +2,23 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DuplicateRecordFields #-} module Eval ( tests, ) where import Control.Applicative.Combinators ( - skipManyTill, + skipManyTill ) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Text as T import qualified Data.Text.IO as T -import Language.Haskell.LSP.Test ( - Session, - anyMessage, - documentContents, - executeCommand, - fullCaps, - getCodeLenses, - message, - openDoc, - runSession, - ) -import Language.Haskell.LSP.Types ( - ApplyWorkspaceEditRequest, - CodeLens (CodeLens, _command, _range), - Command (Command, _title, _arguments), - Position (..), - Range (..), - TextDocumentIdentifier, - ) +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens (command, title, range) +import Control.Lens (view, _Just, preview) import System.Directory (doesFileExist) import System.FilePath ( (<.>), @@ -51,7 +37,6 @@ import Test.Tasty.HUnit ( (@?=), ) import Data.List.Extra (nubOrdOn) -import Development.IDE (List(List)) import Ide.Plugin.Eval.Types (EvalParams(..)) import Data.Aeson (fromJSON) import Data.Aeson.Types (Result(Success)) @@ -64,27 +49,27 @@ tests = runSession hlsCommand fullCaps evalPath $ do doc <- openDoc "T1.hs" "haskell" lenses <- getEvalCodeLenses doc - liftIO $ map (fmap _title . _command) lenses @?= [Just "Evaluate..."] + liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."] , testCase "Produces Refresh code lenses" $ runSession hlsCommand fullCaps evalPath $ do doc <- openDoc "T2.hs" "haskell" lenses <- getEvalCodeLenses doc - liftIO $ map (fmap _title . _command) lenses @?= [Just "Refresh..."] + liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."] , testCase "Code lenses have ranges" $ runSession hlsCommand fullCaps evalPath $ do doc <- openDoc "T1.hs" "haskell" lenses <- getEvalCodeLenses doc - liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 5 0)] + liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] , testCase "Multi-line expressions have a multi-line range" $ do runSession hlsCommand fullCaps evalPath $ do doc <- openDoc "T3.hs" "haskell" lenses <- getEvalCodeLenses doc - liftIO $ map _range lenses @?= [Range (Position 3 0) (Position 5 0)] + liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)] , testCase "Executed expressions range covers only the expression" $ do runSession hlsCommand fullCaps evalPath $ do doc <- openDoc "T2.hs" "haskell" lenses <- getEvalCodeLenses doc - liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 5 0)] + liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] , testCase "Evaluation of expressions" $ goldenTest "T1.hs" , testCase "Reevaluation of expressions" $ goldenTest "T2.hs" , testCase "Evaluation of expressions w/ imports" $ goldenTest "T3.hs" @@ -227,7 +212,7 @@ getCodeLensesBy f doc = filter f <$> getCodeLenses doc executeCmd :: Command -> Session () executeCmd cmd = do executeCommand cmd - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) -- liftIO $ print _resp return () diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index 39f067af7f..b304237fb3 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -19,7 +19,8 @@ library , base >=4.12 && <5 , containers , deepseq - , haskell-lsp-types + , lsp-types + , lsp , hls-plugin-api , ghc , ghcide >= 0.7.4 @@ -29,3 +30,4 @@ library default-language: Haskell2010 include-dirs: include + default-extensions: DataKinds, TypeOperators diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 41a733a5ad..cc2b3eecc0 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -29,7 +29,8 @@ import Development.Shake.Classes import GHC.Generics (Generic) import Ide.PluginUtils ( mkLspCommand ) import Ide.Types -import Language.Haskell.LSP.Types +import Language.LSP.Types +import Language.LSP.Server import PrelNames (pRELUDE) import RnNames ( findImportUsage, @@ -45,14 +46,17 @@ importCommandId = "ImportLensCommand" descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { -- This plugin provides code lenses - pluginCodeLensProvider = Just lensProvider, + { -- This plugin provides a command handler pluginCommands = [importLensCommand], - -- This plugin provides code actions - pluginCodeActionProvider = Just codeActionProvider, -- This plugin defines a new rule - pluginRules = minimalImportsRule + pluginRules = minimalImportsRule, + pluginHandlers = mconcat + [ -- This plugin provides code lenses + mkPluginHandler STextDocumentCodeLens lensProvider + -- This plugin provides code actions + , mkPluginHandler STextDocumentCodeAction codeActionProvider + ] } -- | The command descriptor @@ -67,9 +71,10 @@ data ImportCommandParams = ImportCommandParams WorkspaceEdit -- | The actual command handler runImportCommand :: CommandFunction IdeState ImportCommandParams -runImportCommand _lspFuncs _state (ImportCommandParams edit) = do +runImportCommand _state (ImportCommandParams edit) = do -- This command simply triggers a workspace edit! - return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams edit)) + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + return (Right Null) -- | For every implicit import statement, return a code lens of the corresponding explicit import -- Example - for the module below: @@ -81,15 +86,14 @@ runImportCommand _lspFuncs _state (ImportCommandParams edit) = do -- the provider should produce one code lens associated to the import statement: -- -- > import Data.List (intercalate, sortBy) -lensProvider :: CodeLensProvider IdeState +lensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens lensProvider - _lspFuncs -- LSP functions, not used state -- ghcide state, used to retrieve typechecking artifacts pId -- plugin Id CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} -- VSCode uses URIs instead of file paths -- haskell-lsp provides conversion functions - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $ do mbMinImports <- runAction "" state $ useWithStale MinimalImports nfp case mbMinImports of @@ -110,10 +114,10 @@ lensProvider -- | If there are any implicit imports, provide one code action to turn them all -- into explicit imports. -codeActionProvider :: CodeActionProvider IdeState -codeActionProvider _lspFuncs ideState _pId docId range _context +codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider ideState _pId (CodeActionParams _ _ docId range _context) | TextDocumentIdentifier {_uri} <- docId, - Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = + Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $ do pm <- runIde ideState $ use GetParsedModule nfp let insideImport = case pm of @@ -132,7 +136,7 @@ codeActionProvider _lspFuncs ideState _pId docId range _context maybe [] getMinimalImportsResult minImports, Just e <- [mkExplicitEdit zeroMapping imp explicit] ] - caExplicitImports = CACodeAction CodeAction {..} + caExplicitImports = InR CodeAction {..} _title = "Make all imports explicit" _kind = Just CodeActionQuickFix _command = Nothing @@ -140,6 +144,8 @@ codeActionProvider _lspFuncs ideState _pId docId range _context _changes = Just $ HashMap.singleton _uri $ List edits _documentChanges = Nothing _diagnostics = Nothing + _isPreferred = Nothing + _disabled = Nothing return $ Right $ List [caExplicitImports | not (null edits)] | otherwise = return $ Right $ List [] @@ -238,7 +244,7 @@ generateLens pId uri importEdit@TextEdit {_range} = do -- the command argument is simply the edit _arguments = Just [toJSON $ ImportCommandParams edit] -- create the command - _command <- Just <$> mkLspCommand pId importCommandId title _arguments + _command = Just $ mkLspCommand pId importCommandId title _arguments -- create and return the code lens return $ Just CodeLens {..} diff --git a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal index dcfa1b479b..002aed0629 100644 --- a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal +++ b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal @@ -17,16 +17,17 @@ bug-reports: https://github.com/haskell/haskell-language-server/issues library exposed-modules: Ide.Plugin.HaddockComments hs-source-dirs: src - ghc-options: -Wall -Wno-name-shadowing -Wredundant-constraints + ghc-options: -Wall -Wno-name-shadowing -Wredundant-constraints -Wno-unticked-promoted-constructors build-depends: , base >=4.12 && <5 , containers , ghc , ghc-exactprint , ghcide - , haskell-lsp-types + , lsp-types , hls-plugin-api , text , unordered-containers default-language: Haskell2010 + default-extensions: DataKinds, TypeOperators diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index ce71531ca0..03175520ed 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -11,32 +11,33 @@ import Control.Monad (join) import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import qualified Data.Text as T -import Development.IDE +import Development.IDE hiding (pluginHandlers) import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (..), annsA, astA) import Ide.Types import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) import Language.Haskell.GHC.ExactPrint.Utils -import Language.Haskell.LSP.Types +import Language.LSP.Types +import Control.Monad.IO.Class ----------------------------------------------------------------------------- descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginCodeActionProvider = Just codeActionProvider + { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider } -codeActionProvider :: CodeActionProvider IdeState -codeActionProvider _lspFuncs ideState _pId (TextDocumentIdentifier uri) range CodeActionContext {_diagnostics = List diags} = +codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider ideState _pId (CodeActionParams _ _ (TextDocumentIdentifier uri) range CodeActionContext {_diagnostics = List diags}) = do let noErr = and $ (/= Just DsError) . _severity <$> diags nfp = uriToNormalizedFilePath $ toNormalizedUri uri - (join -> pm) <- runAction "HaddockComments.GetAnnotatedParsedSource" ideState $ use GetAnnotatedParsedSource `traverse` nfp + (join -> pm) <- liftIO $ runAction "HaddockComments.GetAnnotatedParsedSource" ideState $ use GetAnnotatedParsedSource `traverse` nfp let locDecls = hsmodDecls . unLoc . astA <$> pm anns = annsA <$> pm edits = [runGenComments gen locDecls anns range | noErr, gen <- genList] - return $ Right $ List [CACodeAction $ toAction title uri edit | (Just (title, edit)) <- edits] + return $ Right $ List [InR $ toAction title uri edit | (Just (title, edit)) <- edits] genList :: [GenComments] genList = @@ -121,6 +122,8 @@ toAction title uri edit = CodeAction {..} _changes = Just $ HashMap.singleton uri $ List [edit] _documentChanges = Nothing _edit = Just WorkspaceEdit {..} + _isPreferred = Nothing + _disabled = Nothing toRange :: SrcSpan -> Maybe Range toRange src diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 5338de266c..ef7c29608a 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -41,7 +41,7 @@ library , ghc-exactprint >=0.6.3.4 , ghcide >=0.7.2.0 , hashable - , haskell-lsp + , lsp , hlint >=3.2 , hls-plugin-api >=0.7.1.0 , hslogger @@ -64,9 +64,10 @@ library cpp-options: -DHLINT_ON_GHC_LIB - ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing + ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror default-language: Haskell2010 + default-extensions: DataKinds, TypeOperators diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 9c3c6981a5..e3027b1c24 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Ide.Plugin.Hlint ( @@ -60,12 +61,13 @@ import Ide.Types import Ide.Plugin.Config import Ide.PluginUtils import Language.Haskell.HLint as Hlint -import Language.Haskell.LSP.Core - ( LspFuncs(withIndefiniteProgress), +import Language.LSP.Server + ( withIndefiniteProgress, + sendRequest, ProgressCancellable(Cancellable) ) -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as LSP -import qualified Language.Haskell.LSP.Types.Lens as LSP +import Language.LSP.Types +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Lens as LSP import Text.Regex.TDFA.Text() import GHC.Generics (Generic) @@ -79,7 +81,7 @@ descriptor plId = (defaultPluginDescriptor plId) [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd ] - , pluginCodeActionProvider = Just codeActionProvider + , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider } -- This rule only exists for generating file diagnostics @@ -105,7 +107,7 @@ rules plugin = do define $ \GetHlintDiagnostics file -> do config <- getClientConfigAction def let pluginConfig = configForPlugin config plugin - let hlintOn' = hlintOn config && pluginEnabled pluginConfig plcDiagnosticsOn + let hlintOn' = hlintOn config && plcGlobalOn pluginConfig && plcDiagnosticsOn pluginConfig ideas <- if hlintOn' then getIdeas file else return (Right []) return (diagnostics file ideas, Just ()) @@ -129,7 +131,7 @@ rules plugin = do _range = srcSpanToRange $ ideaSpan idea , _severity = Just LSP.DsInfo -- we are encoding the fact that idea has refactorings in diagnostic code - , _code = Just (LSP.StringValue $ T.pack $ codePre ++ ideaHint idea) + , _code = Just (InR $ T.pack $ codePre ++ ideaHint idea) , _source = Just "hlint" , _message = idea2Message idea , _relatedInformation = Nothing @@ -152,7 +154,7 @@ rules plugin = do LSP.Diagnostic { _range = srcSpanToRange l , _severity = Just LSP.DsInfo - , _code = Just (LSP.StringValue "parser") + , _code = Just (InR "parser") , _source = Just "hlint" , _message = T.unlines [T.pack msg,T.pack contents] , _relatedInformation = Nothing @@ -251,12 +253,11 @@ getHlintSettingsRule usage = -- --------------------------------------------------------------------- -codeActionProvider :: CodeActionProvider IdeState -codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CACodeAction <$> getCodeActions +codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider ideState plId (CodeActionParams _ _ docId _ context) = Right . LSP.List . map InR <$> liftIO getCodeActions where getCodeActions = do - applyOne <- applyOneActions diags <- getDiagnostics ideState let docNfp = toNormalizedFilePath' <$> uriToFilePath' (docId ^. LSP.uri) numHintsInDoc = length @@ -267,54 +268,54 @@ codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CA -- We only want to show the applyAll code action if there is more than 1 -- hint in the current document if numHintsInDoc > 1 then do - applyAll <- applyAllAction - pure $ applyAll:applyOne + pure $ applyAllAction:applyOneActions else - pure applyOne + pure applyOneActions - applyAllAction = do + applyAllAction = let args = Just [toJSON (docId ^. LSP.uri)] - cmd <- mkLspCommand plId "applyAll" "Apply all hints" args - pure $ LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing (Just cmd) + cmd = mkLspCommand plId "applyAll" "Apply all hints" args + in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing Nothing Nothing (Just cmd) - applyOneActions :: IO [LSP.CodeAction] - applyOneActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags) + applyOneActions :: [LSP.CodeAction] + applyOneActions = catMaybes $ map mkHlintAction (filter validCommand diags) -- |Some hints do not have an associated refactoring - validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _ _) = + validCommand (LSP.Diagnostic _ _ (Just (InR code)) (Just "hlint") _ _ _) = "refact:" `T.isPrefixOf` code validCommand _ = False LSP.List diags = context ^. LSP.diagnostics - mkHlintAction :: LSP.Diagnostic -> IO (Maybe LSP.CodeAction) - mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") _ _ _) = - Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) + mkHlintAction :: LSP.Diagnostic -> Maybe LSP.CodeAction + mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (InR code)) (Just "hlint") _ _ _) = + Just . codeAction $ mkLspCommand plId "applyOne" title (Just args) where - codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd) + codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing Nothing Nothing (Just cmd) -- we have to recover the original ideaHint removing the prefix ideaHint = T.replace "refact:" "" code title = "Apply hint: " <> ideaHint -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location) args = [toJSON (AOP (docId ^. LSP.uri) start ideaHint)] - mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = return Nothing + mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = Nothing -- --------------------------------------------------------------------- applyAllCmd :: CommandFunction IdeState Uri -applyAllCmd lf ide uri = do +applyAllCmd ide uri = do let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) - withIndefiniteProgress lf "Applying all hints" Cancellable $ do + withIndefiniteProgress "Applying all hints" Cancellable $ do logm $ "hlint:applyAllCmd:file=" ++ show file - res <- applyHint ide file Nothing + res <- liftIO $ applyHint ide file Nothing logm $ "hlint:applyAllCmd:res=" ++ show res - return $ - case res of - Left err -> (Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)), Nothing) - Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs)) + case res of + Left err -> pure $ Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)) + Right fs -> do + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) + pure $ Right Null -- --------------------------------------------------------------------- @@ -333,19 +334,20 @@ data OneHint = OneHint } deriving (Eq, Show) applyOneCmd :: CommandFunction IdeState ApplyOneParams -applyOneCmd lf ide (AOP uri pos title) = do +applyOneCmd ide (AOP uri pos title) = do let oneHint = OneHint pos title let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) let progTitle = "Applying hint: " <> title - withIndefiniteProgress lf progTitle Cancellable $ do + withIndefiniteProgress progTitle Cancellable $ do logm $ "hlint:applyOneCmd:file=" ++ show file - res <- applyHint ide file (Just oneHint) + res <- liftIO $ applyHint ide file (Just oneHint) logm $ "hlint:applyOneCmd:res=" ++ show res - return $ - case res of - Left err -> (Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)), Nothing) - Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs)) + case res of + Left err -> pure $ Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)) + Right fs -> do + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) + pure $ Right Null applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) applyHint ide nfp mhint = diff --git a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal index 67cdd15615..a4c3e08601 100644 --- a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal +++ b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal @@ -21,8 +21,8 @@ library , deepseq , directory , extra - , haskell-lsp - , haskell-lsp-types + , lsp + , lsp-types , hls-plugin-api , ghc , ghcide @@ -36,3 +36,5 @@ library default-language: Haskell2010 include-dirs: include + default-extensions: DataKinds, TypeOperators + ghc-options: -Wno-unticked-promoted-constructors diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index a4e163ee10..f6ee55f4fe 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -38,7 +38,7 @@ import Data.String (IsString (fromString)) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Typeable (Typeable) -import Development.IDE +import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.Shake (toKnownFiles, ShakeExtras(knownTargetsVar)) import Development.IDE.GHC.Compat (GenLocated (L), GhcRn, HsBindLR (FunBind), @@ -65,9 +65,8 @@ import GhcPlugins (Outputable, rdrNameOcc, unpackFS) import Ide.PluginUtils import Ide.Types -import Language.Haskell.LSP.Core (LspFuncs (..), ProgressCancellable (Cancellable)) -import Language.Haskell.LSP.Messages (FromServerMessage (NotShowMessage)) -import Language.Haskell.LSP.Types as J +import Language.LSP.Server (ProgressCancellable (Cancellable), withIndefiniteProgress, LspM, sendRequest, sendNotification) +import Language.LSP.Types as J import Retrie.CPP (CPP (NoCPP), parseCPP) import Retrie.ExactPrint (fix, relativiseApiAnns, transformA, unsafeMkA) @@ -90,7 +89,7 @@ import qualified Data.Aeson as Aeson descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginCodeActionProvider = Just provider, + { pluginHandlers = mkPluginHandler STextDocumentCodeAction provider, pluginCommands = [retrieCommand] } @@ -110,21 +109,20 @@ data RunRetrieParams = RunRetrieParams } deriving (Eq, Show, Generic, FromJSON, ToJSON) runRetrieCmd :: - LspFuncs a -> IdeState -> RunRetrieParams -> - IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) -runRetrieCmd lsp state RunRetrieParams{originatingFile = uri, ..} = - withIndefiniteProgress lsp description Cancellable $ do - res <- runMaybeT $ do + LspM c (Either ResponseError Value) +runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = + withIndefiniteProgress description Cancellable $ do + runMaybeT $ do nfp <- MaybeT $ return $ uriToNormalizedFilePath $ toNormalizedUri uri - (session, _) <- MaybeT $ + (session, _) <- MaybeT $ liftIO $ runAction "Retrie.GhcSessionDeps" state $ useWithStale GhcSessionDeps nfp - (ms, binds, _, _, _) <- MaybeT $ runAction "Retrie.getBinds" state $ getBinds nfp + (ms, binds, _, _, _) <- MaybeT $ liftIO $ runAction "Retrie.getBinds" state $ getBinds nfp let importRewrites = concatMap (extractImports ms binds) rewrites - (errors, edits) <- lift $ + (errors, edits) <- liftIO $ callRetrie state (hscEnv session) @@ -132,16 +130,14 @@ runRetrieCmd lsp state RunRetrieParams{originatingFile = uri, ..} = nfp restrictToOriginatingFile unless (null errors) $ - lift $ sendFunc lsp $ - NotShowMessage $ - NotificationMessage "2.0" WindowShowMessage $ + lift $ sendNotification SWindowShowMessage $ ShowMessageParams MtWarning $ T.unlines $ "## Found errors during rewrite:" : ["-" <> T.pack (show e) | e <- errors] - return (WorkspaceApplyEdit, ApplyWorkspaceEditParams edits) - return - (Right Null, res) + lift $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ()) + return () + return $ Right Null extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec] extractImports ModSummary{ms_mod} topLevelBinds (Unfold thing) @@ -166,14 +162,14 @@ extractImports _ _ _ = [] ------------------------------------------------------------------------------- -provider :: CodeActionProvider IdeState -provider _a state plId (TextDocumentIdentifier uri) range ca = response $ do +provider :: PluginMethodHandler IdeState TextDocumentCodeAction +provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = response $ do let (J.CodeActionContext _diags _monly) = ca nuri = toNormalizedUri uri nfp <- handleMaybe "uri" $ uriToNormalizedFilePath nuri (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) - <- handleMaybeM "typecheck" $ runAction "retrie" state $ getBinds nfp + <- handleMaybeM "typecheck" $ liftIO $ runAction "retrie" state $ getBinds nfp pos <- handleMaybe "pos" $ _start <$> fromCurrentRange posMapping range let rewrites = @@ -188,11 +184,11 @@ provider _a state plId (TextDocumentIdentifier uri) range ca = response $ do ] commands <- lift $ - forM rewrites $ \(title, kind, params) -> do - c <- mkLspCommand plId (coerce retrieCommandName) title (Just [toJSON params]) - return $ CodeAction title (Just kind) Nothing Nothing (Just c) + forM rewrites $ \(title, kind, params) -> liftIO $ do + let c = mkLspCommand plId (coerce retrieCommandName) title (Just [toJSON params]) + return $ CodeAction title (Just kind) Nothing Nothing Nothing Nothing (Just c) - return $ J.List [CACodeAction c | c <- commands] + return $ J.List [InR c | c <- commands] getBinds :: NormalizedFilePath -> Action (Maybe (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn])) getBinds nfp = runMaybeT $ do @@ -491,7 +487,7 @@ handleMaybe msg = maybe (throwE msg) return handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b handleMaybeM msg act = maybe (throwE msg) return =<< lift act -response :: ExceptT String IO a -> IO (Either ResponseError a) +response :: Monad m => ExceptT String m a -> m (Either ResponseError a) response = fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) . runExceptT diff --git a/plugins/hls-splice-plugin/hls-splice-plugin.cabal b/plugins/hls-splice-plugin/hls-splice-plugin.cabal index 9fb9272efe..407b4ce506 100644 --- a/plugins/hls-splice-plugin/hls-splice-plugin.cabal +++ b/plugins/hls-splice-plugin/hls-splice-plugin.cabal @@ -12,14 +12,14 @@ build-type: Simple library exposed-modules: Ide.Plugin.Splice - ghc-options: -Wall + ghc-options: -Wall -Wno-unticked-promoted-constructors other-modules: Ide.Plugin.Splice.Types hs-source-dirs: src build-depends: aeson , base >=4.12 && <5 , containers , foldl - , haskell-lsp + , lsp , hls-plugin-api , ghc , ghc-exactprint @@ -32,5 +32,7 @@ library , text , transformers , unordered-containers + , unliftio-core default-language: Haskell2010 + default-extensions: DataKinds, TypeOperators diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 373be9f919..f5d47ad9d5 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -44,23 +43,23 @@ import GHC.Exts import GhcMonad import GhcPlugins hiding (Var, getLoc, (<>)) import Ide.Plugin.Splice.Types -import Ide.PluginUtils (mkLspCommand, responseError) import Development.IDE.GHC.ExactPrint import Ide.Types import Language.Haskell.GHC.ExactPrint (setPrecedingLines, uniqueSrcSpanT) -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as J +import Language.LSP.Server +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import qualified Language.LSP.Types.Lens as J import RnSplice import TcRnMonad import Data.Foldable (Foldable(foldl')) +import Control.Monad.IO.Unlift descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands = commands - , pluginCodeActionProvider = Just codeAction + , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction } commands :: [PluginCommand IdeState] @@ -81,34 +80,11 @@ expandTHSplice :: -- | Inplace? ExpandStyle -> CommandFunction IdeState ExpandSpliceParams -expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = - fmap (fromMaybe defaultResult) $ - runMaybeT $ do - - fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri - eedits <- - ( lift . runExceptT . withTypeChecked fp - =<< MaybeT - (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck fp) - ) - <|> lift (runExceptT $ expandManually fp) - - case eedits of - Left err -> do - reportEditor - lsp - MtError - ["Error during expanding splice: " <> T.pack err] - pure (Left $ responseError $ T.pack err, Nothing) - Right edits -> - pure - ( Right Null - , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams edits) - ) - where - range = realSrcSpanToRange spliceSpan - srcSpan = RealSrcSpan spliceSpan - defaultResult = (Right Null, Nothing) +expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do + clientCapabilities <- getClientCapabilities + rio <- askRunInIO + let reportEditor :: ReportEditor + reportEditor msgTy msgs = liftIO $ rio $ sendNotification SWindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) expandManually fp = do mresl <- liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp @@ -118,7 +94,6 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = ) pure mresl reportEditor - lsp MtWarning [ "Expansion in type-chcking phase failed;" , "trying to expand manually, but note taht it is less rigorous." @@ -130,7 +105,8 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = (ps, hscEnv, _dflags) <- setupHscEnv ideState fp pm manualCalcEdit - lsp + clientCapabilities + reportEditor range ps hscEnv @@ -138,6 +114,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = spliceSpan _eStyle params + withTypeChecked fp TcModuleResult {..} = do (ps, _hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed let Splices {..} = tmrTopLevelSplices @@ -162,7 +139,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = expandeds <&> \(_, expanded) -> transform dflags - (clientCapabilities lsp) + clientCapabilities uri (graft (RealSrcSpan spliceSpan) expanded) ps @@ -178,7 +155,7 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = declSuperSpans <&> \(_, expanded) -> transform dflags - (clientCapabilities lsp) + clientCapabilities uri (graftDecls (RealSrcSpan spliceSpan) expanded) ps @@ -186,6 +163,36 @@ expandTHSplice _eStyle lsp ideState params@ExpandSpliceParams {..} = -- FIXME: Why ghc-exactprint sweeps preceeding comments? adjustToRange uri range + res <- liftIO $ runMaybeT $ do + + fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri uri + eedits <- + ( lift . runExceptT . withTypeChecked fp + =<< MaybeT + (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck fp) + ) + <|> lift (runExceptT $ expandManually fp) + + case eedits of + Left err -> do + reportEditor + MtError + ["Error during expanding splice: " <> T.pack err] + pure (Left $ responseError $ T.pack err) + Right edits -> + pure (Right edits) + case res of + Nothing -> pure $ Right Null + Just (Left err) -> pure $ Left err + Just (Right edit) -> do + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + pure $ Right Null + + where + range = realSrcSpanToRange spliceSpan + srcSpan = RealSrcSpan spliceSpan + + setupHscEnv :: IdeState -> NormalizedFilePath @@ -239,10 +246,12 @@ adjustToRange uri ran (WorkspaceEdit mhult mlt) = eds in adjustLine minStart <$> eds adjustWS = ix uri %~ adjustTextEdits - adjustDoc es + adjustDoc :: DocumentChange -> DocumentChange + adjustDoc (InR es) = InR es + adjustDoc (InL es) | es ^. J.textDocument . J.uri == uri = - es & J.edits %~ adjustTextEdits - | otherwise = es + InL $ es & J.edits %~ adjustTextEdits + | otherwise = InL es adjustLine :: Range -> TextEdit -> TextEdit adjustLine bad = @@ -291,17 +300,11 @@ classifyAST = \case Pat -> OneToOneAST @Pat proxy# HsType -> OneToOneAST @HsType proxy# -reportEditor :: MonadIO m => LspFuncs a -> MessageType -> [T.Text] -> m () -reportEditor lsp msgTy msgs = - liftIO $ - sendFunc lsp $ - NotShowMessage $ - NotificationMessage "2.0" WindowShowMessage $ - ShowMessageParams msgTy $ - T.unlines msgs +type ReportEditor = forall m. MonadIO m => MessageType -> [T.Text] -> m () manualCalcEdit :: - LspFuncs a -> + ClientCapabilities -> + ReportEditor -> Range -> Annotated ParsedSource -> HscEnv -> @@ -310,14 +313,14 @@ manualCalcEdit :: ExpandStyle -> ExpandSpliceParams -> ExceptT String IO WorkspaceEdit -manualCalcEdit lsp ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do +manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {..} = do (warns, resl) <- ExceptT $ do ((warns, errs), eresl) <- initTcWithGbl hscEnv typechkd srcSpan $ case classifyAST spliceContext of IsHsDecl -> fmap (fmap $ adjustToRange uri ran) $ - flip (transformM dflags (clientCapabilities lsp) uri) ps $ + flip (transformM dflags clientCapabilities uri) ps $ graftDeclsWithM (RealSrcSpan srcSpan) $ \case (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do eExpr <- @@ -330,7 +333,7 @@ manualCalcEdit lsp ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {.. pure $ Just eExpr _ -> pure Nothing OneToOneAST astP -> - flip (transformM dflags (clientCapabilities lsp) uri) ps $ + flip (transformM dflags clientCapabilities uri) ps $ graftWithM (RealSrcSpan srcSpan) $ \case (L _spn (matchSplice astP -> Just spl)) -> do eExpr <- @@ -347,7 +350,6 @@ manualCalcEdit lsp ran ps hscEnv typechkd srcSpan _eStyle ExpandSpliceParams {.. unless (null warns) $ reportEditor - lsp MtWarning [ "Warning during expanding: " , "" @@ -383,8 +385,8 @@ fromSearchResult _ = Nothing -- TODO: workaround when HieAst unavailable (e.g. when the module itself errors) -- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? -codeAction :: CodeActionProvider IdeState -codeAction _ state plId docId ran _ = +codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction +codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ fmap (maybe (Right $ List []) Right) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri @@ -397,10 +399,10 @@ codeAction _ state plId docId ran _ = \(spliceSpan, spliceContext) -> forM expandStyles $ \(_, (title, cmdId)) -> do let params = ExpandSpliceParams {uri = theUri, ..} - act <- liftIO $ mkLspCommand plId cmdId title (Just [toJSON params]) + act = mkLspCommand plId cmdId title (Just [toJSON params]) pure $ - CACodeAction $ - CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing (Just act) + InR $ + CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing Nothing Nothing (Just act) pure $ maybe mempty List mcmds where diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index f6e6b8fd4e..71914280be 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -41,7 +41,7 @@ library Ide.Plugin.Tactic.TestTypes ghc-options: - -Wno-name-shadowing -Wredundant-constraints + -Wno-name-shadowing -Wredundant-constraints -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror @@ -59,7 +59,7 @@ library , ghc-exactprint , ghc-source-gen , ghcide >=0.1 - , haskell-lsp ^>=0.23 + , lsp , hls-plugin-api , lens , mtl @@ -72,6 +72,7 @@ library , deepseq default-language: Haskell2010 + default-extensions: DataKinds, TypeOperators test-suite tests type: exitcode-stdio-1.0 diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index d2f61d0829..74bba3f52c 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -58,8 +58,8 @@ import Ide.Plugin.Tactic.TestTypes import Ide.Plugin.Tactic.Types import Ide.PluginUtils import Ide.Types -import Language.Haskell.LSP.Core (clientCapabilities) -import Language.Haskell.LSP.Types +import Language.LSP.Server +import Language.LSP.Types import OccName import Refinery.Tactic (goal) import SrcLoc (containsSpan) @@ -76,7 +76,7 @@ descriptor plId = (defaultPluginDescriptor plId) (tacticDesc $ tcCommandName tc) (tacticCmd $ commandTactic tc)) [minBound .. maxBound] - , pluginCodeActionProvider = Just codeActionProvider + , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider } tacticDesc :: T.Text -> T.Text @@ -85,7 +85,7 @@ tacticDesc name = "fill the hole using the " <> name <> " tactic" ------------------------------------------------------------------------------ -- | A 'TacticProvider' is a way of giving context-sensitive actions to the LS -- UI. -type TacticProvider = DynFlags -> PluginId -> Uri -> Range -> Judgement -> IO [CAResult] +type TacticProvider = DynFlags -> PluginId -> Uri -> Range -> Judgement -> IO [Command |? CodeAction] ------------------------------------------------------------------------------ @@ -166,10 +166,10 @@ runIde :: IdeState -> Action a -> IO a runIde state = runAction "tactic" state -codeActionProvider :: CodeActionProvider IdeState -codeActionProvider _conf state plId (TextDocumentIdentifier uri) range _ctx +codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _ctx) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = - fromMaybeT (Right $ List []) $ do + liftIO $ fromMaybeT (Right $ List []) $ do (_, jdg, _, dflags) <- judgementForHole state nfp range actions <- lift $ -- This foldMap is over the function monoid. @@ -180,11 +180,11 @@ codeActionProvider _conf state plId (TextDocumentIdentifier uri) range _ctx range jdg pure $ Right $ List actions -codeActionProvider _ _ _ _ _ _ = pure $ Right $ codeActions [] +codeActionProvider _ _ _ = pure $ Right $ codeActions [] -codeActions :: [CodeAction] -> List CAResult -codeActions = List . fmap CACodeAction +codeActions :: [CodeAction] -> List (Command |? CodeAction) +codeActions = List . fmap InR ------------------------------------------------------------------------------ @@ -194,11 +194,11 @@ provide :: TacticCommand -> T.Text -> TacticProvider provide tc name _ plId uri range _ = do let title = tacticTitle tc name params = TacticParams { file = uri , range = range , var_name = name } - cmd <- mkLspCommand plId (tcCommandId tc) title (Just [toJSON params]) + cmd = mkLspCommand plId (tcCommandId tc) title (Just [toJSON params]) pure $ pure - $ CACodeAction - $ CodeAction title (Just CodeActionQuickFix) Nothing Nothing + $ InR + $ CodeAction title (Just CodeActionQuickFix) Nothing Nothing Nothing Nothing $ Just cmd @@ -312,9 +312,10 @@ spliceProvenance provs x = tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams -tacticCmd tac lf state (TacticParams uri range var_name) - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = - fromMaybeT (Right Null, Nothing) $ do +tacticCmd tac state (TacticParams uri range var_name) + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do + clientCapabilities <- getClientCapabilities + res <- liftIO $ fromMaybeT (Right Nothing) $ do (range', jdg, ctx, dflags) <- judgementForHole state nfp range let span = rangeToRealSrcSpan (fromNormalizedFilePath nfp) range' pm <- MaybeT $ useAnnotatedSource "tacticsCmd" state nfp @@ -324,9 +325,8 @@ tacticCmd tac lf state (TacticParams uri range var_name) $ mkVarOcc $ T.unpack var_name of Left err -> - pure $ (, Nothing) - $ Left - $ ResponseError InvalidRequest (T.pack $ show err) Nothing + pure $ Left + $ ResponseError InvalidRequest (T.pack $ show err) Nothing Right rtr -> do traceMX "solns" $ rtr_other_solns rtr traceMX "simplified" $ rtr_extract rtr @@ -334,19 +334,22 @@ tacticCmd tac lf state (TacticParams uri range var_name) -- Parenthesize the extract iff we're not in a top level hole $ bool maybeParensAST id (_jIsTopHole jdg) $ rtr_extract rtr - response = transform dflags (clientCapabilities lf) uri g pm + response = transform dflags clientCapabilities uri g pm pure $ case response of - Right res -> (Right Null , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) - Left err -> (Left $ ResponseError InternalError (T.pack err) Nothing, Nothing) + Right res -> Right $ Just res + Left err -> Left $ ResponseError InternalError (T.pack err) Nothing pure $ case x of Just y -> y - Nothing -> (, Nothing) - $ Left + Nothing -> Left $ ResponseError InvalidRequest "timed out" Nothing -tacticCmd _ _ _ _ = - pure ( Left $ ResponseError InvalidRequest (T.pack "Bad URI") Nothing - , Nothing - ) + case res of + Left err -> pure $ Left err + Right medit -> do + forM_ medit $ \edit -> + sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + pure $ Right Null +tacticCmd _ _ _ = + pure $ Left $ ResponseError InvalidRequest (T.pack "Bad URI") Nothing fromMaybeT :: Functor m => a -> MaybeT m a -> m a diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs index 679b045c9b..d84e2b7e43 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements.hs index d29229f1ed..06d070548d 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Tactics.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Tactics.hs index 2274d8f513..44c53b3d95 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Tactics.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Tactics.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TupleSections #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs index a60049de48..0929d461d4 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 2a9107c495..ee36576843 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -18,7 +18,7 @@ import qualified Data.Text as T import Development.IDE.Core.Rules import Development.IDE.Session (setInitialDynFlags, getHieDbLoc, runWithDb) import Development.IDE.Types.Logger as G -import qualified Language.Haskell.LSP.Core as LSP +import qualified Language.LSP.Server as LSP import Ide.Arguments import Ide.Logger import Ide.Version diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 1690a0175a..8ac168836b 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -29,12 +29,12 @@ extra-deps: - ghc-exactprint-0.6.3.4 - ghc-lib-8.10.3.20201220 - ghc-lib-parser-8.10.3.20201220 - - haskell-lsp-0.23.0.0 - - haskell-lsp-types-0.23.0.0 + - lsp-1.1.0.0 + - lsp-types-1.1.0.0 + - lsp-test-0.13.0.0 - heapsize-0.3.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - refinery-0.3.0.0 - retrie-0.1.1.1 @@ -43,6 +43,12 @@ extra-deps: - temporary-1.2.1.1 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 + - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 + - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 + - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 + - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 configure-options: ghcide: diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index c4a6aa04ba..b40e7aad32 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -28,17 +28,23 @@ extra-deps: - heapsize-0.3.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - refinery-0.3.0.0 - retrie-0.1.1.1 - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 - - haskell-lsp-0.23.0.0 - - haskell-lsp-types-0.23.0.0 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 + - lsp-1.1.0.0 + - lsp-types-1.1.0.0 + - lsp-test-0.13.0.0 + - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 + - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 + - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 + - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 configure-options: ghcide: diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index 77d4e93ef5..0a131baa46 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -29,17 +29,23 @@ extra-deps: - heapsize-0.3.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - refinery-0.3.0.0 - retrie-0.1.1.1 - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 - - haskell-lsp-0.23.0.0 - - haskell-lsp-types-0.23.0.0 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 + - lsp-1.1.0.0 + - lsp-types-1.1.0.0 + - lsp-test-0.13.0.0 + - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 + - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 + - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 + - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 configure-options: ghcide: diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 48e3a13c38..a0fbb624c6 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -44,8 +44,6 @@ extra-deps: - haddock-api-2.22.0@rev:1 - haddock-library-1.8.0 - hashable-1.3.0.0 - - haskell-lsp-0.23.0.0 - - haskell-lsp-types-0.23.0.0 - heapsize-0.3.0 - hie-bios-0.7.1 - hlint-3.2.3 @@ -55,7 +53,6 @@ extra-deps: - implicit-hie-0.1.2.5 - indexed-profunctors-0.1 - lens-4.18 - - lsp-test-0.12.0.0 - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 @@ -83,6 +80,16 @@ extra-deps: - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 + - lsp-1.1.0.0 + - lsp-types-1.1.0.0 + - lsp-test-0.13.0.0 + - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 + - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 + - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 + - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - resourcet-1.2.3 flags: haskell-language-server: diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index de10dea95c..21fc410e6d 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -43,8 +43,6 @@ extra-deps: - haddock-api-2.22.0@rev:1 - haddock-library-1.8.0 - hashable-1.3.0.0 - - haskell-lsp-0.23.0.0 - - haskell-lsp-types-0.23.0.0 - heapsize-0.3.0 - hie-bios-0.7.1 - hlint-3.2.3 @@ -54,7 +52,6 @@ extra-deps: - implicit-hie-0.1.2.5 - indexed-profunctors-0.1 - lens-4.18 - - lsp-test-0.12.0.0 - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 @@ -82,6 +79,16 @@ extra-deps: - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 + - lsp-1.1.0.0 + - lsp-types-1.1.0.0 + - lsp-test-0.13.0.0 + - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 + - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 + - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 + - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - resourcet-1.2.3 configure-options: ghcide: diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index fe7eb81284..729204c456 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -36,8 +36,6 @@ extra-deps: - ghc-lib-parser-ex-8.10.0.17 - ghc-trace-events-0.1.2.1 - haddock-library-1.8.0 - - haskell-lsp-0.23.0.0 - - haskell-lsp-types-0.23.0.0 - haskell-src-exts-1.21.1 - heapsize-0.3.0 - hie-bios-0.7.1 @@ -49,7 +47,6 @@ extra-deps: - ilist-0.3.1.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.12.0.0 - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 @@ -69,6 +66,15 @@ extra-deps: - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 + - lsp-1.1.0.0 + - lsp-types-1.1.0.0 + - lsp-test-0.13.0.0 + - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 + - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 + - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 + - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 configure-options: ghcide: diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index bd196b7a13..f068f9dc39 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -32,8 +32,6 @@ extra-deps: - ghc-lib-8.10.3.20201220 - ghc-lib-parser-8.10.3.20201220 - ghc-trace-events-0.1.2.1 - - haskell-lsp-0.23.0.0 - - haskell-lsp-types-0.23.0.0 - haskell-src-exts-1.21.1 - heapsize-0.3.0 - hie-bios-0.7.1 @@ -44,7 +42,6 @@ extra-deps: - ilist-0.3.1.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.12.0.0 - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 @@ -61,6 +58,15 @@ extra-deps: - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 + - lsp-1.1.0.0 + - lsp-types-1.1.0.0 + - lsp-test-0.13.0.0 + - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 + - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 + - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 + - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 configure-options: ghcide: diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 5265b528fc..55ab6f7da7 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -30,8 +30,6 @@ extra-deps: - fourmolu-0.3.0.0 - ghc-exactprint-0.6.3.4 - ghc-trace-events-0.1.2.1 - - haskell-lsp-0.23.0.0 - - haskell-lsp-types-0.23.0.0 - haskell-src-exts-1.21.1 - heapsize-0.3.0 - hie-bios-0.7.1 @@ -42,7 +40,6 @@ extra-deps: - ilist-0.3.1.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.12.0.0 - megaparsec-9.0.1 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 @@ -56,6 +53,15 @@ extra-deps: - hiedb-0.3.0.1 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 + - lsp-1.1.0.0 + - lsp-types-1.1.0.0 + - lsp-test-0.13.0.0 + - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 + - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 + - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 + - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 configure-options: ghcide: diff --git a/stack.yaml b/stack.yaml index e63af8a734..51e7b86da1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -45,8 +45,6 @@ extra-deps: - haddock-api-2.22.0@rev:1 - haddock-library-1.8.0 - hashable-1.3.0.0 - - haskell-lsp-0.23.0.0 - - haskell-lsp-types-0.23.0.0 - heapsize-0.3.0 - hie-bios-0.7.1 - hlint-3.2.3 @@ -57,7 +55,6 @@ extra-deps: - indexed-profunctors-0.1 - lens-4.18 - megaparsec-9.0.1 - - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 @@ -84,6 +81,16 @@ extra-deps: - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 + - lsp-1.1.0.0 + - lsp-types-1.1.0.0 + - lsp-test-0.13.0.0 + - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 + - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 + - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 + - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - resourcet-1.2.3 configure-options: ghcide: diff --git a/test/functional/Class.hs b/test/functional/Class.hs index 4d02ad4e41..0a0a2d0d4d 100644 --- a/test/functional/Class.hs +++ b/test/functional/Class.hs @@ -2,6 +2,7 @@ -- {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module Class ( tests ) @@ -11,14 +12,15 @@ import Control.Lens hiding ((<.>)) import Control.Monad.IO.Class (MonadIO(liftIO)) import qualified Data.ByteString.Lazy as BS import qualified Data.Text.Encoding as T -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types hiding (_title, _command) -import qualified Language.Haskell.LSP.Types.Lens as J +import Language.LSP.Test +import Language.LSP.Types hiding (_title, _command) +import qualified Language.LSP.Types.Lens as J import System.FilePath import Test.Hls.Util import Test.Tasty import Test.Tasty.Golden import Test.Tasty.HUnit +import Control.Applicative.Combinators tests :: TestTree tests = testGroup @@ -54,10 +56,10 @@ tests = testGroup executeCodeAction _fAction ] -_CACodeAction :: Prism' CAResult CodeAction -_CACodeAction = prism' CACodeAction $ \case - CACodeAction action -> Just action - _ -> Nothing +_CACodeAction :: Prism' (Command |? CodeAction) CodeAction +_CACodeAction = prism' InR $ \case + InR action -> Just action + _ -> Nothing classPath :: FilePath classPath = "test" "testdata" "class" @@ -71,7 +73,7 @@ glodenTest name fp deco execute _ <- waitForDiagnosticsFromSource doc "typecheck" actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc execute actions - BS.fromStrict . T.encodeUtf8 <$> getDocumentEdit doc + BS.fromStrict . T.encodeUtf8 <$> (skipManyTill anyMessage $ getDocumentEdit doc) where fpWithDeco | deco == "" = fp diff --git a/test/functional/Command.hs b/test/functional/Command.hs index 61a806801d..cd39bbf89d 100644 --- a/test/functional/Command.hs +++ b/test/functional/Command.hs @@ -5,9 +5,9 @@ import Control.Lens hiding (List) import Control.Monad.IO.Class import qualified Data.Text as T import Data.Char -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types as LSP -import Language.Haskell.LSP.Types.Lens as LSP +import Language.LSP.Test +import Language.LSP.Types as LSP +import Language.LSP.Types.Lens as LSP import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit @@ -25,8 +25,8 @@ tests = testGroup "commands" [ , testCase "get de-prefixed" $ runSession hlsCommand fullCaps "test/testdata/" $ do ResponseMessage _ _ (Left err) <- request - WorkspaceExecuteCommand - (ExecuteCommandParams "34133:eval:evalCommand" (Just (List [])) Nothing) :: Session ExecuteCommandResponse + SWorkspaceExecuteCommand + (ExecuteCommandParams Nothing "34133:eval:evalCommand" (Just (List []))) let ResponseError _ msg _ = err -- We expect an error message about the dud arguments, but we can -- check that we found the right plugin. diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index bd8ed721f4..2ff96754e6 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -5,9 +5,9 @@ module Completion(tests) where import Control.Monad.IO.Class import Control.Lens hiding ((.=)) import Data.Aeson (object, (.=)) -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens hiding (applyEdit) +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (applyEdit) import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) @@ -42,8 +42,8 @@ tests = testGroup "completions" [ compls <- getCompletions doc (Position 5 9) let item = head $ filter ((== "putStrLn") . (^. label)) compls - resolvedRes <- request CompletionItemResolve item - let Right (resolved :: CompletionItem) = resolvedRes ^. result + resolvedRes <- request SCompletionItemResolve item + let Right resolved = resolvedRes ^. result liftIO $ print resolved liftIO $ do resolved ^. label @?= "putStrLn" @@ -336,7 +336,7 @@ snippetTests = testGroup "snippets" [ let config = object [ "haskell" .= object ["completionSnippetsOn" .= False]] - sendNotification WorkspaceDidChangeConfiguration + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config) checkNoSnippets doc diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 43721fe55a..8e25b244e6 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -11,9 +11,9 @@ import Data.Default import qualified Data.Map as Map import qualified Data.Text as T import Ide.Plugin.Config -import Language.Haskell.LSP.Test as Test -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as L +import Language.LSP.Test as Test +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as L import System.FilePath (()) import Test.Hls.Util import Test.Tasty @@ -34,13 +34,13 @@ hlintTests = testGroup "hlint plugin enables" [ testCase "changing hlintOn configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do let config = def { hlintOn = True } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "ApplyRefact2.hs" "haskell" testHlintDiagnostics doc let config' = def { hlintOn = False } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) diags' <- waitForDiagnosticsFrom doc @@ -48,13 +48,13 @@ hlintTests = testGroup "hlint plugin enables" [ , testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do let config = def { hlintOn = True } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "ApplyRefact2.hs" "haskell" testHlintDiagnostics doc let config' = pluginGlobalOn config "hlint" False - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) diags' <- waitForDiagnosticsFrom doc @@ -78,12 +78,12 @@ configTests :: TestTree configTests = testGroup "config parsing" [ testCase "empty object as user configuration should not send error logMessage" $ runConfigSession "" $ do let config = object [] - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) -- Send custom request so server returns a response to prevent blocking - void $ Test.sendRequest (CustomClientMethod "non-existent-method") () + void $ sendNotification (SCustomMethod "non-existent-method") Null - logNot <- skipManyTill Test.anyMessage Test.message :: Session LogMessageNotification + logNot <- skipManyTill Test.anyMessage (message SWindowLogMessage) liftIO $ (logNot ^. L.params . L.xtype) > MtError || "non-existent-method" `T.isInfixOf` (logNot ^. L.params . L.message) diff --git a/test/functional/Deferred.hs b/test/functional/Deferred.hs index 1cec874df8..91c2a19248 100644 --- a/test/functional/Deferred.hs +++ b/test/functional/Deferred.hs @@ -8,10 +8,10 @@ import Control.Monad.IO.Class import Control.Lens hiding (List) -- import Control.Monad -- import Data.Maybe -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens hiding (id, message) --- import qualified Language.Haskell.LSP.Types.Lens as LSP +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (id, message) +-- import qualified Language.LSP.Types.Lens as LSP import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) @@ -94,7 +94,7 @@ tests = testGroup "deferred responses" [ testCase "instantly respond to failed modules with no cache" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "FuncTestFail.hs" "haskell" defs <- getDefinitions doc (Position 1 11) - liftIO $ defs @?= [] + liftIO $ defs @?= InR [] -- TODO: the benefits of caching parsed modules is doubted. -- TODO: add issue link @@ -160,16 +160,16 @@ multiMainTests = testGroup "multiple main modules" [ testCase "Can load one file at a time, when more than one Main module exists" $ runSession hlsCommand fullCaps "test/testdata" $ do _doc <- openDoc "ApplyRefact2.hs" "haskell" - _diagsRspHlint <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification - diagsRspGhc <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification + _diagsRspHlint <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) + diagsRspGhc <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) let (List diags) = diagsRspGhc ^. params . diagnostics liftIO $ length diags @?= 2 _doc2 <- openDoc "HaReRename.hs" "haskell" - _diagsRspHlint2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification + _diagsRspHlint2 <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) -- errMsg <- skipManyTill anyNotification notification :: Session ShowMessageNotification - diagsRsp2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification + diagsRsp2 <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) let (List diags2) = diagsRsp2 ^. params . diagnostics liftIO $ show diags2 @?= "[]" diff --git a/test/functional/Definition.hs b/test/functional/Definition.hs index e34a65c063..ddf5529acd 100644 --- a/test/functional/Definition.hs +++ b/test/functional/Definition.hs @@ -2,9 +2,9 @@ module Definition (tests) where import Control.Lens import Control.Monad.IO.Class -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens import System.Directory import Test.Hls.Util import Test.Tasty @@ -19,7 +19,7 @@ tests = testGroup "definitions" [ doc <- openDoc "References.hs" "haskell" defs <- getDefinitions doc (Position 7 8) let expRange = Range (Position 4 0) (Position 4 3) - liftIO $ defs @?= [Location (doc ^. uri) expRange] + liftIO $ defs @?= InL [Location (doc ^. uri) expRange] -- ----------------------------------- @@ -29,7 +29,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 2 8) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= [Location (filePathToUri fp) zeroRange] + defs @?= InL [Location (filePathToUri fp) zeroRange] , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's exported modules" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do @@ -37,7 +37,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 0 15) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= [Location (filePathToUri fp) zeroRange] + defs @?= InL [Location (filePathToUri fp) zeroRange] , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's imported modules that are loaded" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do @@ -46,7 +46,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 2 8) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= [Location (filePathToUri fp) zeroRange] + defs @?= InL [Location (filePathToUri fp) zeroRange] , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's imported modules that are loaded, and then closed" $ @@ -59,7 +59,7 @@ tests = testGroup "definitions" [ liftIO $ putStrLn "D" liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= [Location (filePathToUri fp) zeroRange] + defs @?= InL [Location (filePathToUri fp) zeroRange] liftIO $ putStrLn "E" -- AZ noDiagnostics diff --git a/test/functional/Diagnostic.hs b/test/functional/Diagnostic.hs index 855a729203..26ea60616d 100644 --- a/test/functional/Diagnostic.hs +++ b/test/functional/Diagnostic.hs @@ -8,9 +8,9 @@ import Control.Monad.IO.Class import Data.Aeson (toJSON) import qualified Data.Default import Ide.Plugin.Config -import Language.Haskell.LSP.Test hiding (message) -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as LSP +import Language.LSP.Test hiding (message) +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as LSP import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) @@ -64,7 +64,7 @@ saveTests = testGroup "only diagnostics on save" [ ignoreTestBecause "diagnosticsOnChange parameter is not supported right now" $ testCase "Respects diagnosticsOnChange setting" $ runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do let config = Data.Default.def { diagnosticsOnChange = False } :: Config - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "Hover.hs" "haskell" diags <- waitForDiagnosticsFrom doc @@ -75,7 +75,7 @@ saveTests = testGroup "only diagnostics on save" [ _ <- applyEdit doc te skipManyTill loggingNotification noDiagnostics - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + sendNotification STextDocumentDidSave (DidSaveTextDocumentParams doc Nothing) diags2 <- waitForDiagnosticsFrom doc liftIO $ length diags2 @?= 1 diff --git a/test/functional/Format.hs b/test/functional/Format.hs index e0202c87f8..4b58b6d793 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -5,12 +5,14 @@ import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString.Lazy as BS import qualified Data.Text.Encoding as T -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types +import Language.LSP.Test +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as LSP import Test.Hls.Util import Test.Tasty import Test.Tasty.Golden import Test.Tasty.HUnit +import Control.Lens ((^.)) #if AGPL import qualified Data.Text.IO as T @@ -20,11 +22,11 @@ tests :: TestTree tests = testGroup "format document" [ goldenVsStringDiff "works" goldenGitDiff "test/testdata/format/Format.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 2 True) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "works with custom tab size" goldenGitDiff "test/testdata/format/Format.formatted_document_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 5 True) + formatDoc doc (FormattingOptions 5 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , rangeTests , providerTests @@ -40,11 +42,11 @@ rangeTests :: TestTree rangeTests = testGroup "format range" [ goldenVsStringDiff "works" goldenGitDiff "test/testdata/format/Format.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" - formatRange doc (FormattingOptions 2 True) (Range (Position 5 0) (Position 7 10)) + formatRange doc (FormattingOptions 2 True Nothing Nothing Nothing) (Range (Position 5 0) (Position 7 10)) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "works with custom tab size" goldenGitDiff "test/testdata/format/Format.formatted_range_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" - formatRange doc (FormattingOptions 5 True) (Range (Position 8 0) (Position 11 19)) + formatRange doc (FormattingOptions 5 True Nothing Nothing Nothing) (Range (Position 8 0) (Position 11 19)) BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] @@ -52,13 +54,8 @@ providerTests :: TestTree providerTests = testGroup "formatting provider" [ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" - orig <- documentContents doc - - formatDoc doc (FormattingOptions 2 True) - documentContents doc >>= liftIO . (@?= orig) - - formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) - documentContents doc >>= liftIO . (@?= orig) + resp <- request STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) + liftIO $ resp ^. LSP.result @?= (Left $ ResponseError InvalidRequest "No plugin enabled for STextDocumentFormatting, available: []" Nothing) #if AGPL , testCase "can change on the fly" $ runSession hlsCommand fullCaps "test/testdata/format" $ do @@ -68,16 +65,16 @@ providerTests = testGroup "formatting provider" [ doc <- openDoc "Format.hs" "haskell" - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) - formatDoc doc (FormattingOptions 2 True) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedBrittany) - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "floskell")) - formatDoc doc (FormattingOptions 2 True) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "floskell")) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedFloskell) - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) - formatDoc doc (FormattingOptions 2 True) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedBrittanyPostFloskell) , testCase "supports both new and old configuration sections" $ runSession hlsCommand fullCaps "test/testdata/format" $ do formattedBrittany <- liftIO $ T.readFile "test/testdata/format/Format.brittany.formatted.hs" @@ -85,12 +82,12 @@ providerTests = testGroup "formatting provider" [ doc <- openDoc "Format.hs" "haskell" - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfigOld "brittany")) - formatDoc doc (FormattingOptions 2 True) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfigOld "brittany")) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedBrittany) - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfigOld "floskell")) - formatDoc doc (FormattingOptions 2 True) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfigOld "floskell")) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedFloskell) #endif ] @@ -98,14 +95,14 @@ providerTests = testGroup "formatting provider" [ stylishHaskellTests :: TestTree stylishHaskellTests = testGroup "stylish-haskell" [ goldenVsStringDiff "formats a document" goldenGitDiff "test/testdata/format/StylishHaskell.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell")) doc <- openDoc "StylishHaskell.hs" "haskell" - formatDoc doc (FormattingOptions 2 True) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats a range" goldenGitDiff "test/testdata/format/StylishHaskell.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "stylish-haskell")) doc <- openDoc "StylishHaskell.hs" "haskell" - formatRange doc (FormattingOptions 2 True) (Range (Position 0 0) (Position 2 21)) + formatRange doc (FormattingOptions 2 True Nothing Nothing Nothing) (Range (Position 0 0) (Position 2 21)) BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] @@ -113,29 +110,29 @@ stylishHaskellTests = testGroup "stylish-haskell" [ brittanyTests :: TestTree brittanyTests = testGroup "brittany" [ goldenVsStringDiff "formats a document with LF endings" goldenGitDiff "test/testdata/format/BrittanyLF.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) doc <- openDoc "BrittanyLF.hs" "haskell" - formatDoc doc (FormattingOptions 4 True) + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats a document with CRLF endings" goldenGitDiff "test/testdata/format/BrittanyCRLF.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) doc <- openDoc "BrittanyCRLF.hs" "haskell" - formatDoc doc (FormattingOptions 4 True) + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats a range with LF endings" goldenGitDiff "test/testdata/format/BrittanyLF.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) doc <- openDoc "BrittanyLF.hs" "haskell" let range = Range (Position 1 0) (Position 2 22) - formatRange doc (FormattingOptions 4 True) range + formatRange doc (FormattingOptions 4 True Nothing Nothing Nothing) range BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats a range with CRLF endings" goldenGitDiff "test/testdata/format/BrittanyCRLF.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) doc <- openDoc "BrittanyCRLF.hs" "haskell" let range = Range (Position 1 0) (Position 2 22) - formatRange doc (FormattingOptions 4 True) range + formatRange doc (FormattingOptions 4 True Nothing Nothing Nothing) range BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] #endif @@ -143,28 +140,28 @@ brittanyTests = testGroup "brittany" [ ormoluTests :: TestTree ormoluTests = testGroup "ormolu" [ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/format/Format.ormolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 2 True) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats imports correctly" goldenGitDiff "test/testdata/format/Format2.ormolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format2.hs" "haskell" - formatDoc doc (FormattingOptions 2 True) + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] fourmoluTests :: TestTree fourmoluTests = testGroup "fourmolu" [ goldenVsStringDiff "formats correctly" goldenGitDiff "test/testdata/format/Format.fourmolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 4 True) + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc , goldenVsStringDiff "formats imports correctly" goldenGitDiff "test/testdata/format/Format2.fourmolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) doc <- openDoc "Format2.hs" "haskell" - formatDoc doc (FormattingOptions 4 True) + formatDoc doc (FormattingOptions 4 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc ] diff --git a/test/functional/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs index 1e8082427f..bca731f965 100644 --- a/test/functional/FunctionalBadProject.hs +++ b/test/functional/FunctionalBadProject.hs @@ -5,9 +5,9 @@ module FunctionalBadProject (tests) where -- import Control.Lens hiding (List) -- import Control.Monad.IO.Class -- import qualified Data.Text as T --- import Language.Haskell.LSP.Test hiding (message) --- import Language.Haskell.LSP.Types as LSP --- import Language.Haskell.LSP.Types.Lens as LSP hiding (contents, error ) +-- import Language.LSP.Test hiding (message) +-- import Language.LSP.Types as LSP +-- import Language.LSP.Types.Lens as LSP hiding (contents, error ) -- import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 80b1c75296..a150c274c6 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} module FunctionalCodeAction (tests) where @@ -14,10 +15,10 @@ import Data.List import Data.Maybe import qualified Data.Text as T import Ide.Plugin.Config -import Language.Haskell.LSP.Test as Test -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as L -import qualified Language.Haskell.LSP.Types.Capabilities as C +import Language.LSP.Test as Test +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Types.Capabilities as C import Test.Hls.Util import Test.Hspec.Expectations @@ -52,7 +53,7 @@ hlintTests = testGroup "hlint suggestions" [ length diags @?= 2 -- "Eta Reduce" and "Redundant Id" reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12) reduceDiag ^. L.severity @?= Just DsInfo - reduceDiag ^. L.code @?= Just (StringValue "refact:Eta reduce") + reduceDiag ^. L.code @?= Just (InR "refact:Eta reduce") reduceDiag ^. L.source @?= Just "hlint" cas <- map fromAction <$> getAllCodeActions doc @@ -85,13 +86,13 @@ hlintTests = testGroup "hlint suggestions" [ , testCase "changing configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do let config = def { hlintOn = True } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "ApplyRefact2.hs" "haskell" testHlintDiagnostics doc let config' = def { hlintOn = False } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) diags' <- waitForDiagnosticsFrom doc @@ -188,7 +189,7 @@ hlintTests = testGroup "hlint suggestions" [ executeCodeAction (fromJust ca) - contents <- getDocumentEdit doc + contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= T.unlines expected expectedLambdaCase = [ "module ApplyRefact1 where", "" @@ -223,6 +224,7 @@ renameTests = testGroup "rename suggestions" [ cars <- getAllCodeActions doc replaceButStrLn <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"] executeCommand replaceButStrLn + _ <- anyRequest x:_ <- T.lines <$> documentContents doc liftIO $ x @?= "main = putStrLn \"hello\"" @@ -242,6 +244,7 @@ renameTests = testGroup "rename suggestions" [ not ("documentChanges" `HM.member` editParams) @? "Doesn't contain documentChanges" executeCommand cmd + _ <- anyRequest x1:x2:_ <- T.lines <$> documentContents doc liftIO $ @@ -256,7 +259,7 @@ importTests = testGroup "import suggestions" [ doc <- openDoc "CodeActionImport.hs" "haskell" -- No Formatting: let config = def { formattingProvider = "none" } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) (diag:_) <- waitForDiagnosticsFrom doc liftIO $ diag ^. L.message @?= "Variable not in scope: when :: Bool -> IO () -> IO ()" @@ -295,7 +298,7 @@ packageTests = testGroup "add package suggestions" [ in liftIO $ any (`T.isPrefixOf` (diag ^. L.message)) prefixes @? "Contains prefix" acts <- getAllCodeActions doc - let (CACodeAction action:_) = acts + let (InR action:_) = acts liftIO $ do action ^. L.title @?= "Add text as a dependency" @@ -373,8 +376,9 @@ redundantImportTests = testGroup "redundant import code actions" [ , testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do doc <- openDoc "src/MultipleImports.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" - _ : CACommand cmd : _ <- getAllCodeActions doc + _ : InL cmd : _ <- getAllCodeActions doc executeCommand cmd + _ <- anyRequest contents <- documentContents doc liftIO $ T.lines contents @?= [ "{-# OPTIONS_GHC -Wunused-imports #-}" @@ -580,12 +584,12 @@ unusedTermTests = testGroup "unused term code actions" [ doc <- openDoc "CodeActionOnly.hs" "haskell" _ <- waitForDiagnosticsFrom doc diags <- getCurrentDiagnostics doc - let params = CodeActionParams doc (Range (Position 1 0) (Position 4 0)) caContext Nothing + let params = CodeActionParams Nothing Nothing doc (Range (Position 1 0) (Position 4 0)) caContext caContext = CodeActionContext (List diags) (Just (List [CodeActionRefactorInline])) caContextAllActions = CodeActionContext (List diags) Nothing -- Verify that we get code actions of at least two different kinds. ResponseMessage _ _ (Right (List allCodeActions)) - <- request TextDocumentCodeAction (params & L.context .~ caContextAllActions) + <- request STextDocumentCodeAction (params & L.context .~ caContextAllActions) liftIO $ do redundantId <- inspectCodeAction allCodeActions ["Redundant id"] redundantId ^. L.kind @?= Just CodeActionQuickFix @@ -593,7 +597,7 @@ unusedTermTests = testGroup "unused term code actions" [ unfoldFoo ^. L.kind @?= Just CodeActionRefactorInline -- Verify that that when we set the only parameter, we only get actions -- of the right kind. - ResponseMessage _ _ (Right (List res)) <- request TextDocumentCodeAction params + ResponseMessage _ _ (Right (List res)) <- request STextDocumentCodeAction params let cas = map fromAction res kinds = map (^. L.kind) cas liftIO $ do @@ -605,4 +609,4 @@ noLiteralCaps :: C.ClientCapabilities noLiteralCaps = def { C._textDocument = Just textDocumentCaps } where textDocumentCaps = def { C._codeAction = Just codeActionCaps } - codeActionCaps = C.CodeActionClientCapabilities (Just True) Nothing + codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing diff --git a/test/functional/FunctionalLiquid.hs b/test/functional/FunctionalLiquid.hs index 8a461d5777..5ecdab96e8 100644 --- a/test/functional/FunctionalLiquid.hs +++ b/test/functional/FunctionalLiquid.hs @@ -6,9 +6,9 @@ import Control.Lens hiding (List) import Control.Monad.IO.Class import Data.Aeson import Data.Default -import Language.Haskell.LSP.Test hiding (message) -import Language.Haskell.LSP.Types as LSP -import Language.Haskell.LSP.Types.Lens as LSP hiding (contents) +import Language.LSP.Test hiding (message) +import Language.LSP.Types as LSP +import Language.LSP.Types.Lens as LSP hiding (contents) import Ide.Plugin.Config import Test.Hls.Util import Test.Tasty @@ -25,7 +25,7 @@ tests = testGroup "liquid haskell diagnostics" [ doc <- openDoc "liquid/Evens.hs" "haskell" let config = def { liquidOn = True, hlintOn = False } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) diags <- waitForDiagnosticsFromSource doc "liquid" d <- liftIO $ inspectDiagnostic diags ["Liquid Type Mismatch"] diff --git a/test/functional/HaddockComments.hs b/test/functional/HaddockComments.hs index 9e0378acd8..acc650575f 100644 --- a/test/functional/HaddockComments.hs +++ b/test/functional/HaddockComments.hs @@ -2,6 +2,9 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} module HaddockComments ( tests, @@ -14,8 +17,8 @@ import Data.Foldable (find) import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types +import Language.LSP.Test +import Language.LSP.Types import System.FilePath ((<.>), ()) import Test.Hls.Util import Test.Tasty @@ -43,7 +46,7 @@ goldenTest fp (toTitle -> expectedTitle) l c = goldenVsStringDiff (fp <> " (gold _ <- waitForDiagnostics actions <- getCodeActions doc (Range (Position l c) (Position l $ succ c)) case find ((== Just expectedTitle) . caTitle) actions of - Just (CACodeAction x) -> do + Just (InR x) -> do executeCodeAction x LBS.fromStrict . encodeUtf8 <$> documentContents doc _ -> liftIO $ assertFailure "Unable to find CodeAction" @@ -65,8 +68,8 @@ toTitle :: GenCommentsType -> Text toTitle Signature = "Generate signature comments" toTitle Record = "Generate fields comments" -caTitle :: CAResult -> Maybe Text -caTitle (CACodeAction CodeAction {_title}) = Just _title +caTitle :: (Command |? CodeAction) -> Maybe Text +caTitle (InR CodeAction {_title}) = Just _title caTitle _ = Nothing haddockCommentsPath :: String diff --git a/test/functional/HieBios.hs b/test/functional/HieBios.hs index bda0c552a4..a8442b5d4a 100644 --- a/test/functional/HieBios.hs +++ b/test/functional/HieBios.hs @@ -4,9 +4,9 @@ module HieBios (tests) where import Control.Lens ((^.)) import Control.Monad.IO.Class import qualified Data.Text as T -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as L +import Language.LSP.Test +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as L import System.FilePath (()) import Test.Hls.Util import Test.Tasty diff --git a/test/functional/Highlight.hs b/test/functional/Highlight.hs index 14bb24a768..6457c120a6 100644 --- a/test/functional/Highlight.hs +++ b/test/functional/Highlight.hs @@ -2,8 +2,8 @@ module Highlight (tests) where import Control.Monad.IO.Class -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types +import Language.LSP.Test +import Language.LSP.Types import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit diff --git a/test/functional/ModuleName.hs b/test/functional/ModuleName.hs index 67f8e9425a..b45aef34a2 100644 --- a/test/functional/ModuleName.hs +++ b/test/functional/ModuleName.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} - +{-# LANGUAGE DuplicateRecordFields #-} + module ModuleName ( tests ) @@ -9,12 +10,11 @@ where import Control.Applicative.Combinators (skipManyTill) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Text.IO as T -import Language.Haskell.LSP.Test (anyMessage, documentContents, +import Language.LSP.Test (anyMessage, documentContents, executeCommand, fullCaps, getCodeLenses, message, openDoc, runSession) -import Language.Haskell.LSP.Types (ApplyWorkspaceEditRequest, - CodeLens (..)) +import Language.LSP.Types import System.FilePath ((<.>), ()) import Test.Hls.Util (hlsCommand) import Test.Tasty (TestTree, testGroup) @@ -34,7 +34,7 @@ goldenTest input = runSession hlsCommand fullCaps testdataPath $ do -- getCodeLenses doc >>= liftIO . print . length [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) edited <- documentContents doc -- liftIO $ T.writeFile (testdataPath input <.> "expected") edited expected <- liftIO $ T.readFile $ testdataPath input <.> "expected" diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index d674e077da..676e4dc664 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -1,6 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} module Progress (tests) where @@ -13,10 +17,10 @@ import Data.List (delete) import Data.Maybe (fromJust) import Data.Text (Text, pack) import Ide.Plugin.Config -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities -import qualified Language.Haskell.LSP.Types.Lens as L +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import qualified Language.LSP.Types.Lens as L import System.FilePath (()) import Test.Hls.Util import Test.Tasty @@ -38,29 +42,29 @@ tests = expectProgressReports ["Setting up testdata (for T1.hs)", "Processing"] [evalLens] <- getCodeLenses doc let cmd = evalLens ^?! L.command . _Just - _ <- sendRequest WorkspaceExecuteCommand $ ExecuteCommandParams (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) Nothing + _ <- sendRequest SWorkspaceExecuteCommand $ ExecuteCommandParams Nothing (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) expectProgressReports ["Evaluating"] , testCase "ormolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format.hs" "haskell" expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"] - _ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing + _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressReports ["Formatting Format.hs"] , testCase "fourmolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) doc <- openDoc "Format.hs" "haskell" expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"] - _ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing + _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressReports ["Formatting Format.hs"] , ignoreTestBecause "no liquid Haskell support" $ testCase "liquid haskell plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata" $ do doc <- openDoc "liquid/Evens.hs" "haskell" let config = def{liquidOn = True, hlintOn = False} - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification STextDocumentDidSave (DidSaveTextDocumentParams doc Nothing) expectProgressReports ["Running Liquid Haskell on Evens.hs"] ] @@ -71,10 +75,10 @@ progressCaps :: ClientCapabilities progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True))} data CollectedProgressNotification - = CreateM WorkDoneProgressCreateRequest - | BeginM WorkDoneProgressBeginNotification - | ProgressM WorkDoneProgressReportNotification - | EndM WorkDoneProgressEndNotification + = CreateM WorkDoneProgressCreateParams + | BeginM (ProgressParams WorkDoneProgressBeginParams) + | ProgressM (ProgressParams WorkDoneProgressReportParams) + | EndM (ProgressParams WorkDoneProgressEndParams) {- | Test that the server is correctly producing a sequence of progress related messages. Each create must be pair with a corresponding begin and end, @@ -83,7 +87,7 @@ data CollectedProgressNotification the titles we see are those we expect. -} expectProgressReports :: [Text] -> Session () -expectProgressReports = expectProgressReports' [] +expectProgressReports xs = expectProgressReports' [] xs where expectProgressReports' [] [] = return () expectProgressReports' tokens expectedTitles = @@ -93,7 +97,7 @@ expectProgressReports = expectProgressReports' [] CreateM msg -> expectProgressReports' (token msg : tokens) expectedTitles BeginM msg -> do - liftIO $ title msg `expectElem` ("Indexing references from:":expectedTitles) + liftIO $ title msg `expectElem` ("Indexing references from:":xs) liftIO $ token msg `expectElem` tokens expectProgressReports' tokens (delete (title msg) expectedTitles) ProgressM msg -> do @@ -102,10 +106,16 @@ expectProgressReports = expectProgressReports' [] EndM msg -> do liftIO $ token msg `expectElem` tokens expectProgressReports' (delete (token msg) tokens) expectedTitles - title msg = msg ^. L.params ^. L.value ^. L.title - token msg = msg ^. L.params ^. L.token - create = CreateM <$> message - begin = BeginM <$> message - progress = ProgressM <$> message - end = EndM <$> message + title msg = msg ^. L.value ^. L.title + token msg = msg ^. L.token + create = CreateM . view L.params <$> (message SWindowWorkDoneProgressCreate) + begin = BeginM <$> satisfyMaybe (\case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Begin x))) -> Just (ProgressParams t x) + _ -> Nothing) + progress = ProgressM <$> satisfyMaybe (\case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Report x))) -> Just (ProgressParams t x) + _ -> Nothing) + end = EndM <$> satisfyMaybe (\case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (End x))) -> Just (ProgressParams t x) + _ -> Nothing) expectElem a as = a `elem` as @? "Unexpected " ++ show a diff --git a/test/functional/Reference.hs b/test/functional/Reference.hs index fbe2ce2330..c4718e7e35 100644 --- a/test/functional/Reference.hs +++ b/test/functional/Reference.hs @@ -3,13 +3,14 @@ module Reference (tests) where import Control.Lens import Control.Monad.IO.Class import Data.List -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit +import Data.Coerce tests :: TestTree tests = testGroup "references" [ @@ -24,7 +25,7 @@ tests = testGroup "references" [ , mkRange 4 14 4 17 , mkRange 4 0 4 3 , mkRange 2 6 2 9 - ] `isInfixOf` refs @? "Contains references" + ] `isInfixOf` (coerce refs) @? "Contains references" -- TODO: Respect withDeclaration parameter -- ignoreTestBecause "Broken" $ testCase "works without definitions" $ runSession hlsCommand fullCaps "test/testdata" $ do -- doc <- openDoc "References.hs" "haskell" diff --git a/test/functional/Rename.hs b/test/functional/Rename.hs index bcd9a65a62..576bbaf6c8 100644 --- a/test/functional/Rename.hs +++ b/test/functional/Rename.hs @@ -2,8 +2,8 @@ module Rename (tests) where import Control.Monad.IO.Class (liftIO) -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types +import Language.LSP.Test +import Language.LSP.Types import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit diff --git a/test/functional/Splice.hs b/test/functional/Splice.hs index e5fdca0468..a0c5f02e65 100644 --- a/test/functional/Splice.hs +++ b/test/functional/Splice.hs @@ -2,6 +2,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} module Splice (tests) where @@ -13,16 +16,8 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Ide.Plugin.Splice.Types -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types - ( ApplyWorkspaceEditRequest, - CAResult (..), - CodeAction (..), - Position (..), - Range (..), - TextDocumentContentChangeEvent (..), - TextEdit (..), - ) +import Language.LSP.Test +import Language.LSP.Types import System.Directory import System.FilePath import System.Time.Extra (sleep) @@ -77,9 +72,9 @@ goldenTest input tc line col = _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of - Just (CACodeAction CodeAction {_command = Just c}) -> do + Just (InR CodeAction {_command = Just c}) -> do executeCommand c - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) edited <- documentContents doc let expected_name = spliceTestPath input <.> "expected" -- Write golden tests if they don't already exist @@ -110,9 +105,9 @@ goldenTestWithEdit input tc line col = void waitForDiagnostics actions <- getCodeActions doc $ pointRange line col case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of - Just (CACodeAction CodeAction {_command = Just c}) -> do + Just (InR CodeAction {_command = Just c}) -> do executeCommand c - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) edited <- documentContents doc let expected_name = spliceTestPath input <.> "expected" -- Write golden tests if they don't already exist @@ -134,6 +129,6 @@ pointRange Range (Position line col) (Position line $ col + 1) -- | Get the title of a code action. -codeActionTitle :: CAResult -> Maybe Text -codeActionTitle CACommand {} = Nothing -codeActionTitle (CACodeAction (CodeAction title _ _ _ _)) = Just title +codeActionTitle :: (Command |? CodeAction) -> Maybe Text +codeActionTitle InL{} = Nothing +codeActionTitle (InR(CodeAction title _ _ _ _ _ _)) = Just title diff --git a/test/functional/Symbol.hs b/test/functional/Symbol.hs index bda453841f..04af41ede0 100644 --- a/test/functional/Symbol.hs +++ b/test/functional/Symbol.hs @@ -4,10 +4,10 @@ module Symbol (tests) where import Control.Lens (to, ix, (^?), _Just) import Control.Monad.IO.Class import Data.List -import Language.Haskell.LSP.Test as Test -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as L -import Language.Haskell.LSP.Types.Capabilities +import Language.LSP.Test as Test +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as L +import Language.LSP.Types.Capabilities import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) diff --git a/test/functional/Tactic.hs b/test/functional/Tactic.hs index a797479d01..c48bdc2411 100644 --- a/test/functional/Tactic.hs +++ b/test/functional/Tactic.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} module Tactic ( tests @@ -19,9 +22,9 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Ide.Plugin.Tactic.TestTypes -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types (ExecuteCommandParams(ExecuteCommandParams), ClientMethod (..), Command, ExecuteCommandResponse, ResponseMessage (..), ApplyWorkspaceEditRequest, Position(..) , Range(..) , CAResult(..) , CodeAction(..)) -import Language.Haskell.LSP.Types.Lens hiding (id, capabilities, message, executeCommand, applyEdit, rename) +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (id, capabilities, message, executeCommand, applyEdit, rename) import System.Directory (doesFileExist) import System.FilePath import Test.Hls.Util @@ -44,9 +47,9 @@ pointRange ------------------------------------------------------------------------------ -- | Get the title of a code action. -codeActionTitle :: CAResult -> Maybe Text -codeActionTitle CACommand{} = Nothing -codeActionTitle (CACodeAction(CodeAction title _ _ _ _)) = Just title +codeActionTitle :: (Command |? CodeAction) -> Maybe Text +codeActionTitle InL{} = Nothing +codeActionTitle (InR(CodeAction title _ _ _ _ _ _)) = Just title tests :: TestTree @@ -158,10 +161,10 @@ goldenTest input line col tc occ = doc <- openDoc input "haskell" _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col - Just (CACodeAction CodeAction {_command = Just c}) + Just (InR CodeAction {_command = Just c}) <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions executeCommand c - _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) edited <- documentContents doc let expected_name = tacticPath input <.> "expected" -- Write golden tests if they don't already exist @@ -178,7 +181,7 @@ expectFail input line col tc occ = doc <- openDoc input "haskell" _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col - Just (CACodeAction CodeAction {_command = Just c}) + Just (InR CodeAction {_command = Just c}) <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions resp <- executeCommandWithResp c liftIO $ unless (isLeft $ _result resp) $ @@ -189,8 +192,8 @@ tacticPath :: FilePath tacticPath = "test/testdata/tactic" -executeCommandWithResp :: Command -> Session ExecuteCommandResponse +executeCommandWithResp :: Command -> Session (ResponseMessage WorkspaceExecuteCommand) executeCommandWithResp cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments - execParams = ExecuteCommandParams (cmd ^. command) args Nothing - request WorkspaceExecuteCommand execParams + execParams = ExecuteCommandParams Nothing (cmd ^. command) args + request SWorkspaceExecuteCommand execParams diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index c1b6e7e7b2..4bf49efb84 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -2,8 +2,8 @@ module TypeDefinition (tests) where import Control.Monad.IO.Class import Data.Tuple.Extra (first3) -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types +import Language.LSP.Test +import Language.LSP.Types import System.FilePath (()) import Test.Hls.Util import Test.Tasty @@ -38,7 +38,7 @@ getTypeDefinitionTest :: SymbolLocation -> [SymbolLocation] -> Assertion getTypeDefinitionTest (symbolFile, symbolLine, symbolCol) definitionLocations = failIfSessionTimeout . runSession (hlsCommand ++ " --test") fullCaps definitionsPath $ do doc <- openDoc symbolFile "haskell" - defs <- getTypeDefinitions doc $ Position symbolLine symbolCol + InL defs <- getTypeDefinitions doc $ Position symbolLine symbolCol liftIO $ defs `expectSameLocations` map (first3 (definitionsPath )) definitionLocations getTypeDefinitionTest' :: Int -> Int -> Int -> Int -> Assertion diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs index 2e27cc3cd5..b3b4296f3b 100644 --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns, MultiParamTypeClasses #-} +{-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns, MultiParamTypeClasses, DuplicateRecordFields, TypeOperators, GADTs #-} +{-# LANGUAGE FlexibleContexts #-} module Test.Hls.Util ( codeActionSupportCaps - , dummyLspFuncs , expectCodeAction , expectDiagnostic , expectNoMoreDiagnostics @@ -36,6 +36,7 @@ module Test.Hls.Util ) where +import qualified Data.Aeson as A import Control.Exception (throwIO, catch) import Control.Monad import Control.Monad.IO.Class @@ -47,12 +48,10 @@ import Data.List.Extra (find) import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Messages (FromServerMessage(NotLogMessage)) -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Test as Test -import qualified Language.Haskell.LSP.Types.Lens as L -import qualified Language.Haskell.LSP.Types.Capabilities as C +import Language.LSP.Types hiding (Reason(..)) +import qualified Language.LSP.Test as Test +import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Types.Capabilities as C import System.Directory import System.Environment import System.Time.Extra (Seconds, sleep) @@ -72,8 +71,8 @@ codeActionSupportCaps :: C.ClientCapabilities codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps } where textDocumentCaps = def { C._codeAction = Just codeActionCaps } - codeActionCaps = C.CodeActionClientCapabilities (Just True) (Just literalSupport) - literalSupport = C.CodeActionLiteralSupport def + codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) + literalSupport = CodeActionLiteralSupport def -- --------------------------------------------------------------------- @@ -292,22 +291,6 @@ flushStackEnvironment = do -- --------------------------------------------------------------------- -dummyLspFuncs :: Default a => LspFuncs a -dummyLspFuncs = LspFuncs { clientCapabilities = def - , config = return (Just def) - , sendFunc = const (return ()) - , getVirtualFileFunc = const (return Nothing) - , persistVirtualFileFunc = \uri -> return (uriToFilePath (fromNormalizedUri uri)) - , reverseFileMapFunc = return id - , publishDiagnosticsFunc = mempty - , flushDiagnosticsBySourceFunc = mempty - , getNextReqId = pure (IdInt 0) - , rootPath = Nothing - , getWorkspaceFolders = return Nothing - , withProgress = \_ _ f -> f (const (return ())) - , withIndefiniteProgress = \_ _ f -> f - } - -- | Like 'withCurrentDirectory', but will copy the directory over to the system -- temporary directory first to avoid haskell-language-server's source tree from -- interfering with the cradle @@ -335,12 +318,12 @@ copyDir src dst = do else copyFile srcFp dstFp where ignored = ["dist", "dist-newstyle", ".stack-work"] -fromAction :: CAResult -> CodeAction -fromAction (CACodeAction action) = action +fromAction :: (Command |? CodeAction) -> CodeAction +fromAction (InR action) = action fromAction _ = error "Not a code action" -fromCommand :: CAResult -> Command -fromCommand (CACommand command) = command +fromCommand :: (Command |? CodeAction) -> Command +fromCommand (InL command) = command fromCommand _ = error "Not a command" onMatch :: [a] -> (a -> Bool) -> String -> IO a @@ -353,24 +336,24 @@ inspectDiagnostic diags s = onMatch diags (\ca -> all (`T.isInfixOf` (ca ^. L.me expectDiagnostic :: [Diagnostic] -> [T.Text] -> IO () expectDiagnostic diags s = void $ inspectDiagnostic diags s -inspectCodeAction :: [CAResult] -> [T.Text] -> IO CodeAction +inspectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO CodeAction inspectCodeAction cars s = fromAction <$> onMatch cars predicate err - where predicate (CACodeAction ca) = all (`T.isInfixOf` (ca ^. L.title)) s + where predicate (InR ca) = all (`T.isInfixOf` (ca ^. L.title)) s predicate _ = False err = "expected code action matching '" ++ show s ++ "' but did not find one" -expectCodeAction :: [CAResult] -> [T.Text] -> IO () +expectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO () expectCodeAction cars s = void $ inspectCodeAction cars s -inspectCommand :: [CAResult] -> [T.Text] -> IO Command +inspectCommand :: [Command |? CodeAction] -> [T.Text] -> IO Command inspectCommand cars s = fromCommand <$> onMatch cars predicate err - where predicate (CACommand command) = all (`T.isInfixOf` (command ^. L.title)) s + where predicate (InL command) = all (`T.isInfixOf` (command ^. L.title)) s predicate _ = False err = "expected code action matching '" ++ show s ++ "' but did not find one" waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic] waitForDiagnosticsFrom doc = do - diagsNot <- skipManyTill Test.anyMessage Test.message :: Test.Session PublishDiagnosticsNotification + diagsNot <- skipManyTill Test.anyMessage (Test.message STextDocumentPublishDiagnostics) let (List diags) = diagsNot ^. L.params . L.diagnostics if doc ^. L.uri /= diagsNot ^. L.params . L.uri then waitForDiagnosticsFrom doc @@ -378,7 +361,7 @@ waitForDiagnosticsFrom doc = do waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> Test.Session [Diagnostic] waitForDiagnosticsFromSource doc src = do - diagsNot <- skipManyTill Test.anyMessage Test.message :: Test.Session PublishDiagnosticsNotification + diagsNot <- skipManyTill Test.anyMessage (Test.message STextDocumentPublishDiagnostics) let (List diags) = diagsNot ^. L.params . L.diagnostics let res = filter matches diags if doc ^. L.uri /= diagsNot ^. L.params . L.uri || null res @@ -408,7 +391,7 @@ waitForDiagnosticsFromSourceWithTimeout timeout document source = do -- Send a dummy message to provoke a response from the server. -- This guarantees that we have at least one message to -- process, so message won't block or timeout. - void $ Test.sendRequest (CustomClientMethod "non-existent-method") () + void $ Test.sendNotification (SCustomMethod "non-existent-method") A.Null handleMessages where matches :: Diagnostic -> Bool @@ -416,7 +399,7 @@ waitForDiagnosticsFromSourceWithTimeout timeout document source = do handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers handleDiagnostic = do - diagsNot <- Test.message :: Test.Session PublishDiagnosticsNotification + diagsNot <- Test.message STextDocumentPublishDiagnostics let fileUri = diagsNot ^. L.params . L.uri (List diags) = diagsNot ^. L.params . L.diagnostics res = filter matches diags @@ -427,8 +410,9 @@ waitForDiagnosticsFromSourceWithTimeout timeout document source = do -- handle that and then exit void (Test.satisfyMaybe responseForNonExistentMethod) >> return [] + responseForNonExistentMethod :: FromServerMessage -> Maybe FromServerMessage responseForNonExistentMethod notif - | NotLogMessage logMsg <- notif, + | FromServerMess SWindowLogMessage logMsg <- notif, "non-existent-method" `T.isInfixOf` (logMsg ^. L.params . L.message) = Just notif | otherwise = Nothing