diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,358 @@ +# Revision history for lsp + +## 1.0.0.0 + +1.0.0.0 is a major rework with both internal and external facing changes, and +will require manual migration. + +* The package has been renamed from `haskell-lsp` to `lsp`, and similarly for `haskell-lsp-types` to `lsp-types` + * Because of this, all modules are now exported from `Language.LSP.X` rather than `Language.Haskell.X`. +* Both `lsp` and `lsp-types` have been reworked to be much more *type safe* +* The 3.15 specification should be fully supported now. If you find anything in + the specification that isn't in lsp-types, please let us know +* The Capture module has been removed as it will be reworked later on and moved to lsp-test +* `lsp` can now handle dynamic registration through the `registerCapability` and + `unregisterCapability` functions + +### Type safety + +There are three types of concrete messages, `NotificationMessage`, +`RequestMessage` and `ResponseMessage`. They are parameterised by their +`Method`, which determines what type their parameters or response result must be. + +```haskell +data RequestMessage (m :: Method f Request) = RequestMessage + { _jsonrpc :: Text + , _id :: LspId m + , _method :: SMethod m + , _params :: MessageParams m + } +``` + +A `Method` in turn is parameterised by whether it originates from the client or +the server, and whether it is used for notifications or requests: + +```haskell +TextDocumentFoldingRange :: Method FromClient Request +TextDocumentSelectionRange :: Method FromClient Request +WindowShowMessage :: Method FromServer Notification +WindowShowMessageRequest :: Method FromServer Request +``` + +Each `Method` also has a singleton counterpart which allows it to be used at the +term level, for example in `RequestMessage._method`: + +```haskell +STextDocumentFoldingRange :: SMethod TextDocumentFoldingRange +STextDocumentSelectionRange :: SMethod TextDocumentSelectionRange + +SWindowShowMessage :: SMethod WindowShowMessage +SWindowShowMessageRequest :: SMethod WindowShowMessageRequest +``` + +The type families `MessageParams` and `ResponseResult` map each `Method` to the +appropriate type to be used in a response: + +```haskell +ResponseResult TextDocumentRename = WorkspaceEdit +ResponseResult TextDocumentPrepareRename = Range |? RangeWithPlaceholder +``` + +Also new is the `|?` type which represents [union types in +TypeScript](https://www.typescriptlang.org/docs/handbook/unions-and-intersections.html#union-types), +and is used throughout the specification where a field can accept several +different types. + +As an example of this in action, the types of your handlers will now depend on +whether or not they are a request or a notification. They will pass along the +precise type for the parameters the method you are handling, and in the case of +a request handler, will expect that the response you give back is of the correct +type as well. + +```haskell +type family Handler (f :: Type -> Type) (m :: Method from t) = (result :: Type) | result -> f t m where + Handler f (m :: Method _from Request) = RequestMessage m -> (Either ResponseError (ResponseResult m) -> f ()) -> f () + Handler f (m :: Method _from Notification) = NotificationMessage m -> f () +``` + +### LspT +`LspFuncs` has been removed and instead functionality is exposed through +functions in the `MonadLsp` class. + +```haskell +getVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe VirtualFile) +sendRequest :: forall (m :: Method FromServer Request) f config. MonadLsp config f + => SServerMethod m + -> MessageParams m + -> (Either ResponseError (ResponseResult m) -> f ()) + -> f (LspId m) +``` + +It is parameterised over the server's LSP configuration type and the underlying +monad. +We recommend that you build your own monad for your server on top of the `LspT` +transformer, so it will automatically become an instance of `MonadLsp`. + +Inside the new `ServerDefinition` data type which gets passed to `runServer`, +you need to specify how to convert from IO to your monad and back in +`interpretHandler` so that `lsp` can execute your monad inside the handlers. You +can use the result returned from `doInitialize` to pass along the +`LanguageContextEnv` needed to run an `LspT`, as well as anything else your +monad needs. +```haskell +type +ServerDefinition { ... +, doInitialize = \env _req -> pure $ Right env +, interpretHandler = \env -> Iso + (runLspT env) -- how to convert from IO ~> m + liftIO -- how to convert from m ~> IO +} +``` + +### Steps to migrate + +1. In your `.cabal` file change any `haskell-lsp` dependencies to `lsp` +2. Replace your existing imports with `Haskell.LSP.Server` +3. If necessary define your own monad and fill in `interpretHandler` +4. Migrate your handlers to use `notificationHandler` and `requestHandler`, + passing along the corresponding `SMethod` (See `example/Simple.hs`) +5. Remove any storage/use of `LspFuncs` and instead call the corresponding + functions directly from your monad instead of `IO` + +## 0.23.0.0 + +* Add runWith for transporots other than stdio (@paulyoung) +* Fix race condition in event captures (@bgamari) +* Tweak the sectionSeparator (@alanz) +* Add hashWithSaltInstances (@ndmitchell) +* Fix CompletionItem.tags not being optional (@bubba) +* Avoid unnecessary normalisation in Binary instance for + NormalizedFilePath (@cocreature) +* Fix ordering of TH splices (@fendor) + +## 0.22.0.0 + +* ResponseMessage results are now an Either type (@greenhat) +* Support for GHC 8.10.1 + +## 0.21.0.0 + +* Stop getCompletionPrefix from crashing if beforePos is empty +* Add DidChangeWatchedFilesRegistrationOptions +* Add NormalizedFilePath from ghcide +* Add diagnostic and completion tags +* Fix language server example +* Correctly fix the problem with '$/' notifications +* Add azure ci + +## 0.20.0.1 + +* Fix Haddock generation syntax error + +## 0.20.0.0 + +* Force utf8 encoding when writing vfs temp files +* Don't log errors for '$/' notifications (@jinwoo) +* Force utf8 encoding when writing vfs temp files (@jneira) +* Store a hash in a NormalizedUri (@mpickering) +* Move "Semigroup WorkspaceEdit" instance (@sheaf) +* Fix vfs line endings (@jneira) + +## 0.19.0.0 -- 2019-12-14 + +* Fix vfs line endings (@jneira) +* Fix typo in .cabal (@turion) +* Normalize file paths before converting to Uri's (@jneira) +* Fixes to persistVirtualFile (@mpickering) + +## 0.18.0.0 -- 2019-11-17 + +* Explain the use of NonEmpty in + documentOnTypeFormattingTriggerCharacters (@bubba) +* Fix response type for CodeLensResolve, add the ContentModified error + code (@SquidDev) +* Virtual file fixes, removing race conditions and other cleanups (@mpickering) +* Add missing fmClientPrepareRenameRequest to MessageFuncs export (@alanz) +* Make explicit GHC 8.6.5 stack file (@alanz) +* Rework Core.Options and infer all server capabilities from handlers (@bubba) +* Generate lenses for WorkDoneProgress data types (@alanz) + +## 0.17.0.0 -- 2019-10-18 + +* Update progress reporting to match the LSP 3.15 specification (@cocreature) +* Fix progress cancellation action being retained (@mpickering) +* Respect both codeActionProvider and codeActionHandler in server + capabilities (@fendor) +* Ensure ResponseMessage has either a result or an error (@cocreature) + +## 0.16.0.0 -- 2019-09-07 + +* Add support for CodeActionOptions (@thomasjm) +* Add support for `textDocument/prepareRename` request (@thomasjm) +* Fix diagnostic code parsing (@thomasjm) +* Fix shutdown response type (@bubba) +* Relax base constraints for GHC 8.8 (@bubba) + +## 0.15.0.0 -- 2019-07-01 + +* Fix decoding of `ResponseMessage` to account for `null` messages (@cocreature) +* Normalize URIs to avoid issues with percent encoding (@cocreature) +* Changed the initial callbacks type to also capture initial config (@lorenzo) +* Improved documentation (@bubba) + +## 0.14.0.0 -- 2019-06-13 + +* Add support for custom request and notification methods + (@cocreature) +* Use attoparsec to parse message headers incrementally (@cocreature) +* Only build lsp-hello when -fdemo flag is set (@bubba) + +## 0.13.0.0 -- 2019-05-18 + +* Fix relative posix URIs (@DavidM-D) +* Make sure that markedUpContent always starts on a newline (@alanz) + +## 0.12.1.0 -- 2019-05-08 + +* Bring over functions from @mpickering's hie-bios. + So `LspFuncs` now includes + +```haskell + , persistVirtualFileFunc :: !(J.Uri -> IO FilePath) + , reverseFileMapFunc :: !(IO (FilePath -> FilePath)) +``` + +* Fix exception on empty filepaths + +* Migrate some utility functions from `haskell-ide-engine`, for the + benefit of other language servers. + - `rangeLinesFromVfs` + - `PosPrefixInfo(..)` + - `getCompletionPrefix` + +* Remove `HoverContentsEmpty`. It is unnecessary, and generated + illegal JSON on the wire. + +## 0.12.0.0 -- 2019-05-05 + +* Added A NFData instance for Diagnostics (@DavidM-D/@ndmitchell) +* Switch to using the rope-utf16-splay library for ropes (@ollef) + +## 0.11.0.0 -- 2019-04-28 + +* Add support for cancellable requests within `withProgress` and + `withIndefiniteProgress` +* Align `withProgress` and `withIndefiniteProgress` types to be in `IO` + like the rest of the library. (Look at using `monad-control` and + `unliftio` if you need to use them with a Monad transformer stack) + +## 0.10.0.0 -- 2019-04-22 + +* Add `withProgress` and `withIndefiniteProgress` functions for sending + `window/progress` notifications. + +## 0.9.0.0 + +* Add `MarkupContent` to `HoverResponse`, and (some) json roundtrip tests. + +## 0.8.2.0 -- 2019-04-11 + +* Add `applyTextEdit` and `editTextEdit` helpers +* Set the typedefinitionProvider capability if it has a handler +* Add stack files for GHC 8.4.4 and 8.6.4 + +## 0.8.1.0 -- 2019-02-28 + +* Update Handler to delegate to typeDefinitionHandler instead of + definitionHandler. by @fendor + +## 0.8.0.1 -- 2018-10-27 + +* Support GHC 8.6.1 by loosening constraints. Via @domenkozar + +## 0.8.0.0 -- 2018-09-08 + +* Update Hover to be a nullable according to spec +* Move Lenses into a separate module, `Language.Haskell.LSP.Types.Lens` + +## 0.7.0.0 -- 2018-08-14 + +* Update CompletionItem + * Add `commitCharacters` field + * Add `MarkupContent` option for `documentation` + * Add `preselect` field +* Add CompletionContext +* Add new server capabilities +* Add workspace folder support +* Add document color and color presentation +* Add folding range support +* Add goto type support +* s/TH/Types/g + * Move all types into haskell-lsp-types + * Hide Language.Haskell.LSP.TH.DataTypesJSON - Use Language.Haskell.LSP.Types instead +* Add lenses for Language.Haskell.LSP.Types.Capabilities + + +## 0.6.0.0 -- 2018-08-06 + +* Add new DocumentSymbol type and heirarchal support +* Rename CommandOrCodeAction to CAResult +* Add handler for 'textDocument/implementation' request from client +* Bump stack resolvers for lts 11 and lts 12 + +## 0.5.0.0 -- 2018-08-03 + +* Update Command.arguments to match specification +* Update ClientCapabilities to v3.10 +* Add MarkupContent +* Add new CompletionKinds +* Add new SymbolKinds +* Add preset version capabilities + +## 0.4.0.0 -- 2018-07-10 + +* CodeAction support as per v3.8 of the specification, by @Bubba +* Update VersionedTextDocumentIdentifier to match specification, by @Bubba + +## 0.3.0.0 + +* Handle TextDocumentSync fallbacks with new TDS type. + +## 0.2.3.0 -- 2018-99-99 + +* GHC 8.4.3 support +* Apply changes to the VFS in the order received in a message. + This fixes vscode undo behaviour. By @Bubba +* Introduce additional error codes as per the LSP spec. By @Bubba +* Add preliminary support for recording LSP traffic for later playback + in test scenarios. By @Bubba + +## 0.2.2.0 -- 2018-05-04 + +* Make Diagnostic relatedInformation optional, as per the LSP Spec. By @Bubba. + +## 0.2.1.0 -- 2018-05-02 + +* Support GHC 8.4.2 +* Split into two packages +* Language.Haskell.LSP.TH.DataTypesJSON becomes Language.Haskell.LSP.Types +* Diagnostic now has _relatedInformation. Can default it to mempty. via @AlexeyRaga +* Correct the name of the DidChangeWatchedFilesParams field, by @robrix +* Make sure to escape URIs properly for Windows file paths + Fixes #75. Also added a couple of pretty dumb tests!, by @johnsonw + + +## 0.2.0.1 -- 2017-12-27 + +* Built with LTS 10.1 (stack) +* Don't escape semicolons after drive letters by @nponeccop +* Add Foldable and Traversable instance to List by @noughtmare + +## 0.2.0.0 -- 2017-11-23 + +* Major changes as implementation continued. Now seems stable, used in haskell-ide-engine + +## 0.1.0.0 -- 2017-07-19 + +* First version. Implements version 3 of the Microsoft Language + Server Protocol diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Alan Zimmerman + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,90 @@ +[![CircleCI](https://circleci.com/gh/alanz/lsp/tree/master.svg?style=svg)](https://circleci.com/gh/alanz/lsp/tree/master) +[![Hackage](https://img.shields.io/hackage/v/lsp.svg)](https://hackage.haskell.org/package/lsp) + +# lsp +Haskell library for the Microsoft Language Server Protocol. +It currently implements all of the [3.15 specification](https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/). + +It is split into two separate packages, `lsp` and `lsp-types` +- `lsp-types` provides *type-safe* definitions that match up with the +typescript definitions laid out in the specification +- `lsp` is a library for building language servers, handling: + - JSON-RPC transport + - Keeping track of the document state in memory with the Virtual File System (VFS) + - Responding to notifications and requests via handlers + - Setting the server capabilities in the initialize request based on registered handlers + - Dynamic registration of capabilities + - Cancellable requests and progress notifications + - Publishing and flushing of diagnostics + +## Language servers built on lsp +- [ghcide](https://github.com/haskell/ghcide) +- [haskell-language-server](https://github.com/haskell/haskell-language-server) +- [dhall-lsp-server](https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-lsp-server#readme) + +## Example language servers +There are two example language servers in the `example/` folder. `Simple.hs` provides a minimal example: + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import Language.LSP.Server +import Language.LSP.Types +import Control.Monad.IO.Class +import qualified Data.Text as T + +handlers :: Handlers (LspM ()) +handlers = mconcat + [ notificationHandler SInitialized $ \_not -> do + let params = ShowMessageRequestParams MtInfo "Turn on code lenses?" + (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) + _ <- sendRequest SWindowShowMessageRequest params $ \res -> + case res of + Right (Just (MessageActionItem "Turn on")) -> do + let regOpts = CodeLensRegistrationOptions Nothing Nothing (Just False) + + _ <- registerCapability STextDocumentCodeLens regOpts $ \_req responder -> do + let cmd = Command "Say hello" "lsp-hello-command" Nothing + rsp = List [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] + responder (Right rsp) + pure () + Right _ -> + sendNotification SWindowShowMessage (ShowMessageParams MtInfo "Not turning on code lenses") + Left err -> + sendNotification SWindowShowMessage (ShowMessageParams MtError $ "Something went wrong!\n" <> T.pack (show err)) + pure () + , requestHandler STextDocumentHover $ \req responder -> do + let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req + Position _l _c' = pos + rsp = Hover ms (Just range) + ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world" + range = Range pos pos + responder (Right $ Just rsp) + ] + +main :: IO Int +main = runServer $ ServerDefinition + { onConfigurationChange = const $ pure $ Right () + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } +``` + +Whilst `Reactor.hs` shows how a reactor design can be used to handle all +requests on a separate thread, such in a way that we could then execute them on +multiple threads without blocking server communication. They can be installed +from source with + + cabal install lsp-demo-simple-server lsp-demo-reactor-server + stack install :lsp-demo-simple-server :lsp-demo-reactor-server --flag haskell-lsp:demo + +## Useful links + +- https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md + +## Other resources + +See #haskell-ide-engine on IRC freenode + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Reactor.hs b/example/Reactor.hs new file mode 100644 --- /dev/null +++ b/example/Reactor.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE DuplicateRecordFields #-} + +{- | +This is an example language server built with haskell-lsp using a 'Reactor' +design. With a 'Reactor' all requests are handled on a /single thread/. +A thread is spun up for it, which repeatedly reads from a 'TChan' of +'ReactorInput's. +The `lsp` handlers then simply pass on all the requests and +notifications onto the channel via 'ReactorInput's. +This way there is the option of executing requests on multiple threads, without +blocking server communication. + +To try out this server, install it with +> cabal install lsp-demo-reactor-server -fdemo +and plug it into your client of choice. +-} +module Main (main) where +import Control.Concurrent.STM.TChan +import qualified Control.Exception as E +import Control.Lens hiding (Iso) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.STM +import qualified Data.Aeson as J +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import GHC.Generics (Generic) +import Language.LSP.Server +import Language.LSP.Diagnostics +import qualified Language.LSP.Types as J +import qualified Language.LSP.Types.Lens as J +import Language.LSP.VFS +import System.Exit +import System.Log.Logger +import Control.Concurrent + + +-- --------------------------------------------------------------------- +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +-- --------------------------------------------------------------------- +-- + +main :: IO () +main = do + run >>= \case + 0 -> exitSuccess + c -> exitWith . ExitFailure $ c + +-- --------------------------------------------------------------------- + +data Config = Config { fooTheBar :: Bool, wibbleFactor :: Int } + deriving (Generic, J.ToJSON, J.FromJSON) + +run :: IO Int +run = flip E.catches handlers $ do + + rin <- atomically newTChan :: IO (TChan ReactorInput) + + let + serverDefinition = ServerDefinition + { onConfigurationChange = \v -> case J.fromJSON v of + J.Error e -> pure $ Left (T.pack e) + J.Success cfg -> do + sendNotification J.SWindowShowMessage $ + J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) + pure $ Right cfg + , doInitialize = \env _ -> forkIO (reactor rin) >> pure (Right env) + , staticHandlers = lspHandlers rin + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = lspOptions + } + + flip E.finally finalProc $ do + setupLogger Nothing ["reactor"] DEBUG + runServer serverDefinition + + where + handlers = [ E.Handler ioExcept + , E.Handler someExcept + ] + finalProc = removeAllHandlers + ioExcept (e :: E.IOException) = print e >> return 1 + someExcept (e :: E.SomeException) = print e >> return 1 + +-- --------------------------------------------------------------------- + +syncOptions :: J.TextDocumentSyncOptions +syncOptions = J.TextDocumentSyncOptions + { J._openClose = Just True + , J._change = Just J.TdSyncIncremental + , J._willSave = Just False + , J._willSaveWaitUntil = Just False + , J._save = Just $ J.InR $ J.SaveOptions $ Just False + } + +lspOptions :: Options +lspOptions = defaultOptions + { textDocumentSync = Just syncOptions + , executeCommandCommands = Just ["lsp-hello-command"] + } + +-- --------------------------------------------------------------------- + +-- The reactor is a process that serialises and buffers all requests from the +-- LSP client, so they can be sent to the backend compiler one at a time, and a +-- reply sent. + +newtype ReactorInput + = ReactorAction (IO ()) + +-- | Analyze the file and send any diagnostics to the client in a +-- "textDocument/publishDiagnostics" notification +sendDiagnostics :: J.NormalizedUri -> Maybe Int -> LspM Config () +sendDiagnostics fileUri version = do + let + diags = [J.Diagnostic + (J.Range (J.Position 0 1) (J.Position 0 5)) + (Just J.DsWarning) -- severity + Nothing -- code + (Just "lsp-hello") -- source + "Example diagnostic message" + Nothing -- tags + (Just (J.List [])) + ] + publishDiagnostics 100 fileUri version (partitionBySource diags) + +-- --------------------------------------------------------------------- + +-- | The single point that all events flow through, allowing management of state +-- to stitch replies and requests together from the two asynchronous sides: lsp +-- server and backend compiler +reactor :: TChan ReactorInput -> IO () +reactor inp = do + debugM "reactor" "Started the reactor" + forever $ do + ReactorAction act <- atomically $ readTChan inp + act + +-- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as +-- input into the reactor +lspHandlers :: TChan ReactorInput -> Handlers (LspM Config) +lspHandlers rin = mapHandlers goReq goNot handle + where + goReq :: forall (a :: J.Method J.FromClient J.Request). Handler (LspM Config) a -> Handler (LspM Config) a + goReq f = \msg k -> do + env <- getLspEnv + liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg k) + + goNot :: forall (a :: J.Method J.FromClient J.Notification). Handler (LspM Config) a -> Handler (LspM Config) a + goNot f = \msg -> do + env <- getLspEnv + liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg) + +-- | Where the actual logic resides for handling requests and notifications. +handle :: Handlers (LspM Config) +handle = mconcat + [ notificationHandler J.SInitialized $ \_msg -> do + liftIO $ debugM "reactor.handle" "Processing the Initialized notification" + + -- We're initialized! Lets send a showMessageRequest now + let params = J.ShowMessageRequestParams + J.MtWarning + "What's your favourite language extension?" + (Just [J.MessageActionItem "Rank2Types", J.MessageActionItem "NPlusKPatterns"]) + + void $ sendRequest J.SWindowShowMessageRequest params $ \res -> + case res of + Left e -> liftIO $ errorM "reactor.handle" $ "Got an error: " ++ show e + Right _ -> do + sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Excellent choice") + + -- We can dynamically register a capability once the user accepts it + sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Turning on code lenses dynamically") + + let regOpts = J.CodeLensRegistrationOptions Nothing Nothing (Just False) + + void $ registerCapability J.STextDocumentCodeLens regOpts $ \_req responder -> do + liftIO $ debugM "reactor.handle" "Processing a textDocument/codeLens request" + let cmd = J.Command "Say hello" "lsp-hello-command" Nothing + rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] + responder (Right rsp) + + , notificationHandler J.STextDocumentDidOpen $ \msg -> do + let doc = msg ^. J.params . J.textDocument . J.uri + fileName = J.uriToFilePath doc + liftIO $ debugM "reactor.handle" $ "Processing DidOpenTextDocument for: " ++ show fileName + sendDiagnostics (J.toNormalizedUri doc) (Just 0) + + , notificationHandler J.STextDocumentDidChange $ \msg -> do + let doc = msg ^. J.params + . J.textDocument + . J.uri + . to J.toNormalizedUri + liftIO $ debugM "reactor.handle" $ "Processing DidChangeTextDocument for: " ++ show doc + mdoc <- getVirtualFile doc + case mdoc of + Just (VirtualFile _version str _) -> do + liftIO $ debugM "reactor.handle" $ "Found the virtual file: " ++ show str + Nothing -> do + liftIO $ debugM "reactor.handle" $ "Didn't find anything in the VFS for: " ++ show doc + + , notificationHandler J.STextDocumentDidSave $ \msg -> do + let doc = msg ^. J.params . J.textDocument . J.uri + fileName = J.uriToFilePath doc + liftIO $ debugM "reactor.handle" $ "Processing DidSaveTextDocument for: " ++ show fileName + sendDiagnostics (J.toNormalizedUri doc) Nothing + + , requestHandler J.STextDocumentRename $ \req responder -> do + liftIO $ debugM "reactor.handle" "Processing a textDocument/rename request" + let params = req ^. J.params + J.Position l c = params ^. J.position + newName = params ^. J.newName + vdoc <- getVersionedTextDoc (params ^. J.textDocument) + -- Replace some text at the position with what the user entered + let edit = J.TextEdit (J.mkRange l c l (c + T.length newName)) newName + tde = J.TextDocumentEdit vdoc (J.List [edit]) + -- "documentChanges" field is preferred over "changes" + rsp = J.WorkspaceEdit Nothing (Just (J.List [tde])) + responder (Right rsp) + + , requestHandler J.STextDocumentHover $ \req responder -> do + liftIO $ debugM "reactor.handle" "Processing a textDocument/hover request" + let J.HoverParams _doc pos _workDone = req ^. J.params + J.Position _l _c' = pos + rsp = J.Hover ms (Just range) + ms = J.HoverContents $ J.markedUpContent "lsp-hello" "Your type info here!" + range = J.Range pos pos + responder (Right $ Just rsp) + + , requestHandler J.STextDocumentCodeAction $ \req responder -> do + liftIO $ debugM "reactor.handle" $ "Processing a textDocument/codeAction request" + let params = req ^. J.params + doc = params ^. J.textDocument + (J.List diags) = params ^. J.context . J.diagnostics + -- makeCommand only generates commands for diagnostics whose source is us + makeCommand (J.Diagnostic (J.Range start _) _s _c (Just "lsp-hello") _m _t _l) = [J.Command title cmd cmdparams] + where + title = "Apply LSP hello command:" <> head (T.lines _m) + -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above + cmd = "lsp-hello-command" + -- need 'file' and 'start_pos' + args = J.List + [ J.Object $ H.fromList [("file", J.Object $ H.fromList [("textDocument",J.toJSON doc)])] + , J.Object $ H.fromList [("start_pos",J.Object $ H.fromList [("position", J.toJSON start)])] + ] + cmdparams = Just args + makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = [] + rsp = J.List $ map J.InL $ concatMap makeCommand diags + responder (Right rsp) + + , requestHandler J.SWorkspaceExecuteCommand $ \req responder -> do + liftIO $ debugM "reactor.handle" "Processing a workspace/executeCommand request" + let params = req ^. J.params + margs = params ^. J.arguments + + liftIO $ debugM "reactor.handle" $ "The arguments are: " ++ show margs + responder (Right (J.Object mempty)) -- respond to the request + + void $ withProgress "Executing some long running command" Cancellable $ \update -> + forM [(0 :: Double)..10] $ \i -> do + update (ProgressAmount (Just (i * 10)) (Just "Doing stuff")) + liftIO $ threadDelay (1 * 1000000) + ] + +-- --------------------------------------------------------------------- diff --git a/example/Simple.hs b/example/Simple.hs new file mode 100644 --- /dev/null +++ b/example/Simple.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Language.LSP.Server +import Language.LSP.Types +import Control.Monad.IO.Class +import qualified Data.Text as T + +handlers :: Handlers (LspM ()) +handlers = mconcat + [ notificationHandler SInitialized $ \_not -> do + let params = ShowMessageRequestParams MtInfo "Turn on code lenses?" + (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) + _ <- sendRequest SWindowShowMessageRequest params $ \res -> + case res of + Right (Just (MessageActionItem "Turn on")) -> do + let regOpts = CodeLensRegistrationOptions Nothing Nothing (Just False) + + _ <- registerCapability STextDocumentCodeLens regOpts $ \_req responder -> do + let cmd = Command "Say hello" "lsp-hello-command" Nothing + rsp = List [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] + responder (Right rsp) + pure () + Right _ -> + sendNotification SWindowShowMessage (ShowMessageParams MtInfo "Not turning on code lenses") + Left err -> + sendNotification SWindowShowMessage (ShowMessageParams MtError $ "Something went wrong!\n" <> T.pack (show err)) + pure () + , requestHandler STextDocumentHover $ \req responder -> do + let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req + Position _l _c' = pos + rsp = Hover ms (Just range) + ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world" + range = Range pos pos + responder (Right $ Just rsp) + ] + +main :: IO Int +main = runServer $ ServerDefinition + { onConfigurationChange = const $ pure $ Right () + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } diff --git a/lsp.cabal b/lsp.cabal new file mode 100644 --- /dev/null +++ b/lsp.cabal @@ -0,0 +1,155 @@ +cabal-version: 2.4 +name: lsp +version: 1.0.0.0 +synopsis: Haskell library for the Microsoft Language Server Protocol + +description: An implementation of the types, and basic message server to + allow language implementors to support the Language Server + Protocol for their specific language. + . + An example of this is for Haskell via the Haskell IDE + Engine, at https://github.com/haskell/haskell-ide-engine + +homepage: https://github.com/alanz/lsp +license: MIT +license-file: LICENSE +author: Alan Zimmerman +maintainer: alan.zimm@gmail.com +copyright: Alan Zimmerman, 2016-2020 +category: Development +build-type: Simple +extra-source-files: ChangeLog.md, README.md + +library + reexported-modules: Language.LSP.Types + , Language.LSP.Types.Capabilities + , Language.LSP.Types.Lens + , Language.LSP.VFS + exposed-modules: Language.LSP.Server + , Language.LSP.Diagnostics + other-modules: Language.LSP.Server.Core + , Language.LSP.Server.Control + , Language.LSP.Server.Processing + ghc-options: -Wall + build-depends: base >= 4.9 && < 4.15 + , async + , aeson >=1.0.0.0 + , attoparsec + , bytestring + , containers + , directory + , data-default + , filepath + , hslogger + , hashable + , lsp-types == 1.0.* + , dependent-map + , lens >= 4.15.2 + , mtl + , network-uri + , sorted-list == 0.2.1.* + , stm == 2.5.* + , scientific + , text + , transformers >= 0.5.6 && < 0.6 + , time + , unordered-containers + , unliftio-core + -- used for generating random uuids for dynamic registration + , random + , uuid >= 1.3 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-explicit-kinds + +executable lsp-demo-reactor-server + main-is: Reactor.hs + hs-source-dirs: example + default-language: Haskell2010 + ghc-options: -Wall -Wno-unticked-promoted-constructors + + build-depends: base >= 4.9 && < 4.15 + , aeson + , bytestring + , containers + , directory + , filepath + , hslogger + , lens >= 4.15.2 + , mtl + , stm + , text + , transformers + , unordered-containers + , unliftio + -- the package library. Comment this out if you want repl changes to propagate + , lsp + if !flag(demo) + buildable: False + +executable lsp-demo-simple-server + main-is: Simple.hs + hs-source-dirs: example + default-language: Haskell2010 + ghc-options: -Wall -Wno-unticked-promoted-constructors + build-depends: base >= 4.9 && < 5 + -- the package library. Comment this out if you want repl changes to propagate + , lsp + , text + if !flag(demo) + buildable: False + +flag demo + description: Build the demo executables + default: False + + +test-suite unit-test + type: exitcode-stdio-1.0 + -- hs-source-dirs: test src + hs-source-dirs: test + main-is: Main.hs + other-modules: Spec + CapabilitiesSpec + JsonSpec + DiagnosticsSpec + MethodSpec + ServerCapabilitiesSpec + TypesSpec + URIFilePathSpec + VspSpec + WorkspaceEditSpec + build-depends: base + , QuickCheck + , aeson + , bytestring + , containers + , data-default + , directory + , filepath + , hashable + , lsp + , hspec + -- , hspec-jenkins + , lens >= 4.15.2 + , network-uri + , quickcheck-instances + , rope-utf16-splay >= 0.2 + , sorted-list == 0.2.1.* + , stm + , text + , unordered-containers + -- For GHCI tests + -- , async + -- , haskell-lsp-types + -- , hslogger + -- , temporary + -- , time + -- , unordered-containers + build-tool-depends: hspec-discover:hspec-discover + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/alanz/lsp diff --git a/src/Language/LSP/Diagnostics.hs b/src/Language/LSP/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Diagnostics.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- + +Manage the "textDocument/publishDiagnostics" notifications to keep a local copy of the +diagnostics for a particular file and version, partitioned by source. +-} +module Language.LSP.Diagnostics + ( + DiagnosticStore + , DiagnosticsBySource + , StoreItem(..) + , partitionBySource + , flushBySource + , updateDiagnostics + , getDiagnosticParamsFor + + -- * for tests + ) where + +import qualified Data.SortedList as SL +import qualified Data.Map as Map +import qualified Data.HashMap.Strict as HM +import qualified Language.LSP.Types as J + +-- --------------------------------------------------------------------- +{-# ANN module ("hlint: ignore Eta reduce" :: String) #-} +{-# ANN module ("hlint: ignore Redundant do" :: String) #-} +-- --------------------------------------------------------------------- + +{- +We need a three level store + + Uri : Maybe TextDocumentVersion : Maybe DiagnosticSource : [Diagnostics] + +For a given Uri, as soon as we see a new (Maybe TextDocumentVersion) we flush +all prior entries for the Uri. + +-} + +type DiagnosticStore = HM.HashMap J.NormalizedUri StoreItem + +data StoreItem + = StoreItem J.TextDocumentVersion DiagnosticsBySource + deriving (Show,Eq) + +type DiagnosticsBySource = Map.Map (Maybe J.DiagnosticSource) (SL.SortedList J.Diagnostic) + +-- --------------------------------------------------------------------- + +partitionBySource :: [J.Diagnostic] -> DiagnosticsBySource +partitionBySource diags = Map.fromListWith mappend $ map (\d -> (J._source d, (SL.singleton d))) diags + +-- --------------------------------------------------------------------- + +flushBySource :: DiagnosticStore -> Maybe J.DiagnosticSource -> DiagnosticStore +flushBySource store Nothing = store +flushBySource store (Just source) = HM.map remove store + where + remove (StoreItem mv diags) = StoreItem mv (Map.delete (Just source) diags) + +-- --------------------------------------------------------------------- + +updateDiagnostics :: DiagnosticStore + -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource + -> DiagnosticStore +updateDiagnostics store uri mv newDiagsBySource = r + where + newStore :: DiagnosticStore + newStore = HM.insert uri (StoreItem mv newDiagsBySource) store + + updateDbs dbs = HM.insert uri new store + where + new = StoreItem mv newDbs + -- note: Map.union is left-biased, so for identical keys the first + -- argument is used + newDbs = Map.union newDiagsBySource dbs + + r = case HM.lookup uri store of + Nothing -> newStore + Just (StoreItem mvs dbs) -> + if mvs /= mv + then newStore + else updateDbs dbs + +-- --------------------------------------------------------------------- + +getDiagnosticParamsFor :: Int -> DiagnosticStore -> J.NormalizedUri -> Maybe J.PublishDiagnosticsParams +getDiagnosticParamsFor maxDiagnostics ds uri = + case HM.lookup uri ds of + Nothing -> Nothing + Just (StoreItem mv diags) -> + Just $ J.PublishDiagnosticsParams (J.fromNormalizedUri uri) mv (J.List (take maxDiagnostics $ SL.fromSortedList $ mconcat $ Map.elems diags)) + +-- --------------------------------------------------------------------- diff --git a/src/Language/LSP/Server.hs b/src/Language/LSP/Server.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Server.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeOperators #-} +module Language.LSP.Server + ( module Language.LSP.Server.Control + , VFSData(..) + , ServerDefinition(..) + + -- * Handlers + , Handlers(..) + , Handler + , transmuteHandlers + , mapHandlers + , notificationHandler + , requestHandler + , ClientMessageHandler(..) + + , Options(..) + , defaultOptions + + -- * LspT and LspM + , LspT(..) + , LspM + , MonadLsp(..) + , runLspT + , LanguageContextEnv(..) + , type (<~>)(..) + + , getClientCapabilities + , getConfig + , getRootPath + , getWorkspaceFolders + + , sendRequest + , sendNotification + + -- * VFS + , getVirtualFile + , getVirtualFiles + , persistVirtualFile + , getVersionedTextDoc + , reverseFileMap + + -- * Diagnostics + , publishDiagnostics + , flushDiagnosticsBySource + + -- * Progress + , withProgress + , withIndefiniteProgress + , ProgressAmount(..) + , ProgressCancellable(..) + , ProgressCancelledException + + -- * Dynamic registration + , registerCapability + , unregisterCapability + , RegistrationToken + + , setupLogger + , reverseSortEdit + ) where + +import Language.LSP.Server.Control +import Language.LSP.Server.Core diff --git a/src/Language/LSP/Server/Control.hs b/src/Language/LSP/Server/Control.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Server/Control.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +module Language.LSP.Server.Control + ( + -- * Running + runServer + , runServerWith + , runServerWithHandles + ) where + +import Control.Concurrent +import Control.Concurrent.STM.TChan +import Control.Monad +import Control.Monad.STM +import qualified Data.Aeson as J +import qualified Data.Attoparsec.ByteString as Attoparsec +import Data.Attoparsec.ByteString.Char8 +import qualified Data.ByteString as BS +import Data.ByteString.Builder.Extra (defaultChunkSize) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.List +import Language.LSP.Server.Core +import Language.LSP.Server.Processing +import Language.LSP.Types +import Language.LSP.VFS +import System.IO +import System.Log.Logger + + +-- --------------------------------------------------------------------- + +-- | Convenience function for 'runServerWithHandles stdin stdout'. +runServer :: ServerDefinition config + -- ^ function to be called once initialize has + -- been received from the client. Further message + -- processing will start only after this returns. + -> IO Int +runServer = runServerWithHandles stdin stdout + +-- | Starts a language server over the specified handles. +-- This function will return once the @exit@ notification is received. +runServerWithHandles :: + Handle + -- ^ Handle to read client input from. + -> Handle + -- ^ Handle to write output to. + -> ServerDefinition config + -> IO Int -- exit code +runServerWithHandles hin hout serverDefinition = do + + hSetBuffering hin NoBuffering + hSetEncoding hin utf8 + + hSetBuffering hout NoBuffering + hSetEncoding hout utf8 + + let + clientIn = BS.hGetSome hin defaultChunkSize + + clientOut out = do + BSL.hPut hout out + hFlush hout + + runServerWith clientIn clientOut serverDefinition + +-- | Starts listening and sending requests and responses +-- using the specified I/O. +runServerWith :: + IO BS.ByteString + -- ^ Client input. + -> (BSL.ByteString -> IO ()) + -- ^ Function to provide output to. + -> ServerDefinition config + -> IO Int -- exit code +runServerWith clientIn clientOut serverDefinition = do + + infoM "haskell-lsp.runWith" "\n\n\n\n\nhaskell-lsp:Starting up server ..." + + cout <- atomically newTChan :: IO (TChan J.Value) + _rhpid <- forkIO $ sendServer cout clientOut + + let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg + + initVFS $ \vfs -> do + ioLoop clientIn serverDefinition vfs sendMsg + + return 1 + +-- --------------------------------------------------------------------- + +ioLoop :: + IO BS.ByteString + -> ServerDefinition config + -> VFS + -> (FromServerMessage -> IO ()) + -> IO () +ioLoop clientIn serverDefinition vfs sendMsg = do + minitialize <- parseOne (parse parser "") + case minitialize of + Nothing -> pure () + Just (msg,remainder) -> do + case J.eitherDecode $ BSL.fromStrict msg of + Left err -> + errorM "haskell-lsp.ioLoop" $ + "Got error while decoding initialize:\n" <> err <> "\n exiting 1 ...\n" + Right initialize -> do + mInitResp <- initializeRequestHandler serverDefinition vfs sendMsg initialize + case mInitResp of + Nothing -> pure () + Just env -> loop env (parse parser remainder) + where + + parseOne :: Result BS.ByteString -> IO (Maybe (BS.ByteString,BS.ByteString)) + parseOne (Fail _ ctxs err) = do + errorM "haskell-lsp.parseOne" $ + "Failed to parse message header:\n" <> intercalate " > " ctxs <> ": " <> + err <> "\n exiting 1 ...\n" + pure Nothing + parseOne (Partial c) = do + bs <- clientIn + if BS.null bs + then do + errorM "haskell-lsp.parseON" "haskell-lsp:Got EOF, exiting 1 ...\n" + pure Nothing + else parseOne (c bs) + parseOne (Done remainder msg) = do + debugM "haskell-lsp.parseOne" $ "---> " <> T.unpack (T.decodeUtf8 msg) + pure $ Just (msg,remainder) + + loop env = go + where + go r = do + res <- parseOne r + case res of + Nothing -> pure () + Just (msg,remainder) -> do + runLspT env $ processMessage $ BSL.fromStrict msg + go (parse parser remainder) + + parser = do + _ <- string "Content-Length: " + len <- decimal + _ <- string _TWO_CRLF + Attoparsec.take len + +-- --------------------------------------------------------------------- + +-- | Simple server to make sure all output is serialised +sendServer :: TChan J.Value -> (BSL.ByteString -> IO ()) -> IO () +sendServer msgChan clientOut = do + forever $ do + msg <- atomically $ readTChan msgChan + + -- We need to make sure we only send over the content of the message, + -- and no other tags/wrapper stuff + let str = J.encode msg + + let out = BSL.concat + [ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str) + , BSL.fromStrict _TWO_CRLF + , str ] + + clientOut out + debugM "haskell-lsp.sendServer" $ "<--2--" <> TL.unpack (TL.decodeUtf8 str) + +-- | +-- +-- +_TWO_CRLF :: BS.ByteString +_TWO_CRLF = "\r\n\r\n" + + diff --git a/src/Language/LSP/Server/Core.hs b/src/Language/LSP/Server/Core.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Server/Core.hs @@ -0,0 +1,754 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecursiveDo #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -fprint-explicit-kinds #-} + + +module Language.LSP.Server.Core where + +import Control.Concurrent.Async +import Control.Concurrent.STM +import qualified Control.Exception as E +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class +import Control.Monad.IO.Unlift +import Control.Lens ( (^.), (^?), _Just ) +import qualified Data.Aeson as J +import Data.Default +import Data.Functor.Product +import Data.IxMap +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Map (DMap) +import qualified Data.HashMap.Strict as HM +import Data.Kind +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as T +import Data.Text ( Text ) +import qualified Data.UUID as UUID +import qualified Language.LSP.Types.Capabilities as J +import Language.LSP.Types as J +import qualified Language.LSP.Types.Lens as J +import Language.LSP.VFS +import Language.LSP.Diagnostics +import System.IO +import qualified System.Log.Formatter as L +import qualified System.Log.Handler as LH +import qualified System.Log.Handler.Simple as LHS +import System.Log.Logger +import qualified System.Log.Logger as L +import System.Random +import Control.Monad.Trans.Identity + +-- --------------------------------------------------------------------- +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +-- --------------------------------------------------------------------- + +newtype LspT config m a = LspT { unLspT :: ReaderT (LanguageContextEnv config) m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadUnliftIO, MonadFix) + +runLspT :: LanguageContextEnv config -> LspT config m a -> m a +runLspT env = flip runReaderT env . unLspT + +type LspM config = LspT config IO + +class MonadUnliftIO m => MonadLsp config m | m -> config where + getLspEnv :: m (LanguageContextEnv config) + +instance MonadUnliftIO m => MonadLsp config (LspT config m) where + getLspEnv = LspT ask + +instance MonadLsp c m => MonadLsp c (ReaderT r m) where + getLspEnv = lift getLspEnv +instance MonadLsp c m => MonadLsp c (IdentityT m) where + getLspEnv = lift getLspEnv + +data LanguageContextEnv config = + LanguageContextEnv + { resHandlers :: !(Handlers IO) + , resParseConfig :: !(J.Value -> IO (Either T.Text config)) + , resSendMessage :: !(FromServerMessage -> IO ()) + -- We keep the state in a TVar to be thread safe + , resState :: !(TVar (LanguageContextState config)) + , resClientCapabilities :: !J.ClientCapabilities + , resRootPath :: !(Maybe FilePath) + } + +-- --------------------------------------------------------------------- +-- Handlers +-- --------------------------------------------------------------------- + +-- | A mapping from methods to the static 'Handler's that should be used to +-- handle responses when they come in from the client. To build up a 'Handlers', +-- you should 'mconcat' a list of 'notificationHandler' and 'requestHandler's: +-- +-- @ +-- mconcat [ +-- notificationHandler SInitialized $ \notif -> pure () +-- , requestHandler STextDocumentHover $ \req responder -> pure () +-- ] +-- @ +data Handlers m + = Handlers + { reqHandlers :: DMap SMethod (ClientMessageHandler m Request) + , notHandlers :: DMap SMethod (ClientMessageHandler m Notification) + } +instance Semigroup (Handlers config) where + Handlers r1 n1 <> Handlers r2 n2 = Handlers (r1 <> r2) (n1 <> n2) +instance Monoid (Handlers config) where + mempty = Handlers mempty mempty + +notificationHandler :: forall (m :: Method FromClient Notification) f. SMethod m -> Handler f m -> Handlers f +notificationHandler m h = Handlers mempty (DMap.singleton m (ClientMessageHandler h)) + +requestHandler :: forall (m :: Method FromClient Request) f. SMethod m -> Handler f m -> Handlers f +requestHandler m h = Handlers (DMap.singleton m (ClientMessageHandler h)) mempty + +-- | Wrapper to restrict 'Handler's to 'FromClient' 'Method's +newtype ClientMessageHandler f (t :: MethodType) (m :: Method FromClient t) = ClientMessageHandler (Handler f m) + +-- | The type of a handler that handles requests and notifications coming in +-- from the server or client +type family Handler (f :: Type -> Type) (m :: Method from t) = (result :: Type) | result -> f t m where + Handler f (m :: Method _from Request) = RequestMessage m -> (Either ResponseError (ResponseResult m) -> f ()) -> f () + Handler f (m :: Method _from Notification) = NotificationMessage m -> f () + +-- | How to convert two isomorphic data structures between each other. +data m <~> n + = Iso + { forward :: forall a. m a -> n a + , backward :: forall a. n a -> m a + } + +transmuteHandlers :: (m <~> n) -> Handlers m -> Handlers n +transmuteHandlers nat = mapHandlers (\i m k -> forward nat (i m (backward nat . k))) (\i m -> forward nat (i m)) + +mapHandlers + :: (forall (a :: Method FromClient Request). Handler m a -> Handler n a) + -> (forall (a :: Method FromClient Notification). Handler m a -> Handler n a) + -> Handlers m -> Handlers n +mapHandlers mapReq mapNot (Handlers reqs nots) = Handlers reqs' nots' + where + reqs' = DMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapReq i) reqs + nots' = DMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapNot i) nots + +-- | state used by the LSP dispatcher to manage the message loop +data LanguageContextState config = + LanguageContextState + { resVFS :: !VFSData + , resDiagnostics :: !DiagnosticStore + , resConfig :: !(Maybe config) + , resWorkspaceFolders :: ![WorkspaceFolder] + , resProgressData :: !ProgressData + , resPendingResponses :: !ResponseMap + , resRegistrationsNot :: !(RegistrationMap Notification) + , resRegistrationsReq :: !(RegistrationMap Request) + , resLspId :: !Int + } + +type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback) + +type RegistrationMap (t :: MethodType) = DMap SMethod (Product RegistrationId (ClientMessageHandler IO t)) + +data RegistrationToken (m :: Method FromClient t) = RegistrationToken (SMethod m) (RegistrationId m) +newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text + deriving Eq + +data ProgressData = ProgressData { progressNextId :: !Int + , progressCancel :: !(Map.Map ProgressToken (IO ())) } + +data VFSData = + VFSData + { vfsData :: !VFS + , reverseMap :: !(Map.Map FilePath FilePath) + } + +modifyState :: MonadLsp config m => (LanguageContextState config -> LanguageContextState config) -> m () +modifyState f = do + tvarDat <- resState <$> getLspEnv + liftIO $ atomically $ modifyTVar' tvarDat f + +stateState :: MonadLsp config m => (LanguageContextState config -> (a,LanguageContextState config)) -> m a +stateState f = do + tvarDat <- resState <$> getLspEnv + liftIO $ atomically $ stateTVar tvarDat f + +getsState :: MonadLsp config m => (LanguageContextState config -> a) -> m a +getsState f = do + tvarDat <- resState <$> getLspEnv + liftIO $ f <$> readTVarIO tvarDat + +-- --------------------------------------------------------------------- + +-- | Language Server Protocol options that the server may configure. +-- If you set handlers for some requests, you may need to set some of these options. +data Options = + Options + { textDocumentSync :: Maybe J.TextDocumentSyncOptions + -- | The characters that trigger completion automatically. + , completionTriggerCharacters :: Maybe [Char] + -- | The list of all possible characters that commit a completion. This field can be used + -- if clients don't support individual commmit characters per completion item. See + -- `_commitCharactersSupport`. + , completionAllCommitCharacters :: Maybe [Char] + -- | The characters that trigger signature help automatically. + , signatureHelpTriggerCharacters :: Maybe [Char] + -- | List of characters that re-trigger signature help. + -- These trigger characters are only active when signature help is already showing. All trigger characters + -- are also counted as re-trigger characters. + , signatureHelpRetriggerCharacters :: Maybe [Char] + -- | CodeActionKinds that this server may return. + -- The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server + -- may list out every specific kind they provide. + , codeActionKinds :: Maybe [CodeActionKind] + -- | The list of characters that triggers on type formatting. + -- If you set `documentOnTypeFormattingHandler`, you **must** set this. + -- The first character is mandatory, so a 'NonEmpty' should be passed. + , documentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char) + -- | The commands to be executed on the server. + -- If you set `executeCommandHandler`, you **must** set this. + , executeCommandCommands :: Maybe [Text] + -- | Information about the server that can be advertised to the client. + , serverInfo :: Maybe J.ServerInfo + } + +instance Default Options where + def = Options Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing + +defaultOptions :: Options +defaultOptions = def + +-- | A package indicating the perecentage of progress complete and a +-- an optional message to go with it during a 'withProgress' +-- +-- @since 0.10.0.0 +data ProgressAmount = ProgressAmount (Maybe Double) (Maybe Text) + +-- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session +-- +-- @since 0.11.0.0 +data ProgressCancelledException = ProgressCancelledException + deriving Show +instance E.Exception ProgressCancelledException + +-- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress' +-- session +-- +-- @since 0.11.0.0 +data ProgressCancellable = Cancellable | NotCancellable + +-- | Contains all the callbacks to use for initialized the language server. +-- it is parameterized over a config type variable representing the type for the +-- specific configuration data the language server needs to use. +data ServerDefinition config = forall m a. + ServerDefinition + { onConfigurationChange :: J.Value -> m (Either T.Text config) + -- ^ @onConfigurationChange newConfig@ is called whenever the + -- clients sends a message with a changed client configuration. This + -- callback should return either the parsed configuration data or an error + -- indicating what went wrong. The parsed configuration object will be + -- stored internally and can be accessed via 'config'. + , doInitialize :: LanguageContextEnv config -> Message Initialize -> IO (Either ResponseError a) + -- ^ Called *after* receiving the @initialize@ request and *before* + -- returning the response. This callback will be invoked to offer the + -- language server implementation the chance to create any processes or + -- start new threads that may be necesary for the server lifecycle. It can + -- also return an error in the initialization if necessary. + , staticHandlers :: Handlers m + -- ^ Handlers for any methods you want to statically support. + -- The handlers here cannot be unregistered during the server's lifetime + -- and will be regsitered statically in the initialize request. + , interpretHandler :: a -> (m <~> IO) + -- ^ How to run the handlers in your own monad of choice, @m@. + -- It is passed the result of 'doInitialize', so typically you will want + -- to thread along the 'LanguageContextEnv' as well as any other state you + -- need to run your monad. @m@ should most likely be built on top of + -- 'LspT'. + -- + -- @ + -- ServerDefinition { ... + -- , doInitialize = \env _req -> pure $ Right env + -- , interpretHandler = \env -> Iso + -- (runLspT env) -- how to convert from IO ~> m + -- liftIO -- how to convert from m ~> IO + -- } + -- @ + , options :: Options + -- ^ Configurable options for the server's capabilities. + } + +-- | A function that a 'Handler' is passed that can be used to respond to a +-- request with either an error, or the response params. +newtype ServerResponseCallback (m :: Method FromServer Request) + = ServerResponseCallback (Either ResponseError (ResponseResult m) -> IO ()) + +-- | Return value signals if response handler was inserted succesfully +-- Might fail if the id was already in the map +addResponseHandler :: MonadLsp config f => LspId m -> (Product SMethod ServerResponseCallback) m -> f Bool +addResponseHandler lid h = do + stateState $ \ctx@LanguageContextState{resPendingResponses} -> + case insertIxMap lid h resPendingResponses of + Just m -> (True, ctx { resPendingResponses = m}) + Nothing -> (False, ctx) + +sendNotification + :: forall (m :: Method FromServer Notification) f config. MonadLsp config f + => SServerMethod m + -> MessageParams m + -> f () +sendNotification m params = + let msg = NotificationMessage "2.0" m params + in case splitServerMethod m of + IsServerNot -> sendToClient $ fromServerNot msg + IsServerEither -> sendToClient $ FromServerMess m $ NotMess msg + +sendRequest :: forall (m :: Method FromServer Request) f config. MonadLsp config f + => SServerMethod m + -> MessageParams m + -> (Either ResponseError (ResponseResult m) -> f ()) + -> f (LspId m) +sendRequest m params resHandler = do + reqId <- IdInt <$> freshLspId + rio <- askRunInIO + success <- addResponseHandler reqId (Pair m (ServerResponseCallback (rio . resHandler))) + unless success $ error "haskell-lsp: could not send FromServer request as id is reused" + + let msg = RequestMessage "2.0" reqId m params + ~() <- case splitServerMethod m of + IsServerReq -> sendToClient $ fromServerReq msg + IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg + return reqId + +-- --------------------------------------------------------------------- + +-- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one. +getVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe VirtualFile) +getVirtualFile uri = getsState $ Map.lookup uri . vfsMap . vfsData . resVFS + +getVirtualFiles :: MonadLsp config m => m VFS +getVirtualFiles = getsState $ vfsData . resVFS + +-- | Dump the current text for a given VFS file to a temporary file, +-- and return the path to the file. +persistVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe FilePath) +persistVirtualFile uri = do + join $ stateState $ \ctx@LanguageContextState{resVFS = vfs} -> + case persistFileVFS (vfsData vfs) uri of + Nothing -> (return Nothing, ctx) + Just (fn, write) -> + let revMap = case uriToFilePath (fromNormalizedUri uri) of + Just uri_fp -> Map.insert fn uri_fp $ reverseMap vfs + -- TODO: Does the VFS make sense for URIs which are not files? + -- The reverse map should perhaps be (FilePath -> URI) + Nothing -> reverseMap vfs + act = do + liftIO write + pure (Just fn) + in (act, ctx{resVFS = vfs {reverseMap = revMap} }) + +-- | Given a text document identifier, annotate it with the latest version. +getVersionedTextDoc :: MonadLsp config m => TextDocumentIdentifier -> m VersionedTextDocumentIdentifier +getVersionedTextDoc doc = do + let uri = doc ^. J.uri + mvf <- getVirtualFile (toNormalizedUri uri) + let ver = case mvf of + Just (VirtualFile lspver _ _) -> Just lspver + Nothing -> Nothing + return (VersionedTextDocumentIdentifier uri ver) + +-- TODO: should this function return a URI? +-- | If the contents of a VFS has been dumped to a temporary file, map +-- the temporary file name back to the original one. +reverseFileMap :: MonadLsp config m => m (FilePath -> FilePath) +reverseFileMap = do + vfs <- getsState resVFS + let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs + return f + +-- --------------------------------------------------------------------- + +defaultProgressData :: ProgressData +defaultProgressData = ProgressData 0 Map.empty + +-- --------------------------------------------------------------------- + +sendToClient :: MonadLsp config m => FromServerMessage -> m () +sendToClient msg = do + f <- resSendMessage <$> getLspEnv + liftIO $ f msg + +-- --------------------------------------------------------------------- + +sendErrorLog :: MonadLsp config m => Text -> m () +sendErrorLog msg = + sendToClient $ fromServerNot $ + NotificationMessage "2.0" SWindowLogMessage (LogMessageParams MtError msg) + +-- --------------------------------------------------------------------- + +freshLspId :: MonadLsp config m => m Int +freshLspId = do + stateState $ \c -> + (resLspId c, c{resLspId = resLspId c+1}) + +-- --------------------------------------------------------------------- + +-- | The current configuration from the client as set via the @initialize@ and +-- @workspace/didChangeConfiguration@ requests. +getConfig :: MonadLsp config m => m (Maybe config) +getConfig = getsState resConfig + +getClientCapabilities :: MonadLsp config m => m J.ClientCapabilities +getClientCapabilities = resClientCapabilities <$> getLspEnv + +getRootPath :: MonadLsp config m => m (Maybe FilePath) +getRootPath = resRootPath <$> getLspEnv + +-- | The current workspace folders, if the client supports workspace folders. +getWorkspaceFolders :: MonadLsp config m => m (Maybe [WorkspaceFolder]) +getWorkspaceFolders = do + clientCaps <- getClientCapabilities + let clientSupportsWfs = fromMaybe False $ do + let (J.ClientCapabilities mw _ _ _) = clientCaps + (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw + mwf + if clientSupportsWfs + then Just <$> getsState resWorkspaceFolders + else pure Nothing + +-- | Sends a @client/registerCapability@ request and dynamically registers +-- a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not +-- support dynamic registration for the specified method, otherwise a +-- 'RegistrationToken' which can be used to unregister it later. +registerCapability :: forall f t (m :: Method FromClient t) config. + MonadLsp config f + => SClientMethod m + -> RegistrationOptions m + -> Handler f m + -> f (Maybe (RegistrationToken m)) +registerCapability method regOpts f = do + clientCaps <- resClientCapabilities <$> getLspEnv + handlers <- resHandlers <$> getLspEnv + let alreadyStaticallyRegistered = case splitClientMethod method of + IsClientNot -> DMap.member method $ notHandlers handlers + IsClientReq -> DMap.member method $ reqHandlers handlers + IsClientEither -> error "Cannot register capability for custom methods" + go clientCaps alreadyStaticallyRegistered + where + -- If the server has already registered statically, don't dynamically register + -- as per the spec + go _clientCaps True = pure Nothing + go clientCaps False + -- First, check to see if the client supports dynamic registration on this method + | dynamicSupported clientCaps = do + uuid <- liftIO $ UUID.toText <$> getStdRandom random + let registration = J.Registration uuid method regOpts + params = J.RegistrationParams (J.List [J.SomeRegistration registration]) + regId = RegistrationId uuid + rio <- askUnliftIO + ~() <- case splitClientMethod method of + IsClientNot -> modifyState $ \ctx -> + let newRegs = DMap.insert method pair (resRegistrationsNot ctx) + pair = Pair regId (ClientMessageHandler (unliftIO rio . f)) + in ctx { resRegistrationsNot = newRegs } + IsClientReq -> modifyState $ \ctx -> + let newRegs = DMap.insert method pair (resRegistrationsReq ctx) + pair = Pair regId (ClientMessageHandler (\msg k -> unliftIO rio $ f msg (liftIO . k))) + in ctx { resRegistrationsReq = newRegs } + IsClientEither -> error "Cannot register capability for custom methods" + + -- TODO: handle the scenario where this returns an error + _ <- sendRequest SClientRegisterCapability params $ \_res -> pure () + + pure (Just (RegistrationToken method regId)) + | otherwise = pure Nothing + + -- Also I'm thinking we should move this function to somewhere in messages.hs so + -- we don't forget to update it when adding new methods... + capDyn :: J.HasDynamicRegistration a (Maybe Bool) => Maybe a -> Bool + capDyn (Just x) = fromMaybe False $ x ^. J.dynamicRegistration + capDyn Nothing = False + + -- | Checks if client capabilities declares that the method supports dynamic registration + dynamicSupported clientCaps = case method of + SWorkspaceDidChangeConfiguration -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeConfiguration . _Just + SWorkspaceDidChangeWatchedFiles -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeWatchedFiles . _Just + SWorkspaceSymbol -> capDyn $ clientCaps ^? J.workspace . _Just . J.symbol . _Just + SWorkspaceExecuteCommand -> capDyn $ clientCaps ^? J.workspace . _Just . J.executeCommand . _Just + STextDocumentDidOpen -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + STextDocumentDidChange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + STextDocumentDidClose -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + STextDocumentCompletion -> capDyn $ clientCaps ^? J.textDocument . _Just . J.completion . _Just + STextDocumentHover -> capDyn $ clientCaps ^? J.textDocument . _Just . J.hover . _Just + STextDocumentSignatureHelp -> capDyn $ clientCaps ^? J.textDocument . _Just . J.signatureHelp . _Just + STextDocumentDeclaration -> capDyn $ clientCaps ^? J.textDocument . _Just . J.declaration . _Just + STextDocumentDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.definition . _Just + STextDocumentTypeDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.typeDefinition . _Just + STextDocumentImplementation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.implementation . _Just + STextDocumentReferences -> capDyn $ clientCaps ^? J.textDocument . _Just . J.references . _Just + STextDocumentDocumentHighlight -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentHighlight . _Just + STextDocumentDocumentSymbol -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentSymbol . _Just + STextDocumentCodeAction -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeAction . _Just + STextDocumentCodeLens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeLens . _Just + STextDocumentDocumentLink -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentLink . _Just + STextDocumentDocumentColor -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just + STextDocumentColorPresentation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just + STextDocumentFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.formatting . _Just + STextDocumentRangeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rangeFormatting . _Just + STextDocumentOnTypeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.onTypeFormatting . _Just + STextDocumentRename -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rename . _Just + STextDocumentFoldingRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.foldingRange . _Just + STextDocumentSelectionRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just + _ -> False + +-- | Sends a @client/unregisterCapability@ request and removes the handler +-- for that associated registration. +unregisterCapability :: MonadLsp config f => RegistrationToken m -> f () +unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do + ~() <- case splitClientMethod m of + IsClientReq -> do + reqRegs <- getsState resRegistrationsReq + let newMap = DMap.delete m reqRegs + modifyState (\ctx -> ctx { resRegistrationsReq = newMap }) + IsClientNot -> do + notRegs <- getsState resRegistrationsNot + let newMap = DMap.delete m notRegs + modifyState (\ctx -> ctx { resRegistrationsNot = newMap }) + IsClientEither -> error "Cannot unregister capability for custom methods" + + let unregistration = J.Unregistration uuid (J.SomeClientMethod m) + params = J.UnregistrationParams (J.List [unregistration]) + void $ sendRequest SClientUnregisterCapability params $ \_res -> pure () + +-------------------------------------------------------------------------------- +-- PROGRESS +-------------------------------------------------------------------------------- + +storeProgress :: MonadLsp config m => ProgressToken -> Async a -> m () +storeProgress n a = do + let f = Map.insert n (cancelWith a ProgressCancelledException) . progressCancel + modifyState $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}} + +deleteProgress :: MonadLsp config m => ProgressToken -> m () +deleteProgress n = do + let f = Map.delete n . progressCancel + modifyState $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}} + +-- Get a new id for the progress session and make a new one +getNewProgressId :: MonadLsp config m => m ProgressToken +getNewProgressId = do + stateState $ \ctx@LanguageContextState{resProgressData} -> + let x = progressNextId resProgressData + ctx' = ctx { resProgressData = resProgressData { progressNextId = x + 1 }} + in (ProgressNumericToken x, ctx') + +withProgressBase :: MonadLsp c m => Bool -> Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a +withProgressBase indefinite title cancellable f = do + + progId <- getNewProgressId + + let initialPercentage + | indefinite = Nothing + | otherwise = Just 0 + cancellable' = case cancellable of + Cancellable -> True + NotCancellable -> False + + -- Create progress token + -- FIXME : This needs to wait until the request returns before + -- continuing!!! + _ <- sendRequest SWindowWorkDoneProgressCreate + (WorkDoneProgressCreateParams progId) $ \res -> do + case res of + -- An error ocurred when the client was setting it up + -- No need to do anything then, as per the spec + Left _err -> pure () + Right () -> pure () + + -- Send initial notification + sendNotification SProgress $ + fmap Begin $ ProgressParams progId $ + WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage + + -- Send the begin and done notifications via 'bracket_' so that they are always fired + res <- withRunInIO $ \runInBase -> + E.bracket_ + -- Send begin notification + (runInBase $ sendNotification SProgress $ + fmap Begin $ ProgressParams progId $ + WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage) + + -- Send end notification + (runInBase $ sendNotification SProgress $ + End <$> ProgressParams progId (WorkDoneProgressEndParams Nothing)) $ do + + -- Run f asynchronously + aid <- async $ runInBase $ f (updater progId) + runInBase $ storeProgress progId aid + wait aid + + -- Delete the progress cancellation from the map + -- If we don't do this then it's easy to leak things as the map contains any IO action. + deleteProgress progId + + return res + where updater progId (ProgressAmount percentage msg) = do + liftIO $ putStrLn "asdf" + sendNotification SProgress $ fmap Report $ ProgressParams progId $ + WorkDoneProgressReportParams Nothing msg percentage + +clientSupportsProgress :: J.ClientCapabilities -> Bool +clientSupportsProgress (J.ClientCapabilities _ _ wc _) = fromMaybe False $ do + (J.WindowClientCapabilities mProgress) <- wc + mProgress + +-- | Wrapper for reporting progress to the client during a long running +-- task. +-- 'withProgress' @title cancellable f@ starts a new progress reporting +-- session, and finishes it once f is completed. +-- f is provided with an update function that allows it to report on +-- the progress during the session. +-- If @cancellable@ is 'Cancellable', @f@ will be thrown a +-- 'ProgressCancelledException' if the user cancels the action in +-- progress. +withProgress :: MonadLsp c m => Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a +withProgress title cancellable f = do + clientCaps <- getClientCapabilities + if clientSupportsProgress clientCaps + then withProgressBase False title cancellable f + else f (const $ return ()) + +-- | Same as 'withProgress', but for processes that do not report the +-- precentage complete. +-- +-- @since 0.10.0.0 +withIndefiniteProgress :: MonadLsp c m => Text -> ProgressCancellable -> m a -> m a +withIndefiniteProgress title cancellable f = do + clientCaps <- getClientCapabilities + if clientSupportsProgress clientCaps + then withProgressBase True title cancellable (const f) + else f + +-- --------------------------------------------------------------------- + +-- | Aggregate all diagnostics pertaining to a particular version of a document, +-- by source, and sends a @textDocument/publishDiagnostics@ notification with +-- the total (limited by the first parameter) whenever it is updated. +publishDiagnostics :: MonadLsp config m => Int -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource -> m () +publishDiagnostics maxDiagnosticCount uri version diags = join $ stateState $ \ctx -> + let ds = updateDiagnostics (resDiagnostics ctx) uri version diags + ctx' = ctx{resDiagnostics = ds} + mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri + act = case mdp of + Nothing -> return () + Just params -> + sendToClient $ J.fromServerNot $ J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics params + in (act,ctx') + +-- --------------------------------------------------------------------- + +-- | Remove all diagnostics from a particular source, and send the updates to +-- the client. +flushDiagnosticsBySource :: MonadLsp config m => Int -- ^ Max number of diagnostics to send + -> Maybe DiagnosticSource -> m () +flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateState $ \ctx -> + let ds = flushBySource (resDiagnostics ctx) msource + ctx' = ctx {resDiagnostics = ds} + -- Send the updated diagnostics to the client + act = forM_ (HM.keys ds) $ \uri -> do + let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri + case mdp of + Nothing -> return () + Just params -> do + sendToClient $ J.fromServerNot $ J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics params + in (act,ctx') + +-- ===================================================================== +-- +-- utility + + +-- +-- Logger +-- +setupLogger :: Maybe FilePath -> [String] -> Priority -> IO () +setupLogger mLogFile extraLogNames level = do + + logStream <- case mLogFile of + Just logFile -> openFile logFile AppendMode `E.catch` handleIOException logFile + Nothing -> return stderr + hSetEncoding logStream utf8 + + logH <- LHS.streamHandler logStream level + + let logHandle = logH {LHS.closeFunc = hClose} + logFormatter = L.tfLogFormatter logDateFormat logFormat + logHandler = LH.setFormatter logHandle logFormatter + + L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle]) + L.updateGlobalLogger "haskell-lsp" $ L.setHandlers [logHandler] + L.updateGlobalLogger "haskell-lsp" $ L.setLevel level + + -- Also route the additional log names to the same log + forM_ extraLogNames $ \logName -> do + L.updateGlobalLogger logName $ L.setHandlers [logHandler] + L.updateGlobalLogger logName $ L.setLevel level + where + logFormat = "$time [$tid] $prio $loggername:\t$msg" + logDateFormat = "%Y-%m-%d %H:%M:%S%Q" + +handleIOException :: FilePath -> E.IOException -> IO Handle +handleIOException logFile _ = do + hPutStr stderr $ "Couldn't open log file " ++ logFile ++ "; falling back to stderr logging" + return stderr + +-- --------------------------------------------------------------------- + +-- | The changes in a workspace edit should be applied from the end of the file +-- toward the start. Sort them into this order. +reverseSortEdit :: J.WorkspaceEdit -> J.WorkspaceEdit +reverseSortEdit (J.WorkspaceEdit cs dcs) = J.WorkspaceEdit cs' dcs' + where + cs' :: Maybe J.WorkspaceEditMap + cs' = (fmap . fmap ) sortTextEdits cs + + dcs' :: Maybe (J.List J.TextDocumentEdit) + dcs' = (fmap . fmap ) sortTextDocumentEdits dcs + + sortTextEdits :: J.List J.TextEdit -> J.List J.TextEdit + sortTextEdits (J.List edits) = J.List (L.sortBy down edits) + + sortTextDocumentEdits :: J.TextDocumentEdit -> J.TextDocumentEdit + sortTextDocumentEdits (J.TextDocumentEdit td (J.List edits)) = J.TextDocumentEdit td (J.List edits') + where + edits' = L.sortBy down edits + + down (J.TextEdit r1 _) (J.TextEdit r2 _) = r2 `compare` r1 diff --git a/src/Language/LSP/Server/Processing.hs b/src/Language/LSP/Server/Processing.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Server/Processing.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +module Language.LSP.Server.Processing where + +import Control.Lens hiding (List, Empty) +import Data.Aeson hiding (Options) +import Data.Aeson.Types hiding (Options) +import qualified Data.ByteString.Lazy as BSL +import Data.List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import qualified Language.LSP.Types.Lens as LSP +import Language.LSP.Server.Core +import Language.LSP.VFS +import Data.Functor.Product +import qualified Control.Exception as E +import Data.Monoid hiding (Product) +import Control.Monad.IO.Class +import Control.Monad.Except +import Control.Concurrent.STM +import Control.Monad.Trans.Except +import Control.Monad.Reader +import Data.IxMap +import System.Directory +import System.Log.Logger +import qualified Data.Dependent.Map as DMap +import Data.Maybe +import Data.Dependent.Map (DMap) +import qualified Data.Map as Map +import System.Exit + +processMessage :: BSL.ByteString -> LspM config () +processMessage jsonStr = do + tvarDat <- LspT $ asks resState + join $ liftIO $ atomically $ fmap handleErrors $ runExceptT $ do + val <- except $ eitherDecode jsonStr + ctx <- lift $ readTVar tvarDat + msg <- except $ parseEither (parser $ resPendingResponses ctx) val + lift $ case msg of + FromClientMess m mess -> + pure $ handle m mess + FromClientRsp (Pair (ServerResponseCallback f) (Const newMap)) res -> do + modifyTVar' tvarDat (\c -> c { resPendingResponses = newMap }) + pure $ liftIO $ f (res ^. LSP.result) + where + parser :: ResponseMap -> Value -> Parser (FromClientMessage' (Product ServerResponseCallback (Const ResponseMap))) + parser rm = parseClientMessage $ \i -> + let (mhandler, newMap) = pickFromIxMap i rm + in (\(Pair m handler) -> (m,Pair handler (Const newMap))) <$> mhandler + + handleErrors = either (sendErrorLog . errMsg) id + + errMsg err = TL.toStrict $ TL.unwords + [ "haskell-lsp:incoming message parse error." + , TL.decodeUtf8 jsonStr + , TL.pack err + ] <> "\n" + +-- | Call this to initialize the session +initializeRequestHandler + :: ServerDefinition config + -> VFS + -> (FromServerMessage -> IO ()) + -> Message Initialize + -> IO (Maybe (LanguageContextEnv config)) +initializeRequestHandler ServerDefinition{..} vfs sendFunc req = do + let sendResp = sendFunc . FromServerRsp SInitialize + handleErr (Left err) = do + sendResp $ makeResponseError (req ^. LSP.id) err + pure Nothing + handleErr (Right a) = pure $ Just a + flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. LSP.id)) $ handleErr <=< runExceptT $ mdo + + let params = req ^. LSP.params + rootDir = getFirst $ foldMap First [ params ^. LSP.rootUri >>= uriToFilePath + , params ^. LSP.rootPath <&> T.unpack ] + + liftIO $ case rootDir of + Nothing -> return () + Just dir -> do + debugM "lsp.initializeRequestHandler" $ "Setting current dir to project root:" ++ dir + unless (null dir) $ setCurrentDirectory dir + + let initialWfs = case params ^. LSP.workspaceFolders of + Just (List xs) -> xs + Nothing -> [] + + tvarCtx <- liftIO $ newTVarIO $ + LanguageContextState + (VFSData vfs mempty) + mempty + Nothing + initialWfs + defaultProgressData + emptyIxMap + mempty + mempty + 0 + + -- Call the 'duringInitialization' callback to let the server kick stuff up + let env = LanguageContextEnv handlers (forward interpreter . onConfigurationChange) sendFunc tvarCtx (params ^. LSP.capabilities) rootDir + handlers = transmuteHandlers interpreter staticHandlers + interpreter = interpretHandler initializationResult + initializationResult <- ExceptT $ doInitialize env req + + let serverCaps = inferServerCapabilities (params ^. LSP.capabilities) options handlers + liftIO $ sendResp $ makeResponseMessage (req ^. LSP.id) (InitializeResult serverCaps (serverInfo options)) + pure env + where + makeResponseMessage rid result = ResponseMessage "2.0" (Just rid) (Right result) + makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) + + initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a) + initializeErrorHandler sendResp e = do + sendResp $ ResponseError InternalError msg Nothing + pure Nothing + where + msg = T.pack $ unwords ["Error on initialize:", show e] + + +-- | Infers the capabilities based on registered handlers, and sets the appropriate options. +-- A provider should be set to Nothing if the server does not support it, unless it is a +-- static option. +inferServerCapabilities :: ClientCapabilities -> Options -> Handlers m -> ServerCapabilities +inferServerCapabilities clientCaps o h = + ServerCapabilities + { _textDocumentSync = sync + , _hoverProvider = supportedBool STextDocumentHover + , _completionProvider = completionProvider + , _declarationProvider = supportedBool STextDocumentDeclaration + , _signatureHelpProvider = signatureHelpProvider + , _definitionProvider = supportedBool STextDocumentDefinition + , _typeDefinitionProvider = supportedBool STextDocumentTypeDefinition + , _implementationProvider = supportedBool STextDocumentImplementation + , _referencesProvider = supportedBool STextDocumentReferences + , _documentHighlightProvider = supportedBool STextDocumentDocumentHighlight + , _documentSymbolProvider = supportedBool STextDocumentDocumentSymbol + , _codeActionProvider = codeActionProvider + , _codeLensProvider = supported' STextDocumentCodeLens $ CodeLensOptions + (Just False) + (supported SCodeLensResolve) + , _documentFormattingProvider = supportedBool STextDocumentFormatting + , _documentRangeFormattingProvider = supportedBool STextDocumentRangeFormatting + , _documentOnTypeFormattingProvider = documentOnTypeFormattingProvider + , _renameProvider = supportedBool STextDocumentRename + , _documentLinkProvider = supported' STextDocumentDocumentLink $ DocumentLinkOptions + (Just False) + (supported SDocumentLinkResolve) + , _colorProvider = supportedBool STextDocumentDocumentColor + , _foldingRangeProvider = supportedBool STextDocumentFoldingRange + , _executeCommandProvider = executeCommandProvider + , _selectionRangeProvider = supportedBool STextDocumentSelectionRange + , _workspaceSymbolProvider = supported SWorkspaceSymbol + , _workspace = Just workspace + -- TODO: Add something for experimental + , _experimental = Nothing :: Maybe Value + } + where + + -- | For when we just return a simple @true@/@false@ to indicate if we + -- support the capability + supportedBool = Just . InL . supported_b + + supported' m b + | supported_b m = Just b + | otherwise = Nothing + + supported :: forall m. SClientMethod m -> Maybe Bool + supported = Just . supported_b + + supported_b :: forall m. SClientMethod m -> Bool + supported_b m = case splitClientMethod m of + IsClientNot -> DMap.member m $ notHandlers h + IsClientReq -> DMap.member m $ reqHandlers h + IsClientEither -> error "capabilities depend on custom method" + + singleton :: a -> [a] + singleton x = [x] + + completionProvider + | supported_b STextDocumentCompletion = Just $ + CompletionOptions + Nothing + (map singleton <$> completionTriggerCharacters o) + (map singleton <$> completionAllCommitCharacters o) + (supported SCompletionItemResolve) + | otherwise = Nothing + + clientSupportsCodeActionKinds = isJust $ + clientCaps ^? LSP.textDocument . _Just . LSP.codeAction . _Just . LSP.codeActionLiteralSupport + + codeActionProvider + | clientSupportsCodeActionKinds + , supported_b STextDocumentCodeAction = Just $ + maybe (InL True) (InR . CodeActionOptions Nothing . Just . List) + (codeActionKinds o) + | supported_b STextDocumentCodeAction = Just (InL True) + | otherwise = Just (InL False) + + signatureHelpProvider + | supported_b STextDocumentSignatureHelp = Just $ + SignatureHelpOptions + Nothing + (List . map singleton <$> signatureHelpTriggerCharacters o) + (List . map singleton <$> signatureHelpRetriggerCharacters o) + | otherwise = Nothing + + documentOnTypeFormattingProvider + | supported_b STextDocumentOnTypeFormatting + , Just (first :| rest) <- documentOnTypeFormattingTriggerCharacters o = Just $ + DocumentOnTypeFormattingOptions (T.pack [first]) (Just (map (T.pack . singleton) rest)) + | supported_b STextDocumentOnTypeFormatting + , Nothing <- documentOnTypeFormattingTriggerCharacters o = + error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" + | otherwise = Nothing + + executeCommandProvider + | supported_b SWorkspaceExecuteCommand + , Just cmds <- executeCommandCommands o = Just (ExecuteCommandOptions Nothing (List cmds)) + | supported_b SWorkspaceExecuteCommand + , Nothing <- executeCommandCommands o = + error "executeCommandCommands needs to be set if a executeCommandHandler is set" + | otherwise = Nothing + + sync = case textDocumentSync o of + Just x -> Just (InL x) + Nothing -> Nothing + + workspace = WorkspaceServerCapabilities workspaceFolder + workspaceFolder = supported' SWorkspaceDidChangeWorkspaceFolders $ + -- sign up to receive notifications + WorkspaceFoldersServerCapabilities (Just True) (Just (InR True)) + +-- | Invokes the registered dynamic or static handlers for the given message and +-- method, as well as doing some bookkeeping. +handle :: SClientMethod m -> ClientMessage m -> LspM config () +handle m msg = + case m of + SWorkspaceDidChangeWorkspaceFolders -> handle' (Just updateWorkspaceFolders) m msg + SWorkspaceDidChangeConfiguration -> handle' (Just handleConfigChange) m msg + STextDocumentDidOpen -> handle' (Just $ vfsFunc openVFS) m msg + STextDocumentDidChange -> handle' (Just $ vfsFunc changeFromClientVFS) m msg + STextDocumentDidClose -> handle' (Just $ vfsFunc closeVFS) m msg + SWindowWorkDoneProgressCancel -> handle' (Just progressCancelHandler) m msg + _ -> handle' Nothing m msg + + +handle' :: forall t (m :: Method FromClient t) config. + Maybe (ClientMessage m -> LspM config ()) + -- ^ An action to be run before invoking the handler, used for + -- bookkeeping stuff like the vfs etc. + -> SClientMethod m + -> ClientMessage m + -> LspM config () +handle' mAction m msg = do + maybe (return ()) (\f -> f msg) mAction + + dynReqHandlers <- getsState resRegistrationsReq + dynNotHandlers <- getsState resRegistrationsNot + + env <- getLspEnv + let Handlers{reqHandlers, notHandlers} = resHandlers env + + let mkRspCb :: RequestMessage (m1 :: Method FromClient Request) -> Either ResponseError (ResponseResult m1) -> IO () + mkRspCb req (Left err) = runLspT env $ sendToClient $ + FromServerRsp (req ^. LSP.method) $ ResponseMessage "2.0" (Just (req ^. LSP.id)) (Left err) + mkRspCb req (Right rsp) = runLspT env $ sendToClient $ + FromServerRsp (req ^. LSP.method) $ ResponseMessage "2.0" (Just (req ^. LSP.id)) (Right rsp) + + case splitClientMethod m of + IsClientNot -> case pickHandler dynNotHandlers notHandlers of + Just h -> liftIO $ h msg + Nothing + | SExit <- m -> liftIO $ exitNotificationHandler msg + | otherwise -> reportMissingHandler + + IsClientReq -> case pickHandler dynReqHandlers reqHandlers of + Just h -> liftIO $ h msg (mkRspCb msg) + Nothing + | SShutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb msg) + | otherwise -> reportMissingHandler + + IsClientEither -> case msg of + NotMess noti -> case pickHandler dynNotHandlers notHandlers of + Just h -> liftIO $ h noti + Nothing -> reportMissingHandler + ReqMess req -> case pickHandler dynReqHandlers reqHandlers of + Just h -> liftIO $ h req (mkRspCb req) + Nothing -> reportMissingHandler + where + -- | Checks to see if there's a dynamic handler, and uses it in favour of the + -- static handler, if it exists. + pickHandler :: RegistrationMap t -> DMap SMethod (ClientMessageHandler IO t) -> Maybe (Handler IO m) + pickHandler dynHandlerMap staticHandler = case (DMap.lookup m dynHandlerMap, DMap.lookup m staticHandler) of + (Just (Pair _ (ClientMessageHandler h)), _) -> Just h + (Nothing, Just (ClientMessageHandler h)) -> Just h + (Nothing, Nothing) -> Nothing + + -- '$/' notifications should/could be ignored by server. + -- Don't log errors in that case. + -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests. + reportMissingHandler :: LspM config () + reportMissingHandler + | isOptionalNotification m = return () + | otherwise = do + let errorMsg = T.pack $ unwords ["haskell-lsp:no handler for: ", show m] + sendErrorLog errorMsg + isOptionalNotification (SCustomMethod method) + | "$/" `T.isPrefixOf` method = True + isOptionalNotification _ = False + +progressCancelHandler :: Message WindowWorkDoneProgressCancel -> LspM config () +progressCancelHandler (NotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do + mact <- getsState $ Map.lookup tid . progressCancel . resProgressData + case mact of + Nothing -> return () + Just cancelAction -> liftIO $ cancelAction + +exitNotificationHandler :: Handler IO Exit +exitNotificationHandler = \_ -> do + noticeM "lsp.exitNotificationHandler" "Got exit, exiting" + exitSuccess + +-- | Default Shutdown handler +shutdownRequestHandler :: Handler IO Shutdown +shutdownRequestHandler = \_req k -> do + k $ Right Empty + + + +handleConfigChange :: Message WorkspaceDidChangeConfiguration -> LspM config () +handleConfigChange req = do + parseConfig <- LspT $ asks resParseConfig + res <- liftIO $ parseConfig (req ^. LSP.params . LSP.settings) + case res of + Left err -> do + let msg = T.pack $ unwords + ["haskell-lsp:configuration parse error.", show req, show err] + sendErrorLog msg + Right newConfig -> + modifyState $ \ctx -> ctx { resConfig = Just newConfig } + +vfsFunc :: (VFS -> b -> (VFS, [String])) -> b -> LspM config () +vfsFunc modifyVfs req = do + join $ stateState $ \ctx@LanguageContextState{resVFS = VFSData vfs rm} -> + let (vfs', ls) = modifyVfs vfs req + in (liftIO $ mapM_ (debugM "haskell-lsp.vfsFunc") ls,ctx{ resVFS = VFSData vfs' rm}) + +-- | Updates the list of workspace folders +updateWorkspaceFolders :: Message WorkspaceDidChangeWorkspaceFolders -> LspM config () +updateWorkspaceFolders (NotificationMessage _ _ params) = do + let List toRemove = params ^. LSP.event . LSP.removed + List toAdd = params ^. LSP.event . LSP.added + newWfs oldWfs = foldr delete oldWfs toRemove <> toAdd + modifyState $ \c -> c {resWorkspaceFolders = newWfs $ resWorkspaceFolders c} + +-- --------------------------------------------------------------------- + diff --git a/test/CapabilitiesSpec.hs b/test/CapabilitiesSpec.hs new file mode 100644 --- /dev/null +++ b/test/CapabilitiesSpec.hs @@ -0,0 +1,16 @@ +module CapabilitiesSpec where + +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import Test.Hspec + +spec :: Spec +spec = describe "capabilities" $ do + it "gives 3.10 capabilities" $ + let ClientCapabilities _ (Just tdcs) _ _ = capsForVersion (LSPVersion 3 10) + Just (DocumentSymbolClientCapabilities _ _ mHierarchical) = _documentSymbol tdcs + in mHierarchical `shouldBe` Just True + it "gives pre 3.10 capabilities" $ + let ClientCapabilities _ (Just tdcs) _ _ = capsForVersion (LSPVersion 3 9) + Just (DocumentSymbolClientCapabilities _ _ mHierarchical) = _documentSymbol tdcs + in mHierarchical `shouldBe` Nothing diff --git a/test/DiagnosticsSpec.hs b/test/DiagnosticsSpec.hs new file mode 100644 --- /dev/null +++ b/test/DiagnosticsSpec.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE OverloadedStrings #-} +module DiagnosticsSpec where + + +import qualified Data.Map as Map +import qualified Data.HashMap.Strict as HM +import qualified Data.SortedList as SL +import Data.Text (Text) +import Language.LSP.Diagnostics +import qualified Language.LSP.Types as J + +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "Diagnostics functions" diagnosticsSpec + +-- -- |Used when running from ghci, and it sets the current directory to ./tests +-- tt :: IO () +-- tt = do +-- cd ".." +-- hspec spec + +-- --------------------------------------------------------------------- + +mkDiagnostic :: Maybe J.DiagnosticSource -> Text -> J.Diagnostic +mkDiagnostic ms str = + let + rng = J.Range (J.Position 0 1) (J.Position 3 0) + loc = J.Location (J.Uri "file") rng + in + J.Diagnostic rng Nothing Nothing ms str Nothing (Just (J.List [J.DiagnosticRelatedInformation loc str])) + +mkDiagnostic2 :: Maybe J.DiagnosticSource -> Text -> J.Diagnostic +mkDiagnostic2 ms str = + let + rng = J.Range (J.Position 4 1) (J.Position 5 0) + loc = J.Location (J.Uri "file") rng + in J.Diagnostic rng Nothing Nothing ms str Nothing (Just (J.List [J.DiagnosticRelatedInformation loc str])) + +-- --------------------------------------------------------------------- + +diagnosticsSpec :: Spec +diagnosticsSpec = do + describe "constructs a new store" $ do + it "constructs a store with no doc version and a single source" $ do + let + diags = + [ mkDiagnostic (Just "hlint") "a" + , mkDiagnostic (Just "hlint") "b" + ] + uri = J.toNormalizedUri $ J.Uri "uri" + (updateDiagnostics HM.empty uri Nothing (partitionBySource diags)) `shouldBe` + HM.fromList + [ (uri,StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags) ] ) + ] + + -- --------------------------------- + + it "constructs a store with no doc version and multiple sources" $ do + let + diags = + [ mkDiagnostic (Just "hlint") "a" + , mkDiagnostic (Just "ghcmod") "b" + ] + uri = J.toNormalizedUri $ J.Uri "uri" + (updateDiagnostics HM.empty uri Nothing (partitionBySource diags)) `shouldBe` + HM.fromList + [ (uri,StoreItem Nothing $ Map.fromList + [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) + ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) + ]) + ] + + -- --------------------------------- + + it "constructs a store with doc version and multiple sources" $ do + let + diags = + [ mkDiagnostic (Just "hlint") "a" + , mkDiagnostic (Just "ghcmod") "b" + ] + uri = J.toNormalizedUri $ J.Uri "uri" + (updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags)) `shouldBe` + HM.fromList + [ (uri,StoreItem (Just 1) $ Map.fromList + [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) + ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) + ]) + ] + + -- --------------------------------- + + describe "updates a store for same document version" $ do + it "updates a store without a document version, single source only" $ do + let + diags1 = + [ mkDiagnostic (Just "hlint") "a1" + , mkDiagnostic (Just "hlint") "b1" + ] + diags2 = + [ mkDiagnostic (Just "hlint") "a2" + ] + uri = J.toNormalizedUri $ J.Uri "uri" + let origStore = updateDiagnostics HM.empty uri Nothing (partitionBySource diags1) + (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) `shouldBe` + HM.fromList + [ (uri,StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] ) + ] + + -- --------------------------------- + + it "updates just one source of a 2 source store" $ do + let + diags1 = + [ mkDiagnostic (Just "hlint") "a1" + , mkDiagnostic (Just "ghcmod") "b1" + ] + diags2 = + [ mkDiagnostic (Just "hlint") "a2" + ] + uri = J.toNormalizedUri $ J.Uri "uri" + let origStore = updateDiagnostics HM.empty uri Nothing (partitionBySource diags1) + (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) `shouldBe` + HM.fromList + [ (uri,StoreItem Nothing $ Map.fromList + [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) + ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b1")) + ] ) + ] + + -- --------------------------------- + + it "updates just one source of a 2 source store, with empty diags" $ do + let + diags1 = + [ mkDiagnostic (Just "hlint") "a1" + , mkDiagnostic (Just "ghcmod") "b1" + ] + uri = J.toNormalizedUri $ J.Uri "uri" + let origStore = updateDiagnostics HM.empty uri Nothing (partitionBySource diags1) + (updateDiagnostics origStore uri Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])])) `shouldBe` + HM.fromList + [ (uri,StoreItem Nothing $ Map.fromList + [(Just "ghcmod", SL.toSortedList []) + ,(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a1")) + ] ) + ] + + + -- --------------------------------- + + describe "updates a store for a new document version" $ do + it "updates a store without a document version, single source only" $ do + let + diags1 = + [ mkDiagnostic (Just "hlint") "a1" + , mkDiagnostic (Just "hlint") "b1" + ] + diags2 = + [ mkDiagnostic (Just "hlint") "a2" + ] + uri = J.toNormalizedUri $ J.Uri "uri" + let origStore = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags1) + (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) `shouldBe` + HM.fromList + [ (uri,StoreItem (Just 2) $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] ) + ] + + -- --------------------------------- + + it "updates a store for a new doc version, removing all priot sources" $ do + let + diags1 = + [ mkDiagnostic (Just "hlint") "a1" + , mkDiagnostic (Just "ghcmod") "b1" + ] + diags2 = + [ mkDiagnostic (Just "hlint") "a2" + ] + uri = J.toNormalizedUri $ J.Uri "uri" + let origStore = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags1) + (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) `shouldBe` + HM.fromList + [ (uri,StoreItem (Just 2) $ Map.fromList + [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) + ] ) + ] + + -- --------------------------------- + + describe "retrieves all the diagnostics for a given uri" $ do + + it "gets diagnostics for multiple sources" $ do + let + diags = + [ mkDiagnostic (Just "hlint") "a" + , mkDiagnostic (Just "ghcmod") "b" + ] + uri = J.toNormalizedUri $ J.Uri "uri" + let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) + getDiagnosticParamsFor 10 ds uri `shouldBe` + Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) (J.List $ reverse diags)) + + -- --------------------------------- + + describe "limits the number of diagnostics retrieved, in order" $ do + + it "gets diagnostics for multiple sources" $ do + let + diags = + [ mkDiagnostic2 (Just "hlint") "a" + , mkDiagnostic2 (Just "ghcmod") "b" + , mkDiagnostic (Just "hlint") "c" + , mkDiagnostic (Just "ghcmod") "d" + ] + uri = J.toNormalizedUri $ J.Uri "uri" + let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) + getDiagnosticParamsFor 2 ds uri `shouldBe` + Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) + (J.List [ + mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + ])) + + getDiagnosticParamsFor 1 ds uri `shouldBe` + Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) + (J.List [ + mkDiagnostic (Just "ghcmod") "d" + ])) + + -- --------------------------------- + + describe "flushes the diagnostics for a given source" $ do + + it "gets diagnostics for multiple sources" $ do + let + diags = + [ mkDiagnostic2 (Just "hlint") "a" + , mkDiagnostic2 (Just "ghcmod") "b" + , mkDiagnostic (Just "hlint") "c" + , mkDiagnostic (Just "ghcmod") "d" + ] + uri = J.toNormalizedUri $ J.Uri "uri" + let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) + getDiagnosticParamsFor 100 ds uri `shouldBe` + Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) + (J.List [ + mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + , mkDiagnostic2 (Just "ghcmod") "b" + , mkDiagnostic2 (Just "hlint") "a" + ])) + + let ds' = flushBySource ds (Just "hlint") + getDiagnosticParamsFor 100 ds' uri `shouldBe` + Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) + (J.List [ + mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic2 (Just "ghcmod") "b" + ])) + + -- --------------------------------- diff --git a/test/JsonSpec.hs b/test/JsonSpec.hs new file mode 100644 --- /dev/null +++ b/test/JsonSpec.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- For the use of MarkedString +{-# OPTIONS_GHC -fno-warn-deprecations #-} +-- | Test for JSON serialization +module JsonSpec where + +import Language.LSP.Types + +import qualified Data.Aeson as J +import Data.List(isPrefixOf) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck hiding (Success) +import Test.QuickCheck.Instances () + +-- import Debug.Trace +-- --------------------------------------------------------------------- + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "dispatcher" jsonSpec + describe "ResponseMessage" responseMessageSpec + +-- --------------------------------------------------------------------- + +jsonSpec :: Spec +jsonSpec = do + describe "General JSON instances round trip" $ do + -- DataTypesJSON + prop "LanguageString" (propertyJsonRoundtrip :: LanguageString -> Property) + prop "MarkedString" (propertyJsonRoundtrip :: MarkedString -> Property) + prop "MarkupContent" (propertyJsonRoundtrip :: MarkupContent -> Property) + prop "HoverContents" (propertyJsonRoundtrip :: HoverContents -> Property) + prop "ResponseError" (propertyJsonRoundtrip :: ResponseError -> Property) + prop "WatchedFiles" (propertyJsonRoundtrip :: DidChangeWatchedFilesRegistrationOptions -> Property) + prop "ResponseMessage Initialize" + (propertyJsonRoundtrip :: ResponseMessage 'TextDocumentHover -> Property) + -- prop "ResponseMessage JSON value" + -- (propertyJsonRoundtrip :: ResponseMessage J.Value -> Property) + describe "JSON decoding regressions" $ + it "CompletionItem" $ + (J.decode "{\"jsonrpc\":\"2.0\",\"result\":[{\"label\":\"raisebox\"}],\"id\":1}" :: Maybe (ResponseMessage 'TextDocumentCompletion)) + `shouldNotBe` Nothing + + +responseMessageSpec :: Spec +responseMessageSpec = do + describe "edge cases" $ do + it "decodes result = null" $ do + let input = "{\"jsonrpc\": \"2.0\", \"id\": 123, \"result\": null}" + in J.decode input `shouldBe` Just + ((ResponseMessage "2.0" (Just (IdInt 123)) (Right J.Null)) :: ResponseMessage 'WorkspaceExecuteCommand) + describe "invalid JSON" $ do + it "throws if neither result nor error is present" $ do + (J.eitherDecode "{\"jsonrpc\":\"2.0\",\"id\":1}" :: Either String (ResponseMessage 'Initialize)) + `shouldBe` Left ("Error in $: both error and result cannot be Nothing") + it "throws if both result and error are present" $ do + (J.eitherDecode + "{\"jsonrpc\":\"2.0\",\"id\": 1,\"result\":{\"capabilities\": {}},\"error\":{\"code\":-32700,\"message\":\"\",\"data\":null}}" + :: Either String (ResponseMessage 'Initialize)) + `shouldSatisfy` + (either (\err -> "Error in $: both error and result cannot be present" `isPrefixOf` err) (\_ -> False)) + +-- --------------------------------------------------------------------- + +propertyJsonRoundtrip :: (Eq a, Show a, J.ToJSON a, J.FromJSON a) => a -> Property +propertyJsonRoundtrip a = J.Success a === J.fromJSON (J.toJSON a) + +-- --------------------------------------------------------------------- + +instance Arbitrary LanguageString where + arbitrary = LanguageString <$> arbitrary <*> arbitrary + +instance Arbitrary MarkedString where + arbitrary = oneof [PlainString <$> arbitrary, CodeString <$> arbitrary] + +instance Arbitrary MarkupContent where + arbitrary = MarkupContent <$> arbitrary <*> arbitrary + +instance Arbitrary MarkupKind where + arbitrary = oneof [pure MkPlainText,pure MkMarkdown] + +instance Arbitrary HoverContents where + arbitrary = oneof [ HoverContentsMS <$> arbitrary + , HoverContents <$> arbitrary + ] + +instance Arbitrary Uri where + arbitrary = Uri <$> arbitrary + +instance Arbitrary Position where + arbitrary = Position <$> arbitrary <*> arbitrary + +instance Arbitrary Location where + arbitrary = Location <$> arbitrary <*> arbitrary + +instance Arbitrary Range where + arbitrary = Range <$> arbitrary <*> arbitrary + +instance Arbitrary Hover where + arbitrary = Hover <$> arbitrary <*> arbitrary + +instance Arbitrary (ResponseResult m) => Arbitrary (ResponseMessage m) where + arbitrary = + oneof + [ ResponseMessage + <$> arbitrary + <*> arbitrary + <*> (Right <$> arbitrary) + , ResponseMessage + <$> arbitrary + <*> arbitrary + <*> (Left <$> arbitrary) + ] + +instance Arbitrary (LspId m) where + arbitrary = oneof [IdInt <$> arbitrary, IdString <$> arbitrary] + +instance Arbitrary ResponseError where + arbitrary = ResponseError <$> arbitrary <*> arbitrary <*> pure Nothing + +instance Arbitrary ErrorCode where + arbitrary = + elements + [ ParseError + , InvalidRequest + , MethodNotFound + , InvalidParams + , InternalError + , ServerErrorStart + , ServerErrorEnd + , ServerNotInitialized + , UnknownErrorCode + , RequestCancelled + , ContentModified + ] + +-- | make lists of maximum length 3 for test performance +smallList :: Gen a -> Gen [a] +smallList = resize 3 . listOf + +instance (Arbitrary a) => Arbitrary (List a) where + arbitrary = List <$> arbitrary + +instance Arbitrary J.Value where + arbitrary = oneof + [ J.String <$> arbitrary + , J.Number <$> arbitrary + , J.Bool <$> arbitrary + , pure J.Null + ] + +-- --------------------------------------------------------------------- + +instance Arbitrary DidChangeWatchedFilesRegistrationOptions where + arbitrary = DidChangeWatchedFilesRegistrationOptions <$> arbitrary + +instance Arbitrary FileSystemWatcher where + arbitrary = FileSystemWatcher <$> arbitrary <*> arbitrary + +instance Arbitrary WatchKind where + arbitrary = WatchKind <$> arbitrary <*> arbitrary <*> arbitrary + +-- --------------------------------------------------------------------- diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,22 @@ +module Main where + + +-- import Test.Hspec.Formatters.Jenkins +import Test.Hspec.Runner +import qualified Spec + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec Spec.spec + +-- main :: IO () +-- main = do +-- summary <- withFile "results.xml" WriteMode $ \h -> do +-- let c = defaultConfig +-- { configFormatter = xmlFormatter +-- , configHandle = h +-- } +-- hspecWith c Spec.spec +-- unless (summaryFailures summary == 0) $ +-- exitFailure diff --git a/test/MethodSpec.hs b/test/MethodSpec.hs new file mode 100644 --- /dev/null +++ b/test/MethodSpec.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings, DataKinds #-} +module MethodSpec where + + +import Control.Monad +import qualified Data.Aeson as J +import qualified Language.LSP.Types as J +import Test.Hspec +import qualified Data.Text as T + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "Method enum aeson instance consistency" diagnosticsSpec + +-- --------------------------------------------------------------------- + +clientMethods :: [T.Text] +clientMethods = [ + -- General + "initialize" + ,"initialized" + ,"shutdown" + ,"exit" + ,"$/cancelRequest" + -- Workspace + ,"workspace/didChangeConfiguration" + ,"workspace/didChangeWatchedFiles" + ,"workspace/symbol" + ,"workspace/executeCommand" + -- Document + ,"textDocument/didOpen" + ,"textDocument/didChange" + ,"textDocument/willSave" + ,"textDocument/willSaveWaitUntil" + ,"textDocument/didSave" + ,"textDocument/didClose" + ,"textDocument/completion" + ,"completionItem/resolve" + ,"textDocument/hover" + ,"textDocument/signatureHelp" + ,"textDocument/references" + ,"textDocument/documentHighlight" + ,"textDocument/documentSymbol" + ,"textDocument/formatting" + ,"textDocument/rangeFormatting" + ,"textDocument/onTypeFormatting" + ,"textDocument/definition" + ,"textDocument/codeAction" + ,"textDocument/codeLens" + ,"codeLens/resolve" + ,"textDocument/documentLink" + ,"documentLink/resolve" + ,"textDocument/rename" + ,"textDocument/prepareRename" + ] + +serverMethods :: [T.Text] +serverMethods = [ + -- Window + "window/showMessage" + ,"window/showMessageRequest" + ,"window/logMessage" + ,"telemetry/event" + -- Client + ,"client/registerCapability" + ,"client/unregisterCapability" + -- Workspace + ,"workspace/applyEdit" + -- Document + ,"textDocument/publishDiagnostics" + ] + +diagnosticsSpec :: Spec +diagnosticsSpec = do + describe "Client Methods" $ do + it "maintains roundtrip consistency" $ do + forM_ clientMethods $ \m -> do + (J.toJSON <$> (J.fromJSON (J.String m) :: J.Result (J.SomeClientMethod))) + `shouldBe` (J.Success $ J.String m) + describe "Server Methods" $ do + it "maintains roundtrip consistency" $ do + forM_ serverMethods $ \m -> do + (J.toJSON <$> (J.fromJSON (J.String m) :: J.Result (J.SomeServerMethod))) + `shouldBe` (J.Success $ J.String m) + + -- --------------------------------- diff --git a/test/ServerCapabilitiesSpec.hs b/test/ServerCapabilitiesSpec.hs new file mode 100644 --- /dev/null +++ b/test/ServerCapabilitiesSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +module ServerCapabilitiesSpec where + +import Control.Lens.Operators +import Data.Aeson +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import Language.LSP.Types.Lens +import Test.Hspec + +spec :: Spec +spec = describe "server capabilities" $ do + describe "folding range options" $ do + describe "decodes" $ do + it "just id" $ + let input = "{\"id\": \"abc123\"}" + in decode input `shouldBe` Just (FoldingRangeRegistrationOptions Nothing Nothing (Just "abc123")) + it "id and document selector" $ + let input = "{\"id\": \"foo\", \"documentSelector\": " <> documentFiltersJson <> "}" + in decode input `shouldBe` Just (FoldingRangeRegistrationOptions (Just documentFilters) Nothing (Just "foo")) + it "static boolean" $ + let input = "true" + in decode input `shouldBe` Just True + describe "encodes" $ + it "just id" $ + encode (FoldingRangeRegistrationOptions Nothing Nothing (Just "foo")) `shouldBe` "{\"id\":\"foo\"}" + it "decodes" $ + let input = "{\"hoverProvider\": true, \"colorProvider\": {\"id\": \"abc123\", \"documentSelector\": " <> documentFiltersJson <> "}}" + Just caps = decode input :: Maybe ServerCapabilities + in caps ^. colorProvider `shouldBe` Just (InR $ InR $ DocumentColorRegistrationOptions (Just documentFilters) (Just "abc123") Nothing) + where + documentFilters = List [DocumentFilter (Just "haskell") Nothing Nothing] + documentFiltersJson = "[{\"language\": \"haskell\"}]" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} +{- + +See https://github.com/hspec/hspec/tree/master/hspec-discover#readme +to understand this module + +Or http://hspec.github.io/hspec-discover.html + +-} diff --git a/test/TypesSpec.hs b/test/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/TypesSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +module TypesSpec where + +import qualified Language.LSP.Types as J +import Test.Hspec + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = diagnosticsSpec + +-- --------------------------------------------------------------------- + +diagnosticsSpec :: Spec +diagnosticsSpec = do + describe "MarkupContent" $ do + it "appends two plainstrings" $ do + J.unmarkedUpContent "string1\n" <> J.unmarkedUpContent "string2\n" + `shouldBe` J.unmarkedUpContent "string1\nstring2\n" + it "appends a marked up and a plain string" $ do + J.markedUpContent "haskell" "foo :: Int" <> J.unmarkedUpContent "string2\n" + `shouldBe` J.MarkupContent J.MkMarkdown "\n```haskell\nfoo :: Int\n```\nstring2\n" + it "appends a plain string and a marked up string" $ do + J.unmarkedUpContent "string2\n" <> J.markedUpContent "haskell" "foo :: Int" + `shouldBe` J.MarkupContent J.MkMarkdown "string2\n\n```haskell\nfoo :: Int\n```\n" + +-- --------------------------------------------------------------------- diff --git a/test/URIFilePathSpec.hs b/test/URIFilePathSpec.hs new file mode 100644 --- /dev/null +++ b/test/URIFilePathSpec.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE OverloadedStrings #-} +module URIFilePathSpec where + +import Control.Monad (when) +import Data.List +import Data.Text (Text, pack) +import Language.LSP.Types + +import Network.URI +import Test.Hspec +import Test.QuickCheck +import qualified System.FilePath.Windows as FPW +import System.FilePath (normalise) +import qualified System.Info +-- --------------------------------------------------------------------- + +isWindows :: Bool +isWindows = System.Info.os == "mingw32" + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Platform aware URI file path functions" platformAwareUriFilePathSpec + describe "URI file path functions" uriFilePathSpec + describe "URI normalization functions" uriNormalizeSpec + describe "Normalized file path functions" normalizedFilePathSpec + +windowsOS :: String +windowsOS = "mingw32" + +testPosixUri :: Uri +testPosixUri = Uri $ pack "file:///home/myself/example.hs" + +testPosixFilePath :: FilePath +testPosixFilePath = "/home/myself/example.hs" + +relativePosixFilePath :: FilePath +relativePosixFilePath = "myself/example.hs" + +testWindowsUri :: Uri +testWindowsUri = Uri $ pack "file:///c:/Users/myself/example.hs" + +testWindowsFilePath :: FilePath +testWindowsFilePath = "c:\\Users\\myself\\example.hs" + +platformAwareUriFilePathSpec :: Spec +platformAwareUriFilePathSpec = do + it "converts a URI to a POSIX file path" $ do + let theFilePath = platformAwareUriToFilePath "posix" testPosixUri + theFilePath `shouldBe` Just testPosixFilePath + + it "converts a POSIX file path to a URI" $ do + let theUri = platformAwareFilePathToUri "posix" testPosixFilePath + theUri `shouldBe` testPosixUri + + it "converts a URI to a Windows file path" $ do + let theFilePath = platformAwareUriToFilePath windowsOS testWindowsUri + theFilePath `shouldBe` Just testWindowsFilePath + + it "converts a Windows file path to a URI" $ do + let theUri = platformAwareFilePathToUri windowsOS testWindowsFilePath + theUri `shouldBe` testWindowsUri + + it "converts a POSIX file path to a URI" $ do + let theFilePath = platformAwareFilePathToUri "posix" "./Functional.hs" + theFilePath `shouldBe` (Uri "file://./Functional.hs") + + it "converts a Windows file path to a URI" $ do + let theFilePath = platformAwareFilePathToUri windowsOS "./Functional.hs" + theFilePath `shouldBe` (Uri "file:///./Functional.hs") + + it "converts a Windows file path to a URI" $ do + let theFilePath = platformAwareFilePathToUri windowsOS "c:/Functional.hs" + theFilePath `shouldBe` (Uri "file:///c:/Functional.hs") + + it "converts a POSIX file path to a URI and back" $ do + let theFilePath = platformAwareFilePathToUri "posix" "./Functional.hs" + theFilePath `shouldBe` (Uri "file://./Functional.hs") + let Just (URI scheme' auth' path' query' frag') = parseURI "file://./Functional.hs" + (scheme',auth',path',query',frag') `shouldBe` + ("file:" + ,Just (URIAuth {uriUserInfo = "", uriRegName = ".", uriPort = ""}) -- AZ: Seems odd + ,"/Functional.hs" + ,"" + ,"") + Just "./Functional.hs" `shouldBe` platformAwareUriToFilePath "posix" theFilePath + + it "converts a Posix file path to a URI and back" $ property $ forAll genPosixFilePath $ \fp -> do + let uri = platformAwareFilePathToUri "posix" fp + platformAwareUriToFilePath "posix" uri `shouldBe` Just fp + + it "converts a Windows file path to a URI and back" $ property $ forAll genWindowsFilePath $ \fp -> do + let uri = platformAwareFilePathToUri windowsOS fp + -- We normalise to account for changes in the path separator. + -- But driver letters are *not* normalized so we skip them + when (not $ "c:" `isPrefixOf` fp) $ + platformAwareUriToFilePath windowsOS uri `shouldBe` Just (FPW.normalise fp) + + it "converts a relative POSIX file path to a URI and back" $ do + let uri = platformAwareFilePathToUri "posix" relativePosixFilePath + uri `shouldBe` Uri "file://myself/example.hs" + let back = platformAwareUriToFilePath "posix" uri + back `shouldBe` Just relativePosixFilePath + + +testUri :: Uri +testUri | isWindows = Uri "file:///C:/Users/myself/example.hs" + | otherwise = Uri "file:///home/myself/example.hs" + +testFilePath :: FilePath +testFilePath | isWindows = "C:\\Users\\myself\\example.hs" + | otherwise = "/home/myself/example.hs" + +withCurrentDirFilePath :: FilePath +withCurrentDirFilePath | isWindows = "C:\\Users\\.\\myself\\.\\.\\example.hs" + | otherwise = "/home/./myself/././example.hs" + +fromRelativefilePathUri :: Uri +fromRelativefilePathUri | isWindows = Uri "file:///myself/example.hs" + | otherwise = Uri "file://myself/example.hs" + +relativeFilePath :: FilePath +relativeFilePath | isWindows = "myself\\example.hs" + | otherwise = "myself/example.hs" + +withLowerCaseDriveLetterFilePath :: FilePath +withLowerCaseDriveLetterFilePath = "c:\\Users\\.\\myself\\.\\.\\example.hs" + +withInitialCurrentDirUriStr :: String +withInitialCurrentDirUriStr | isWindows = "file:///Functional.hs" + | otherwise = "file://Functional.hs" + +withInitialCurrentDirUriParts :: (String, Maybe URIAuth, String, String, String) +withInitialCurrentDirUriParts + | isWindows = + ("file:" + ,Just (URIAuth {uriUserInfo = "", uriRegName = "", uriPort = ""}) -- JNS: And asymmetrical + ,"/Functional.hs","","") + | otherwise = + ("file:" + ,Just (URIAuth {uriUserInfo = "", uriRegName = "Functional.hs", uriPort = ""}) -- AZ: Seems odd + ,"","","") + +withInitialCurrentDirFilePath :: FilePath +withInitialCurrentDirFilePath | isWindows = ".\\Functional.hs" + | otherwise = "./Functional.hs" + +noNormalizedUriTxt :: Text +noNormalizedUriTxt | isWindows = "file:///c:/Users/./myself/././example.hs" + | otherwise = "file:///home/./myself/././example.hs" + +noNormalizedUri :: Uri +noNormalizedUri = Uri noNormalizedUriTxt + +uriFilePathSpec :: Spec +uriFilePathSpec = do + it "converts a URI to a file path" $ do + let theFilePath = uriToFilePath testUri + theFilePath `shouldBe` Just testFilePath + + it "converts a file path to a URI" $ do + let theUri = filePathToUri testFilePath + theUri `shouldBe` testUri + + it "removes unnecesary current directory paths" $ do + let theUri = filePathToUri withCurrentDirFilePath + theUri `shouldBe` testUri + + when isWindows $ + it "make the drive letter upper case when converting a Windows file path to a URI" $ do + let theUri = filePathToUri withLowerCaseDriveLetterFilePath + theUri `shouldBe` testUri + + it "converts a file path to a URI and back" $ property $ forAll genFilePath $ \fp -> do + let uri = filePathToUri fp + uriToFilePath uri `shouldBe` Just (normalise fp) + + it "converts a relative file path to a URI and back" $ do + let uri = filePathToUri relativeFilePath + uri `shouldBe` fromRelativefilePathUri + let back = uriToFilePath uri + back `shouldBe` Just relativeFilePath + + it "converts a file path with initial current dir to a URI and back" $ do + let uri = filePathToUri withInitialCurrentDirFilePath + uri `shouldBe` (Uri (pack withInitialCurrentDirUriStr)) + let Just (URI scheme' auth' path' query' frag') = parseURI withInitialCurrentDirUriStr + (scheme',auth',path',query',frag') `shouldBe` withInitialCurrentDirUriParts + Just "Functional.hs" `shouldBe` uriToFilePath uri + +uriNormalizeSpec :: Spec +uriNormalizeSpec = do + + it "ignores differences in percent-encoding" $ property $ \uri -> + toNormalizedUri (Uri $ pack $ escapeURIString isUnescapedInURI uri) `shouldBe` + toNormalizedUri (Uri $ pack $ escapeURIString (const False) uri) + + it "ignores differences in percent-encoding (examples)" $ do + toNormalizedUri (Uri $ pack "http://server/path%C3%B1?param=%C3%B1") `shouldBe` + toNormalizedUri (Uri $ pack "http://server/path%c3%b1?param=%c3%b1") + toNormalizedUri (Uri $ pack "file:///path%2A") `shouldBe` + toNormalizedUri (Uri $ pack "file:///path%2a") + + it "normalizes uri file path when converting from uri to normalized uri" $ do + let (NormalizedUri _ uri) = toNormalizedUri noNormalizedUri + let (Uri nuri) = testUri + uri `shouldBe` nuri + + it "converts a file path with reserved uri chars to a normalized URI and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "path;part#fragmen?param=val" + let nuri = toNormalizedUri (filePathToUri fp) + uriToFilePath (fromNormalizedUri nuri) `shouldBe` Just fp + + it "converts a file path with substrings that looks like uri escaped chars and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "ca%C3%B1a" + let nuri = toNormalizedUri (filePathToUri fp) + uriToFilePath (fromNormalizedUri nuri) `shouldBe` Just fp + + it "converts a file path to a normalized URI and back" $ property $ forAll genFilePath $ \fp -> do + let nuri = toNormalizedUri (filePathToUri fp) + case uriToFilePath (fromNormalizedUri nuri) of + Just nfp -> nfp `shouldBe` (normalise fp) + Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now + +genFilePath :: Gen FilePath +genFilePath | isWindows = genWindowsFilePath + | otherwise = genPosixFilePath + +genWindowsFilePath :: Gen FilePath +genWindowsFilePath = do + segments <- listOf1 pathSegment + pathSep <- elements ['/', '\\'] + driveLetter <- elements ["C:", "c:"] + pure (driveLetter <> [pathSep] <> intercalate [pathSep] segments) + where pathSegment = listOf1 (genValidUnicodeChar `suchThat` (`notElem` ['/', '\\', ':'])) + +genPosixFilePath :: Gen FilePath +genPosixFilePath = do + segments <- listOf1 pathSegment + pure ("/" <> intercalate "/" segments) + where pathSegment = listOf1 (genValidUnicodeChar `suchThat` (`notElem` ['/'])) + +genValidUnicodeChar :: Gen Char +genValidUnicodeChar = arbitraryUnicodeChar `suchThat` isCharacter + where isCharacter x = x /= '\65534' && x /= '\65535' + +normalizedFilePathSpec :: Spec +normalizedFilePathSpec = do + it "makes file path normalized" $ property $ forAll genFilePath $ \fp -> do + let nfp = toNormalizedFilePath fp + fromNormalizedFilePath nfp `shouldBe` (normalise fp) + + it "converts to a normalized uri and back" $ property $ forAll genFilePath $ \fp -> do + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + case uriToNormalizedFilePath nuri of + Just nfp -> fromNormalizedFilePath nfp `shouldBe` (normalise fp) + Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now + + it "converts a file path with reserved uri chars to a normalized URI and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "path;part#fragmen?param=val" + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp + + it "converts a file path with substrings that looks like uri escaped chars and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "ca%C3%B1a" + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp + + it "creates the same NormalizedUri than the older implementation" $ property $ forAll genFilePath $ \fp -> do + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + let oldNuri = toNormalizedUri (filePathToUri fp) + nuri `shouldBe` oldNuri diff --git a/test/VspSpec.hs b/test/VspSpec.hs new file mode 100644 --- /dev/null +++ b/test/VspSpec.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE OverloadedStrings #-} +module VspSpec where + + +import Data.String +import qualified Data.Rope.UTF16 as Rope +import Language.LSP.VFS +import qualified Language.LSP.Types as J +import qualified Data.Text as T + +import Test.Hspec + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "VSP functions" vspSpec + +-- -- |Used when running from ghci, and it sets the current directory to ./tests +-- tt :: IO () +-- tt = do +-- cd ".." +-- hspec spec + +-- --------------------------------------------------------------------- + + +mkRange :: Int -> Int -> Int -> Int -> Maybe J.Range +mkRange ls cs le ce = Just $ J.Range (J.Position ls cs) (J.Position le ce) + +vfsFromText :: T.Text -> VirtualFile +vfsFromText text = VirtualFile 0 0 (Rope.fromText text) + +-- --------------------------------------------------------------------- + +vspSpec :: Spec +vspSpec = do + describe "applys changes in order" $ do + it "handles vscode style undos" $ do + let orig = "abc" + changes = + [ J.TextDocumentContentChangeEvent (mkRange 0 2 0 3) Nothing "" + , J.TextDocumentContentChangeEvent (mkRange 0 1 0 2) Nothing "" + , J.TextDocumentContentChangeEvent (mkRange 0 0 0 1) Nothing "" + ] + applyChanges orig changes `shouldBe` "" + it "handles vscode style redos" $ do + let orig = "" + changes = + [ J.TextDocumentContentChangeEvent (mkRange 0 1 0 1) Nothing "a" + , J.TextDocumentContentChangeEvent (mkRange 0 2 0 2) Nothing "b" + , J.TextDocumentContentChangeEvent (mkRange 0 3 0 3) Nothing "c" + ] + applyChanges orig changes `shouldBe` "abc" + + -- --------------------------------- + + describe "deletes characters" $ do + it "deletes characters within a line" $ do + -- based on vscode log + let + orig = unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + new = applyChange (fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 2 1 2 5) (Just 4) "" + lines (Rope.toString new) `shouldBe` + [ "abcdg" + , "module Foo where" + , "-oo" + , "foo :: Int" + ] + + it "deletes characters within a line (no len)" $ do + let + orig = unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + new = applyChange (fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 2 1 2 5) Nothing "" + lines (Rope.toString new) `shouldBe` + [ "abcdg" + , "module Foo where" + , "-oo" + , "foo :: Int" + ] + + -- --------------------------------- + + it "deletes one line" $ do + -- based on vscode log + let + orig = unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + new = applyChange (fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 2 0 3 0) (Just 8) "" + lines (Rope.toString new) `shouldBe` + [ "abcdg" + , "module Foo where" + , "foo :: Int" + ] + + it "deletes one line(no len)" $ do + -- based on vscode log + let + orig = unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + new = applyChange (fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 2 0 3 0) Nothing "" + lines (Rope.toString new) `shouldBe` + [ "abcdg" + , "module Foo where" + , "foo :: Int" + ] + -- --------------------------------- + + it "deletes two lines" $ do + -- based on vscode log + let + orig = unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + ] + new = applyChange (fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 1 0 3 0) (Just 19) "" + lines (Rope.toString new) `shouldBe` + [ "module Foo where" + , "foo = bb" + ] + + it "deletes two lines(no len)" $ do + -- based on vscode log + let + orig = unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + ] + new = applyChange (fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 1 0 3 0) Nothing "" + lines (Rope.toString new) `shouldBe` + [ "module Foo where" + , "foo = bb" + ] + -- --------------------------------- + + describe "adds characters" $ do + it "adds one line" $ do + -- based on vscode log + let + orig = unlines + [ "abcdg" + , "module Foo where" + , "foo :: Int" + ] + new = applyChange (fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 1 16 1 16) (Just 0) "\n-- fooo" + lines (Rope.toString new) `shouldBe` + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + + -- --------------------------------- + + it "adds two lines" $ do + -- based on vscode log + let + orig = unlines + [ "module Foo where" + , "foo = bb" + ] + new = applyChange (fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 1 8 1 8) Nothing "\n-- fooo\nfoo :: Int" + lines (Rope.toString new) `shouldBe` + [ "module Foo where" + , "foo = bb" + , "-- fooo" + , "foo :: Int" + ] + + -- --------------------------------- + + describe "changes characters" $ do + it "removes end of a line" $ do + -- based on vscode log + let + orig = unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] + -- new = changeChars (fromString orig) (J.Position 7 0) (J.Position 7 8) "baz =" + new = applyChange (fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 7 0 7 8) (Just 8) "baz =" + lines (Rope.toString new) `shouldBe` + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz =" + , " putStrLn \"hello world\"" + ] + it "removes end of a line(no len)" $ do + -- based on vscode log + let + orig = unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] + -- new = changeChars (fromString orig) (J.Position 7 0) (J.Position 7 8) "baz =" + new = applyChange (fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 7 0 7 8) Nothing "baz =" + lines (Rope.toString new) `shouldBe` + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz =" + , " putStrLn \"hello world\"" + ] + it "indexes using utf-16 code units" $ do + let + orig = unlines + [ "a𐐀b" + , "a𐐀b" + ] + new = applyChange (fromString orig) + $ J.TextDocumentContentChangeEvent (mkRange 1 0 1 3) (Just 3) "𐐀𐐀" + lines (Rope.toString new) `shouldBe` + [ "a𐐀b" + , "𐐀𐐀b" + ] + + -- --------------------------------- + + describe "LSP utilities" $ do + it "splits at a line" $ do + let + orig = unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] + (left,right) = Rope.splitAtLine 4 (fromString orig) + + lines (Rope.toString left) `shouldBe` + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + ] + lines (Rope.toString right) `shouldBe` + [ "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] + + -- --------------------------------- + + it "getCompletionPrefix" $ do + let + orig = T.unlines + [ "{-# ings #-}" + , "import Data.List" + ] + pp4 <- getCompletionPrefix (J.Position 0 4) (vfsFromText orig) + pp4 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "" (J.Position 0 4)) + + pp5 <- getCompletionPrefix (J.Position 0 5) (vfsFromText orig) + pp5 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "i" (J.Position 0 5)) + + pp6 <- getCompletionPrefix (J.Position 0 6) (vfsFromText orig) + pp6 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "in" (J.Position 0 6)) + + pp14 <- getCompletionPrefix (J.Position 1 14) (vfsFromText orig) + pp14 `shouldBe` Just (PosPrefixInfo "import Data.List" "Data" "Li" (J.Position 1 14)) + + pp00 <- getCompletionPrefix (J.Position 0 0) (vfsFromText orig) + pp00 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "" (J.Position 0 0)) diff --git a/test/WorkspaceEditSpec.hs b/test/WorkspaceEditSpec.hs new file mode 100644 --- /dev/null +++ b/test/WorkspaceEditSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +module WorkspaceEditSpec where + +import Test.Hspec +import Language.LSP.Types + +spec :: Spec +spec = do + describe "applyTextEdit" $ do + it "inserts text" $ + let te = TextEdit (Range (Position 1 2) (Position 1 2)) "foo" + in applyTextEdit te "lorem\nipsum\ndolor" `shouldBe` "lorem\nipfoosum\ndolor" + it "deletes text" $ + let te = TextEdit (Range (Position 0 2) (Position 1 2)) "" + in applyTextEdit te "lorem\nipsum\ndolor" `shouldBe` "losum\ndolor" + it "edits a multiline text" $ + let te = TextEdit (Range (Position 1 0) (Position 2 0)) "slorem" + in applyTextEdit te "lorem\nipsum\ndolor" `shouldBe` "lorem\nsloremdolor" + + describe "editTextEdit" $ + it "edits a multiline text edit" $ + let orig = TextEdit (Range (Position 1 1) (Position 2 2)) "hello\nworld" + inner = TextEdit (Range (Position 0 3) (Position 1 3)) "ios\ngo" + expected = TextEdit (Range (Position 1 1) (Position 2 2)) "helios\ngold" + in editTextEdit orig inner `shouldBe` expected