diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index fbe7b5df29..c70315c2fe 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -964,7 +964,7 @@ useWithStale key file = runIdentity <$> usesWithStale key (Identity file) -- |Request a Rule result, it not available return the last computed result -- which may be stale. -- --- Throws an `BadDependency` IO exception which is caught by the rule system if +-- Throws an `BadDependency` exception which is caught by the rule system if -- none available. -- -- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead. @@ -974,7 +974,7 @@ useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) -- |Plural version of 'useWithStale_' -- --- Throws an `BadDependency` IO exception which is caught by the rule system if +-- Throws an `BadDependency` exception which is caught by the rule system if -- none available. -- -- WARNING: Not suitable for PluginHandlers. @@ -1053,7 +1053,7 @@ useNoFile key = use key emptyFilePath -- Requests a rule if available. -- --- Throws an `BadDependency` IO exception which is caught by the rule system if +-- Throws an `BadDependency` exception which is caught by the rule system if -- none available. -- -- WARNING: Not suitable for PluginHandlers. Use `useE` instead. @@ -1065,7 +1065,7 @@ useNoFile_ key = use_ key emptyFilePath -- |Plural version of `use_` -- --- Throws an `BadDependency` IO exception which is caught by the rule system if +-- Throws an `BadDependency` exception which is caught by the rule system if -- none available. -- -- WARNING: Not suitable for PluginHandlers. Use `usesE` instead. diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index ff7aeed59c..7ef7eeed65 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -6,6 +6,7 @@ module Development.IDE.Plugin.HLS ( asGhcIdePlugin + , toResponseError , Log(..) ) where @@ -80,11 +81,17 @@ prettyResponseError err = errorCode <> ":" <+> errorBody errorCode = pretty $ show $ err ^. L.code errorBody = pretty $ err ^. L.message -pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text -pluginNotEnabled method availPlugins = - "No plugin enabled for " <> T.pack (show method) <> ", potentially available: " - <> (T.intercalate ", " $ map (\(PluginId plid, _, _) -> plid) availPlugins) - +noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c) +noPluginEnabled recorder m fs' = do + logWith recorder Warning (LogNoPluginForMethod $ Some m) + let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing + msg = pluginNotEnabled m fs' + return $ Left err + where pluginNotEnabled :: SMethod m -> [PluginId] -> Text + pluginNotEnabled method availPlugins = + "No plugin enabled for " <> T.pack (show method) <> ", potentially available: " + <> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins) + pluginDoesntExist :: PluginId -> Text pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" @@ -113,13 +120,6 @@ logAndReturnError recorder p errCode msg = do logWith recorder Warning $ LogResponseError p err pure $ Left err --- | Logs the provider error before returning it to the caller -logAndReturnError' :: Recorder (WithPriority Log) -> (LSPErrorCodes |? ErrorCodes) -> Log -> LSP.LspT Config IO (Either ResponseError a) -logAndReturnError' recorder errCode msg = do - let err = ResponseError errCode (fromString $ show msg) Nothing - logWith recorder Warning $ msg - pure $ Left err - -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = @@ -219,8 +219,15 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom Just (PluginCommand _ _ f) -> case A.fromJSON arg of A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) A.Success a -> do - (first (toResponseError . (p,)) <$> runExceptT (f ide a)) `catchAny` -- See Note [Exception handling in plugins] - (\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e)) + res <- runExceptT (f ide a) `catchAny` -- See Note [Exception handling in plugins] + (\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e)) + case res of + (Left (PluginRequestRefused _)) -> + liftIO $ noPluginEnabled recorder SMethod_WorkspaceExecuteCommand (fst <$> ecs) + (Left pluginErr) -> do + liftIO $ logErrors recorder [(p, pluginErr)] + pure $ Left $ toResponseError (p, pluginErr) + (Right result) -> pure $ Right result -- --------------------------------------------------------------------- @@ -242,7 +249,7 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' -- Clients generally don't display ResponseErrors so instead we log any that we come across case nonEmpty fs of - Nothing -> liftIO $ noPluginEnabled m fs' + Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs') Just fs -> do let handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs es <- runConcurrently exceptionInPlugin m handlers ide params @@ -255,16 +262,11 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } noRefused (_, _) = True filteredErrs = filter noRefused errs case nonEmpty filteredErrs of - Nothing -> liftIO $ noPluginEnabled m fs' + Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs') Just xs -> pure $ Left $ combineErrors xs Just xs -> do pure $ Right $ combineResponses m config caps params xs - noPluginEnabled :: SMethod m -> [(PluginId, b, a)] -> IO (Either ResponseError c) - noPluginEnabled m fs' = do - logWith recorder Warning (LogNoPluginForMethod $ Some m) - let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing - msg = pluginNotEnabled m fs' - return $ Left err + -- --------------------------------------------------------------------- @@ -313,7 +315,6 @@ combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError combineErrors (x NE.:| []) = toResponseError x combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs - toResponseError :: (PluginId, PluginError) -> ResponseError toResponseError (PluginId plId, err) = ResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index 06cc195332..a528cb29ad 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -1,9 +1,8 @@ module ExceptionTests (tests) where -import Control.Concurrent.Async import Control.Exception (ArithException (DivideByZero), - finally, throwIO) + throwIO) import Control.Lens import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (liftIO) @@ -12,6 +11,7 @@ import Data.Text as T import Development.IDE.Core.Shake (IdeState (..)) import qualified Development.IDE.LSP.Notifications as Notifications import qualified Development.IDE.Main as IDE +import Development.IDE.Plugin.HLS (toResponseError) import Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import GHC.Base (coerce) @@ -30,8 +30,6 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import LogType (Log (..)) -import System.Directory -import System.Process.Extra (createPipe) import Test.Tasty import Test.Tasty.HUnit import TestUtils @@ -50,7 +48,6 @@ tests recorder logger = do pure (InL []) ] }] - testIde recorder (testingLite recorder logger plugins) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone @@ -60,6 +57,7 @@ tests recorder logger = do liftIO $ assertBool "We caught an error, but it wasn't ours!" (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) _ -> liftIO $ assertFailure $ show lens + , testCase "Commands" $ do let pluginId = "command-exception" commandId = CommandId "exception" @@ -71,7 +69,6 @@ tests recorder logger = do pure (InR Null) ] }] - testIde recorder (testingLite recorder logger plugins) $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone @@ -83,6 +80,7 @@ tests recorder logger = do liftIO $ assertBool "We caught an error, but it wasn't ours!" (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) _ -> liftIO $ assertFailure $ show res + , testCase "Notification Handlers" $ do let pluginId = "notification-exception" plugins = pluginDescToIdePlugins $ @@ -95,101 +93,24 @@ tests recorder logger = do [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do pure (InL []) ] - } - , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - + }] testIde recorder (testingLite recorder logger plugins) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) case lens of Right (InL []) -> + -- We don't get error responses from notification handlers, so + -- we can only make sure that the server is still responding pure () _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens] , testGroup "Testing PluginError order..." - [ testCase "InternalError over InvalidParams" $ do - let pluginId = "internal-error-order" - plugins = pluginDescToIdePlugins $ - [ (defaultPluginDescriptor pluginId) - { pluginHandlers = mconcat - [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginInternalError "error test" - ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginInvalidParams "error test" - ] - } - , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - - testIde recorder (testingLite recorder logger plugins) $ do - doc <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) - case lens of - Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> - liftIO $ assertBool "We caught an error, but it wasn't ours!" - (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message) - _ -> liftIO $ assertFailure $ show lens - , testCase "InvalidParams over InvalidUserState" $ do - let pluginId = "invalid-params-order" - plugins = pluginDescToIdePlugins $ - [ (defaultPluginDescriptor pluginId) - { pluginHandlers = mconcat - [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginInvalidParams "error test" - ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginInvalidUserState "error test" - ] - } - , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - - testIde recorder (testingLite recorder logger plugins) $ do - doc <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) - case lens of - Left (ResponseError {_code = InR ErrorCodes_InvalidParams, _message}) -> - liftIO $ assertBool "We caught an error, but it wasn't ours!" - (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message) - _ -> liftIO $ assertFailure $ show lens - , testCase "InvalidUserState over RequestRefused" $ do - let pluginId = "invalid-user-state-order" - plugins = pluginDescToIdePlugins $ - [ (defaultPluginDescriptor pluginId) - { pluginHandlers = mconcat - [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginInvalidUserState "error test" - ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError $ PluginRequestRefused "error test" - ] - } - , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - - testIde recorder (testingLite recorder logger plugins) $ do - doc <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) - case lens of - Left (ResponseError {_code = InL LSPErrorCodes_RequestFailed, _message}) -> - liftIO $ assertBool "We caught an error, but it wasn't ours!" - (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message) - _ -> liftIO $ assertFailure $ show lens - ]] - -testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - let projDir = "." - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session + [ pluginOrderTestCase recorder logger "InternalError over InvalidParams" PluginInternalError PluginInvalidParams + , pluginOrderTestCase recorder logger "InvalidParams over InvalidUserState" PluginInvalidParams PluginInvalidUserState + , pluginOrderTestCase recorder logger "InvalidUserState over RequestRefused" PluginInvalidUserState PluginRequestRefused + ] + ] testingLite :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> IDE.Arguments testingLite recorder logger plugins = @@ -210,3 +131,25 @@ testingLite recorder logger plugins = { IDE.argsHlsPlugins = hlsPlugins , IDE.argsIdeOptions = ideOptions } + +pluginOrderTestCase :: Recorder (WithPriority Log) -> Logger -> TestName -> (T.Text -> PluginError) -> (T.Text -> PluginError) -> TestTree +pluginOrderTestCase recorder logger msg err1 err2 = + testCase msg $ do + let pluginId = "error-order-test" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId) + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ err1 "error test" + ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError $ err2 "error test" + ] + }] + testIde recorder (testingLite recorder logger plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left re | toResponseError (pluginId, err1 "error test") == re -> pure () + | otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!" + _ -> liftIO $ assertFailure $ show lens diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 21d80cfb6e..445a66c5f6 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -1,129 +1,52 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeOperators #-} module TestUtils where import Control.Applicative.Combinators -import Control.Concurrent -import Control.Exception (bracket_, catch, finally) -import qualified Control.Lens as Lens -import qualified Control.Lens.Extras as Lens +import Control.Concurrent.Async +import Control.Exception (bracket_, finally) +import Control.Lens ((.~)) +import qualified Control.Lens as Lens +import qualified Control.Lens.Extras as Lens import Control.Monad -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (toJSON) -import qualified Data.Aeson as A -import Data.Default +import Control.Monad.IO.Class (liftIO) import Data.Foldable -import Data.List.Extra +import Data.Function ((&)) import Data.Maybe -import Data.Proxy -import Data.Row -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text.Utf16.Rope (Rope) -import qualified Data.Text.Utf16.Rope as Rope -import Development.IDE.Core.PositionMapping (PositionResult (..), - fromCurrent, - positionResultToMaybe, - toCurrent) -import Development.IDE.GHC.Compat (GhcVersion (..), - ghcVersion) +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import Development.IDE.GHC.Util -import qualified Development.IDE.Main as IDE -import Development.IDE.Plugin.TypeLenses (typeLensCommandId) -import Development.IDE.Spans.Common -import Development.IDE.Test (Cursor, canonicalizeUri, - configureCheckProject, - diagnostic, - expectCurrentDiagnostics, - expectDiagnostics, - expectDiagnosticsWithTags, - expectNoMoreDiagnostics, - flushMessages, - getInterfaceFilesDir, - getStoredKeys, - isReferenceReady, - referenceReady, - standardizeQuotes, - waitForAction, waitForGC, - waitForTypecheck) +import qualified Development.IDE.Main as IDE +import Development.IDE.Test (canonicalizeUri, + configureCheckProject, + expectNoMoreDiagnostics) import Development.IDE.Test.Runfiles -import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location -import Development.Shake (getDirectoryFilesIO) -import Ide.Plugin.Config -import qualified Language.LSP.Protocol.Lens as L +import Development.Shake (getDirectoryFilesIO) +import Ide.Logger (Recorder, WithPriority, + cmapWithPrio) +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - SemanticTokensEdit (..), - mkRange) +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) import Language.LSP.Test -import Language.LSP.VFS (VfsLog, applyChange) -import Network.URI import System.Directory -import System.Environment.Blank (getEnv, setEnv, unsetEnv) -import System.Exit (ExitCode (ExitSuccess)) +import System.Environment.Blank (getEnv, setEnv, unsetEnv) import System.FilePath -import System.Info.Extra (isMac, isWindows) +import System.Info.Extra (isMac, isWindows) import qualified System.IO.Extra -import System.IO.Extra hiding (withTempDir) -import System.Mem (performGC) -import System.Process.Extra (CreateProcess (cwd), - createPipe, proc, - readCreateProcessWithExitCode) -import Test.QuickCheck --- import Test.QuickCheck.Instances () -import Control.Concurrent.Async -import Control.Lens (to, (.~), (^.)) -import Control.Monad.Extra (whenJust) -import Data.Function ((&)) -import Data.Functor.Identity (runIdentity) -import Data.IORef -import Data.IORef.Extra (atomicModifyIORef_) -import Data.String (IsString (fromString)) -import Data.Tuple.Extra -import Development.IDE.Core.FileStore (getModTime) -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide -import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), - WaitForIdeRuleResult (..), - blockCommandId) -import qualified FuzzySearch -import GHC.Stack (emptyCallStack) -import GHC.TypeLits (symbolVal) -import qualified HieDbRetry -import Ide.Logger (Logger (Logger), - LoggingColumn (DataColumn, PriorityColumn), - Pretty (pretty), - Priority (Debug), - Recorder (Recorder, logger_), - WithPriority (WithPriority, priority), - cfilter, cmapWithPrio, - makeDefaultStderrRecorder, - toCologActionWithPrio) -import Ide.PluginUtils (pluginDescToIdePlugins) -import Ide.Types -import qualified Progress -import System.Time.Extra -import qualified Test.QuickCheck.Monadic as MonadicQuickCheck -import Test.QuickCheck.Monadic (forAllM, monadicIO) +import System.Process.Extra (createPipe) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit -import Test.Tasty.Ingredients.Rerun -import Test.Tasty.QuickCheck -import Text.Printf (printf) -import Text.Regex.TDFA ((=~)) + +import LogType -- | Wait for the next progress begin step waitForProgressBegin :: Session () @@ -389,3 +312,18 @@ defToLocation (InR (InR Null)) = [] thDollarIdx :: UInt thDollarIdx | ghcVersion >= GHC90 = 1 | otherwise = 0 + +testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () +testIde recorder arguments session = do + config <- getConfigFromEnv + cwd <- getCurrentDirectory + (hInRead, hInWrite) <- createPipe + (hOutRead, hOutWrite) <- createPipe + let projDir = "." + let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments + { IDE.argsHandleIn = pure hInRead + , IDE.argsHandleOut = pure hOutWrite + } + + flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> + runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs index fea2829144..d76e24372e 100644 --- a/ghcide/test/exe/UnitTests.hs +++ b/ghcide/test/exe/UnitTests.hs @@ -2,8 +2,6 @@ module UnitTests (tests) where import Control.Concurrent -import Control.Concurrent.Async -import Control.Exception (finally) import Control.Monad.IO.Class (liftIO) import Data.IORef import Data.IORef.Extra (atomicModifyIORef_) @@ -30,10 +28,8 @@ import Language.LSP.Test import LogType (Log (..)) import Network.URI import qualified Progress -import System.Directory import System.IO.Extra hiding (withTempDir) import System.Mem (performGC) -import System.Process.Extra (createPipe) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit @@ -112,19 +108,3 @@ findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do t <- getModTime f t' <- getModTime f' if t /= t' then return delay_us else findResolution_us (delay_us * 10) - - -testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - let projDir = "." - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index 877dc02188..ce874b744a 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -48,8 +48,10 @@ import Language.LSP.Protocol.Types -- and then returning PluginRequestRefused should be the same as if no plugins -- passed the `pluginEnabled` stage. data PluginError - = -- |PluginInternalError should be used if something has gone horribly wrong. - -- All uncaught exceptions will be caught and converted to this error. + = -- |PluginInternalError should be used if an error has occurred. This + -- should only rarely be returned. As it's logged with Error, it will be + -- shown by the client to the user via `showWindow`. All uncaught exceptions + -- will be caught and converted to this error. -- -- This error will be be converted into an InternalError response code. It -- will be logged with Error and takes the highest precedence (1) in being @@ -110,6 +112,7 @@ instance Pretty PluginError where PluginInvalidUserState text -> "Invalid User State:" <+> pretty text PluginRequestRefused msg -> "Request Refused: " <+> pretty msg +-- |Converts to ErrorCode used in LSP ResponseErrors toErrorCode :: PluginError -> (LSPErrorCodes |? ErrorCodes) toErrorCode (PluginInternalError _) = InR ErrorCodes_InternalError toErrorCode (PluginInvalidParams _) = InR ErrorCodes_InvalidParams @@ -121,6 +124,9 @@ toErrorCode (PluginRequestRefused _) = InR ErrorCodes_MethodNotFound toErrorCode (PluginRuleFailed _) = InL LSPErrorCodes_RequestFailed toErrorCode PluginStaleResolve = InL LSPErrorCodes_ContentModified +-- |Converts to a logging priority. In addition to being used by the logger, +-- `combineResponses` currently uses this to choose which response to return, +-- so care should be taken in changing it. toPriority :: PluginError -> Priority toPriority (PluginInternalError _) = Error toPriority (PluginInvalidParams _) = Warning