lsp-types 1.1.0.0 → 1.2.0.0

raw patch · 24 files changed

+858/−378 lines, 24 filesdep ~lenssetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: lens

API changes (from Hackage documentation)

Files

• ChangeLog.md +18/−1
• README.md +6/−2
• Setup.hs +0/−2
• lsp-types.cabal +5/−3
• src/Data/IxMap.hs +4/−3
• src/Language/LSP/Types.hs +2/−0
• src/Language/LSP/Types/Capabilities.hs +28/−4
• src/Language/LSP/Types/CodeAction.hs +38/−3
• src/Language/LSP/Types/Completion.hs +91/−10
• src/Language/LSP/Types/DocumentSymbol.hs +46/−4
• src/Language/LSP/Types/Hover.hs +2/−17
• src/Language/LSP/Types/Initialize.hs +0/−2
• src/Language/LSP/Types/Lens.hs +12/−0
• src/Language/LSP/Types/LspId.hs +13/−7
• src/Language/LSP/Types/Message.hs +10/−259
• src/Language/LSP/Types/Parsing.hs +323/−0
• src/Language/LSP/Types/Progress.hs +9/−26
• src/Language/LSP/Types/Rename.hs +30/−0
• src/Language/LSP/Types/SignatureHelp.hs +64/−11
• src/Language/LSP/Types/TextDocument.hs +1/−1
• src/Language/LSP/Types/Utils.hs +5/−0
• src/Language/LSP/Types/WorkspaceEdit.hs +114/−7
• src/Language/LSP/Types/WorkspaceSymbol.hs +14/−0
• src/Language/LSP/VFS.hs +23/−16

@@ -1,4 +1,21 @@-# Revision history for haskell-lsp-types+# Revision history for lsp-types++## 1.2.0.0++* Prevent crashing when optional fields are missing (@anka-213)+* Use StrictData (@wz1000)+* Add MarkupContent in SignatureHelp types (@michaelpj)+* Add activeParameter support in SignatureInformation (@michaelpj)+* Add label offset support in SignatureHelp (@michaelpj)+* Add some documentation comments to SignatureHelp types (@michaelpj)+* Add support for InsertReplaceEdit (@michaelpj)+* Add support for InsertTextMode (@michaelpj)+* Add resolveSupport (@michaelpj)+* Fix applying a TextEdit past the end of the document (#271) (@michaelpj)+* Use Empty instead of () as progress create response (#295) (@wz1000)+* Add tag support for DocumentSymbol, SymbolInformation, and document symbol provider label (#301) (@michaelpj)+* Support change annotations (#302) (@michaelpj)+* Add some more missing lenses (#307) (@michaelpj)  ## 1.1.0.0 

@@ -3,11 +3,15 @@ # lsp-types Haskell library for the data types for Microsoft Language Server Protocol +It is part of the [lsp](https://github.com/haskell/lsp) family of+packages, along with [lsp](https://hackage.haskell.org/package/lsp)+and [lsp-test](https://hackage.haskell.org/package/lsp-test)+ ## Useful links +- https://github.com/haskell/lsp - https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md  ## Other resource -See #haskell-ide-engine on IRC freenode-+See #haskell-language-server on IRC freenode

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,11 +1,11 @@ name:                lsp-types-version:             1.1.0.0+version:             1.2.0.0 synopsis:            Haskell library for the Microsoft Language Server Protocol, data types  description:         An implementation of the types to allow language implementors to                      support the Language Server Protocol for their specific language. -homepage:            https://github.com/alanz/lsp+homepage:            https://github.com/haskell/lsp license:             MIT license-file:        LICENSE author:              Alan Zimmerman@@ -48,6 +48,7 @@                      , Language.LSP.Types.MarkupContent                      , Language.LSP.Types.Method                      , Language.LSP.Types.Message+                     , Language.LSP.Types.Parsing                      , Language.LSP.Types.Progress                      , Language.LSP.Types.Registration                      , Language.LSP.Types.References@@ -91,7 +92,8 @@                      , unordered-containers   hs-source-dirs:      src   default-language:    Haskell2010+  default-extensions: StrictData  source-repository head   type:     git-  location: https://github.com/alanz/lsp+  location: https://github.com/haskell/lsp

@@ -3,10 +3,11 @@ {-# LANGUAGE RankNTypes       #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns     #-}+{-# LANGUAGE BangPatterns     #-}  module Data.IxMap where -import qualified Data.Map as M+import qualified Data.Map.Strict as M import Data.Some import Data.Kind import Unsafe.Coerce@@ -36,5 +37,5 @@ pickFromIxMap :: IxOrd k => k m -> IxMap k f -> (Maybe (f m), IxMap k f) pickFromIxMap i (IxMap m) =   case M.updateLookupWithKey (\_ _ -> Nothing) (toBase i) m of-    (Nothing,m') -> (Nothing,IxMap m')-    (Just (Some k),m') -> (Just (unsafeCoerce k),IxMap m')+    (Nothing,!m') -> (Nothing,IxMap m')+    (Just (Some k),!m') -> (Just (unsafeCoerce k),IxMap m')

@@ -24,6 +24,7 @@   , module Language.LSP.Types.MarkupContent   , module Language.LSP.Types.Method   , module Language.LSP.Types.Message+  , module Language.LSP.Types.Parsing   , module Language.LSP.Types.Progress   , module Language.LSP.Types.References   , module Language.LSP.Types.Registration@@ -67,6 +68,7 @@ import           Language.LSP.Types.MarkupContent import           Language.LSP.Types.Method import           Language.LSP.Types.Message+import           Language.LSP.Types.Parsing import           Language.LSP.Types.Progress import           Language.LSP.Types.References import           Language.LSP.Types.Registration

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module Language.LSP.Types.Capabilities   (     module Language.LSP.Types.ClientCapabilities@@ -41,7 +42,9 @@           (Just (WorkspaceEditClientCapabilities                   (Just True)                   (since 3 13 resourceOperations)-                  Nothing))+                  Nothing+                  (since 3 16 True)+                  (since 3 16 (WorkspaceEditChangeAnnotationClientCapabilities (Just True)))))           (Just (DidChangeConfigurationClientCapabilities dynamicReg))           (Just (DidChangeWatchedFilesClientCapabilities dynamicReg))           (Just symbolCapabilities)@@ -58,10 +61,14 @@     symbolCapabilities = WorkspaceSymbolClientCapabilities       dynamicReg       (since 3 4 symbolKindCapabilities)+      (since 3 16 symbolTagCapabilities)      symbolKindCapabilities =       WorkspaceSymbolKindClientCapabilities (Just sKs) +    symbolTagCapabilities =+      WorkspaceSymbolTagClientCapabilities (Just (List [StDeprecated]))+     sKs       | maj >= 3 && min >= 4 = List (oldSKs ++ newSKs)       | otherwise            = List oldSKs@@ -115,7 +122,7 @@           (Just (CodeLensClientCapabilities dynamicReg))           (Just (DocumentLinkClientCapabilities dynamicReg (since 3 15 True)))           (since 3 6 (DocumentColorClientCapabilities dynamicReg))-          (Just (RenameClientCapabilities dynamicReg (since 3 12 True)))+          (Just (RenameClientCapabilities dynamicReg (since 3 12 True) (since 3 16 PsIdentifier) (since 3 16 True)))           (Just publishDiagnosticsCapabilities)           (since 3 10 foldingRangeCapability)           (since 3 5 (SelectionRangeClientCapabilities dynamicReg))@@ -140,12 +147,15 @@       (Just True)       (since 3 9 True)       (since 3 15 completionItemTagsCapabilities)+      (since 3 16 True)+      (since 3 16 (CompletionItemResolveClientCapabilities (List ["documentation", "details"])))+      (since 3 16 (CompletionItemInsertTextModeClientCapabilities (List [])))      completionItemKindCapabilities =       CompletionItemKindClientCapabilities (Just ciKs)      completionItemTagsCapabilities =-      CompletionItemTagsClientCapabilities (List [ CtDeprecated ])+      CompletionItemTagsClientCapabilities (List [ CitDeprecated ])      ciKs       | maj >= 3 && min >= 4 = List (oldCiKs ++ newCiKs)@@ -190,6 +200,10 @@           dynamicReg           (since 3 8 (CodeActionLiteralSupport caKs))           (since 3 15 True)+          (since 3 16 True)+          (since 3 16 True)+          (since 3 16 (CodeActionResolveClientCapabilities (List [])))+          (since 3 16 True)     caKs = CodeActionKindClientCapabilities               (List [ CodeActionQuickFix                     , CodeActionRefactor@@ -208,17 +222,27 @@      signatureInformationCapability =       SignatureHelpSignatureInformation-        (Just (List [MkPlainText, MkMarkdown])) Nothing+        (Just (List [MkPlainText, MkMarkdown]))+        (Just signatureParameterCapability)+        (since 3 16 True) +    signatureParameterCapability =+      SignatureHelpParameterInformation (since 3 14 True)+     documentSymbolCapability =       DocumentSymbolClientCapabilities         dynamicReg         (since 3 4 documentSymbolKind)         (since 3 10 True)+        (since 3 16 documentSymbolTag)+        (since 3 16 True)      documentSymbolKind =       DocumentSymbolKindClientCapabilities         (Just sKs) -- same as workspace symbol kinds++    documentSymbolTag =+      DocumentSymbolTagClientCapabilities (Just (List [StDeprecated]))      foldingRangeCapability =       FoldingRangeClientCapabilities

@@ -116,6 +116,13 @@  deriveJSON lspOptions ''CodeActionLiteralSupport +data CodeActionResolveClientCapabilities =+  CodeActionResolveClientCapabilities+    { _properties :: List Text -- ^ The properties that a client can resolve lazily.+    } deriving (Show, Read, Eq)++deriveJSON lspOptions ''CodeActionResolveClientCapabilities+ data CodeActionClientCapabilities = CodeActionClientCapabilities   { -- | Whether code action supports dynamic registration.     _dynamicRegistration :: Maybe Bool,@@ -124,7 +131,30 @@     -- Since 3.8.0     _codeActionLiteralSupport :: Maybe CodeActionLiteralSupport,     -- | Whether code action supports the `isPreferred` property. Since LSP 3.15.0-    _isPreferredSupport :: Maybe Bool+    _isPreferredSupport :: Maybe Bool,+    -- | Whether code action supports the `disabled` property.+    --+    -- @since 3.16.0+    _disabledSupport :: Maybe Bool,+    -- | Whether code action supports the `data` property which is+    -- preserved between a `textDocument/codeAction` and a+    -- `codeAction/resolve` request.+    --+    -- @since 3.16.0+    _dataSupport :: Maybe Bool,+    -- | Whether the client supports resolving additional code action+    -- properties via a separate `codeAction/resolve` request.+    --+    -- @since 3.16.0+    _resolveSupport :: Maybe CodeActionResolveClientCapabilities,+    -- | Whether the client honors the change annotations in+    -- text edits and resource operations returned via the+    -- `CodeAction#edit` property by for example presenting+    -- the workspace edit in the user interface and asking+    -- for confirmation.+    --+    -- @since 3.16.0+    _honorsChangeAnnotations :: Maybe Bool   }   deriving (Show, Read, Eq) @@ -133,7 +163,7 @@ -- -------------------------------------  makeExtendingDatatype "CodeActionOptions" [''WorkDoneProgressOptions]-  [("_codeActionKinds", [t| Maybe (List CodeActionKind) |])]+  [("_codeActionKinds", [t| Maybe (List CodeActionKind) |]), ("_resolveProvider", [t| Maybe Bool |]) ] deriveJSON lspOptions ''CodeActionOptions  makeExtendingDatatype "CodeActionRegistrationOptions"@@ -205,7 +235,12 @@     -- | A command this code action executes. If a code action     -- provides an edit and a command, first the edit is     -- executed and then the command.-    _command :: Maybe Command+    _command :: Maybe Command,+    -- | A data entry field that is preserved on a code action between+    -- a `textDocument/codeAction` and a `codeAction/resolve` request.+    --+    -- @since 3.16.0+    _xdata :: Maybe Value   }   deriving (Read, Show, Eq) deriveJSON lspOptions ''CodeAction

@@ -3,7 +3,6 @@ {-# LANGUAGE TemplateHaskell            #-} module Language.LSP.Types.Completion where -import           Control.Applicative import qualified Data.Aeson                    as A import           Data.Aeson.TH import           Data.Scientific                ( Scientific )@@ -15,6 +14,7 @@ import           Language.LSP.Types.TextDocument import           Language.LSP.Types.Utils import           Language.LSP.Types.WorkspaceEdit+import           Language.LSP.Types.Location (Range)  data CompletionItemKind = CiText                         | CiMethod@@ -100,14 +100,16 @@  data CompletionItemTag   -- | Render a completion as obsolete, usually using a strike-out.-  = CtDeprecated+  = CitDeprecated+  | CitUnknown Scientific   deriving (Eq, Ord, Show, Read)  instance A.ToJSON CompletionItemTag where-  toJSON CtDeprecated  = A.Number 1+  toJSON CitDeprecated  = A.Number 1+  toJSON (CitUnknown i) = A.Number i  instance A.FromJSON CompletionItemTag where-  parseJSON (A.Number 1) = pure CtDeprecated+  parseJSON (A.Number 1) = pure CitDeprecated   parseJSON _            = mempty  data CompletionItemTagsClientCapabilities =@@ -118,6 +120,53 @@  deriveJSON lspOptions ''CompletionItemTagsClientCapabilities +data CompletionItemResolveClientCapabilities =+  CompletionItemResolveClientCapabilities+    { -- | The properties that a client can resolve lazily.+      _properties :: List Text+    } deriving (Show, Read, Eq)++deriveJSON lspOptions ''CompletionItemResolveClientCapabilities++{-|+How whitespace and indentation is handled during completion+item insertion.++@since 3.16.0+-}+data InsertTextMode =+  -- | The insertion or replace strings is taken as it is. If the+  -- value is multi line the lines below the cursor will be+  -- inserted using the indentation defined in the string value.+  -- The client will not apply any kind of adjustments to the+  -- string.+  AsIs+  -- | The editor adjusts leading whitespace of new lines so that+  -- they match the indentation up to the cursor of the line for+  -- which the item is accepted.+  --+  -- Consider a line like this: <2tabs><cursor><3tabs>foo. Accepting a+  -- multi line completion item is indented using 2 tabs and all+  -- following lines inserted will be indented using 2 tabs as well.+  | AdjustIndentation+  deriving (Read,Show,Eq)++instance A.ToJSON InsertTextMode where+  toJSON AsIs              = A.Number 1+  toJSON AdjustIndentation = A.Number 2++instance A.FromJSON InsertTextMode where+  parseJSON (A.Number 1) = pure AsIs+  parseJSON (A.Number 2) = pure AdjustIndentation+  parseJSON _          = mempty++data CompletionItemInsertTextModeClientCapabilities =+  CompletionItemInsertTextModeClientCapabilities+    { _valueSet :: List InsertTextMode+    } deriving (Show, Read, Eq)++deriveJSON lspOptions ''CompletionItemInsertTextModeClientCapabilities+ data CompletionItemClientCapabilities =   CompletionItemClientCapabilities     { -- | Client supports snippets as insert text.@@ -145,7 +194,26 @@       -- supporting tags have to handle unknown tags gracefully. Clients       -- especially need to preserve unknown tags when sending a       -- completion item back to the server in a resolve call.+      --+      -- @since 3.15.0     , _tagSupport :: Maybe CompletionItemTagsClientCapabilities+      -- | Client supports insert replace edit to control different behavior if+      -- completion item is inserted in the text or should replace text.+      --+      -- @since 3.16.0+    , _insertReplaceSupport :: Maybe Bool+      -- | Indicates which properties a client can resolve lazily on a+      -- completion item. Before version 3.16.0 only the predefined properties+      -- `documentation` and `details` could be resolved lazily.+      --+      -- @since 3.16.0+    , _resolveSupport :: Maybe CompletionItemResolveClientCapabilities+      -- | The client supports the `insertTextMode` property on+      -- a completion item to override the whitespace handling mode+      -- as defined by the client (see `insertTextMode`).+      --+      -- @since 3.16.0+    , _insertTextModeSupport :: Maybe CompletionItemInsertTextModeClientCapabilities     } deriving (Show, Read, Eq)  deriveJSON lspOptions ''CompletionItemClientCapabilities@@ -201,13 +269,22 @@                    | CompletionDocMarkup MarkupContent   deriving (Show, Read, Eq) -instance A.ToJSON CompletionDoc where-  toJSON (CompletionDocString x) = A.toJSON x-  toJSON (CompletionDocMarkup x) = A.toJSON x+deriveJSON lspOptionsUntagged ''CompletionDoc -instance A.FromJSON CompletionDoc where-  parseJSON x = CompletionDocString <$> A.parseJSON x <|> CompletionDocMarkup <$> A.parseJSON x+data InsertReplaceEdit =+  InsertReplaceEdit+    { _newText :: Text -- ^ The string to be inserted.+    , _insert  :: Range -- ^ The range if the insert is requested+    , _repalce :: Range -- ^ The range if the replace is requested.+    }+  deriving (Read,Show,Eq)+deriveJSON lspOptions ''InsertReplaceEdit +data CompletionEdit = CompletionEditText TextEdit | CompletionEditInsertReplace InsertReplaceEdit+  deriving (Read,Show,Eq)++deriveJSON lspOptionsUntagged ''CompletionEdit+ data CompletionItem =   CompletionItem     { _label               :: Text -- ^ The label of this completion item. By default also@@ -239,7 +316,11 @@          -- ^ The format of the insert text. The format applies to both the          -- `insertText` property and the `newText` property of a provided          -- `textEdit`.-    , _textEdit            :: Maybe TextEdit+    , _insertTextMode      :: Maybe InsertTextMode+         -- ^ How whitespace and indentation is handled during completion+         -- item insertion. If not provided the client's default value depends on+         -- the @textDocument.completion.insertTextMode@ client capability.+    , _textEdit            :: Maybe CompletionEdit          -- ^ An edit which is applied to a document when selecting this          -- completion. When an edit is provided the value of `insertText` is          -- ignored.

@@ -15,7 +15,9 @@  -- --------------------------------------------------------------------- -makeExtendingDatatype "DocumentSymbolOptions" [''WorkDoneProgressOptions] []+makeExtendingDatatype "DocumentSymbolOptions"+  [''WorkDoneProgressOptions]+  [ ("_label", [t| Maybe Bool |])] deriveJSON lspOptions ''DocumentSymbolOptions  makeExtendingDatatype "DocumentSymbolRegistrationOptions"@@ -123,6 +125,25 @@   parseJSON (Number 26) = pure SkTypeParameter   parseJSON (Number x)  = pure (SkUnknown x)   parseJSON _           = mempty++{-|+Symbol tags are extra annotations that tweak the rendering of a symbol.++@since 3.16.0+-}+data SymbolTag =+  StDeprecated -- ^ Render a symbol as obsolete, usually using a strike-out.+  | StUnknown Scientific+  deriving (Read, Show, Eq)++instance ToJSON SymbolTag where+  toJSON StDeprecated          = Number 1+  toJSON (StUnknown x)   = Number x++instance FromJSON SymbolTag where+  parseJSON (Number  1) = pure StDeprecated+  parseJSON (Number x)  = pure (StUnknown x)+  parseJSON _           = mempty    -- ------------------------------------- @@ -142,6 +163,15 @@  deriveJSON lspOptions ''DocumentSymbolKindClientCapabilities +data DocumentSymbolTagClientCapabilities =+  DocumentSymbolTagClientCapabilities+    { -- | The tags supported by the client.+      _valueSet :: Maybe (List SymbolTag)+    }+  deriving (Show, Read, Eq)++deriveJSON lspOptions ''DocumentSymbolTagClientCapabilities+ data DocumentSymbolClientCapabilities =   DocumentSymbolClientCapabilities     { -- | Whether document symbol supports dynamic registration.@@ -149,11 +179,20 @@       -- | Specific capabilities for the `SymbolKind`.     , _symbolKind :: Maybe DocumentSymbolKindClientCapabilities     , _hierarchicalDocumentSymbolSupport :: Maybe Bool+      -- | The client supports tags on `SymbolInformation`.+      -- Clients supporting tags have to handle unknown tags gracefully.+      --+      -- @since 3.16.0+    , _tagSupport :: Maybe DocumentSymbolTagClientCapabilities+      -- | The client supports an additional label presented in the UI when+      -- registering a document symbol provider.+      --+      -- @since 3.16.0+    , _labelSupport :: Maybe Bool     } deriving (Show, Read, Eq)  deriveJSON lspOptions ''DocumentSymbolClientCapabilities - -- ---------------------------------------------------------------------  -- | Represents programming constructs like variables, classes, interfaces etc.@@ -167,7 +206,8 @@     -- provided the name is used.     , _detail         :: Maybe Text     , _kind           :: SymbolKind -- ^ The kind of this symbol.-    , _deprecated     :: Maybe Bool -- ^ Indicates if this symbol is deprecated.+    , _tags           :: Maybe (List SymbolTag) -- ^ Tags for this document symbol.+    , _deprecated     :: Maybe Bool -- ^ Indicates if this symbol is deprecated. Deprecated, use tags instead.     -- | The range enclosing this symbol not including leading/trailing     -- whitespace but everything else like comments. This information is     -- typically used to determine if the the clients cursor is inside the symbol@@ -190,7 +230,8 @@   SymbolInformation     { _name          :: Text -- ^ The name of this symbol.     , _kind          :: SymbolKind -- ^ The kind of this symbol.-    , _deprecated    :: Maybe Bool -- ^ Indicates if this symbol is deprecated.+    , _tags          :: Maybe (List SymbolTag) -- ^ Tags for this symbol.+    , _deprecated    :: Maybe Bool -- ^ Indicates if this symbol is deprecated. Deprecated, use tags instead.     -- | The location of this symbol. The location's range is used by a tool     -- to reveal the location in the editor. If the symbol is selected in the     -- tool the range's start information is used to position the cursor. So@@ -207,5 +248,6 @@     -- symbols.     , _containerName :: Maybe Text     } deriving (Read,Show,Eq)+{-# DEPRECATED _deprecated "Use tags instead" #-}  deriveJSON lspOptions ''SymbolInformation

@@ -2,8 +2,6 @@ {-# LANGUAGE DuplicateRecordFields      #-} module Language.LSP.Types.Hover where -import           Control.Applicative-import           Data.Aeson import           Data.Aeson.TH import           Data.Text                      ( Text ) @@ -49,12 +47,7 @@   | CodeString LanguageString     deriving (Eq,Read,Show) -instance ToJSON MarkedString where-  toJSON (PlainString x) = toJSON x-  toJSON (CodeString  x) = toJSON x-instance FromJSON MarkedString where-  parseJSON (String t) = pure $ PlainString t-  parseJSON o            = CodeString <$> parseJSON o+deriveJSON lspOptionsUntagged ''MarkedString  -- ------------------------------------- @@ -63,15 +56,7 @@   | HoverContents   MarkupContent   deriving (Read,Show,Eq) -instance ToJSON HoverContents where-  toJSON (HoverContentsMS  x) = toJSON x-  toJSON (HoverContents    x) = toJSON x-instance FromJSON HoverContents where-  parseJSON v@(String _) = HoverContentsMS <$> parseJSON v-  parseJSON v@(Array _)  = HoverContentsMS <$> parseJSON v-  parseJSON v@(Object _) = HoverContents   <$> parseJSON v-                         <|> HoverContentsMS <$> parseJSON v-  parseJSON _ = mempty+deriveJSON lspOptionsUntagged ''HoverContents  -- ------------------------------------- 

@@ -51,8 +51,6 @@   , ("_workspaceFolders",      [t| Maybe (List WorkspaceFolder) |])   ] -{-# DEPRECATED _rootPath "Use _rootUri" #-}- deriveJSON lspOptions ''InitializeParams  data InitializeError =

@@ -7,6 +7,8 @@ {-# LANGUAGE UndecidableInstances   #-} {-# LANGUAGE RankNTypes             #-} {-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE TypeInType             #-}  module Language.LSP.Types.Lens where @@ -113,6 +115,8 @@ makeFieldsNoPrefix ''MarkupContent  -- Completion+makeFieldsNoPrefix ''CompletionDoc+makeFieldsNoPrefix ''CompletionEdit makeFieldsNoPrefix ''CompletionItem makeFieldsNoPrefix ''CompletionContext makeFieldsNoPrefix ''CompletionList@@ -120,9 +124,12 @@ makeFieldsNoPrefix ''CompletionOptions makeFieldsNoPrefix ''CompletionRegistrationOptions makeFieldsNoPrefix ''CompletionItemTagsClientCapabilities+makeFieldsNoPrefix ''CompletionItemResolveClientCapabilities+makeFieldsNoPrefix ''CompletionItemInsertTextModeClientCapabilities makeFieldsNoPrefix ''CompletionItemClientCapabilities makeFieldsNoPrefix ''CompletionItemKindClientCapabilities makeFieldsNoPrefix ''CompletionClientCapabilities+makeFieldsNoPrefix ''InsertReplaceEdit  -- Declaration makeFieldsNoPrefix ''DeclarationClientCapabilities@@ -134,6 +141,7 @@ makeFieldsNoPrefix ''CodeActionKindClientCapabilities makeFieldsNoPrefix ''CodeActionLiteralSupport makeFieldsNoPrefix ''CodeActionClientCapabilities+makeFieldsNoPrefix ''CodeActionResolveClientCapabilities makeFieldsNoPrefix ''CodeActionOptions makeFieldsNoPrefix ''CodeActionRegistrationOptions makeFieldsNoPrefix ''CodeActionContext@@ -190,6 +198,7 @@ makeFieldsNoPrefix ''RenameOptions makeFieldsNoPrefix ''RenameRegistrationOptions makeFieldsNoPrefix ''RenameParams+makeFieldsNoPrefix ''PrepareSupportDefaultBehavior  -- PrepareRename makeFieldsNoPrefix ''PrepareRenameParams@@ -237,6 +246,8 @@  -- WorkspaceEdit makeFieldsNoPrefix ''TextEdit+makeFieldsNoPrefix ''ChangeAnnotation+makeFieldsNoPrefix ''AnnotatedTextEdit makeFieldsNoPrefix ''VersionedTextDocumentIdentifier makeFieldsNoPrefix ''TextDocumentEdit makeFieldsNoPrefix ''CreateFileOptions@@ -247,6 +258,7 @@ makeFieldsNoPrefix ''DeleteFile makeFieldsNoPrefix ''WorkspaceEdit makeFieldsNoPrefix ''WorkspaceEditClientCapabilities+makeFieldsNoPrefix ''WorkspaceEditChangeAnnotationClientCapabilities  -- Workspace Folders makeFieldsNoPrefix ''WorkspaceFolder

@@ -12,7 +12,7 @@ import Language.LSP.Types.Method  -- | Id used for a request, Can be either a String or an Int-data LspId (m :: Method f Request) = IdInt Int | IdString Text+data LspId (m :: Method f Request) = IdInt !Int | IdString !Text   deriving (Show,Read,Eq,Ord)  instance A.ToJSON (LspId m) where@@ -25,15 +25,21 @@   parseJSON _              = mempty  instance IxOrd LspId where-  type Base LspId = Either Int Text-  toBase (IdInt i) = Left i-  toBase (IdString s) = Right s+  type Base LspId = SomeLspId+  toBase = SomeLspId  data SomeLspId where-  SomeLspId :: LspId m -> SomeLspId+  SomeLspId :: !(LspId m) -> SomeLspId  deriving instance Show SomeLspId instance Eq SomeLspId where-  SomeLspId a == SomeLspId b = toBase a == toBase b+  SomeLspId (IdInt a) == SomeLspId (IdInt b) = a == b+  SomeLspId (IdString a) == SomeLspId (IdString b) = a == b+  _ == _ = False instance Ord SomeLspId where-  SomeLspId a `compare` SomeLspId b = toBase a `compare` toBase b+  compare (SomeLspId x) (SomeLspId y) = go x y+    where+      go (IdInt    a) (IdInt    b) = a `compare` b+      go (IdString a) (IdString b) = a `compare` b+      go (IdInt    _) (IdString _) = LT+      go (IdString _) (IdInt    _) = GT

@@ -57,12 +57,8 @@  import Data.Kind import Data.Aeson-import Data.Aeson.Types import Data.Aeson.TH-import Data.GADT.Compare import Data.Text (Text)-import Data.Type.Equality-import Data.Function (on) import GHC.Generics  -- ---------------------------------------------------------------------@@ -201,7 +197,7 @@ -- Server   -- Window   ResponseResult WindowShowMessageRequest      = Maybe MessageActionItem-  ResponseResult WindowWorkDoneProgressCreate  = ()+  ResponseResult WindowWorkDoneProgressCreate  = Empty   -- Capability   ResponseResult ClientRegisterCapability      = Empty   ResponseResult ClientUnregisterCapability    = Empty@@ -237,7 +233,7 @@ deriving instance Show (MessageParams m) => Show (NotificationMessage m)  instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (NotificationMessage m) where-  parseJSON = genericParseJSON lspOptions+  parseJSON = genericParseJSON lspOptions . addNullField "params" instance (ToJSON (MessageParams m)) => ToJSON (NotificationMessage m) where   toJSON     = genericToJSON lspOptions   toEncoding = genericToEncoding lspOptions@@ -253,8 +249,15 @@ deriving instance (Read (SMethod m), Read (MessageParams m)) => Read (RequestMessage m) deriving instance Show (MessageParams m) => Show (RequestMessage m) +-- | Replace a missing field in an object with a null field, to simplify parsing+-- This is a hack to allow other types than Maybe to work like Maybe in allowing the field to be missing.+-- See also this issue: https://github.com/haskell/aeson/issues/646+addNullField :: Text -> Value -> Value+addNullField s (Object o) = Object $ HM.insertWith (\_new old -> old) s Null o+addNullField _ v = v+ instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (RequestMessage m) where-  parseJSON = genericParseJSON lspOptions+  parseJSON = genericParseJSON lspOptions . addNullField "params" instance (ToJSON (MessageParams m), FromJSON (SMethod m)) => ToJSON (RequestMessage m) where   toJSON     = genericToJSON lspOptions   toEncoding = genericToEncoding lspOptions@@ -382,255 +385,3 @@ -- Some helpful type synonyms type ClientMessage (m :: Method FromClient t) = Message m type ServerMessage (m :: Method FromServer t) = Message m---- ------------------------------------------------------------------------ Working with arbritary messages--- -----------------------------------------------------------------------data FromServerMessage' a where-  FromServerMess :: forall t (m :: Method FromServer t) a. SMethod m -> Message m -> FromServerMessage' a-  FromServerRsp  :: forall (m :: Method FromClient Request) a. a m -> ResponseMessage m -> FromServerMessage' a--type FromServerMessage = FromServerMessage' SMethod--instance Eq FromServerMessage where-  (==) = (==) `on` toJSON-instance Show FromServerMessage where-  show = show . toJSON--instance ToJSON FromServerMessage where-  toJSON (FromServerMess m p) = serverMethodJSON m (toJSON p)-  toJSON (FromServerRsp m p) = clientResponseJSON m (toJSON p)--fromServerNot :: forall (m :: Method FromServer Notification).-  Message m ~ NotificationMessage m => NotificationMessage m -> FromServerMessage-fromServerNot m@NotificationMessage{_method=meth} = FromServerMess meth m--fromServerReq :: forall (m :: Method FromServer Request).-  Message m ~ RequestMessage m => RequestMessage m -> FromServerMessage-fromServerReq m@RequestMessage{_method=meth} = FromServerMess meth m--data FromClientMessage' a where-  FromClientMess :: forall t (m :: Method FromClient t) a. SMethod m -> Message m -> FromClientMessage' a-  FromClientRsp  :: forall (m :: Method FromServer Request) a. a m -> ResponseMessage m -> FromClientMessage' a--type FromClientMessage = FromClientMessage' SMethod--instance ToJSON FromClientMessage where-  toJSON (FromClientMess m p) = clientMethodJSON m (toJSON p)-  toJSON (FromClientRsp m p) = serverResponseJSON m (toJSON p)--fromClientNot :: forall (m :: Method FromClient Notification).-  Message m ~ NotificationMessage m => NotificationMessage m -> FromClientMessage-fromClientNot m@NotificationMessage{_method=meth} = FromClientMess meth m--fromClientReq :: forall (m :: Method FromClient Request).-  Message m ~ RequestMessage m => RequestMessage m -> FromClientMessage-fromClientReq m@RequestMessage{_method=meth} = FromClientMess meth m--type LookupFunc f a = forall (m :: Method f Request). LspId m -> Maybe (SMethod m, a m)--{--Message Types we must handle are the following- -Request      | jsonrpc | id | method | params?-Response     | jsonrpc | id |        |         | response? | error?-Notification | jsonrpc |    | method | params?--}--parseServerMessage :: LookupFunc FromClient a -> Value -> Parser (FromServerMessage' a)-parseServerMessage lookupId v@(Object o) = do-  case HM.lookup "method" o of-    Just cmd -> do-      -- Request or Notification-      SomeServerMethod m <- parseJSON cmd-      case splitServerMethod m of-        IsServerNot -> FromServerMess m <$> parseJSON v-        IsServerReq -> FromServerMess m <$> parseJSON v-        IsServerEither-          | HM.member "id" o -- Request-          , SCustomMethod cm <- m ->-              let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Request))-                  in FromServerMess m' <$> parseJSON v-          | SCustomMethod cm <- m ->-              let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Notification))-                  in FromServerMess m' <$> parseJSON v-    Nothing -> do-      case HM.lookup "id" o of-        Just i' -> do-          i <- parseJSON i'-          case lookupId i of-            Just (m,res) -> clientResponseJSON m $ FromServerRsp res <$> parseJSON v-            Nothing -> fail $ unwords ["Failed in looking up response type of", show v]-        Nothing -> fail $ unwords ["Got unexpected message without method or id"]-parseServerMessage _ v = fail $ unwords ["parseServerMessage expected object, got:",show v]--parseClientMessage :: LookupFunc FromServer a -> Value -> Parser (FromClientMessage' a)-parseClientMessage lookupId v@(Object o) = do-  case HM.lookup "method" o of-    Just cmd -> do-      -- Request or Notification-      SomeClientMethod m <- parseJSON cmd-      case splitClientMethod m of-        IsClientNot -> FromClientMess m <$> parseJSON v-        IsClientReq -> FromClientMess m <$> parseJSON v-        IsClientEither-          | HM.member "id" o -- Request-          , SCustomMethod cm <- m ->-              let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Request))-                  in FromClientMess m' <$> parseJSON v-          | SCustomMethod cm <- m ->-              let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Notification))-                  in FromClientMess m' <$> parseJSON v-    Nothing -> do-      case HM.lookup "id" o of-        Just i' -> do-          i <- parseJSON i'-          case lookupId i of-            Just (m,res) -> serverResponseJSON m $ FromClientRsp res <$> parseJSON v-            Nothing -> fail $ unwords ["Failed in looking up response type of", show v]-        Nothing -> fail $ unwords ["Got unexpected message without method or id"]-parseClientMessage _ v = fail $ unwords ["parseClientMessage expected object, got:",show v]---- ------------------------------------------------------------------------ Helper Utilities--- -----------------------------------------------------------------------clientResponseJSON :: SClientMethod m -> (HasJSON (ResponseMessage m) => x) -> x-clientResponseJSON m x = case splitClientMethod m of-  IsClientReq -> x-  IsClientEither -> x--serverResponseJSON :: SServerMethod m -> (HasJSON (ResponseMessage m) => x) -> x-serverResponseJSON m x = case splitServerMethod m of-  IsServerReq -> x-  IsServerEither -> x--clientMethodJSON :: SClientMethod m -> (ToJSON (ClientMessage m) => x) -> x-clientMethodJSON m x =-  case splitClientMethod m of-    IsClientNot -> x-    IsClientReq -> x-    IsClientEither -> x--serverMethodJSON :: SServerMethod m -> (ToJSON (ServerMessage m) => x) -> x-serverMethodJSON m x =-  case splitServerMethod m of-    IsServerNot -> x-    IsServerReq -> x-    IsServerEither -> x--type HasJSON a = (ToJSON a,FromJSON a,Eq a)---- Reify universal properties about Client/Server Messages--data ClientNotOrReq (m :: Method FromClient t) where-  IsClientNot-    :: ( HasJSON (ClientMessage m)-       , Message m ~ NotificationMessage m)-    => ClientNotOrReq (m :: Method FromClient Notification)-  IsClientReq-    :: forall (m :: Method FromClient Request).-    ( HasJSON (ClientMessage m)-    , HasJSON (ResponseMessage m)-    , Message m ~ RequestMessage m)-    => ClientNotOrReq m-  IsClientEither-    :: ClientNotOrReq CustomMethod--data ServerNotOrReq (m :: Method FromServer t) where-  IsServerNot-    :: ( HasJSON (ServerMessage m)-       , Message m ~ NotificationMessage m)-    => ServerNotOrReq (m :: Method FromServer Notification)-  IsServerReq-    :: forall (m :: Method FromServer Request).-    ( HasJSON (ServerMessage m)-    , HasJSON (ResponseMessage m)-    , Message m ~ RequestMessage m)-    => ServerNotOrReq m-  IsServerEither-    :: ServerNotOrReq CustomMethod--splitClientMethod :: SClientMethod m -> ClientNotOrReq m-splitClientMethod SInitialize = IsClientReq-splitClientMethod SInitialized = IsClientNot-splitClientMethod SShutdown = IsClientReq-splitClientMethod SExit = IsClientNot-splitClientMethod SWorkspaceDidChangeWorkspaceFolders = IsClientNot-splitClientMethod SWorkspaceDidChangeConfiguration = IsClientNot-splitClientMethod SWorkspaceDidChangeWatchedFiles = IsClientNot-splitClientMethod SWorkspaceSymbol = IsClientReq-splitClientMethod SWorkspaceExecuteCommand = IsClientReq-splitClientMethod SWindowWorkDoneProgressCancel = IsClientNot-splitClientMethod STextDocumentDidOpen = IsClientNot-splitClientMethod STextDocumentDidChange = IsClientNot-splitClientMethod STextDocumentWillSave = IsClientNot-splitClientMethod STextDocumentWillSaveWaitUntil = IsClientReq-splitClientMethod STextDocumentDidSave = IsClientNot-splitClientMethod STextDocumentDidClose = IsClientNot-splitClientMethod STextDocumentCompletion = IsClientReq-splitClientMethod SCompletionItemResolve = IsClientReq-splitClientMethod STextDocumentHover = IsClientReq-splitClientMethod STextDocumentSignatureHelp = IsClientReq-splitClientMethod STextDocumentDeclaration = IsClientReq-splitClientMethod STextDocumentDefinition = IsClientReq-splitClientMethod STextDocumentTypeDefinition = IsClientReq-splitClientMethod STextDocumentImplementation = IsClientReq-splitClientMethod STextDocumentReferences = IsClientReq-splitClientMethod STextDocumentDocumentHighlight = IsClientReq-splitClientMethod STextDocumentDocumentSymbol = IsClientReq-splitClientMethod STextDocumentCodeAction = IsClientReq-splitClientMethod STextDocumentCodeLens = IsClientReq-splitClientMethod SCodeLensResolve = IsClientReq-splitClientMethod STextDocumentDocumentLink = IsClientReq-splitClientMethod SDocumentLinkResolve = IsClientReq-splitClientMethod STextDocumentDocumentColor = IsClientReq-splitClientMethod STextDocumentColorPresentation = IsClientReq-splitClientMethod STextDocumentFormatting = IsClientReq-splitClientMethod STextDocumentRangeFormatting = IsClientReq-splitClientMethod STextDocumentOnTypeFormatting = IsClientReq-splitClientMethod STextDocumentRename = IsClientReq-splitClientMethod STextDocumentPrepareRename = IsClientReq-splitClientMethod STextDocumentFoldingRange = IsClientReq-splitClientMethod STextDocumentSelectionRange = IsClientReq-splitClientMethod SCancelRequest = IsClientNot-splitClientMethod SCustomMethod{} = IsClientEither--splitServerMethod :: SServerMethod m -> ServerNotOrReq m-splitServerMethod SWindowShowMessage = IsServerNot-splitServerMethod SWindowShowMessageRequest = IsServerReq-splitServerMethod SWindowLogMessage = IsServerNot-splitServerMethod SWindowWorkDoneProgressCreate = IsServerReq-splitServerMethod SProgress = IsServerNot-splitServerMethod STelemetryEvent = IsServerNot-splitServerMethod SClientRegisterCapability = IsServerReq-splitServerMethod SClientUnregisterCapability = IsServerReq-splitServerMethod SWorkspaceWorkspaceFolders = IsServerReq-splitServerMethod SWorkspaceConfiguration = IsServerReq-splitServerMethod SWorkspaceApplyEdit = IsServerReq-splitServerMethod STextDocumentPublishDiagnostics = IsServerNot-splitServerMethod SCancelRequest = IsServerNot-splitServerMethod SCustomMethod{} = IsServerEither---- | Heterogeneous equality on singleton server methods-mEqServer :: SServerMethod m1 -> SServerMethod m2 -> Maybe (m1 :~~: m2)-mEqServer m1 m2 = case (splitServerMethod m1, splitServerMethod m2) of-  (IsServerNot, IsServerNot) -> do-    Refl <- geq m1 m2-    pure HRefl-  (IsServerReq, IsServerReq) -> do-    Refl <- geq m1 m2-    pure HRefl-  _ -> Nothing---- | Heterogeneous equality on singlton client methods-mEqClient :: SClientMethod m1 -> SClientMethod m2 -> Maybe (m1 :~~: m2)-mEqClient m1 m2 = case (splitClientMethod m1, splitClientMethod m2) of-  (IsClientNot, IsClientNot) -> do-    Refl <- geq m1 m2-    pure HRefl-  (IsClientReq, IsClientReq) -> do-    Refl <- geq m1 m2-    pure HRefl-  _ -> Nothing

@@ -0,0 +1,323 @@+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE DuplicateRecordFields      #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE TypeInType                 #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeApplications           #-}+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}++module Language.LSP.Types.Parsing where++import           Language.LSP.Types.LspId+import           Language.LSP.Types.Method+import           Language.LSP.Types.Message+import qualified Data.HashMap.Strict as HM++import Data.Aeson+import Data.Aeson.Types+import Data.GADT.Compare+import Data.Type.Equality+import Data.Function (on)++-- ---------------------------------------------------------------------+-- Working with arbritary messages+-- ---------------------------------------------------------------------++data FromServerMessage' a where+  FromServerMess :: forall t (m :: Method FromServer t) a. SMethod m -> Message m -> FromServerMessage' a+  FromServerRsp  :: forall (m :: Method FromClient Request) a. a m -> ResponseMessage m -> FromServerMessage' a++type FromServerMessage = FromServerMessage' SMethod++instance Eq FromServerMessage where+  (==) = (==) `on` toJSON+instance Show FromServerMessage where+  show = show . toJSON++instance ToJSON FromServerMessage where+  toJSON (FromServerMess m p) = serverMethodJSON m (toJSON p)+  toJSON (FromServerRsp m p) = clientResponseJSON m (toJSON p)++fromServerNot :: forall (m :: Method FromServer Notification).+  Message m ~ NotificationMessage m => NotificationMessage m -> FromServerMessage+fromServerNot m@NotificationMessage{_method=meth} = FromServerMess meth m++fromServerReq :: forall (m :: Method FromServer Request).+  Message m ~ RequestMessage m => RequestMessage m -> FromServerMessage+fromServerReq m@RequestMessage{_method=meth} = FromServerMess meth m++data FromClientMessage' a where+  FromClientMess :: forall t (m :: Method FromClient t) a. SMethod m -> Message m -> FromClientMessage' a+  FromClientRsp  :: forall (m :: Method FromServer Request) a. a m -> ResponseMessage m -> FromClientMessage' a++type FromClientMessage = FromClientMessage' SMethod++instance ToJSON FromClientMessage where+  toJSON (FromClientMess m p) = clientMethodJSON m (toJSON p)+  toJSON (FromClientRsp m p) = serverResponseJSON m (toJSON p)++fromClientNot :: forall (m :: Method FromClient Notification).+  Message m ~ NotificationMessage m => NotificationMessage m -> FromClientMessage+fromClientNot m@NotificationMessage{_method=meth} = FromClientMess meth m++fromClientReq :: forall (m :: Method FromClient Request).+  Message m ~ RequestMessage m => RequestMessage m -> FromClientMessage+fromClientReq m@RequestMessage{_method=meth} = FromClientMess meth m++-- ---------------------------------------------------------------------+-- Parsing+-- ---------------------------------------------------------------------++type LookupFunc f a = forall (m :: Method f Request). LspId m -> Maybe (SMethod m, a m)++{-+Message Types we must handle are the following++Request      | jsonrpc | id | method | params?+Response     | jsonrpc | id |        |         | response? | error?+Notification | jsonrpc |    | method | params?+-}++{-# INLINE parseServerMessage #-}+parseServerMessage :: LookupFunc FromClient a -> Value -> Parser (FromServerMessage' a)+parseServerMessage lookupId v@(Object o) = do+  case HM.lookup "method" o of+    Just cmd -> do+      -- Request or Notification+      SomeServerMethod m <- parseJSON cmd+      case splitServerMethod m of+        IsServerNot -> FromServerMess m <$> parseJSON v+        IsServerReq -> FromServerMess m <$> parseJSON v+        IsServerEither+          | HM.member "id" o -- Request+          , SCustomMethod cm <- m ->+              let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Request))+                  in FromServerMess m' <$> parseJSON v+          | SCustomMethod cm <- m ->+              let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Notification))+                  in FromServerMess m' <$> parseJSON v+    Nothing -> do+      case HM.lookup "id" o of+        Just i' -> do+          i <- parseJSON i'+          case lookupId i of+            Just (m,res) -> clientResponseJSON m $ FromServerRsp res <$> parseJSON v+            Nothing -> fail $ unwords ["Failed in looking up response type of", show v]+        Nothing -> fail $ unwords ["Got unexpected message without method or id"]+parseServerMessage _ v = fail $ unwords ["parseServerMessage expected object, got:",show v]++{-# INLINE parseClientMessage #-}+parseClientMessage :: LookupFunc FromServer a -> Value -> Parser (FromClientMessage' a)+parseClientMessage lookupId v@(Object o) = do+  case HM.lookup "method" o of+    Just cmd -> do+      -- Request or Notification+      SomeClientMethod m <- parseJSON cmd+      case splitClientMethod m of+        IsClientNot -> FromClientMess m <$> parseJSON v+        IsClientReq -> FromClientMess m <$> parseJSON v+        IsClientEither+          | HM.member "id" o -- Request+          , SCustomMethod cm <- m ->+              let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Request))+                  in FromClientMess m' <$> parseJSON v+          | SCustomMethod cm <- m ->+              let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Notification))+                  in FromClientMess m' <$> parseJSON v+    Nothing -> do+      case HM.lookup "id" o of+        Just i' -> do+          i <- parseJSON i'+          case lookupId i of+            Just (m,res) -> serverResponseJSON m $ FromClientRsp res <$> parseJSON v+            Nothing -> fail $ unwords ["Failed in looking up response type of", show v]+        Nothing -> fail $ unwords ["Got unexpected message without method or id"]+parseClientMessage _ v = fail $ unwords ["parseClientMessage expected object, got:",show v]++-- ---------------------------------------------------------------------+-- Helper Utilities+-- ---------------------------------------------------------------------++{-# INLINE clientResponseJSON #-}+clientResponseJSON :: SClientMethod m -> (HasJSON (ResponseMessage m) => x) -> x+clientResponseJSON m x = case splitClientMethod m of+  IsClientReq -> x+  IsClientEither -> x++{-# INLINE serverResponseJSON #-}+serverResponseJSON :: SServerMethod m -> (HasJSON (ResponseMessage m) => x) -> x+serverResponseJSON m x = case splitServerMethod m of+  IsServerReq -> x+  IsServerEither -> x++{-# INLINE clientMethodJSON#-}+clientMethodJSON :: SClientMethod m -> (ToJSON (ClientMessage m) => x) -> x+clientMethodJSON m x =+  case splitClientMethod m of+    IsClientNot -> x+    IsClientReq -> x+    IsClientEither -> x++{-# INLINE serverMethodJSON #-}+serverMethodJSON :: SServerMethod m -> (ToJSON (ServerMessage m) => x) -> x+serverMethodJSON m x =+  case splitServerMethod m of+    IsServerNot -> x+    IsServerReq -> x+    IsServerEither -> x++type HasJSON a = (ToJSON a,FromJSON a,Eq a)++-- Reify universal properties about Client/Server Messages++data ClientNotOrReq (m :: Method FromClient t) where+  IsClientNot+    :: ( HasJSON (ClientMessage m)+       , Message m ~ NotificationMessage m)+    => ClientNotOrReq (m :: Method FromClient Notification)+  IsClientReq+    :: forall (m :: Method FromClient Request).+    ( HasJSON (ClientMessage m)+    , HasJSON (ResponseMessage m)+    , Message m ~ RequestMessage m)+    => ClientNotOrReq m+  IsClientEither+    :: ClientNotOrReq CustomMethod++data ServerNotOrReq (m :: Method FromServer t) where+  IsServerNot+    :: ( HasJSON (ServerMessage m)+       , Message m ~ NotificationMessage m)+    => ServerNotOrReq (m :: Method FromServer Notification)+  IsServerReq+    :: forall (m :: Method FromServer Request).+    ( HasJSON (ServerMessage m)+    , HasJSON (ResponseMessage m)+    , Message m ~ RequestMessage m)+    => ServerNotOrReq m+  IsServerEither+    :: ServerNotOrReq CustomMethod++{-# INLINE splitClientMethod #-}+splitClientMethod :: SClientMethod m -> ClientNotOrReq m+splitClientMethod SInitialize = IsClientReq+splitClientMethod SInitialized = IsClientNot+splitClientMethod SShutdown = IsClientReq+splitClientMethod SExit = IsClientNot+splitClientMethod SWorkspaceDidChangeWorkspaceFolders = IsClientNot+splitClientMethod SWorkspaceDidChangeConfiguration = IsClientNot+splitClientMethod SWorkspaceDidChangeWatchedFiles = IsClientNot+splitClientMethod SWorkspaceSymbol = IsClientReq+splitClientMethod SWorkspaceExecuteCommand = IsClientReq+splitClientMethod SWindowWorkDoneProgressCancel = IsClientNot+splitClientMethod STextDocumentDidOpen = IsClientNot+splitClientMethod STextDocumentDidChange = IsClientNot+splitClientMethod STextDocumentWillSave = IsClientNot+splitClientMethod STextDocumentWillSaveWaitUntil = IsClientReq+splitClientMethod STextDocumentDidSave = IsClientNot+splitClientMethod STextDocumentDidClose = IsClientNot+splitClientMethod STextDocumentCompletion = IsClientReq+splitClientMethod SCompletionItemResolve = IsClientReq+splitClientMethod STextDocumentHover = IsClientReq+splitClientMethod STextDocumentSignatureHelp = IsClientReq+splitClientMethod STextDocumentDeclaration = IsClientReq+splitClientMethod STextDocumentDefinition = IsClientReq+splitClientMethod STextDocumentTypeDefinition = IsClientReq+splitClientMethod STextDocumentImplementation = IsClientReq+splitClientMethod STextDocumentReferences = IsClientReq+splitClientMethod STextDocumentDocumentHighlight = IsClientReq+splitClientMethod STextDocumentDocumentSymbol = IsClientReq+splitClientMethod STextDocumentCodeAction = IsClientReq+splitClientMethod STextDocumentCodeLens = IsClientReq+splitClientMethod SCodeLensResolve = IsClientReq+splitClientMethod STextDocumentDocumentLink = IsClientReq+splitClientMethod SDocumentLinkResolve = IsClientReq+splitClientMethod STextDocumentDocumentColor = IsClientReq+splitClientMethod STextDocumentColorPresentation = IsClientReq+splitClientMethod STextDocumentFormatting = IsClientReq+splitClientMethod STextDocumentRangeFormatting = IsClientReq+splitClientMethod STextDocumentOnTypeFormatting = IsClientReq+splitClientMethod STextDocumentRename = IsClientReq+splitClientMethod STextDocumentPrepareRename = IsClientReq+splitClientMethod STextDocumentFoldingRange = IsClientReq+splitClientMethod STextDocumentSelectionRange = IsClientReq+splitClientMethod SCancelRequest = IsClientNot+splitClientMethod SCustomMethod{} = IsClientEither++{-# INLINE splitServerMethod #-}+splitServerMethod :: SServerMethod m -> ServerNotOrReq m+splitServerMethod SWindowShowMessage = IsServerNot+splitServerMethod SWindowShowMessageRequest = IsServerReq+splitServerMethod SWindowLogMessage = IsServerNot+splitServerMethod SWindowWorkDoneProgressCreate = IsServerReq+splitServerMethod SProgress = IsServerNot+splitServerMethod STelemetryEvent = IsServerNot+splitServerMethod SClientRegisterCapability = IsServerReq+splitServerMethod SClientUnregisterCapability = IsServerReq+splitServerMethod SWorkspaceWorkspaceFolders = IsServerReq+splitServerMethod SWorkspaceConfiguration = IsServerReq+splitServerMethod SWorkspaceApplyEdit = IsServerReq+splitServerMethod STextDocumentPublishDiagnostics = IsServerNot+splitServerMethod SCancelRequest = IsServerNot+splitServerMethod SCustomMethod{} = IsServerEither++-- | Given a witness that two custom methods are of the same type, produce a witness that the methods are the same+data CustomEq m1 m2 where+  CustomEq+    :: (m1 ~ (CustomMethod :: Method f t1), m2 ~ (CustomMethod :: Method f t2))+    => { runCustomEq :: (t1 ~ t2 => m1 :~~: m2) }+    -> CustomEq m1 m2++runEq :: (t1 ~ t2)+      => (SMethod m1 -> SMethod m2 -> Maybe (Either (CustomEq m1 m2) (m1 :~~: m2)))+      -> SMethod (m1 :: Method f t1)+      -> SMethod (m2 :: Method f t2)+      -> Maybe (m1 :~~: m2)+runEq f m1 m2 = do+  res <- f m1 m2+  pure $ case res of+    Right eq -> eq+    Left ceq -> runCustomEq ceq++-- | Heterogeneous equality on singleton server methods+mEqServer :: SServerMethod m1 -> SServerMethod m2 -> Maybe (Either (CustomEq m1 m2) (m1 :~~: m2))+mEqServer m1 m2 = go (splitServerMethod m1) (splitServerMethod m2)+  where+    go IsServerNot IsServerNot = do+      Refl <- geq m1 m2+      pure $ Right HRefl+    go IsServerReq IsServerReq = do+      Refl <- geq m1 m2+      pure $ Right HRefl+    go IsServerEither IsServerEither+      | SCustomMethod c1 <- m1+      , SCustomMethod c2 <- m2+      , c1 == c2+      = Just $ Left $ CustomEq HRefl+    go _ _ = Nothing++-- | Heterogeneous equality on singleton client methods+mEqClient :: SClientMethod m1 -> SClientMethod m2 -> Maybe (Either (CustomEq m1 m2) (m1 :~~: m2))+mEqClient m1 m2 = go (splitClientMethod m1) (splitClientMethod m2)+  where+    go IsClientNot IsClientNot = do+      Refl <- geq m1 m2+      pure $ Right HRefl+    go IsClientReq IsClientReq = do+      Refl <- geq m1 m2+      pure $ Right HRefl+    go IsClientEither IsClientEither+      | SCustomMethod c1 <- m1+      , SCustomMethod c2 <- m2+      , c1 == c2+      = Just $ Left $ CustomEq HRefl+    go _ _ = Nothing

@@ -6,7 +6,6 @@  module Language.LSP.Types.Progress where -import           Control.Applicative import           Control.Monad (unless) import qualified Data.Aeson as A import           Data.Aeson.TH@@ -22,14 +21,7 @@     | ProgressTextToken Text     deriving (Show, Read, Eq, Ord) -instance A.ToJSON ProgressToken where-    toJSON (ProgressNumericToken i) = A.toJSON i-    toJSON (ProgressTextToken t) = A.toJSON t--instance A.FromJSON ProgressToken where-    parseJSON (A.String t) = pure $ ProgressTextToken t-    parseJSON (A.Number i) = ProgressNumericToken <$> A.parseJSON (A.Number i)-    parseJSON v = fail $ "Invalid progress token: " ++ show v+deriveJSON lspOptionsUntagged ''ProgressToken  -- | Parameters for a $/progress notification. data ProgressParams t =@@ -40,23 +32,6 @@  deriveJSON lspOptions ''ProgressParams -data SomeProgressParams-  = Begin WorkDoneProgressBeginParams-  | Report WorkDoneProgressReportParams-  | End WorkDoneProgressEndParams-  deriving Eq--instance A.FromJSON SomeProgressParams where-  parseJSON x =-       (Begin  <$> A.parseJSON x)-   <|> (Report <$> A.parseJSON x)-   <|> (End    <$> A.parseJSON x)--instance A.ToJSON SomeProgressParams where-  toJSON (Begin  x) = A.toJSON x-  toJSON (Report x) = A.toJSON x-  toJSON (End    x) = A.toJSON x- -- | Parameters for 'WorkDoneProgressBeginNotification'. -- -- @since 0.10.0.0@@ -220,6 +195,14 @@       _workDoneToken :: Maybe ProgressToken     } deriving (Read,Show,Eq) deriveJSON lspOptions ''WorkDoneProgressParams++data SomeProgressParams+  = Begin WorkDoneProgressBeginParams+  | Report WorkDoneProgressReportParams+  | End WorkDoneProgressEndParams+  deriving Eq++deriveJSON lspOptionsUntagged ''SomeProgressParams  data PartialResultParams =   PartialResultParams

@@ -3,14 +3,29 @@  module Language.LSP.Types.Rename where +import Data.Aeson import Data.Aeson.TH import Data.Text (Text)+import Data.Scientific (Scientific)  import Language.LSP.Types.Location import Language.LSP.Types.TextDocument import Language.LSP.Types.Progress import Language.LSP.Types.Utils +data PrepareSupportDefaultBehavior =+  PsIdentifier |+  PsUnknown Scientific+  deriving (Read, Show, Eq)++instance ToJSON PrepareSupportDefaultBehavior where+  toJSON PsIdentifier  = Number 1+  toJSON (PsUnknown i) = Number i++instance FromJSON PrepareSupportDefaultBehavior where+  parseJSON (Number 1) = pure PsIdentifier+  parseJSON _          = mempty+ data RenameClientCapabilities =   RenameClientCapabilities     { -- | Whether rename supports dynamic registration.@@ -20,6 +35,21 @@       --       -- Since LSP 3.12.0     , _prepareSupport :: Maybe Bool+      -- | Client supports the default behavior result+      -- (`{ defaultBehavior: boolean }`).+      --+      -- The value indicates the default behavior used by the client.+      --+      -- @since 3.16.0+    , prepareSupportDefaultBehavior :: Maybe PrepareSupportDefaultBehavior+      -- | Whether the client honors the change annotations in+      -- text edits and resource operations returned via the+      -- rename request's workspace edit by for example presenting+      -- the workspace edit in the user interface and asking+      -- for confirmation.+      --+      -- @since 3.16.0+    , honorsChangeAnnotations :: Maybe Bool     } deriving (Show, Read, Eq)  deriveJSON lspOptions ''RenameClientCapabilities

@@ -12,6 +12,7 @@ import Language.LSP.Types.Progress import Language.LSP.Types.TextDocument import Language.LSP.Types.Utils+import Control.Applicative (Alternative((<|>)))  -- ------------------------------------- @@ -33,6 +34,11 @@       _documentationFormat :: Maybe (List MarkupKind)       -- | Client capabilities specific to parameter information.     , _parameterInformation :: Maybe SignatureHelpParameterInformation+      -- | The client supports the `activeParameter` property on+      -- 'SignatureInformation' literal.+      --+      -- @since 3.16.0+    , _activeParameterSuport :: Maybe Bool     }   deriving (Show, Read, Eq) @@ -72,38 +78,83 @@  -- ------------------------------------- +data SignatureHelpDoc = SignatureHelpDocString Text | SignatureHelpDocMarkup MarkupContent+  deriving (Read,Show,Eq)++deriveJSON lspOptionsUntagged ''SignatureHelpDoc++-- -------------------------------------++data ParameterLabel = ParameterLabelString Text | ParameterLabelOffset Int Int+  deriving (Read,Show,Eq)++instance ToJSON ParameterLabel where+  toJSON (ParameterLabelString t) = toJSON t+  toJSON (ParameterLabelOffset l h) = toJSON [l, h]++instance FromJSON ParameterLabel where+  parseJSON x = ParameterLabelString <$> parseJSON x <|> parseInterval x+    where+      parseInterval v@(Array _) = do+        is <- parseJSON v+        case is of+          [l, h] -> pure $ ParameterLabelOffset l h+          _ -> mempty+      parseInterval _ = mempty++-- -------------------------------------++{-| +Represents a parameter of a callable-signature. A parameter can+have a label and a doc-comment.+-} data ParameterInformation =   ParameterInformation-    { _label         :: Text-    , _documentation :: Maybe Text+    { _label         :: ParameterLabel -- ^ The label of this parameter information.+    , _documentation :: Maybe SignatureHelpDoc -- ^ The human-readable doc-comment of this parameter.     } deriving (Read,Show,Eq) deriveJSON lspOptions ''ParameterInformation  -- ------------------------------------- +{-|+Represents the signature of something callable. A signature+can have a label, like a function-name, a doc-comment, and+a set of parameters.+-} data SignatureInformation =   SignatureInformation-    { _label         :: Text-    , _documentation :: Maybe Text-    , _parameters    :: Maybe (List ParameterInformation)+    { _label           :: Text -- ^ The label of the signature.+    , _documentation   :: Maybe SignatureHelpDoc -- ^ The human-readable doc-comment of this signature.+    , _parameters      :: Maybe (List ParameterInformation) -- ^ The parameters of this signature.+    , _activeParameter :: Maybe Int -- ^ The index of the active parameter.     } deriving (Read,Show,Eq)  deriveJSON lspOptions ''SignatureInformation ++{-|+Signature help represents the signature of something+callable. There can be multiple signature but only one+active and only one active parameter.+-} data SignatureHelp =   SignatureHelp-    { _signatures      :: List SignatureInformation-    , _activeSignature :: Maybe Int -- ^ The active signature-    , _activeParameter :: Maybe Int -- ^ The active parameter of the active signature+    { _signatures      :: List SignatureInformation -- ^ One or more signatures.+    , _activeSignature :: Maybe Int -- ^ The active signature.+    , _activeParameter :: Maybe Int -- ^ The active parameter of the active signature.     } deriving (Read,Show,Eq)  deriveJSON lspOptions ''SignatureHelp  -- ------------------------------------- -data SignatureHelpTriggerKind = SHTKInvoked-                              | SHTKTriggerCharacter-                              | SHTKContentChange+-- | How a signature help was triggered.+--+-- @since 3.15.0+data SignatureHelpTriggerKind = SHTKInvoked -- ^ Signature help was invoked manually by the user or by a command.+                              | SHTKTriggerCharacter -- ^ Signature help was triggered by a trigger character.+                              | SHTKContentChange -- ^ Signature help was triggered by the cursor moving or by the document content changing.   deriving (Read,Show,Eq)  instance ToJSON SignatureHelpTriggerKind where@@ -119,6 +170,8 @@  -- | Additional information about the context in which a signature help request -- was triggered.+--+-- @since 3.15.0 data SignatureHelpContext =    SignatureHelpContext     { -- | Action that caused signature help to be triggered.

@@ -162,12 +162,12 @@  deriveJSON lspOptions ''TextDocumentChangeRegistrationOptions -{-# DEPRECATED _rangeLength "Use _range instead" #-} data TextDocumentContentChangeEvent =   TextDocumentContentChangeEvent     { -- | The range of the document that changed.       _range       :: Maybe Range       -- | The optional length of the range that got replaced.+      -- Deprecated, use _range instead     , _rangeLength :: Maybe Int       -- | The new text for the provided range, if provided.       -- Otherwise the new text of the whole document.

@@ -8,6 +8,7 @@   , makeRegHelper   , makeExtendingDatatype   , lspOptions+  , lspOptionsUntagged   ) where  import Control.Monad@@ -115,4 +116,8 @@   modifier "_xdata" = "data"   modifier "_xtype" = "type"   modifier xs = drop 1 xs++-- | Standard options for use when generating JSON instances for an untagged union+lspOptionsUntagged :: Options+lspOptionsUntagged = lspOptions { sumEncoding = UntaggedValue } 

@@ -3,6 +3,7 @@ {-# LANGUAGE TypeOperators              #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Language.LSP.Types.WorkspaceEdit where @@ -13,6 +14,7 @@ import           Data.Maybe                                 (catMaybes) import           Data.Text                                  (Text) import qualified Data.Text                                  as T+import           Data.Hashable  import           Language.LSP.Types.Common import           Language.LSP.Types.Location@@ -30,13 +32,47 @@  deriveJSON lspOptions ''TextEdit +-- --------------------------------------------------------------------- +{-|+Additional information that describes document changes.++@since 3.16.0+-}+data ChangeAnnotation =+  ChangeAnnotation+    { -- | A human-readable string describing the actual change. The string+      -- is rendered prominent in the user interface.+      _label             :: Text+      -- | A flag which indicates that user confirmation is needed+      -- before applying the change.+    , _needsConfirmation :: Maybe Bool+      -- | A human-readable string which is rendered less prominent in+      -- the user interface.+    , _description       :: Maybe Text+    } deriving (Show, Read, Eq)++deriveJSON lspOptions ''ChangeAnnotation++{-|+An identifier referring to a change annotation managed by a workspace+edit.++@since 3.16.0+-}+newtype ChangeAnnotationIdentifier = ChangeAnnotationIdentifierId Text+  deriving (Show, Read, Eq, FromJSON, ToJSON, ToJSONKey, FromJSONKey, Hashable)++makeExtendingDatatype "AnnotatedTextEdit" [''TextEdit]+  [("_annotationId", [t| ChangeAnnotationIdentifier |]) ]+deriveJSON lspOptions ''AnnotatedTextEdit+ -- ---------------------------------------------------------------------  data TextDocumentEdit =   TextDocumentEdit     { _textDocument :: VersionedTextDocumentIdentifier-    , _edits        :: List TextEdit+    , _edits        :: List (TextEdit |? AnnotatedTextEdit)     } deriving (Show, Read, Eq)  deriveJSON lspOptions ''TextDocumentEdit@@ -61,6 +97,10 @@       _uri      :: Uri       -- | Additional options     , _options  :: Maybe CreateFileOptions+      -- | An optional annotation identifer describing the operation.+      --+      -- @since 3.16.0+    , _annotationId  :: Maybe ChangeAnnotationIdentifier     } deriving (Show, Read, Eq)  instance ToJSON CreateFile where@@ -69,6 +109,7 @@         [ Just $ "kind" .= ("create" :: Text)         , Just $ "uri" .= _uri         , ("options" .=) <$> _options+        , ("annotationId" .=) <$> _annotationId         ]  instance FromJSON CreateFile where@@ -78,6 +119,7 @@           $ fail $ "Expected kind \"create\" but got " ++ show kind         _uri <- o .: "uri"         _options <- o .:? "options"+        _annotationId <- o .:? "annotationId"         pure CreateFile{..}  -- Rename file options@@ -100,6 +142,10 @@     , _newUri   :: Uri       -- | Rename options.     , _options  :: Maybe RenameFileOptions+      -- | An optional annotation identifer describing the operation.+      --+      -- @since 3.16.0+    , _annotationId  :: Maybe ChangeAnnotationIdentifier     } deriving (Show, Read, Eq)  instance ToJSON RenameFile where@@ -109,6 +155,7 @@         , Just $ "oldUri" .= _oldUri         , Just $ "newUri" .= _newUri         , ("options" .=) <$> _options+        , ("annotationId" .=) <$> _annotationId         ]  instance FromJSON RenameFile where@@ -119,6 +166,7 @@         _oldUri <- o .: "oldUri"         _newUri <- o .: "newUri"         _options <- o .:? "options"+        _annotationId <- o .:? "annotationId"         pure RenameFile{..}  -- Delete file options@@ -139,6 +187,10 @@       _uri      :: Uri       -- | Delete options.     , _options  :: Maybe DeleteFileOptions+      -- | An optional annotation identifer describing the operation.+      --+      -- @since 3.16.0+    , _annotationId  :: Maybe ChangeAnnotationIdentifier     } deriving (Show, Read, Eq)  instance ToJSON DeleteFile where@@ -147,6 +199,7 @@         [ Just $ "kind" .= ("delete" :: Text)         , Just $ "uri" .= _uri         , ("options" .=) <$> _options+        , ("annotationId" .=) <$> _annotationId         ]  instance FromJSON DeleteFile where@@ -156,9 +209,9 @@           $ fail $ "Expected kind \"delete\" but got " ++ show kind         _uri <- o .: "uri"         _options <- o .:? "options"+        _annotationId <- o .:? "annotationId"         pure DeleteFile{..} - -- ---------------------------------------------------------------------  -- | `TextDocumentEdit |? CreateFile |? RenameFile |? DeleteFile` is a bit mouthful, here's the synonym@@ -167,17 +220,42 @@ -- ---------------------------------------------------------------------  type WorkspaceEditMap = H.HashMap Uri (List TextEdit)+type ChangeAnnotationMap = H.HashMap ChangeAnnotationIdentifier ChangeAnnotation  data WorkspaceEdit =   WorkspaceEdit-    { _changes         :: Maybe WorkspaceEditMap-    , _documentChanges :: Maybe (List DocumentChange)+    {+      -- | Holds changes to existing resources.+      _changes           :: Maybe WorkspaceEditMap+      -- | Depending on the client capability+      -- `workspace.workspaceEdit.resourceOperations` document changes are either+      -- an array of `TextDocumentEdit`s to express changes to n different text+      -- documents where each text document edit addresses a specific version of+      -- a text document. Or it can contain above `TextDocumentEdit`s mixed with+      -- create, rename and delete file / folder operations.+      --+      -- Whether a client supports versioned document edits is expressed via+      -- `workspace.workspaceEdit.documentChanges` client capability.+      --+      -- If a client neither supports `documentChanges` nor+      -- `workspace.workspaceEdit.resourceOperations` then only plain `TextEdit`s+      -- using the `changes` property are supported.+    , _documentChanges   :: Maybe (List DocumentChange)+      -- | A map of change annotations that can be referenced in+      -- `AnnotatedTextEdit`s or create, rename and delete file / folder+      -- operations.+      --+      -- Whether clients honor this property depends on the client capability+      -- `workspace.changeAnnotationSupport`.+      --+      -- @since 3.16.0+    , _changeAnnotations :: Maybe ChangeAnnotationMap     } deriving (Show, Read, Eq)  instance Semigroup WorkspaceEdit where-  (WorkspaceEdit a b) <> (WorkspaceEdit c d) = WorkspaceEdit (a <> c) (b <> d)+  (WorkspaceEdit a b c) <> (WorkspaceEdit a' b' c') = WorkspaceEdit (a <> a') (b <> b') (c <> c') instance Monoid WorkspaceEdit where-  mempty = WorkspaceEdit Nothing Nothing+  mempty = WorkspaceEdit Nothing Nothing Nothing  deriveJSON lspOptions ''WorkspaceEdit @@ -220,6 +298,17 @@   parseJSON (String "undo")                  = pure FailureHandlingUndo   parseJSON _                                = mempty +data WorkspaceEditChangeAnnotationClientCapabilities =+  WorkspaceEditChangeAnnotationClientCapabilities+  {+    -- | Whether the client groups edits with equal labels into tree nodes,+    -- for instance all edits labelled with "Changes in Strings" would+    -- be a tree node.+    groupsOnLabel :: Maybe Bool+  } deriving (Show, Read, Eq)++deriveJSON lspOptions ''WorkspaceEditChangeAnnotationClientCapabilities+ data WorkspaceEditClientCapabilities =   WorkspaceEditClientCapabilities   { _documentChanges :: Maybe Bool -- ^The client supports versioned document@@ -230,6 +319,19 @@     -- | The failure handling strategy of a client if applying the workspace edit     -- fails.   , _failureHandling :: Maybe FailureHandlingKind+    -- | Whether the client normalizes line endings to the client specific+    -- setting.+    --+    -- If set to `true` the client will normalize line ending characters+    -- in a workspace edit to the client specific new line character(s).+    --+    -- @since 3.16.0+  , _normalizesLineEndings :: Maybe Bool+    -- | Whether the client in general supports change annotations on text edits,+    -- create file, rename file and delete file changes.+    --+    -- @since 3.16.0+  , _changeAnnotationSupport :: Maybe WorkspaceEditChangeAnnotationClientCapabilities   } deriving (Show, Read, Eq)  deriveJSON lspOptions ''WorkspaceEditClientCapabilities@@ -274,6 +376,9 @@   where     splitAtPos :: Position -> Text -> (Text, Text)     splitAtPos (Position sl sc) t =+      -- If we are looking for a line beyond the end of the text, this will give us an index+      -- past the end. Fortunately, T.splitAt is fine with this, and just gives us the whole+      -- string and an empty string, which is what we want.       let index = sc + startLineIndex sl t         in T.splitAt index t @@ -282,7 +387,9 @@     startLineIndex line t' =       case T.findIndex (== '\n') t' of         Just i -> i + 1 + startLineIndex (line - 1) (T.drop (i + 1) t')-        Nothing -> 0+        -- i != 0, and there are no newlines, so this is a line beyond the end of the text.+        -- In this case give the "start index" as the end, so we will at least append the text.+        Nothing -> T.length t'  -- | 'editTextEdit' @outer@ @inner@ applies @inner@ to the text inside @outer@. editTextEdit :: TextEdit -> TextEdit -> TextEdit

@@ -26,6 +26,15 @@  deriveJSON lspOptions ''WorkspaceSymbolKindClientCapabilities +data WorkspaceSymbolTagClientCapabilities =+  WorkspaceSymbolTagClientCapabilities+    { -- | The tags supported by the client.+      _valueSet :: Maybe (List SymbolTag)+    }+  deriving (Show, Read, Eq)++deriveJSON lspOptions ''WorkspaceSymbolTagClientCapabilities+ instance Default WorkspaceSymbolKindClientCapabilities where   def = WorkspaceSymbolKindClientCapabilities (Just $ List allKinds)     where allKinds = [ SkFile@@ -53,6 +62,11 @@     { _dynamicRegistration :: Maybe Bool -- ^Symbol request supports dynamic                                          -- registration.     , _symbolKind :: Maybe WorkspaceSymbolKindClientCapabilities -- ^ Specific capabilities for the `SymbolKind`.+      -- | The client supports tags on `SymbolInformation`.+      -- Clients supporting tags have to handle unknown tags gracefully.+      --+      -- @since 3.16.0+    , _tagSupport :: Maybe WorkspaceSymbolTagClientCapabilities      } deriving (Show, Read, Eq)  deriveJSON lspOptions ''WorkspaceSymbolClientCapabilities

@@ -6,6 +6,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}  {-| Handles the "Language.LSP.Types.TextDocumentDidChange" \/@@ -48,7 +49,7 @@ import           Data.List import           Data.Ord import qualified Data.HashMap.Strict as HashMap-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map import           Data.Maybe import           Data.Rope.UTF16 ( Rope ) import qualified Data.Rope.UTF16 as Rope@@ -71,14 +72,14 @@       _lsp_version :: !Int  -- ^ The LSP version of the document     , _file_version :: !Int -- ^ This number is only incremented whilst the file                            -- remains in the map.-    , _text    :: Rope  -- ^ The full contents of the document+    , _text    :: !Rope  -- ^ The full contents of the document     } deriving (Show)   type VFSMap = Map.Map J.NormalizedUri VirtualFile -data VFS = VFS { vfsMap :: Map.Map J.NormalizedUri VirtualFile-               , vfsTempDir :: FilePath -- ^ This is where all the temporary files will be written to+data VFS = VFS { vfsMap :: !(Map.Map J.NormalizedUri VirtualFile)+               , vfsTempDir :: !FilePath -- ^ This is where all the temporary files will be written to                } deriving Show  ---@@ -130,7 +131,7 @@ -- ---------------------------------------------------------------------  applyCreateFile :: J.CreateFile -> VFS -> VFS-applyCreateFile (J.CreateFile uri options) = +applyCreateFile (J.CreateFile uri options _ann) =    updateVFS $ Map.insertWith                  (\ new old -> if shouldOverwrite then new else old)                 (J.toNormalizedUri uri)@@ -150,7 +151,7 @@         Just (J.CreateFileOptions (Just False)  (Just False)) -> False  -- `overwrite` wins over `ignoreIfExists`  applyRenameFile :: J.RenameFile -> VFS -> VFS-applyRenameFile (J.RenameFile oldUri' newUri' options) vfs = +applyRenameFile (J.RenameFile oldUri' newUri' options _ann) vfs =    let oldUri = J.toNormalizedUri oldUri'       newUri = J.toNormalizedUri newUri'   in  case Map.lookup oldUri (vfsMap vfs) of @@ -178,7 +179,7 @@  -- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory applyDeleteFile :: J.DeleteFile -> VFS -> VFS-applyDeleteFile (J.DeleteFile uri _options) = +applyDeleteFile (J.DeleteFile uri _options _ann) =    updateVFS $ Map.delete (J.toNormalizedUri uri)  @@ -186,7 +187,7 @@ applyTextDocumentEdit (J.TextDocumentEdit vid (J.List edits)) vfs = do   -- all edits are supposed to be applied at once   -- so apply from bottom up so they don't affect others-  let sortedEdits = sortOn (Down . (^. J.range)) edits+  let sortedEdits = sortOn (Down . editRange) edits       changeEvents = map editToChangeEvent sortedEdits       ps = J.DidChangeTextDocumentParams vid (J.List changeEvents)       notif = J.NotificationMessage "" J.STextDocumentDidChange ps@@ -194,9 +195,15 @@   mapM_ (debugM "haskell-lsp.applyTextDocumentEdit") ls   return vfs' -  where -    editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text+  where+    editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range+    editRange (J.InR e) = e ^. J.range+    editRange (J.InL e) = e ^. J.range +    editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent+    editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText)+    editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText)+ applyDocumentChange :: J.DocumentChange -> VFS -> IO VFS  applyDocumentChange (J.InL               change)   = applyTextDocumentEdit change applyDocumentChange (J.InR (J.InL        change))  = return . applyCreateFile change@@ -207,7 +214,7 @@ changeFromServerVFS :: VFS -> J.Message 'J.WorkspaceApplyEdit -> IO VFS changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do   let J.ApplyWorkspaceEditParams _label edit = params-      J.WorkspaceEdit mChanges mDocChanges = edit+      J.WorkspaceEdit mChanges mDocChanges _anns = edit   case mDocChanges of     Just (J.List docChanges) -> applyDocumentChanges docChanges     Nothing -> case mChanges of@@ -218,7 +225,7 @@    where     changeToTextDocumentEdit acc uri edits =-      acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) edits]+      acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) (fmap J.InL edits)]      applyDocumentChanges :: [J.DocumentChange] -> IO VFS      applyDocumentChanges = foldM (flip applyDocumentChange) initVfs . sortOn project@@ -318,19 +325,19 @@ -- TODO:AZ:move this to somewhere sane -- | Describes the line at the current cursor position data PosPrefixInfo = PosPrefixInfo-  { fullLine :: T.Text+  { fullLine :: !T.Text     -- ^ The full contents of the line the cursor is at -  , prefixModule :: T.Text+  , prefixModule :: !T.Text     -- ^ If any, the module name that was typed right before the cursor position.     --  For example, if the user has typed "Data.Maybe.from", then this property     --  will be "Data.Maybe" -  , prefixText :: T.Text+  , prefixText :: !T.Text     -- ^ The word right before the cursor position, after removing the module part.     -- For example if the user has typed "Data.Maybe.from",     -- then this property will be "from"-  , cursorPos :: J.Position+  , cursorPos :: !J.Position     -- ^ The cursor position   } deriving (Show,Eq)