lsp (empty) → 1.0.0.0
raw patch · 23 files changed
+3680/−0 lines, 23 filesdep +QuickCheckdep +aesondep +asyncsetup-changed
Dependencies added: QuickCheck, aeson, async, attoparsec, base, bytestring, containers, data-default, dependent-map, directory, filepath, hashable, hslogger, hspec, lens, lsp, lsp-types, mtl, network-uri, quickcheck-instances, random, rope-utf16-splay, scientific, sorted-list, stm, text, time, transformers, unliftio, unliftio-core, unordered-containers, uuid
Files
- ChangeLog.md +358/−0
- LICENSE +20/−0
- README.md +90/−0
- Setup.hs +2/−0
- example/Reactor.hs +275/−0
- example/Simple.hs +44/−0
- lsp.cabal +155/−0
- src/Language/LSP/Diagnostics.hs +97/−0
- src/Language/LSP/Server.hs +63/−0
- src/Language/LSP/Server/Control.hs +179/−0
- src/Language/LSP/Server/Core.hs +754/−0
- src/Language/LSP/Server/Processing.hs +369/−0
- test/CapabilitiesSpec.hs +16/−0
- test/DiagnosticsSpec.hs +269/−0
- test/JsonSpec.hs +175/−0
- test/Main.hs +22/−0
- test/MethodSpec.hs +90/−0
- test/ServerCapabilitiesSpec.hs +33/−0
- test/Spec.hs +9/−0
- test/TypesSpec.hs +30/−0
- test/URIFilePathSpec.hs +278/−0
- test/VspSpec.hs +327/−0
- test/WorkspaceEditSpec.hs +25/−0
+ ChangeLog.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,90 @@+[](https://circleci.com/gh/alanz/lsp/tree/master)+[](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+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Reactor.hs view
@@ -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)+ ]++-- ---------------------------------------------------------------------
+ example/Simple.hs view
@@ -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+ }
+ lsp.cabal view
@@ -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
+ src/Language/LSP/Diagnostics.hs view
@@ -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))++-- ---------------------------------------------------------------------
+ src/Language/LSP/Server.hs view
@@ -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
+ src/Language/LSP/Server/Control.hs view
@@ -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"++
+ src/Language/LSP/Server/Core.hs view
@@ -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
+ src/Language/LSP/Server/Processing.hs view
@@ -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}++-- ---------------------------------------------------------------------+
+ test/CapabilitiesSpec.hs view
@@ -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
+ test/DiagnosticsSpec.hs view
@@ -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"+ ]))++ -- ---------------------------------
+ test/JsonSpec.hs view
@@ -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+ +-- ---------------------------------------------------------------------
+ test/Main.hs view
@@ -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
+ test/MethodSpec.hs view
@@ -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)++ -- ---------------------------------
+ test/ServerCapabilitiesSpec.hs view
@@ -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\"}]"
+ test/Spec.hs view
@@ -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++-}
+ test/TypesSpec.hs view
@@ -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"++-- ---------------------------------------------------------------------
+ test/URIFilePathSpec.hs view
@@ -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
+ test/VspSpec.hs view
@@ -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))
+ test/WorkspaceEditSpec.hs view
@@ -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