diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for lsp-test +## 0.16.0.1 + +- Support newer versions of dependencies. + ## 0.16.0.0 - The client configuration is now _mandatory_ and is an `Object` rather than a `Value`. diff --git a/bench/SimpleBench.hs b/bench/SimpleBench.hs --- a/bench/SimpleBench.hs +++ b/bench/SimpleBench.hs @@ -1,46 +1,49 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + module Main where -import Language.LSP.Server -import qualified Language.LSP.Test as Test -import Language.LSP.Protocol.Types -import Language.LSP.Protocol.Message -import Control.Monad.IO.Class +import Control.Concurrent import Control.Monad -import System.Process hiding (env) +import Control.Monad.IO.Class +import Data.IORef +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server +import Language.LSP.Test qualified as Test import System.Environment +import System.Process hiding (env) import System.Time.Extra -import Control.Concurrent -import Data.IORef handlers :: Handlers (LspM ()) -handlers = mconcat - [ requestHandler SMethod_TextDocumentHover $ \req responder -> do - let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req - Position _l _c' = pos - rsp = Hover ms (Just range) - ms = InL $ mkMarkdown "Hello world" - range = Range pos pos - responder (Right $ InL rsp) - , requestHandler SMethod_TextDocumentDefinition $ \req responder -> do - let TRequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req - responder (Right $ InL $ Definition $ InL $ Location doc $ Range pos pos) - ] +handlers = + mconcat + [ requestHandler SMethod_TextDocumentHover $ \req responder -> do + let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req + Position _l _c' = pos + rsp = Hover ms (Just range) + ms = InL $ mkMarkdown "Hello world" + range = Range pos pos + responder (Right $ InL rsp) + , requestHandler SMethod_TextDocumentDefinition $ \req responder -> do + let TRequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req + responder (Right $ InL $ Definition $ InL $ Location doc $ Range pos pos) + ] server :: ServerDefinition () -server = ServerDefinition - { parseConfig = const $ const $ Right () - , onConfigChange = const $ pure () - , defaultConfig = () - , configSection = "demo" - , doInitialize = \env _req -> pure $ Right env - , staticHandlers = \_caps -> handlers - , interpretHandler = \env -> Iso (runLspT env) liftIO - , options = defaultOptions - } +server = + ServerDefinition + { parseConfig = const $ const $ Right () + , onConfigChange = const $ pure () + , defaultConfig = () + , configSection = "demo" + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = \_caps -> handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } main :: IO () main = do @@ -59,13 +62,14 @@ replicateM_ n $ do v <- liftIO $ readIORef i liftIO $ when (v `mod` 1000 == 0) $ putStrLn $ show v - TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentHover $ - HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing - TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentDefinition $ - DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing + TResponseMessage{_result = Right (InL _)} <- + Test.request SMethod_TextDocumentHover $ + HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing + TResponseMessage{_result = Right (InL _)} <- + Test.request SMethod_TextDocumentDefinition $ + DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing - liftIO $ modifyIORef' i (+1) + liftIO $ modifyIORef' i (+ 1) pure () end <- liftIO start liftIO $ putStrLn $ "Completed " <> show n <> " rounds in " <> showDuration end - diff --git a/example/Test.hs b/example/Test.hs --- a/example/Test.hs +++ b/example/Test.hs @@ -1,21 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} + import Control.Applicative.Combinators import Control.Monad.IO.Class -import Language.LSP.Test -import Language.LSP.Protocol.Types import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Test main = runSession "lsp-demo-reactor-server" fullCaps "test/data/" $ do doc <- openDoc "Rename.hs" "haskell" - + -- Use your favourite favourite combinators. skipManyTill loggingNotification (count 1 publishDiagnosticsNotification) -- Send requests and notifications and receive responses - rsp <- request SMethod_TextDocumentDocumentSymbol $ - DocumentSymbolParams Nothing Nothing doc + rsp <- + request SMethod_TextDocumentDocumentSymbol $ + DocumentSymbolParams Nothing Nothing doc liftIO $ print rsp -- Or use one of the helper functions getDocumentSymbols doc >>= liftIO . print - diff --git a/func-test/FuncTest.hs b/func-test/FuncTest.hs --- a/func-test/FuncTest.hs +++ b/func-test/FuncTest.hs @@ -1,25 +1,27 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs, OverloadedStrings #-} + module Main where -import Language.LSP.Server -import qualified Language.LSP.Test as Test -import Language.LSP.Protocol.Types -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message +import Colog.Core qualified as L +import Control.Applicative.Combinators +import Control.Exception +import Control.Lens hiding (Iso, List) +import Control.Monad import Control.Monad.IO.Class +import Data.Maybe +import Language.LSP.Protocol.Lens qualified as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server +import Language.LSP.Test qualified as Test +import System.Exit import System.IO -import Control.Monad import System.Process -import Control.Applicative.Combinators -import Control.Lens hiding (List, Iso) import Test.Hspec -import Data.Maybe import UnliftIO import UnliftIO.Concurrent -import Control.Exception -import System.Exit -import qualified Colog.Core as L main :: IO () main = hspec $ do @@ -28,42 +30,44 @@ it "sends end notification if thread is killed" $ do (hinRead, hinWrite) <- createPipe (houtRead, houtWrite) <- createPipe - + killVar <- newEmptyMVar - let definition = ServerDefinition - { parseConfig = const $ const $ Right () - , onConfigChange = const $ pure () - , defaultConfig = () - , configSection = "demo" - , doInitialize = \env _req -> pure $ Right env - , staticHandlers = \_caps -> handlers killVar - , interpretHandler = \env -> Iso (runLspT env) liftIO - , options = defaultOptions - } + let definition = + ServerDefinition + { parseConfig = const $ const $ Right () + , onConfigChange = const $ pure () + , defaultConfig = () + , configSection = "demo" + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = \_caps -> handlers killVar + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } handlers :: MVar () -> Handlers (LspM ()) handlers killVar = notificationHandler SMethod_Initialized $ \noti -> do tid <- withRunInIO $ \runInIO -> - forkIO $ runInIO $ - withProgress "Doing something" NotCancellable $ \updater -> - liftIO $ threadDelay (1 * 1000000) + forkIO $ + runInIO $ + withProgress "Doing something" NotCancellable $ \updater -> + liftIO $ threadDelay (1 * 1000000) liftIO $ void $ forkIO $ do takeMVar killVar killThread tid - + forkIO $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition - + Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do -- First make sure that we get a $/progress begin notification skipManyTill Test.anyMessage $ do x <- Test.message SMethod_Progress guard $ has (L.params . L.value . _workDoneProgressBegin) x - + -- Then kill the thread liftIO $ putMVar killVar () - + -- Then make sure we still get a $/progress end notification skipManyTill Test.anyMessage $ do x <- Test.message SMethod_Progress @@ -73,53 +77,56 @@ it "keeps track of open workspace folders" $ do (hinRead, hinWrite) <- createPipe (houtRead, houtWrite) <- createPipe - + countVar <- newMVar 0 let wf0 = WorkspaceFolder (filePathToUri "one") "Starter workspace" wf1 = WorkspaceFolder (filePathToUri "/foo/bar") "My workspace" wf2 = WorkspaceFolder (filePathToUri "/foo/baz") "My other workspace" - - definition = ServerDefinition - { parseConfig = const $ const $ Right () - , onConfigChange = const $ pure () - , defaultConfig = () - , configSection = "demo" - , doInitialize = \env _req -> pure $ Right env - , staticHandlers = \_caps -> handlers - , interpretHandler = \env -> Iso (runLspT env) liftIO - , options = defaultOptions - } + definition = + ServerDefinition + { parseConfig = const $ const $ Right () + , onConfigChange = const $ pure () + , defaultConfig = () + , configSection = "demo" + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = \_caps -> handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } + handlers :: Handlers (LspM ()) - handlers = mconcat - [ notificationHandler SMethod_Initialized $ \noti -> do - wfs <- fromJust <$> getWorkspaceFolders - liftIO $ wfs `shouldContain` [wf0] - , notificationHandler SMethod_WorkspaceDidChangeWorkspaceFolders $ \noti -> do - i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i)) - wfs <- fromJust <$> getWorkspaceFolders - liftIO $ case i of - 0 -> do - wfs `shouldContain` [wf1] - wfs `shouldContain` [wf0] - 1 -> do - wfs `shouldNotContain` [wf1] - wfs `shouldContain` [wf0] - wfs `shouldContain` [wf2] - _ -> error "Shouldn't be here" - ] - + handlers = + mconcat + [ notificationHandler SMethod_Initialized $ \noti -> do + wfs <- fromJust <$> getWorkspaceFolders + liftIO $ wfs `shouldContain` [wf0] + , notificationHandler SMethod_WorkspaceDidChangeWorkspaceFolders $ \noti -> do + i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i)) + wfs <- fromJust <$> getWorkspaceFolders + liftIO $ case i of + 0 -> do + wfs `shouldContain` [wf1] + wfs `shouldContain` [wf0] + 1 -> do + wfs `shouldNotContain` [wf1] + wfs `shouldContain` [wf0] + wfs `shouldContain` [wf2] + _ -> error "Shouldn't be here" + ] + server <- async $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition - - let config = Test.defaultConfig - { Test.initialWorkspaceFolders = Just [wf0] - } - + + let config = + Test.defaultConfig + { Test.initialWorkspaceFolders = Just [wf0] + } + changeFolders add rmv = let ev = WorkspaceFoldersChangeEvent add rmv ps = DidChangeWorkspaceFoldersParams ev - in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps + in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps Test.runSessionWithHandles hinWrite houtRead config Test.fullCaps "." $ do changeFolders [wf1] [] @@ -127,4 +134,3 @@ Left e <- waitCatch server fromException e `shouldBe` Just ExitSuccess - diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: lsp-test -version: 0.16.0.0 +version: 0.16.0.1 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against @@ -34,6 +34,7 @@ library hs-source-dirs: src default-language: Haskell2010 + default-extensions: ImportQualifiedPost exposed-modules: Language.LSP.Test reexported-modules: lsp-types:Language.LSP.Protocol.Types @@ -60,8 +61,8 @@ , Glob >=0.9 && <0.11 , lens , lens-aeson - , lsp ^>=2.2 - , lsp-types ^>=2.0 + , lsp ^>=2.3 + , lsp-types ^>=2.1 , mtl <2.4 , parser-combinators >=1.2 , process >=1.6 @@ -92,6 +93,7 @@ hs-source-dirs: test main-is: Test.hs default-language: Haskell2010 + default-extensions: ImportQualifiedPost ghc-options: -W other-modules: DummyServer build-depends: @@ -103,7 +105,7 @@ , filepath , hspec , lens - , lsp ^>=2.2 + , lsp ^>=2.3 , lsp-test , mtl <2.4 , parser-combinators @@ -116,6 +118,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: func-test default-language: Haskell2010 + default-extensions: ImportQualifiedPost main-is: FuncTest.hs build-depends: , base @@ -133,6 +136,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: example default-language: Haskell2010 + default-extensions: ImportQualifiedPost main-is: Test.hs build-depends: , base @@ -144,6 +148,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: bench default-language: Haskell2010 + default-extensions: ImportQualifiedPost main-is: SimpleBench.hs ghc-options: -Wall -O2 -eventlog -rtsopts build-depends: diff --git a/src/Language/LSP/Test.hs b/src/Language/LSP/Test.hs --- a/src/Language/LSP/Test.hs +++ b/src/Language/LSP/Test.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} -{-| +{- | Module : Language.LSP.Test Description : A functional testing framework for LSP servers. Maintainer : luke_lau@icloud.com @@ -20,223 +20,279 @@ . You should import "Language.LSP.Types" alongside this. -} -module Language.LSP.Test - ( +module Language.LSP.Test ( -- * Sessions - Session - , runSession - , runSessionWithConfig - , runSessionWithConfigCustomProcess - , runSessionWithHandles - , runSessionWithHandles' - , setIgnoringLogNotifications - , setIgnoringConfigurationRequests + Session, + runSession, + runSessionWithConfig, + runSessionWithConfigCustomProcess, + runSessionWithHandles, + runSessionWithHandles', + setIgnoringLogNotifications, + setIgnoringConfigurationRequests, + -- ** Config - , SessionConfig(..) - , defaultConfig - , C.fullCaps + SessionConfig (..), + defaultConfig, + C.fullCaps, + -- ** Exceptions - , module Language.LSP.Test.Exceptions - , withTimeout + module Language.LSP.Test.Exceptions, + withTimeout, + -- * Sending - , request - , request_ - , sendRequest - , sendNotification - , sendResponse + request, + request_, + sendRequest, + sendNotification, + sendResponse, + -- * Receiving - , module Language.LSP.Test.Parsing + module Language.LSP.Test.Parsing, + -- * Utilities + -- | Quick helper functions for common tasks. -- ** Initialization - , initializeResponse + initializeResponse, + -- ** Config - , modifyConfig - , setConfig - , modifyConfigSection - , setConfigSection + modifyConfig, + setConfig, + modifyConfigSection, + setConfigSection, + -- ** Documents - , createDoc - , openDoc - , closeDoc - , changeDoc - , documentContents - , getDocumentEdit - , getDocUri - , getVersionedDoc + createDoc, + openDoc, + closeDoc, + changeDoc, + documentContents, + getDocumentEdit, + getDocUri, + getVersionedDoc, + -- ** Symbols - , getDocumentSymbols + getDocumentSymbols, + -- ** Diagnostics - , waitForDiagnostics - , waitForDiagnosticsSource - , noDiagnostics - , getCurrentDiagnostics - , getIncompleteProgressSessions + waitForDiagnostics, + waitForDiagnosticsSource, + noDiagnostics, + getCurrentDiagnostics, + getIncompleteProgressSessions, + -- ** Commands - , executeCommand + executeCommand, + -- ** Code Actions - , getCodeActions - , getAndResolveCodeActions - , getAllCodeActions - , executeCodeAction - , resolveCodeAction - , resolveAndExecuteCodeAction + getCodeActions, + getAndResolveCodeActions, + getAllCodeActions, + executeCodeAction, + resolveCodeAction, + resolveAndExecuteCodeAction, + -- ** Completions - , getCompletions - , getAndResolveCompletions + getCompletions, + getAndResolveCompletions, + -- ** References - , getReferences + getReferences, + -- ** Definitions - , getDeclarations - , getDefinitions - , getTypeDefinitions - , getImplementations + getDeclarations, + getDefinitions, + getTypeDefinitions, + getImplementations, + -- ** Renaming - , rename + rename, + -- ** Hover - , getHover + getHover, + -- ** Highlights - , getHighlights + getHighlights, + -- ** Formatting - , formatDoc - , formatRange + formatDoc, + formatRange, + -- ** Edits - , applyEdit + applyEdit, + -- ** Code lenses - , getCodeLenses - , getAndResolveCodeLenses - , resolveCodeLens + getCodeLenses, + getAndResolveCodeLenses, + resolveCodeLens, + -- ** Call hierarchy - , prepareCallHierarchy - , incomingCalls - , outgoingCalls + prepareCallHierarchy, + incomingCalls, + outgoingCalls, + -- ** SemanticTokens - , getSemanticTokens + getSemanticTokens, + -- ** Capabilities - , getRegisteredCapabilities - ) where + getRegisteredCapabilities, +) where import Control.Applicative.Combinators import Control.Concurrent +import Control.Exception +import Control.Lens hiding (Empty, List, (.=)) import Control.Monad import Control.Monad.IO.Class -import Control.Exception -import Control.Lens hiding ((.=), List, Empty) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Control.Monad.State (execState) import Data.Aeson hiding (Null) -import qualified Data.Aeson as J +import Data.Aeson qualified as J import Data.Default import Data.List +import Data.Map.Strict qualified as Map import Data.Maybe -import Language.LSP.Protocol.Types +import Data.Set qualified as Set +import Data.String (fromString) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Traversable (for) +import Language.LSP.Protocol.Capabilities qualified as C +import Language.LSP.Protocol.Lens qualified as L import Language.LSP.Protocol.Message -import qualified Language.LSP.Protocol.Lens as L -import qualified Language.LSP.Protocol.Capabilities as C -import Language.LSP.VFS +import Language.LSP.Protocol.Types import Language.LSP.Test.Compat import Language.LSP.Test.Decoding import Language.LSP.Test.Exceptions import Language.LSP.Test.Parsing -import Language.LSP.Test.Session import Language.LSP.Test.Server -import System.Environment -import System.IO +import Language.LSP.Test.Session +import Language.LSP.VFS import System.Directory +import System.Environment import System.FilePath -import System.Process (ProcessHandle, CreateProcess) -import qualified System.FilePath.Glob as Glob -import Control.Monad.State (execState) -import Data.Traversable (for) -import Data.String (fromString) +import System.FilePath.Glob qualified as Glob +import System.IO +import System.Process (CreateProcess, ProcessHandle) --- | Starts a new session. --- --- > runSession "hie" fullCaps "path/to/root/dir" $ do --- > doc <- openDoc "Desktop/simple.hs" "haskell" --- > diags <- waitForDiagnostics --- > let pos = Position 12 5 --- > params = TextDocumentPositionParams doc --- > hover <- request STextdocumentHover params -runSession :: String -- ^ The command to run the server. - -> ClientCapabilities -- ^ The capabilities that the client should declare. - -> FilePath -- ^ The filepath to the root directory for the session. - -> Session a -- ^ The session to run. - -> IO a +{- | Starts a new session. + + > runSession "hie" fullCaps "path/to/root/dir" $ do + > doc <- openDoc "Desktop/simple.hs" "haskell" + > diags <- waitForDiagnostics + > let pos = Position 12 5 + > params = TextDocumentPositionParams doc + > hover <- request STextdocumentHover params +-} +runSession :: + -- | The command to run the server. + String -> + -- | The capabilities that the client should declare. + ClientCapabilities -> + -- | The filepath to the root directory for the session. + FilePath -> + -- | The session to run. + Session a -> + IO a runSession = runSessionWithConfig def -- | Starts a new session with a custom configuration. -runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session. - -> String -- ^ The command to run the server. - -> ClientCapabilities -- ^ The capabilities that the client should declare. - -> FilePath -- ^ The filepath to the root directory for the session. - -> Session a -- ^ The session to run. - -> IO a +runSessionWithConfig :: + -- | Configuration options for the session. + SessionConfig -> + -- | The command to run the server. + String -> + -- | The capabilities that the client should declare. + ClientCapabilities -> + -- | The filepath to the root directory for the session. + FilePath -> + -- | The session to run. + Session a -> + IO a runSessionWithConfig = runSessionWithConfigCustomProcess id -- | Starts a new session with a custom configuration and server 'CreateProcess'. -runSessionWithConfigCustomProcess :: (CreateProcess -> CreateProcess) -- ^ Tweak the 'CreateProcess' used to start the server. - -> SessionConfig -- ^ Configuration options for the session. - -> String -- ^ The command to run the server. - -> ClientCapabilities -- ^ The capabilities that the client should declare. - -> FilePath -- ^ The filepath to the root directory for the session. - -> Session a -- ^ The session to run. - -> IO a +runSessionWithConfigCustomProcess :: + -- | Tweak the 'CreateProcess' used to start the server. + (CreateProcess -> CreateProcess) -> + -- | Configuration options for the session. + SessionConfig -> + -- | The command to run the server. + String -> + -- | The capabilities that the client should declare. + ClientCapabilities -> + -- | The filepath to the root directory for the session. + FilePath -> + -- | The session to run. + Session a -> + IO a runSessionWithConfigCustomProcess modifyCreateProcess config' serverExe caps rootDir session = do config <- envOverrideConfig config' withServer serverExe (logStdErr config) modifyCreateProcess $ \serverIn serverOut serverProc -> runSessionWithHandles' (Just serverProc) serverIn serverOut config caps rootDir session --- | Starts a new session, using the specified handles to communicate with the --- server. You can use this to host the server within the same process. --- An example with lsp might look like: --- --- > (hinRead, hinWrite) <- createPipe --- > (houtRead, houtWrite) <- createPipe --- > --- > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition --- > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do --- > -- ... -runSessionWithHandles :: Handle -- ^ The input handle - -> Handle -- ^ The output handle - -> SessionConfig - -> ClientCapabilities -- ^ The capabilities that the client should declare. - -> FilePath -- ^ The filepath to the root directory for the session. - -> Session a -- ^ The session to run. - -> IO a -runSessionWithHandles = runSessionWithHandles' Nothing +{- | Starts a new session, using the specified handles to communicate with the + server. You can use this to host the server within the same process. + An example with lsp might look like: + > (hinRead, hinWrite) <- createPipe + > (houtRead, houtWrite) <- createPipe + > + > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition + > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do + > -- ... +-} +runSessionWithHandles :: + -- | The input handle + Handle -> + -- | The output handle + Handle -> + SessionConfig -> + -- | The capabilities that the client should declare. + ClientCapabilities -> + -- | The filepath to the root directory for the session. + FilePath -> + -- | The session to run. + Session a -> + IO a +runSessionWithHandles = runSessionWithHandles' Nothing -runSessionWithHandles' :: Maybe ProcessHandle - -> Handle -- ^ The input handle - -> Handle -- ^ The output handle - -> SessionConfig - -> ClientCapabilities -- ^ The capabilities that the client should declare. - -> FilePath -- ^ The filepath to the root directory for the session. - -> Session a -- ^ The session to run. - -> IO a +runSessionWithHandles' :: + Maybe ProcessHandle -> + -- | The input handle + Handle -> + -- | The output handle + Handle -> + SessionConfig -> + -- | The capabilities that the client should declare. + ClientCapabilities -> + -- | The filepath to the root directory for the session. + FilePath -> + -- | The session to run. + Session a -> + IO a runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir session = do pid <- getCurrentProcessID absRootDir <- canonicalizePath rootDir config <- envOverrideConfig config' - let initializeParams = InitializeParams Nothing - -- Narrowing to Int32 here, but it's unlikely that a PID will - -- be outside the range - (InL $ fromIntegral pid) - (Just lspTestClientInfo) - (Just $ T.pack absRootDir) - Nothing - (InL $ filePathToUri absRootDir) - caps - -- TODO: make this configurable? - (Just $ Object $ lspConfig config') - (Just TraceValues_Off) - (fmap InL $ initialWorkspaceFolders config) + let initializeParams = + InitializeParams + Nothing + -- Narrowing to Int32 here, but it's unlikely that a PID will + -- be outside the range + (InL $ fromIntegral pid) + (Just lspTestClientInfo) + (Just $ T.pack absRootDir) + Nothing + (InL $ filePathToUri absRootDir) + caps + -- TODO: make this configurable? + (Just $ Object $ lspConfig config') + (Just TraceValues_Off) + (fmap InL $ initialWorkspaceFolders config) runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do -- Wrap the session around initialize and shutdown calls initReqId <- sendRequest SMethod_Initialize initializeParams @@ -261,12 +317,12 @@ -- Run the actual test session - where - -- | Asks the server to shutdown and exit politely + where + -- \| Asks the server to shutdown and exit politely exitServer :: Session () exitServer = request_ SMethod_Shutdown Nothing >> sendNotification SMethod_Exit Nothing - -- | Listens to the server output until the shutdown ACK, + -- \| Listens to the server output until the shutdown ACK, -- makes sure it matches the record and signals any semaphores listenServer :: Handle -> SessionContext -> IO () listenServer serverOut context = do @@ -278,9 +334,9 @@ case msg of (FromServerRsp SMethod_Shutdown _) -> return () - _ -> listenServer serverOut context + _ -> listenServer serverOut context - -- | Is this message allowed to be sent by the server between the intialize + -- \| Is this message allowed to be sent by the server between the intialize -- request and response? -- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize checkLegalBetweenMessage :: FromServerMessage -> Session () @@ -295,11 +351,12 @@ envOverrideConfig cfg = do logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES" logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR" - return $ cfg { logMessages = logMessages', logStdErr = logStdErr' } - where checkEnv :: String -> IO (Maybe Bool) - checkEnv s = fmap convertVal <$> lookupEnv s - convertVal "0" = False - convertVal _ = True + return $ cfg{logMessages = logMessages', logStdErr = logStdErr'} + where + checkEnv :: String -> IO (Maybe Bool) + checkEnv s = fmap convertVal <$> lookupEnv s + convertVal "0" = False + convertVal _ = True -- | The current text contents of a document. documentContents :: TextDocumentIdentifier -> Session T.Text @@ -308,33 +365,36 @@ let Just file = vfs ^. vfsMap . at (toNormalizedUri (doc ^. L.uri)) return (virtualFileText file) --- | Parses an ApplyEditRequest, checks that it is for the passed document --- and returns the new content +{- | Parses an ApplyEditRequest, checks that it is for the passed document + and returns the new content +-} getDocumentEdit :: TextDocumentIdentifier -> Session T.Text getDocumentEdit doc = do req <- message SMethod_WorkspaceApplyEdit unless (checkDocumentChanges req || checkChanges req) $ - liftIO $ throw (IncorrectApplyEditRequest (show req)) + liftIO $ + throw (IncorrectApplyEditRequest (show req)) documentContents doc - where - checkDocumentChanges req = - let changes = req ^. L.params . L.edit . L.documentChanges - maybeDocs = fmap (fmap documentChangeUri) changes - in case maybeDocs of - Just docs -> (doc ^. L.uri) `elem` docs - Nothing -> False - checkChanges req = - let mMap = req ^. L.params . L.edit . L.changes - in maybe False (Map.member (doc ^. L.uri)) mMap + where + checkDocumentChanges req = + let changes = req ^. L.params . L.edit . L.documentChanges + maybeDocs = fmap (fmap documentChangeUri) changes + in case maybeDocs of + Just docs -> (doc ^. L.uri) `elem` docs + Nothing -> False + checkChanges req = + let mMap = req ^. L.params . L.edit . L.changes + in maybe False (Map.member (doc ^. L.uri)) mMap --- | Sends a request to the server and waits for its response. --- Will skip any messages in between the request and the response --- @ --- rsp <- request STextDocumentDocumentSymbol params --- @ --- Note: will skip any messages in between the request and the response. +{- | Sends a request to the server and waits for its response. + Will skip any messages in between the request and the response + @ + rsp <- request STextDocumentDocumentSymbol params + @ + Note: will skip any messages in between the request and the response. +-} request :: SClientMethod m -> MessageParams m -> Session (TResponseMessage m) request m = sendRequest m >=> skipManyTill anyMessage . responseForId m @@ -343,21 +403,25 @@ request_ p = void . request p -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response. -sendRequest - :: SClientMethod m -- ^ The request method. - -> MessageParams m -- ^ The request parameters. - -> Session (LspId m) -- ^ The id of the request that was sent. +sendRequest :: + -- | The request method. + SClientMethod m -> + -- | The request parameters. + MessageParams m -> + -- | The id of the request that was sent. + Session (LspId m) sendRequest method params = do idn <- curReqId <$> get - modify $ \c -> c { curReqId = idn+1 } + modify $ \c -> c{curReqId = idn + 1} let id = IdInt idn let mess = TRequestMessage "2.0" id method params -- Update the request map reqMap <- requestMap <$> ask - liftIO $ modifyMVar_ reqMap $ - \r -> return $ fromJust $ updateRequestMap r id method + liftIO $ + modifyMVar_ reqMap $ + \r -> return $ fromJust $ updateRequestMap r id method ~() <- case splitClientMethod method of IsClientReq -> sendMessage mess @@ -366,15 +430,18 @@ return id -- | Sends a notification to the server. -sendNotification :: SClientMethod (m :: Method ClientToServer Notification) -- ^ The notification method. - -> MessageParams m -- ^ The notification parameters. - -> Session () +sendNotification :: + -- | The notification method. + SClientMethod (m :: Method ClientToServer Notification) -> + -- | The notification parameters. + MessageParams m -> + Session () -- Open a virtual file if we send a did open text document notification sendNotification SMethod_TextDocumentDidOpen params = do let n = TNotificationMessage "2.0" SMethod_TextDocumentDidOpen params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ openVFS mempty n - modify (\s -> s { vfs = newVFS }) + modify (\s -> s{vfs = newVFS}) sendMessage n -- Close a virtual file if we send a close text document notification @@ -382,16 +449,14 @@ let n = TNotificationMessage "2.0" SMethod_TextDocumentDidClose params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ closeVFS mempty n - modify (\s -> s { vfs = newVFS }) + modify (\s -> s{vfs = newVFS}) sendMessage n - sendNotification SMethod_TextDocumentDidChange params = do let n = TNotificationMessage "2.0" SMethod_TextDocumentDidChange params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ changeFromClientVFS mempty n - modify (\s -> s { vfs = newVFS }) + modify (\s -> s{vfs = newVFS}) sendMessage n - sendNotification method params = case splitClientMethod method of IsClientNot -> sendMessage (TNotificationMessage "2.0" method params) @@ -401,27 +466,29 @@ sendResponse :: (ToJSON (MessageResult m), ToJSON (ErrorData m)) => TResponseMessage m -> Session () sendResponse = sendMessage --- | Returns the initialize response that was received from the server. --- The initialize requests and responses are not included the session, --- so if you need to test it use this. +{- | Returns the initialize response that was received from the server. + The initialize requests and responses are not included the session, + so if you need to test it use this. +-} initializeResponse :: Session (TResponseMessage Method_Initialize) initializeResponse = ask >>= (liftIO . readMVar) . initRsp setIgnoringLogNotifications :: Bool -> Session () setIgnoringLogNotifications value = do - modify (\ss -> ss { ignoringLogNotifications = value }) + modify (\ss -> ss{ignoringLogNotifications = value}) setIgnoringConfigurationRequests :: Bool -> Session () setIgnoringConfigurationRequests value = do - modify (\ss -> ss { ignoringConfigurationRequests = value }) + modify (\ss -> ss{ignoringConfigurationRequests = value}) --- | Modify the client config. This will send a notification to the server that the --- config has changed. +{- | Modify the client config. This will send a notification to the server that the + config has changed. +-} modifyConfig :: (Object -> Object) -> Session () modifyConfig f = do oldConfig <- curLspConfig <$> get let newConfig = f oldConfig - modify (\ss -> ss { curLspConfig = newConfig }) + modify (\ss -> ss{curLspConfig = newConfig}) caps <- asks sessionCapabilities let supportsConfiguration = fromMaybe False $ caps ^? L.workspace . _Just . L.configuration . _Just @@ -431,34 +498,43 @@ configToSend = if supportsConfiguration then J.Null else Object newConfig sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams configToSend --- | Set the client config. This will send a notification to the server that the --- config has changed. +{- | Set the client config. This will send a notification to the server that the + config has changed. +-} setConfig :: Object -> Session () setConfig newConfig = modifyConfig (const newConfig) --- | Modify a client config section (if already present, otherwise does nothing). --- This will send a notification to the server that the config has changed. +{- | Modify a client config section (if already present, otherwise does nothing). + This will send a notification to the server that the config has changed. +-} modifyConfigSection :: String -> (Value -> Value) -> Session () modifyConfigSection section f = modifyConfig (\o -> o & ix (fromString section) %~ f) --- | Set a client config section. This will send a notification to the server that the --- config has changed. +{- | Set a client config section. This will send a notification to the server that the + config has changed. +-} setConfigSection :: String -> Value -> Session () -setConfigSection section settings = modifyConfig (\o -> o & at(fromString section) ?~ settings) +setConfigSection section settings = modifyConfig (\o -> o & at (fromString section) ?~ settings) --- | /Creates/ a new text document. This is different from 'openDoc' --- as it sends a workspace/didChangeWatchedFiles notification letting the server --- know that a file was created within the workspace, __provided that the server --- has registered for it__, and the file matches any patterns the server --- registered for. --- It /does not/ actually create a file on disk, but is useful for convincing --- the server that one does exist. --- --- @since 11.0.0.0 -createDoc :: FilePath -- ^ The path to the document to open, __relative to the root directory__. - -> T.Text -- ^ The text document's language identifier, e.g. @"haskell"@. - -> T.Text -- ^ The content of the text document to create. - -> Session TextDocumentIdentifier -- ^ The identifier of the document just created. +{- | /Creates/ a new text document. This is different from 'openDoc' + as it sends a workspace/didChangeWatchedFiles notification letting the server + know that a file was created within the workspace, __provided that the server + has registered for it__, and the file matches any patterns the server + registered for. + It /does not/ actually create a file on disk, but is useful for convincing + the server that one does exist. + + @since 11.0.0.0 +-} +createDoc :: + -- | The path to the document to open, __relative to the root directory__. + FilePath -> + -- | The text document's language identifier, e.g. @"haskell"@. + T.Text -> + -- | The content of the text document to create. + T.Text -> + -- | The identifier of the document just created. + Session TextDocumentIdentifier createDoc file languageId contents = do dynCaps <- curDynCaps <$> get rootDir <- asks rootDir @@ -476,26 +552,29 @@ watchHits _ = False fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs + where -- If the pattern is absolute then match against the absolute fp - where relOrAbs - | isAbsolute pattern = absFile - | otherwise = file + relOrAbs + | isAbsolute pattern = absFile + | otherwise = file regHits :: TRegistration Method_WorkspaceDidChangeWatchedFiles -> Bool regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. L.registerOptions . _Just . L.watchers) clientCapsSupports = - caps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just . L.dynamicRegistration . _Just - == Just True + caps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just . L.dynamicRegistration . _Just + == Just True shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs when shouldSend $ - sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - [ FileEvent (filePathToUri (rootDir file)) FileChangeType_Created ] + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ + DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri (rootDir file)) FileChangeType_Created] openDoc' file languageId contents --- | Opens a text document that /exists on disk/, and sends a --- textDocument/didOpen notification to the server. +{- | Opens a text document that /exists on disk/, and sends a + textDocument/didOpen notification to the server. +-} openDoc :: FilePath -> T.Text -> Session TextDocumentIdentifier openDoc file languageId = do context <- ask @@ -503,8 +582,9 @@ contents <- liftIO $ T.readFile fp openDoc' file languageId contents --- | This is a variant of `openDoc` that takes the file content as an argument. --- Use this is the file exists /outside/ of the current workspace. +{- | This is a variant of `openDoc` that takes the file content as an argument. + Use this is the file exists /outside/ of the current workspace. +-} openDoc' :: FilePath -> T.Text -> T.Text -> Session TextDocumentIdentifier openDoc' file languageId contents = do context <- ask @@ -541,8 +621,9 @@ let diags = diagsNot ^. L.params . L.diagnostics return diags --- | The same as 'waitForDiagnostics', but will only match a specific --- 'Language.LSP.Types._source'. +{- | The same as 'waitForDiagnostics', but will only match a specific + 'Language.LSP.Types._source'. +-} waitForDiagnosticsSource :: String -> Session [Diagnostic] waitForDiagnosticsSource src = do diags <- waitForDiagnostics @@ -550,13 +631,14 @@ if null res then waitForDiagnosticsSource src else return res - where - matches :: Diagnostic -> Bool - matches d = d ^. L.source == Just (T.pack src) + where + matches :: Diagnostic -> Bool + matches d = d ^. L.source == Just (T.pack src) --- | Expects a 'PublishDiagnosticsNotification' and throws an --- 'UnexpectedDiagnostics' exception if there are any diagnostics --- returned. +{- | Expects a 'PublishDiagnosticsNotification' and throws an + 'UnexpectedDiagnostics' exception if there are any diagnostics + returned. +-} noDiagnostics :: Session () noDiagnostics = do diagsNot <- message SMethod_TextDocumentPublishDiagnostics @@ -583,51 +665,52 @@ Right (InR _) -> return [] Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) --- | Returns the code actions in the specified range, resolving any with --- a non empty _data_ field. +{- | Returns the code actions in the specified range, resolving any with + a non empty _data_ field. +-} getAndResolveCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction] getAndResolveCodeActions doc range = do items <- getCodeActions doc range - for items $ \case + for items $ \case l@(InL _) -> pure l - (InR r) | isJust (r ^. L.data_) -> InR <$> resolveCodeAction r + (InR r) | isJust (r ^. L.data_) -> InR <$> resolveCodeAction r r@(InR _) -> pure r --- | Returns all the code actions in a document by --- querying the code actions at each of the current --- diagnostics' positions. +{- | Returns all the code actions in a document by + querying the code actions at each of the current + diagnostics' positions. +-} getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction] getAllCodeActions doc = do ctx <- getCodeActionContext doc foldM (go ctx) [] =<< getCurrentDiagnostics doc - - where - go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction] - go ctx acc diag = do - TResponseMessage _ rspLid res <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. L.range) ctx) + where + go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction] + go ctx acc diag = do + TResponseMessage _ rspLid res <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. L.range) ctx) - case res of - Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e) - Right (InL cmdOrCAs) -> pure (acc ++ cmdOrCAs) - Right (InR _) -> pure acc + case res of + Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e) + Right (InL cmdOrCAs) -> pure (acc ++ cmdOrCAs) + Right (InR _) -> pure acc getCodeActionContextInRange :: TextDocumentIdentifier -> Range -> Session CodeActionContext getCodeActionContextInRange doc caRange = do curDiags <- getCurrentDiagnostics doc - let diags = [ d | d@Diagnostic{_range=range} <- curDiags - , overlappingRange caRange range - ] + let diags = + [ d | d@Diagnostic{_range = range} <- curDiags, overlappingRange caRange range + ] return $ CodeActionContext diags Nothing Nothing - where - overlappingRange :: Range -> Range -> Bool - overlappingRange (Range s e) range = - positionInRange s range + where + overlappingRange :: Range -> Range -> Bool + overlappingRange (Range s e) range = + positionInRange s range || positionInRange e range - positionInRange :: Position -> Range -> Bool - positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) = - pl > sl && pl < el + positionInRange :: Position -> Range -> Bool + positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) = + pl > sl && pl < el || pl == sl && pl == el && po >= so && po <= eo || pl == sl && po >= so || pl == el && po <= eo @@ -637,8 +720,9 @@ curDiags <- getCurrentDiagnostics doc return $ CodeActionContext curDiags Nothing Nothing --- | Returns the current diagnostics that have been sent to the client. --- Note that this does not wait for more to come in. +{- | Returns the current diagnostics that have been sent to the client. + Note that this does not wait for more to come in. +-} getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic] getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. L.uri) . curDiagnostics <$> get @@ -653,20 +737,21 @@ execParams = ExecuteCommandParams Nothing (cmd ^. L.command) args void $ sendRequest SMethod_WorkspaceExecuteCommand execParams --- | Executes a code action. --- Matching with the specification, if a code action --- contains both an edit and a command, the edit will --- be applied first. +{- | Executes a code action. + Matching with the specification, if a code action + contains both an edit and a command, the edit will + be applied first. +-} executeCodeAction :: CodeAction -> Session () executeCodeAction action = do maybe (return ()) handleEdit $ action ^. L.edit maybe (return ()) executeCommand $ action ^. L.command - - where handleEdit :: WorkspaceEdit -> Session () - handleEdit e = - -- Its ok to pass in dummy parameters here as they aren't used - let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e) - in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) + where + handleEdit :: WorkspaceEdit -> Session () + handleEdit e = + -- Its ok to pass in dummy parameters here as they aren't used + let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e) + in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) -- |Resolves the provided code action. resolveCodeAction :: CodeAction -> Session CodeAction @@ -676,10 +761,11 @@ Right ca -> return ca Left er -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) er) --- |If a code action contains a _data_ field: resolves the code action, then --- executes it. Otherwise, just executes it. +{- |If a code action contains a _data_ field: resolves the code action, then + executes it. Otherwise, just executes it. +-} resolveAndExecuteCodeAction :: CodeAction -> Session () -resolveAndExecuteCodeAction ca@CodeAction{_data_=Just _} = do +resolveAndExecuteCodeAction ca@CodeAction{_data_ = Just _} = do caRsp <- resolveCodeAction ca executeCodeAction caRsp resolveAndExecuteCodeAction ca = executeCodeAction ca @@ -696,20 +782,20 @@ -- | Applys an edit to the document and returns the updated document version. applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier applyEdit doc edit = do - verDoc <- getVersionedDoc doc caps <- asks sessionCapabilities let supportsDocChanges = fromMaybe False $ caps ^? L.workspace . _Just . L.workspaceEdit . _Just . L.documentChanges . _Just - let wEdit = if supportsDocChanges - then - let docEdit = TextDocumentEdit (review _versionedTextDocumentIdentifier verDoc) [InL edit] - in WorkspaceEdit Nothing (Just [InL docEdit]) Nothing - else - let changes = Map.singleton (doc ^. L.uri) [edit] - in WorkspaceEdit (Just changes) Nothing Nothing + let wEdit = + if supportsDocChanges + then + let docEdit = TextDocumentEdit (review _versionedTextDocumentIdentifier verDoc) [InL edit] + in WorkspaceEdit Nothing (Just [InL docEdit]) Nothing + else + let changes = Map.singleton (doc ^. L.uri) [edit] + in WorkspaceEdit (Just changes) Nothing Nothing let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) updateState (FromServerMess SMethod_WorkspaceApplyEdit req) @@ -727,8 +813,9 @@ InR (InL c) -> return $ c ^. L.items InR (InR _) -> return [] --- | Returns the completions for the position in the document, resolving any with --- a non empty _data_ field. +{- | Returns the completions for the position in the document, resolving any with + a non empty _data_ field. +-} getAndResolveCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] getAndResolveCompletions doc pos = do items <- getCompletions doc pos @@ -743,43 +830,60 @@ Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) -- | Returns the references for the position in the document. -getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. - -> Position -- ^ The position to lookup. - -> Bool -- ^ Whether to include declarations as references. - -> Session [Location] -- ^ The locations of the references. +getReferences :: + -- | The document to lookup in. + TextDocumentIdentifier -> + -- | The position to lookup. + Position -> + -- | Whether to include declarations as references. + Bool -> + -- | The locations of the references. + Session [Location] getReferences doc pos inclDecl = let ctx = ReferenceContext inclDecl params = ReferenceParams doc pos Nothing Nothing ctx - in absorbNull . getResponseResult <$> request SMethod_TextDocumentReferences params + in absorbNull . getResponseResult <$> request SMethod_TextDocumentReferences params -- | Returns the declarations(s) for the term at the specified position. -getDeclarations :: TextDocumentIdentifier -- ^ The document the term is in. - -> Position -- ^ The position the term is at. - -> Session (Declaration |? [DeclarationLink] |? Null) +getDeclarations :: + -- | The document the term is in. + TextDocumentIdentifier -> + -- | The position the term is at. + Position -> + Session (Declaration |? [DeclarationLink] |? Null) getDeclarations doc pos = do rsp <- request SMethod_TextDocumentDeclaration (DeclarationParams doc pos Nothing Nothing) pure $ getResponseResult rsp -- | Returns the definition(s) for the term at the specified position. -getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. - -> Position -- ^ The position the term is at. - -> Session (Definition |? [DefinitionLink] |? Null) +getDefinitions :: + -- | The document the term is in. + TextDocumentIdentifier -> + -- | The position the term is at. + Position -> + Session (Definition |? [DefinitionLink] |? Null) getDefinitions doc pos = do rsp <- request SMethod_TextDocumentDefinition (DefinitionParams doc pos Nothing Nothing) pure $ getResponseResult rsp -- | Returns the type definition(s) for the term at the specified position. -getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. - -> Position -- ^ The position the term is at. - -> Session (Definition |? [DefinitionLink] |? Null) +getTypeDefinitions :: + -- | The document the term is in. + TextDocumentIdentifier -> + -- | The position the term is at. + Position -> + Session (Definition |? [DefinitionLink] |? Null) getTypeDefinitions doc pos = do rsp <- request SMethod_TextDocumentTypeDefinition (TypeDefinitionParams doc pos Nothing Nothing) pure $ getResponseResult rsp -- | Returns the type definition(s) for the term at the specified position. -getImplementations :: TextDocumentIdentifier -- ^ The document the term is in. - -> Position -- ^ The position the term is at. - -> Session (Definition |? [DefinitionLink] |? Null) +getImplementations :: + -- | The document the term is in. + TextDocumentIdentifier -> + -- | The position the term is at. + Position -> + Session (Definition |? [DefinitionLink] |? Null) getImplementations doc pos = do rsp <- request SMethod_TextDocumentImplementation (ImplementationParams doc pos Nothing Nothing) pure $ getResponseResult rsp @@ -800,16 +904,17 @@ getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover) getHover doc pos = let params = HoverParams doc pos Nothing - in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentHover params + in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentHover params -- | Returns the highlighted occurrences of the term at the specified position getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight] getHighlights doc pos = let params = DocumentHighlightParams doc pos Nothing Nothing - in absorbNull . getResponseResult <$> request SMethod_TextDocumentDocumentHighlight params + in absorbNull . getResponseResult <$> request SMethod_TextDocumentDocumentHighlight params --- | Checks the response for errors and throws an exception if needed. --- Returns the result if successful. +{- | Checks the response for errors and throws an exception if needed. + Returns the result if successful. +-} getResponseResult :: (ToJSON (ErrorData m)) => TResponseMessage m -> MessageResult m getResponseResult rsp = case rsp ^. L.result of @@ -835,20 +940,21 @@ let wEdit = WorkspaceEdit (Just (Map.singleton (doc ^. L.uri) edits)) Nothing Nothing -- Send a dummy message to updateState so it can do bookkeeping req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) - in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) + in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) -- | Returns the code lenses for the specified document. getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getCodeLenses tId = do - rsp <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing tId) - pure $ absorbNull $ getResponseResult rsp + rsp <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing tId) + pure $ absorbNull $ getResponseResult rsp --- | Returns the code lenses for the specified document, resolving any with --- a non empty _data_ field. +{- | Returns the code lenses for the specified document, resolving any with + a non empty _data_ field. +-} getAndResolveCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getAndResolveCodeLenses tId = do - codeLenses <- getCodeLenses tId - for codeLenses $ \codeLens -> if isJust (codeLens ^. L.data_) then resolveCodeLens codeLens else pure codeLens + codeLenses <- getCodeLenses tId + for codeLenses $ \codeLens -> if isJust (codeLens ^. L.data_) then resolveCodeLens codeLens else pure codeLens -- |Resolves the provided code lens. resolveCodeLens :: CodeLens -> Session CodeLens @@ -869,11 +975,12 @@ outgoingCalls = resolveRequestWithListResp SMethod_CallHierarchyOutgoingCalls -- | Send a request and receive a response with list. -resolveRequestWithListResp :: forall (m :: Method ClientToServer Request) a - . (ToJSON (ErrorData m), MessageResult m ~ ([a] |? Null)) - => SMethod m - -> MessageParams m - -> Session [a] +resolveRequestWithListResp :: + forall (m :: Method ClientToServer Request) a. + (ToJSON (ErrorData m), MessageResult m ~ ([a] |? Null)) => + SMethod m -> + MessageParams m -> + Session [a] resolveRequestWithListResp method params = do rsp <- request method params pure $ absorbNull $ getResponseResult rsp @@ -885,9 +992,10 @@ rsp <- request SMethod_TextDocumentSemanticTokensFull params pure $ getResponseResult rsp --- | Returns a list of capabilities that the server has requested to /dynamically/ --- register during the 'Session'. --- --- @since 0.11.0.0 +{- | Returns a list of capabilities that the server has requested to /dynamically/ + register during the 'Session'. + + @since 0.11.0.0 +-} getRegisteredCapabilities :: Session [SomeRegistration] getRegisteredCapabilities = Map.elems . curDynCaps <$> get diff --git a/src/Language/LSP/Test/Compat.hs b/src/Language/LSP/Test/Compat.hs --- a/src/Language/LSP/Test/Compat.hs +++ b/src/Language/LSP/Test/Compat.hs @@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -- For some reason ghc warns about not using -- Control.Monad.IO.Class but it's needed for -- MonadIO {-# OPTIONS_GHC -Wunused-imports #-} + module Language.LSP.Test.Compat where -import Data.Row import Data.Maybe -import qualified Data.Text as T +import Data.Row +import Data.Text qualified as T import System.IO #if MIN_VERSION_process(1,6,3) @@ -44,7 +45,6 @@ import qualified System.Posix.Process #endif - getCurrentProcessID :: IO Int #ifdef mingw32_HOST_OS getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessId @@ -54,7 +54,7 @@ getProcessID :: ProcessHandle -> IO Int getProcessID p = fromIntegral . fromJust <$> getProcessID' p - where + where #if MIN_VERSION_process(1,6,3) getProcessID' = System.Process.getPid #else @@ -75,13 +75,12 @@ _ -> return Nothing #endif -cleanupProcess - :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () - -withCreateProcess - :: CreateProcess - -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) - -> IO a +cleanupProcess :: + (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () +withCreateProcess :: + CreateProcess -> + (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> + IO a #if MIN_VERSION_process(1,6,4) diff --git a/src/Language/LSP/Test/Decoding.hs b/src/Language/LSP/Test/Decoding.hs --- a/src/Language/LSP/Test/Decoding.hs +++ b/src/Language/LSP/Test/Decoding.hs @@ -1,55 +1,59 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeInType #-} + module Language.LSP.Test.Decoding where -import Prelude hiding ( id ) -import Data.Aeson -import Data.Aeson.Types -import Data.Foldable -import Data.Functor.Product -import Data.Functor.Const -import Control.Exception -import Control.Lens -import qualified Data.ByteString.Lazy.Char8 as B -import Data.Maybe -import System.IO -import System.IO.Error -import Language.LSP.Protocol.Message -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Test.Exceptions +import Control.Exception +import Control.Lens +import Data.Aeson +import Data.Aeson.Types +import Data.ByteString.Lazy.Char8 qualified as B +import Data.Foldable +import Data.Functor.Const +import Data.Functor.Product +import Data.Maybe +import Language.LSP.Protocol.Lens qualified as L +import Language.LSP.Protocol.Message +import Language.LSP.Test.Exceptions +import System.IO +import System.IO.Error +import Prelude hiding (id) import Data.IxMap import Data.Kind --- | Fetches the next message bytes based on --- the Content-Length header +{- | Fetches the next message bytes based on + the Content-Length header +-} getNextMessage :: Handle -> IO B.ByteString getNextMessage h = do headers <- getHeaders h case read . init <$> lookup "Content-Length" headers of - Nothing -> throw NoContentLengthHeader + Nothing -> throw NoContentLengthHeader Just size -> B.hGet h size addHeader :: B.ByteString -> B.ByteString -addHeader content = B.concat - [ "Content-Length: " - , B.pack $ show $ B.length content - , "\r\n" - , "\r\n" - , content - ] +addHeader content = + B.concat + [ "Content-Length: " + , B.pack $ show $ B.length content + , "\r\n" + , "\r\n" + , content + ] getHeaders :: Handle -> IO [(String, String)] getHeaders h = do l <- catch (hGetLine h) eofHandler let (name, val) = span (/= ':') l if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h - where eofHandler e - | isEOFError e = throw UnexpectedServerTermination - | otherwise = throw e + where + eofHandler e + | isEOFError e = throw UnexpectedServerTermination + | otherwise = throw e -type RequestMap = IxMap LspId (SMethod :: Method ClientToServer Request -> Type ) +type RequestMap = IxMap LspId (SMethod :: Method ClientToServer Request -> Type) newRequestMap :: RequestMap newRequestMap = emptyIxMap @@ -72,22 +76,24 @@ decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage) decodeFromServerMsg reqMap bytes = unP $ parse p obj - where obj = fromJust $ decode bytes :: Value - p = parseServerMessage $ \lid -> - let (mm, newMap) = pickFromIxMap lid reqMap - in case mm of - Nothing -> Nothing - Just m -> Just $ (m, Pair m (Const newMap)) - unP (Success (FromServerMess m msg)) = (reqMap, FromServerMess m msg) - unP (Success (FromServerRsp (Pair m (Const newMap)) msg)) = (newMap, FromServerRsp m msg) - unP (Error e) = error $ "Error decoding " <> show obj <> " :" <> e - {- - WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" - WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet" - CustomServerMethod _ - | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes - | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes - | otherwise -> NotCustomServer $ fromJust $ decode bytes + where + obj = fromJust $ decode bytes :: Value + p = parseServerMessage $ \lid -> + let (mm, newMap) = pickFromIxMap lid reqMap + in case mm of + Nothing -> Nothing + Just m -> Just $ (m, Pair m (Const newMap)) + unP (Success (FromServerMess m msg)) = (reqMap, FromServerMess m msg) + unP (Success (FromServerRsp (Pair m (Const newMap)) msg)) = (newMap, FromServerRsp m msg) + unP (Error e) = error $ "Error decoding " <> show obj <> " :" <> e - Error e -> error e - -} +{- + WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" + WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet" + CustomServerMethod _ + | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes + | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes + | otherwise -> NotCustomServer $ fromJust $ decode bytes + +Error e -> error e +-} diff --git a/src/Language/LSP/Test/Exceptions.hs b/src/Language/LSP/Test/Exceptions.hs --- a/src/Language/LSP/Test/Exceptions.hs +++ b/src/Language/LSP/Test/Exceptions.hs @@ -1,59 +1,75 @@ module Language.LSP.Test.Exceptions where import Control.Exception -import Language.LSP.Protocol.Message import Data.Aeson import Data.Aeson.Encode.Pretty import Data.Algorithm.Diff import Data.Algorithm.DiffOutput +import Data.ByteString.Lazy.Char8 qualified as B import Data.List -import qualified Data.ByteString.Lazy.Char8 as B +import Language.LSP.Protocol.Message -- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session' -data SessionException = Timeout (Maybe FromServerMessage) - | NoContentLengthHeader - | UnexpectedMessage String FromServerMessage - | ReplayOutOfOrder FromServerMessage [FromServerMessage] - | UnexpectedDiagnostics - | IncorrectApplyEditRequest String - | UnexpectedResponseError SomeLspId ResponseError - | UnexpectedServerTermination - | IllegalInitSequenceMessage FromServerMessage - | MessageSendError Value IOError - deriving Eq +data SessionException + = Timeout (Maybe FromServerMessage) + | NoContentLengthHeader + | UnexpectedMessage String FromServerMessage + | ReplayOutOfOrder FromServerMessage [FromServerMessage] + | UnexpectedDiagnostics + | IncorrectApplyEditRequest String + | UnexpectedResponseError SomeLspId ResponseError + | UnexpectedServerTermination + | IllegalInitSequenceMessage FromServerMessage + | MessageSendError Value IOError + deriving (Eq) instance Exception SessionException instance Show SessionException where show (Timeout lastMsg) = - "Timed out waiting to receive a message from the server." ++ - case lastMsg of - Just msg -> "\nLast message received:\n" ++ B.unpack (encodePretty msg) - Nothing -> mempty + "Timed out waiting to receive a message from the server." + ++ case lastMsg of + Just msg -> "\nLast message received:\n" ++ B.unpack (encodePretty msg) + Nothing -> mempty show NoContentLengthHeader = "Couldn't read Content-Length header from the server." show (UnexpectedMessage expected lastMsg) = - "Received an unexpected message from the server:\n" ++ - "Was parsing: " ++ expected ++ "\n" ++ - "But the last message received was:\n" ++ B.unpack (encodePretty lastMsg) + "Received an unexpected message from the server:\n" + ++ "Was parsing: " + ++ expected + ++ "\n" + ++ "But the last message received was:\n" + ++ B.unpack (encodePretty lastMsg) show (ReplayOutOfOrder received expected) = let expected' = nub expected getJsonDiff = lines . B.unpack . encodePretty - showExp exp = B.unpack (encodePretty exp) ++ "\nDiff:\n" ++ - ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff exp)) - in "Replay is out of order:\n" ++ - -- Print json so its a bit easier to update the session logs - "Received from server:\n" ++ B.unpack (encodePretty received) ++ "\n" ++ - "Raw from server:\n" ++ B.unpack (encode received) ++ "\n" ++ - "Expected one of:\n" ++ unlines (map showExp expected') + showExp exp = + B.unpack (encodePretty exp) + ++ "\nDiff:\n" + ++ ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff exp)) + in "Replay is out of order:\n" + ++ + -- Print json so its a bit easier to update the session logs + "Received from server:\n" + ++ B.unpack (encodePretty received) + ++ "\n" + ++ "Raw from server:\n" + ++ B.unpack (encode received) + ++ "\n" + ++ "Expected one of:\n" + ++ unlines (map showExp expected') show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server." - show (IncorrectApplyEditRequest msgStr) = "ApplyEditRequest didn't contain document, instead received:\n" - ++ msgStr - show (UnexpectedResponseError lid e) = "Received an expected error in a response for id " ++ show lid ++ ":\n" - ++ show e + show (IncorrectApplyEditRequest msgStr) = + "ApplyEditRequest didn't contain document, instead received:\n" + ++ msgStr + show (UnexpectedResponseError lid e) = + "Received an expected error in a response for id " + ++ show lid + ++ ":\n" + ++ show e show UnexpectedServerTermination = "Language server unexpectedly terminated" show (IllegalInitSequenceMessage msg) = "Received an illegal message between the initialize request and response:\n" - ++ B.unpack (encodePretty msg) + ++ B.unpack (encodePretty msg) show (MessageSendError msg e) = "IO exception:\n" ++ show e ++ "\narose while trying to send message:\n" ++ B.unpack (encodePretty msg) diff --git a/src/Language/LSP/Test/Files.hs b/src/Language/LSP/Test/Files.hs --- a/src/Language/LSP/Test/Files.hs +++ b/src/Language/LSP/Test/Files.hs @@ -1,25 +1,26 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} -module Language.LSP.Test.Files - ( swapFiles - , rootDir - ) +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} + +module Language.LSP.Test.Files ( + swapFiles, + rootDir, +) where -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types -import qualified Language.LSP.Protocol.Lens as L -import Control.Lens -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Data.Maybe -import System.Directory -import System.FilePath +import Control.Lens +import Data.Map.Strict qualified as M +import Data.Maybe +import Data.Text qualified as T import Data.Time.Clock +import Language.LSP.Protocol.Lens qualified as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import System.Directory +import System.FilePath data Event = ClientEv UTCTime FromClientMessage @@ -33,17 +34,17 @@ let transform uri = let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri) newFp = curBaseDir makeRelative capturedBaseDir fp - in filePathToUri newFp + in filePathToUri newFp newMsgs = map (mapUris transform) msgs return newMsgs rootDir :: [Event] -> FilePath -rootDir (ClientEv _ (FromClientMess SMethod_Initialize req):_) = +rootDir (ClientEv _ (FromClientMess SMethod_Initialize req) : _) = fromMaybe (error "Couldn't find root dir") $ do rootUri <- case req ^. L.params . L.rootUri of - InL r -> Just r - InR _ -> error "Couldn't find root dir" + InL r -> Just r + InR _ -> error "Couldn't find root dir" uriToFilePath rootUri rootDir _ = error "Couldn't find initialize request in session" @@ -52,58 +53,59 @@ case event of ClientEv t msg -> ClientEv t (fromClientMsg msg) ServerEv t msg -> ServerEv t (fromServerMsg msg) - - where - --TODO: Handle all other URIs that might need swapped - fromClientMsg (FromClientMess m@SMethod_Initialize r) = FromClientMess m $ L.params .~ transformInit (r ^. L.params) $ r - fromClientMsg (FromClientMess m@SMethod_TextDocumentDidOpen n) = FromClientMess m $ swapUri (L.params . L.textDocument) n - fromClientMsg (FromClientMess m@SMethod_TextDocumentDidChange n) = FromClientMess m $ swapUri (L.params . L.textDocument) n - fromClientMsg (FromClientMess m@SMethod_TextDocumentWillSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n - fromClientMsg (FromClientMess m@SMethod_TextDocumentDidSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n - fromClientMsg (FromClientMess m@SMethod_TextDocumentDidClose n) = FromClientMess m $ swapUri (L.params . L.textDocument) n - fromClientMsg (FromClientMess m@SMethod_TextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (L.params . L.textDocument) n - fromClientMsg (FromClientMess m@SMethod_TextDocumentRename n) = FromClientMess m $ swapUri (L.params . L.textDocument) n - fromClientMsg x = x + where + -- TODO: Handle all other URIs that might need swapped + fromClientMsg (FromClientMess m@SMethod_Initialize r) = FromClientMess m $ L.params .~ transformInit (r ^. L.params) $ r + fromClientMsg (FromClientMess m@SMethod_TextDocumentDidOpen n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentDidChange n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentWillSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentDidSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentDidClose n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentRename n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg x = x - fromServerMsg :: FromServerMessage -> FromServerMessage - fromServerMsg (FromServerMess m@SMethod_WorkspaceApplyEdit r) = FromServerMess m $ L.params . L.edit .~ swapWorkspaceEdit (r ^. L.params . L.edit) $ r - fromServerMsg (FromServerMess m@SMethod_TextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri L.params n - fromServerMsg (FromServerRsp m@SMethod_TextDocumentDocumentSymbol r) = - let swapUri' :: ([SymbolInformation] |? [DocumentSymbol] |? Null) -> [SymbolInformation] |? [DocumentSymbol] |? Null - swapUri' (InR (InL dss)) = InR $ InL dss -- no file locations here - swapUri' (InR (InR n)) = InR $ InR n - swapUri' (InL si) = InL (swapUri L.location <$> si) - in FromServerRsp m $ r & L.result . _Right %~ swapUri' - fromServerMsg (FromServerRsp m@SMethod_TextDocumentRename r) = FromServerRsp m $ r & L.result . _Right . _L %~ swapWorkspaceEdit - fromServerMsg x = x + fromServerMsg :: FromServerMessage -> FromServerMessage + fromServerMsg (FromServerMess m@SMethod_WorkspaceApplyEdit r) = FromServerMess m $ L.params . L.edit .~ swapWorkspaceEdit (r ^. L.params . L.edit) $ r + fromServerMsg (FromServerMess m@SMethod_TextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri L.params n + fromServerMsg (FromServerRsp m@SMethod_TextDocumentDocumentSymbol r) = + let swapUri' :: ([SymbolInformation] |? [DocumentSymbol] |? Null) -> [SymbolInformation] |? [DocumentSymbol] |? Null + swapUri' (InR (InL dss)) = InR $ InL dss -- no file locations here + swapUri' (InR (InR n)) = InR $ InR n + swapUri' (InL si) = InL (swapUri L.location <$> si) + in FromServerRsp m $ r & L.result . _Right %~ swapUri' + fromServerMsg (FromServerRsp m@SMethod_TextDocumentRename r) = FromServerRsp m $ r & L.result . _Right . _L %~ swapWorkspaceEdit + fromServerMsg x = x - swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit - swapWorkspaceEdit e = - let swapDocumentChangeUri :: DocumentChange -> DocumentChange - swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri L.textDocument textDocEdit - swapDocumentChangeUri (InR (InL createFile)) = InR $ InL $ swapUri id createFile - -- for RenameFile, we swap `newUri` - swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ L.newUri .~ f (renameFile ^. L.newUri) $ renameFile - swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile - in e & L.changes . _Just %~ swapKeys f - & L.documentChanges . _Just . traversed%~ swapDocumentChangeUri + swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit + swapWorkspaceEdit e = + let swapDocumentChangeUri :: DocumentChange -> DocumentChange + swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri L.textDocument textDocEdit + swapDocumentChangeUri (InR (InL createFile)) = InR $ InL $ swapUri id createFile + -- for RenameFile, we swap `newUri` + swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ L.newUri .~ f (renameFile ^. L.newUri) $ renameFile + swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile + in e + & L.changes . _Just %~ swapKeys f + & L.documentChanges . _Just . traversed %~ swapDocumentChangeUri - swapKeys :: (Uri -> Uri) -> M.Map Uri b -> M.Map Uri b - swapKeys f = M.foldlWithKey' (\acc k v -> M.insert (f k) v acc) M.empty + swapKeys :: (Uri -> Uri) -> M.Map Uri b -> M.Map Uri b + swapKeys f = M.foldlWithKey' (\acc k v -> M.insert (f k) v acc) M.empty - swapUri :: L.HasUri b Uri => Lens' a b -> a -> a - swapUri lens x = - let newUri = f (x ^. lens . L.uri) - in (lens . L.uri) .~ newUri $ x + swapUri :: L.HasUri b Uri => Lens' a b -> a -> a + swapUri lens x = + let newUri = f (x ^. lens . L.uri) + in (lens . L.uri) .~ newUri $ x - -- | Transforms rootUri/rootPath. - transformInit :: InitializeParams -> InitializeParams - transformInit x = - let modifyRootPath p = - let fp = T.unpack p - uri = filePathToUri fp - in case uriToFilePath (f uri) of - Just fp -> T.pack fp - Nothing -> p - in x & L.rootUri . _L %~ f - & L.rootPath . _Just . _L %~ modifyRootPath + -- \| Transforms rootUri/rootPath. + transformInit :: InitializeParams -> InitializeParams + transformInit x = + let modifyRootPath p = + let fp = T.unpack p + uri = filePathToUri fp + in case uriToFilePath (f uri) of + Just fp -> T.pack fp + Nothing -> p + in x + & L.rootUri . _L %~ f + & L.rootPath . _Just . _L %~ modifyRootPath diff --git a/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs --- a/src/Language/LSP/Test/Parsing.hs +++ b/src/Language/LSP/Test/Parsing.hs @@ -1,97 +1,100 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} -module Language.LSP.Test.Parsing - ( -- $receiving - satisfy - , satisfyMaybe - , message - , response - , responseForId - , customRequest - , customNotification - , anyRequest - , anyResponse - , anyNotification - , anyMessage - , loggingNotification - , configurationRequest - , loggingOrConfiguration - , publishDiagnosticsNotification - ) where +module Language.LSP.Test.Parsing ( + -- $receiving + satisfy, + satisfyMaybe, + message, + response, + responseForId, + customRequest, + customNotification, + anyRequest, + anyResponse, + anyNotification, + anyMessage, + loggingNotification, + configurationRequest, + loggingOrConfiguration, + publishDiagnosticsNotification, +) where import Control.Applicative import Control.Concurrent -import Control.Monad.IO.Class import Control.Monad +import Control.Monad.IO.Class import Data.Conduit.Parser hiding (named) -import qualified Data.Conduit.Parser (named) -import qualified Data.Text as T +import Data.Conduit.Parser qualified (named) +import Data.GADT.Compare +import Data.Text qualified as T import Data.Typeable +import GHC.TypeLits (KnownSymbol, symbolVal) import Language.LSP.Protocol.Message import Language.LSP.Test.Session -import GHC.TypeLits (KnownSymbol, symbolVal) -import Data.GADT.Compare --- $receiving --- To receive a message, specify the method of the message to expect: --- --- @ --- msg1 <- message SWorkspaceApplyEdit --- msg2 <- message STextDocumentHover --- @ --- --- 'Language.LSP.Test.Session' is actually just a parser --- that operates on messages under the hood. This means that you --- can create and combine parsers to match specific sequences of --- messages that you expect. --- --- For example, if you wanted to match either a definition or --- references request: --- --- > defOrImpl = message STextDocumentDefinition --- > <|> message STextDocumentReferences --- --- If you wanted to match any number of telemetry --- notifications immediately followed by a response: --- --- @ --- logThenDiags = --- skipManyTill (message STelemetryEvent) --- anyResponse --- @ +{- $receiving + To receive a message, specify the method of the message to expect: --- | Consumes and returns the next message, if it satisfies the specified predicate. --- --- @since 0.5.2.0 + @ + msg1 <- message SWorkspaceApplyEdit + msg2 <- message STextDocumentHover + @ + + 'Language.LSP.Test.Session' is actually just a parser + that operates on messages under the hood. This means that you + can create and combine parsers to match specific sequences of + messages that you expect. + + For example, if you wanted to match either a definition or + references request: + + > defOrImpl = message STextDocumentDefinition + > <|> message STextDocumentReferences + + If you wanted to match any number of telemetry + notifications immediately followed by a response: + + @ + logThenDiags = + skipManyTill (message STelemetryEvent) + anyResponse + @ +-} + +{- | Consumes and returns the next message, if it satisfies the specified predicate. + + @since 0.5.2.0 +-} satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing) --- | Consumes and returns the result of the specified predicate if it returns `Just`. --- --- @since 0.6.1.0 +{- | Consumes and returns the result of the specified predicate if it returns `Just`. + + @since 0.6.1.0 +-} satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a satisfyMaybe pred = satisfyMaybeM (pure . pred) satisfyMaybeM :: (FromServerMessage -> Session (Maybe a)) -> Session a -satisfyMaybeM pred = do - +satisfyMaybeM pred = do skipTimeout <- overridingTimeout <$> get timeoutId <- getCurTimeoutId mtid <- if skipTimeout - then pure Nothing - else Just <$> do - chan <- asks messageChan - timeout <- asks (messageTimeout . config) - liftIO $ forkIO $ do - threadDelay (timeout * 1000000) - writeChan chan (TimeoutMessage timeoutId) + then pure Nothing + else + Just <$> do + chan <- asks messageChan + timeout <- asks (messageTimeout . config) + liftIO $ forkIO $ do + threadDelay (timeout * 1000000) + writeChan chan (TimeoutMessage timeoutId) x <- Session await @@ -99,7 +102,7 @@ bumpTimeoutId timeoutId liftIO $ killThread tid - modify $ \s -> s { lastReceivedMessage = Just x } + modify $ \s -> s{lastReceivedMessage = Just x} res <- pred x @@ -112,9 +115,9 @@ named :: T.Text -> Session a -> Session a named s (Session x) = Session (Data.Conduit.Parser.named s x) - --- | Matches a request or a notification coming from the server. --- Doesn't match Custom Messages +{- | Matches a request or a notification coming from the server. + Doesn't match Custom Messages +-} message :: SServerMethod m -> Session (TMessage m) message (SMethod_CustomMethod _) = error "message can't be used with CustomMethod, use customRequest or customNotification instead" message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case @@ -128,28 +131,28 @@ customRequest :: KnownSymbol s => Proxy s -> Session (TMessage (Method_CustomMethod s :: Method ServerToClient Request)) customRequest p = let m = T.pack $ symbolVal p - in named m $ satisfyMaybe $ \case - FromServerMess m1 msg -> case splitServerMethod m1 of - IsServerEither -> case msg of - ReqMess _ -> case m1 `geq` SMethod_CustomMethod p of - Just Refl -> Just msg + in named m $ satisfyMaybe $ \case + FromServerMess m1 msg -> case splitServerMethod m1 of + IsServerEither -> case msg of + ReqMess _ -> case m1 `geq` SMethod_CustomMethod p of + Just Refl -> Just msg + _ -> Nothing + _ -> Nothing _ -> Nothing _ -> Nothing - _ -> Nothing - _ -> Nothing customNotification :: KnownSymbol s => Proxy s -> Session (TMessage (Method_CustomMethod s :: Method ServerToClient Notification)) customNotification p = let m = T.pack $ symbolVal p - in named m $ satisfyMaybe $ \case - FromServerMess m1 msg -> case splitServerMethod m1 of - IsServerEither -> case msg of - NotMess _ -> case m1 `geq` SMethod_CustomMethod p of - Just Refl -> Just msg + in named m $ satisfyMaybe $ \case + FromServerMess m1 msg -> case splitServerMethod m1 of + IsServerEither -> case msg of + NotMess _ -> case m1 `geq` SMethod_CustomMethod p of + Just Refl -> Just msg + _ -> Nothing + _ -> Nothing _ -> Nothing _ -> Nothing - _ -> Nothing - _ -> Nothing -- | Matches if the message is a notification. anyNotification :: Session FromServerMessage @@ -202,25 +205,26 @@ -- | Matches if the message is a log message notification or a show message notification/request. loggingNotification :: Session FromServerMessage loggingNotification = named "Logging notification" $ satisfy shouldSkip - where - shouldSkip (FromServerMess SMethod_WindowLogMessage _) = True - shouldSkip (FromServerMess SMethod_WindowShowMessage _) = True - shouldSkip (FromServerMess SMethod_WindowShowMessageRequest _) = True - shouldSkip (FromServerMess SMethod_WindowShowDocument _) = True - shouldSkip _ = False + where + shouldSkip (FromServerMess SMethod_WindowLogMessage _) = True + shouldSkip (FromServerMess SMethod_WindowShowMessage _) = True + shouldSkip (FromServerMess SMethod_WindowShowMessageRequest _) = True + shouldSkip (FromServerMess SMethod_WindowShowDocument _) = True + shouldSkip _ = False -- | Matches if the message is a configuration request from the server. configurationRequest :: Session FromServerMessage configurationRequest = named "Configuration request" $ satisfy shouldSkip - where - shouldSkip (FromServerMess SMethod_WorkspaceConfiguration _) = True - shouldSkip _ = False + where + shouldSkip (FromServerMess SMethod_WorkspaceConfiguration _) = True + shouldSkip _ = False loggingOrConfiguration :: Session FromServerMessage loggingOrConfiguration = loggingNotification <|> configurationRequest --- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics' --- (textDocument/publishDiagnostics) notification. +{- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics' + (textDocument/publishDiagnostics) notification. +-} publishDiagnosticsNotification :: Session (TMessage Method_TextDocumentPublishDiagnostics) publishDiagnosticsNotification = named "Publish diagnostics notification" $ satisfyMaybe $ \msg -> case msg of diff --git a/src/Language/LSP/Test/Server.hs b/src/Language/LSP/Test/Server.hs --- a/src/Language/LSP/Test/Server.hs +++ b/src/Language/LSP/Test/Server.hs @@ -10,8 +10,8 @@ withServer serverExe logStdErr modifyCreateProcess f = do -- TODO Probably should just change runServer to accept -- separate command and arguments - let cmd:args = words serverExe - createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } + let cmd : args = words serverExe + createProc = (proc cmd args){std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe} withCreateProcess (modifyCreateProcess createProc) $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do -- Need to continuously consume to stderr else it gets blocked -- Can't pass NoStream either to std_err diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs --- a/src/Language/LSP/Test/Session.hs +++ b/src/Language/LSP/Test/Session.hs @@ -1,3 +1,5 @@ +{- ORMOLU_DISABLE -} + {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} @@ -280,8 +282,8 @@ mainThreadId <- myThreadId let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps - initState vfs = SessionState 0 vfs mempty False Nothing mempty (lspConfig config) mempty (ignoreLogNotifications config) (ignoreConfigurationRequests config) - runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses + initState = SessionState 0 emptyVFS mempty False Nothing mempty (lspConfig config) mempty (ignoreLogNotifications config) (ignoreConfigurationRequests config) + runSession' = runSessionMonad context initState errorHandler = throwTo mainThreadId :: SessionException -> IO () serverListenerLauncher = @@ -304,7 +306,7 @@ (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer - (const $ initVFS $ \vfs -> runSessionMonad context (initState vfs) session) + (const $ runSessionMonad context initState session) return result updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () diff --git a/test/DummyServer.hs b/test/DummyServer.hs --- a/test/DummyServer.hs +++ b/test/DummyServer.hs @@ -1,27 +1,28 @@ -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + module DummyServer where import Control.Monad import Control.Monad.Reader -import Data.Aeson hiding (defaultOptions, Null) -import qualified Data.Aeson as J -import qualified Data.Map.Strict as M +import Data.Aeson hiding (Null, defaultOptions) +import Data.Aeson qualified as J import Data.List (isSuffixOf) -import qualified Data.Text as T +import Data.Map.Strict qualified as M +import Data.Proxy import Data.String -import UnliftIO.Concurrent +import Data.Text qualified as T +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Language.LSP.Server -import System.IO -import UnliftIO import System.Directory import System.FilePath +import System.IO import System.Process -import Language.LSP.Protocol.Types -import Language.LSP.Protocol.Message -import Data.Proxy +import UnliftIO +import UnliftIO.Concurrent withDummyServer :: ((Handle, Handle) -> IO ()) -> IO () withDummyServer f = do @@ -30,7 +31,8 @@ handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar let - definition = ServerDefinition + definition = + ServerDefinition { doInitialize = \env _req -> pure $ Right env , defaultConfig = 1 :: Int , configSection = "dummy" @@ -41,7 +43,7 @@ , staticHandlers = \_caps -> handlers , interpretHandler = \env -> Iso (\m -> runLspT env (runReaderT m handlerEnv)) liftIO - , options = defaultOptions {optExecuteCommandCommands = Just ["doAnEdit"]} + , options = defaultOptions{optExecuteCommandCommands = Just ["doAnEdit"]} } bracket @@ -49,7 +51,6 @@ killThread (const $ f (hinWrite, houtRead)) - data HandlerEnv = HandlerEnv { relRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles) , absRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles) @@ -62,11 +63,9 @@ \_noti -> sendNotification SMethod_WindowLogMessage $ LogMessageParams MessageType_Log "initialized" - , requestHandler (SMethod_CustomMethod (Proxy @"getConfig")) $ \_req resp -> do config <- getConfig resp $ Right $ toJSON config - , requestHandler SMethod_TextDocumentHover $ \_req responder -> responder $ @@ -77,18 +76,19 @@ \_req responder -> responder $ Right $ - InR $ InL - [ DocumentSymbol - "foo" - Nothing - SymbolKind_Object - Nothing - Nothing - (mkRange 0 0 3 6) - (mkRange 0 0 3 6) - Nothing - ] - , notificationHandler SMethod_TextDocumentDidOpen $ + InR $ + InL + [ DocumentSymbol + "foo" + Nothing + SymbolKind_Object + Nothing + Nothing + (mkRange 0 0 3 6) + (mkRange 0 0 3 6) + Nothing + ] + , notificationHandler SMethod_TextDocumentDidOpen $ \noti -> do let TNotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti TextDocumentItem uri _ _ _ = doc @@ -153,37 +153,35 @@ do Just token <- runInIO $ asks absRegToken >>= tryReadMVar runInIO $ unregisterCapability token - - -- this handler is used by the + , -- this handler is used by the -- "text document VFS / sends back didChange notifications (documentChanges)" test - , notificationHandler SMethod_TextDocumentDidChange $ \noti -> do + notificationHandler SMethod_TextDocumentDidChange $ \noti -> do let TNotificationMessage _ _ params = noti void $ sendNotification (SMethod_CustomMethod (Proxy @"custom/textDocument/didChange")) (toJSON params) - - , requestHandler SMethod_WorkspaceExecuteCommand $ \req resp -> do - case req of - TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just [val])) -> do - let - Success docUri = fromJSON val - edit = [TextEdit (mkRange 0 0 0 5) "howdy"] - params = - ApplyWorkspaceEditParams (Just "Howdy edit") $ - WorkspaceEdit (Just (M.singleton docUri edit)) Nothing Nothing - resp $ Right $ InR $ Null - void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ())) - TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAVersionedEdit" (Just [val])) -> do - let - Success versionedDocUri = fromJSON val - edit = [InL (TextEdit (mkRange 0 0 0 5) "howdy")] - documentEdit = TextDocumentEdit versionedDocUri edit - params = - ApplyWorkspaceEditParams (Just "Howdy edit") $ - WorkspaceEdit Nothing (Just [InL documentEdit]) Nothing - resp $ Right $ InR Null - void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ())) - TRequestMessage _ _ _ (ExecuteCommandParams _ name _) -> - error $ "unsupported command: " <> show name - , requestHandler SMethod_TextDocumentCodeAction $ \req resp -> do + , requestHandler SMethod_WorkspaceExecuteCommand $ \req resp -> do + case req of + TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just [val])) -> do + let + Success docUri = fromJSON val + edit = [TextEdit (mkRange 0 0 0 5) "howdy"] + params = + ApplyWorkspaceEditParams (Just "Howdy edit") $ + WorkspaceEdit (Just (M.singleton docUri edit)) Nothing Nothing + resp $ Right $ InR $ Null + void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ())) + TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAVersionedEdit" (Just [val])) -> do + let + Success versionedDocUri = fromJSON val + edit = [InL (TextEdit (mkRange 0 0 0 5) "howdy")] + documentEdit = TextDocumentEdit versionedDocUri edit + params = + ApplyWorkspaceEditParams (Just "Howdy edit") $ + WorkspaceEdit Nothing (Just [InL documentEdit]) Nothing + resp $ Right $ InR Null + void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ())) + TRequestMessage _ _ _ (ExecuteCommandParams _ name _) -> + error $ "unsupported command: " <> show name + , requestHandler SMethod_TextDocumentCodeAction $ \req resp -> do let TRequestMessage _ _ _ params = req CodeActionParams _ _ _ _ cactx = params CodeActionContext diags _ _ = cactx @@ -199,7 +197,7 @@ (Just (Command "" "deleteThis" Nothing)) Nothing resp $ Right $ InL $ InR <$> codeActions - , requestHandler SMethod_TextDocumentCompletion $ \_req resp -> do + , requestHandler SMethod_TextDocumentCompletion $ \_req resp -> do let res = CompletionList True Nothing [item] item = CompletionItem @@ -223,7 +221,7 @@ Nothing Nothing resp $ Right $ InR $ InL res - , requestHandler SMethod_TextDocumentPrepareCallHierarchy $ \req resp -> do + , requestHandler SMethod_TextDocumentPrepareCallHierarchy $ \req resp -> do let TRequestMessage _ _ _ params = req CallHierarchyPrepareParams _ pos _ = params Position x y = pos @@ -240,17 +238,21 @@ if x == 0 && y == 0 then resp $ Right $ InR Null else resp $ Right $ InL [item] - , requestHandler SMethod_CallHierarchyIncomingCalls $ \req resp -> do + , requestHandler SMethod_CallHierarchyIncomingCalls $ \req resp -> do let TRequestMessage _ _ _ params = req CallHierarchyIncomingCallsParams _ _ item = params - resp $ Right $ InL - [CallHierarchyIncomingCall item [Range (Position 2 3) (Position 4 5)]] - , requestHandler SMethod_CallHierarchyOutgoingCalls $ \req resp -> do + resp $ + Right $ + InL + [CallHierarchyIncomingCall item [Range (Position 2 3) (Position 4 5)]] + , requestHandler SMethod_CallHierarchyOutgoingCalls $ \req resp -> do let TRequestMessage _ _ _ params = req CallHierarchyOutgoingCallsParams _ _ item = params - resp $ Right $ InL - [CallHierarchyOutgoingCall item [Range (Position 4 5) (Position 2 3)]] - , requestHandler SMethod_TextDocumentSemanticTokensFull $ \_req resp -> do + resp $ + Right $ + InL + [CallHierarchyOutgoingCall item [Range (Position 4 5) (Position 2 3)]] + , requestHandler SMethod_TextDocumentSemanticTokensFull $ \_req resp -> do let tokens = makeSemanticTokens defaultSemanticTokensLegend [SemanticTokenAbsolute 0 1 2 SemanticTokenTypes_Type []] case tokens of Left t -> resp $ Left $ ResponseError (InR ErrorCodes_InternalError) t Nothing diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,46 +1,44 @@ -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +import Control.Applicative.Combinators +import Control.Concurrent +import Control.Lens hiding (Iso, List) +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson +import Data.Aeson qualified as J +import Data.Default +import Data.Either +import Data.Map.Strict qualified as M +import Data.Maybe +import Data.Proxy +import Data.Text qualified as T +import Data.Type.Equality import DummyServer -import Test.Hspec -import Data.Aeson -import qualified Data.Aeson as J -import Data.Default -import qualified Data.Map.Strict as M -import Data.Either -import Data.Maybe -import qualified Data.Text as T -import Data.Type.Equality -import Data.Proxy -import Control.Applicative.Combinators -import Control.Concurrent -import Control.Monad.IO.Class -import Control.Monad -import Control.Lens hiding (List, Iso) -import Language.LSP.Test -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types -import qualified Language.LSP.Protocol.Lens as L -import System.Directory -import System.FilePath -import System.Timeout - +import Language.LSP.Protocol.Lens qualified as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Test +import System.Directory +import System.FilePath +import System.Timeout +import Test.Hspec {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-} - main = hspec $ around withDummyServer $ do describe "Session" $ do it "fails a test" $ \(hin, hout) -> let session = runSessionWithHandles hin hout def fullCaps "." $ do - openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" - anyRequest - in session `shouldThrow` anySessionException + openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" + anyRequest + in session `shouldThrow` anySessionException it "initializeResponse" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do rsp <- initializeResponse liftIO $ rsp ^. L.result `shouldSatisfy` isRight @@ -51,20 +49,20 @@ describe "withTimeout" $ do it "times out" $ \(hin, hout) -> let sesh = runSessionWithHandles hin hout def fullCaps "." $ do - openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" - -- won't receive a request - will timeout - -- incoming logging requests shouldn't increase the - -- timeout - withTimeout 5 $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) - -- wait just a bit longer than 5 seconds so we have time - -- to open the document - in timeout 6000000 sesh `shouldThrow` anySessionException + openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" + -- won't receive a request - will timeout + -- incoming logging requests shouldn't increase the + -- timeout + withTimeout 5 $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + in -- wait just a bit longer than 5 seconds so we have time + -- to open the document + timeout 6000000 sesh `shouldThrow` anySessionException it "doesn't time out" $ \(hin, hout) -> let sesh = runSessionWithHandles hin hout def fullCaps "." $ do - openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" - withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification - in void $ timeout 6000000 sesh + openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" + withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification + in void $ timeout 6000000 sesh it "further timeout messages are ignored" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do @@ -72,24 +70,24 @@ -- shouldn't timeout withTimeout 3 $ getDocumentSymbols doc -- longer than the original timeout - liftIO $ threadDelay (5 * 10^6) + liftIO $ threadDelay (5 * 10 ^ 6) -- shouldn't throw an exception getDocumentSymbols doc return () it "overrides global message timeout" $ \(hin, hout) -> let sesh = - runSessionWithHandles hin hout (def { messageTimeout = 5 }) fullCaps "." $ do + runSessionWithHandles hin hout (def{messageTimeout = 5}) fullCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000 getDocumentSymbols doc return True - in sesh `shouldReturn` True + in sesh `shouldReturn` True it "unoverrides global message timeout" $ \(hin, hout) -> let sesh = - runSessionWithHandles hin hout (def { messageTimeout = 5 }) fullCaps "." $ do + runSessionWithHandles hin hout (def{messageTimeout = 5}) fullCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000 @@ -98,18 +96,17 @@ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) isTimeout (Timeout _) = True isTimeout _ = False - in sesh `shouldThrow` isTimeout - + in sesh `shouldThrow` isTimeout describe "SessionException" $ do it "throw on time out" $ \(hin, hout) -> - let sesh = runSessionWithHandles hin hout (def {messageTimeout = 10}) fullCaps "." $ do - _ <- message SMethod_WorkspaceApplyEdit - return () - in sesh `shouldThrow` anySessionException + let sesh = runSessionWithHandles hin hout (def{messageTimeout = 10}) fullCaps "." $ do + _ <- message SMethod_WorkspaceApplyEdit + return () + in sesh `shouldThrow` anySessionException it "don't throw when no time out" $ \(hin, hout) -> - runSessionWithHandles hin hout (def {messageTimeout = 5}) fullCaps "." $ do + runSessionWithHandles hin hout (def{messageTimeout = 5}) fullCaps "." $ do liftIO $ threadDelay $ 6 * 1000000 _ <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" return () @@ -118,7 +115,7 @@ it "throws when there's an unexpected message" $ \(hin, hout) -> let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SMethod_WindowLogMessage _)) = True selector _ = False - in runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." publishDiagnosticsNotification `shouldThrow` selector + in runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ \(hin, hout) -> let selector (UnexpectedMessage "Response for: SMethod_TextDocumentRename" (FromServerRsp SMethod_TextDocumentDocumentSymbol _)) = True selector _ = False @@ -127,12 +124,12 @@ sendRequest SMethod_TextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) skipMany anyNotification response SMethod_TextDocumentRename -- the wrong type - in runSessionWithHandles hin hout def fullCaps "." sesh - `shouldThrow` selector + in runSessionWithHandles hin hout def fullCaps "." sesh + `shouldThrow` selector describe "config" $ do it "updates config correctly" $ \(hin, hout) -> - runSessionWithHandles hin hout (def { ignoreConfigurationRequests = False }) fullCaps "." $ do + runSessionWithHandles hin hout (def{ignoreConfigurationRequests = False}) fullCaps "." $ do configurationRequest -- initialized configuration request let requestConfig = do resp <- request (SMethod_CustomMethod (Proxy @"getConfig")) J.Null @@ -166,13 +163,13 @@ editReq <- message SMethod_WorkspaceApplyEdit liftIO $ do - let Just [InL(TextDocumentEdit vdoc [InL edit_])] = + let Just [InL (TextDocumentEdit vdoc [InL edit_])] = editReq ^. L.params . L.edit . L.documentChanges - vdoc `shouldBe` OptionalVersionedTextDocumentIdentifier (doc ^. L.uri) (InL beforeVersion) + vdoc `shouldBe` OptionalVersionedTextDocumentIdentifier (doc ^. L.uri) (InL beforeVersion) edit_ `shouldBe` TextEdit (Range (Position 0 0) (Position 0 5)) "howdy" change <- customNotification (Proxy @"custom/textDocument/didChange") - let NotMess (TNotificationMessage _ _ (c::Value)) = change + let NotMess (TNotificationMessage _ _ (c :: Value)) = change Success (DidChangeTextDocumentParams reportedVDoc _edit) = fromJSON c VersionedTextDocumentIdentifier _ reportedVersion = reportedVDoc @@ -229,13 +226,13 @@ liftIO $ do let [InR action] = actions action ^. L.title `shouldBe` "Delete this" - action ^. L.command . _Just . L.command `shouldBe` "deleteThis" + action ^. L.command . _Just . L.command `shouldBe` "deleteThis" describe "getDocumentSymbols" $ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" - Right (mainSymbol:_) <- getDocumentSymbols doc + Right (mainSymbol : _) <- getDocumentSymbols doc liftIO $ do mainSymbol ^. L.name `shouldBe` "foo" @@ -341,24 +338,24 @@ closeDoc doc -- need to evaluate to throw documentContents doc >>= liftIO . print - in sesh `shouldThrow` anyException + in sesh `shouldThrow` anyException describe "satisfy" $ - it "works" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do + it "works" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do openDoc "test/data/Format.hs" "haskell" let pred (FromServerMess SMethod_WindowLogMessage _) = True pred _ = False void $ satisfy pred describe "satisfyMaybe" $ do - it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do + it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do -- Wait for window/logMessage "initialized" from the server. let pred (FromServerMess SMethod_WindowLogMessage _) = Just "match" :: Maybe String pred _ = Nothing :: Maybe String result <- satisfyMaybe pred liftIO $ result `shouldBe` "match" - it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do + it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do let pred (FromServerMess SMethod_TextDocumentPublishDiagnostics _) = Just "matched" :: Maybe String pred _ = Nothing :: Maybe String -- We expect a window/logMessage from the server, but @@ -368,13 +365,12 @@ describe "ignoreLogNotifications" $ it "works" $ \(hin, hout) -> - runSessionWithHandles hin hout (def { ignoreLogNotifications = True }) fullCaps "." $ do + runSessionWithHandles hin hout (def{ignoreLogNotifications = True}) fullCaps "." $ do openDoc "test/data/Format.hs" "haskell" void publishDiagnosticsNotification describe "dynamic capabilities" $ do - - it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do + it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do loggingNotification -- initialized log message createDoc ".register" "haskell" "" message SMethod_ClientRegisterCapability @@ -387,8 +383,11 @@ liftIO $ do case regMethod `mEqClient` SMethod_WorkspaceDidChangeWatchedFiles of Just (Right HRefl) -> - regOpts `shouldBe` (Just $ DidChangeWatchedFilesRegistrationOptions - [ FileSystemWatcher (GlobPattern $ InL $ Pattern "*.watch") (Just WatchKind_Create) ]) + regOpts + `shouldBe` ( Just $ + DidChangeWatchedFilesRegistrationOptions + [FileSystemWatcher (GlobPattern $ InL $ Pattern "*.watch") (Just WatchKind_Create)] + ) _ -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles" -- now unregister it by sending a specific createDoc @@ -399,7 +398,7 @@ void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing void $ anyResponse - it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "" $ do + it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "" $ do loggingNotification -- initialized log message curDir <- liftIO $ getCurrentDirectory @@ -422,10 +421,16 @@ let workPos = Position 1 0 notWorkPos = Position 0 0 params pos = CallHierarchyPrepareParams (TextDocumentIdentifier (Uri "")) pos Nothing - item = CallHierarchyItem "foo" SymbolKind_Function Nothing Nothing (Uri "") - (Range (Position 1 2) (Position 3 4)) - (Range (Position 1 2) (Position 3 4)) - Nothing + item = + CallHierarchyItem + "foo" + SymbolKind_Function + Nothing + Nothing + (Uri "") + (Range (Position 1 2) (Position 3 4)) + (Range (Position 1 2) (Position 3 4)) + Nothing it "prepare works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do rsp <- prepareCallHierarchy (params workPos) liftIO $ head rsp ^. L.range `shouldBe` Range (Position 2 3) (Position 4 5) @@ -443,4 +448,4 @@ it "full works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do let doc = TextDocumentIdentifier (Uri "") InL toks <- getSemanticTokens doc - liftIO $ toks ^. L.data_ `shouldBe` [0,1,2,1,0] + liftIO $ toks ^. L.data_ `shouldBe` [0, 1, 2, 1, 0] diff --git a/test/data/Format.hs b/test/data/Format.hs --- a/test/data/Format.hs +++ b/test/data/Format.hs @@ -1,4 +1,5 @@ module Format where -foo 3 = 2 -foo x = x -bar _ = 2 + +foo 3 = 2 +foo x = x +bar _ = 2 diff --git a/test/data/documentSymbolFail/example/Main.hs b/test/data/documentSymbolFail/example/Main.hs --- a/test/data/documentSymbolFail/example/Main.hs +++ b/test/data/documentSymbolFail/example/Main.hs @@ -1,20 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + module Main where -import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP -import qualified Language.Haskell.LSP.TH.ClientCapabilities as LSP -import qualified LSP.Client as Client -import Data.Proxy -import qualified Data.Text.IO as T import Control.Concurrent -import System.Process import Control.Lens -import System.IO -import System.Exit -import System.Environment -import System.Directory import Control.Monad +import Data.Proxy +import qualified Data.Text.IO as T +import qualified LSP.Client as Client +import qualified Language.Haskell.LSP.TH.ClientCapabilities as LSP +import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP +import System.Directory +import System.Environment +import System.Exit +import System.IO +import System.Process import qualified Compat @@ -39,43 +40,55 @@ pid <- Compat.getPID let caps = LSP.ClientCapabilities (Just workspaceCaps) (Just textDocumentCaps) Nothing - workspaceCaps = LSP.WorkspaceClientCapabilities - (Just False) - (Just (LSP.WorkspaceEditClientCapabilities (Just False))) - (Just (LSP.DidChangeConfigurationClientCapabilities (Just False))) - (Just (LSP.DidChangeWatchedFilesClientCapabilities (Just False))) - (Just (LSP.SymbolClientCapabilities (Just False))) - (Just (LSP.ExecuteClientCapabilities (Just False))) - textDocumentCaps = LSP.TextDocumentClientCapabilities - (Just (LSP.SynchronizationTextDocumentClientCapabilities - (Just False) - (Just False) - (Just False) - (Just False))) - (Just (LSP.CompletionClientCapabilities - (Just False) - (Just (LSP.CompletionItemClientCapabilities (Just False))))) - (Just (LSP.HoverClientCapabilities (Just False))) - (Just (LSP.SignatureHelpClientCapabilities (Just False))) - (Just (LSP.ReferencesClientCapabilities (Just False))) - (Just (LSP.DocumentHighlightClientCapabilities (Just False))) - (Just (LSP.DocumentSymbolClientCapabilities (Just False))) - (Just (LSP.FormattingClientCapabilities (Just False))) - (Just (LSP.RangeFormattingClientCapabilities (Just False))) - (Just (LSP.OnTypeFormattingClientCapabilities (Just False))) - (Just (LSP.DefinitionClientCapabilities (Just False))) - (Just (LSP.CodeActionClientCapabilities (Just False))) - (Just (LSP.CodeLensClientCapabilities (Just False))) - (Just (LSP.DocumentLinkClientCapabilities (Just False))) - (Just (LSP.RenameClientCapabilities (Just False))) - (Just (LSP.CallHierarchyClientCapabilities (Just False))) + workspaceCaps = + LSP.WorkspaceClientCapabilities + (Just False) + (Just (LSP.WorkspaceEditClientCapabilities (Just False))) + (Just (LSP.DidChangeConfigurationClientCapabilities (Just False))) + (Just (LSP.DidChangeWatchedFilesClientCapabilities (Just False))) + (Just (LSP.SymbolClientCapabilities (Just False))) + (Just (LSP.ExecuteClientCapabilities (Just False))) + textDocumentCaps = + LSP.TextDocumentClientCapabilities + ( Just + ( LSP.SynchronizationTextDocumentClientCapabilities + (Just False) + (Just False) + (Just False) + (Just False) + ) + ) + ( Just + ( LSP.CompletionClientCapabilities + (Just False) + (Just (LSP.CompletionItemClientCapabilities (Just False))) + ) + ) + (Just (LSP.HoverClientCapabilities (Just False))) + (Just (LSP.SignatureHelpClientCapabilities (Just False))) + (Just (LSP.ReferencesClientCapabilities (Just False))) + (Just (LSP.DocumentHighlightClientCapabilities (Just False))) + (Just (LSP.DocumentSymbolClientCapabilities (Just False))) + (Just (LSP.FormattingClientCapabilities (Just False))) + (Just (LSP.RangeFormattingClientCapabilities (Just False))) + (Just (LSP.OnTypeFormattingClientCapabilities (Just False))) + (Just (LSP.DefinitionClientCapabilities (Just False))) + (Just (LSP.CodeActionClientCapabilities (Just False))) + (Just (LSP.CodeLensClientCapabilities (Just False))) + (Just (LSP.DocumentLinkClientCapabilities (Just False))) + (Just (LSP.RenameClientCapabilities (Just False))) + (Just (LSP.CallHierarchyClientCapabilities (Just False))) initializeParams :: LSP.InitializeParams initializeParams = LSP.InitializeParams (Just pid) Nothing Nothing Nothing caps Nothing - - (Just inp, Just out, _, _) <- createProcess (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "--debug"]) - {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe} + (Just inp, Just out, _, _) <- + createProcess + (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "--debug"]) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } client <- Client.start (Client.Config inp out testNotificationMessageHandler testRequestMessageHandler) @@ -93,7 +106,8 @@ client (Proxy :: Proxy LSP.DefinitionRequest) LSP.TextDocumentDefinition - (LSP.TextDocumentPositionParams (LSP.TextDocumentIdentifier uri) (LSP.Position 88 36)) >>= \case + (LSP.TextDocumentPositionParams (LSP.TextDocumentIdentifier uri) (LSP.Position 88 36)) + >>= \case Just (Right pos) -> print pos _ -> putStrLn "Server couldn't give us defnition position" @@ -108,21 +122,23 @@ Client.stop client testRequestMessageHandler :: Client.RequestMessageHandler -testRequestMessageHandler = Client.RequestMessageHandler - (\m -> emptyResponse m <$ print m) - (\m -> emptyResponse m <$ print m) - (\m -> emptyResponse m <$ print m) - (\m -> emptyResponse m <$ print m) - where - toRspId (LSP.IdInt i) = LSP.IdRspInt i - toRspId (LSP.IdString t) = LSP.IdRspString t +testRequestMessageHandler = + Client.RequestMessageHandler + (\m -> emptyResponse m <$ print m) + (\m -> emptyResponse m <$ print m) + (\m -> emptyResponse m <$ print m) + (\m -> emptyResponse m <$ print m) + where + toRspId (LSP.IdInt i) = LSP.IdRspInt i + toRspId (LSP.IdString t) = LSP.IdRspString t - emptyResponse :: LSP.RequestMessage m req resp -> LSP.ResponseMessage a - emptyResponse m = LSP.ResponseMessage (m ^. LSP.jsonrpc) (toRspId (m ^. LSP.id)) Nothing Nothing + emptyResponse :: LSP.RequestMessage m req resp -> LSP.ResponseMessage a + emptyResponse m = LSP.ResponseMessage (m ^. LSP.jsonrpc) (toRspId (m ^. LSP.id)) Nothing Nothing testNotificationMessageHandler :: Client.NotificationMessageHandler -testNotificationMessageHandler = Client.NotificationMessageHandler - (T.putStrLn . view (LSP.params . LSP.message)) - (T.putStrLn . view (LSP.params . LSP.message)) - (print . view LSP.params) - (mapM_ T.putStrLn . (^.. LSP.params . LSP.diagnostics . traverse . LSP.message)) +testNotificationMessageHandler = + Client.NotificationMessageHandler + (T.putStrLn . view (LSP.params . LSP.message)) + (T.putStrLn . view (LSP.params . LSP.message)) + (print . view LSP.params) + (mapM_ T.putStrLn . (^.. LSP.params . LSP.diagnostics . traverse . LSP.message)) diff --git a/test/data/renameFail/Desktop/simple.hs b/test/data/renameFail/Desktop/simple.hs --- a/test/data/renameFail/Desktop/simple.hs +++ b/test/data/renameFail/Desktop/simple.hs @@ -8,11 +8,12 @@ type Item = String type Items = [Item] -data Command = Quit - | DisplayItems - | AddItem String - | RemoveItem Int - | Help +data Command + = Quit + | DisplayItems + | AddItem String + | RemoveItem Int + | Help type Error = String @@ -35,8 +36,9 @@ removeItem i items | i < 0 || i >= length items = Left "Out of range" | otherwise = Right result - where (front, back) = splitAt (i + 1) items - result = init front ++ back + where + (front, back) = splitAt (i + 1) items + result = init front ++ back interactWithUser :: Items -> IO () interactWithUser items = do @@ -45,12 +47,10 @@ Right DisplayItems -> do putStrLn $ displayItems items interactWithUser items - Right (AddItem item) -> do let newItems = addItem item items putStrLn "Added" interactWithUser newItems - Right (RemoveItem i) -> case removeItem i items of Right newItems -> do @@ -59,10 +59,7 @@ Left err -> do putStrLn err interactWithUser items - - Right Quit -> return () - Right Help -> do putStrLn "Commands:" putStrLn "help" @@ -70,7 +67,6 @@ putStrLn "add" putStrLn "quit" interactWithUser items - Left err -> do putStrLn $ "Error: " ++ err interactWithUser items diff --git a/test/data/renamePass/Desktop/simple.hs b/test/data/renamePass/Desktop/simple.hs --- a/test/data/renamePass/Desktop/simple.hs +++ b/test/data/renamePass/Desktop/simple.hs @@ -8,11 +8,12 @@ type Item = String type Items = [Item] -data Command = Quit - | DisplayItems - | AddItem String - | RemoveItem Int - | Help +data Command + = Quit + | DisplayItems + | AddItem String + | RemoveItem Int + | Help type Error = String @@ -35,8 +36,9 @@ removeItem i items | i < 0 || i >= length items = Left "Out of range" | otherwise = Right result - where (front, back) = splitAt (i + 1) items - result = init front ++ back + where + (front, back) = splitAt (i + 1) items + result = init front ++ back interactWithUser :: Items -> IO () interactWithUser items = do @@ -45,12 +47,10 @@ Right DisplayItems -> do putStrLn $ displayItems items interactWithUser items - Right (AddItem item) -> do let newItems = addItem item items putStrLn "Added" interactWithUser newItems - Right (RemoveItem i) -> case removeItem i items of Right newItems -> do @@ -59,10 +59,7 @@ Left err -> do putStrLn err interactWithUser items - - Right Quit -> return () - Right Help -> do putStrLn "Commands:" putStrLn "help" @@ -70,7 +67,6 @@ putStrLn "add" putStrLn "quit" interactWithUser items - Left err -> do putStrLn $ "Error: " ++ err interactWithUser items