diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,7 +1,18 @@ # Revision history for haskell-lsp-types +## 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.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) diff --git a/haskell-lsp-types.cabal b/haskell-lsp-types.cabal --- a/haskell-lsp-types.cabal +++ b/haskell-lsp-types.cabal @@ -1,5 +1,5 @@ name: haskell-lsp-types -version: 0.20.0.0 +version: 0.21.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol, data types description: An implementation of the types to allow language implementors to @@ -48,6 +48,7 @@ -- ghc-options: -Werror build-depends: base >= 4.9 && < 4.14 , aeson >=1.2.2.0 + , binary , bytestring , data-default , deepseq diff --git a/src/Language/Haskell/LSP/Types/Capabilities.hs b/src/Language/Haskell/LSP/Types/Capabilities.hs --- a/src/Language/Haskell/LSP/Types/Capabilities.hs +++ b/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -103,7 +103,7 @@ (Just (DocumentLinkClientCapabilities dynamicReg)) (since 3 6 (ColorProviderClientCapabilities dynamicReg)) (Just (RenameClientCapabilities dynamicReg (since 3 12 True))) - (Just (PublishDiagnosticsClientCapabilities (since 3 7 True))) + (Just publishDiagnosticsCapabilities) (since 3 10 foldingRangeCapability) sync = SynchronizationTextDocumentClientCapabilities @@ -125,10 +125,14 @@ (since 3 3 (List [MkPlainText, MkMarkdown])) (Just True) (since 3 9 True) + (since 3 15 completionItemTagsCapabilities) completionItemKindCapabilities = CompletionItemKindClientCapabilities (Just ciKs) + completionItemTagsCapabilities = + CompletionItemTagsClientCapabilities (List [ CtDeprecated ]) + ciKs | maj >= 3 && min >= 4 = List (oldCiKs ++ newCiKs) | otherwise = List oldCiKs @@ -205,6 +209,15 @@ dynamicReg Nothing (Just False) + + publishDiagnosticsCapabilities = + PublishDiagnosticsClientCapabilities + (since 3 7 True) + (since 3 15 publishDiagnosticsTagsCapabilities) + + publishDiagnosticsTagsCapabilities = + PublishDiagnosticsTagsClientCapabilities + (List [ DtUnnecessary, DtDeprecated ]) dynamicReg | maj >= 3 = Just True diff --git a/src/Language/Haskell/LSP/Types/ClientCapabilities.hs b/src/Language/Haskell/LSP/Types/ClientCapabilities.hs --- a/src/Language/Haskell/LSP/Types/ClientCapabilities.hs +++ b/src/Language/Haskell/LSP/Types/ClientCapabilities.hs @@ -9,6 +9,7 @@ import Language.Haskell.LSP.Types.Constants import Language.Haskell.LSP.Types.CodeAction import Language.Haskell.LSP.Types.Completion +import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.MarkupContent import Language.Haskell.LSP.Types.Symbol @@ -637,6 +638,14 @@ -- ------------------------------------- +data CompletionItemTagsClientCapabilities = + CompletionItemTagsClientCapabilities + { -- | The tag supported by the client. + _valueSet :: List CompletionItemTag + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''CompletionItemTagsClientCapabilities) + data CompletionItemClientCapabilities = CompletionItemClientCapabilities { -- | Client supports snippets as insert text. @@ -659,6 +668,12 @@ -- | Client supports the preselect property on a completion item. , _preselectSupport :: Maybe Bool + + -- | Client supports the tag property on a completion item. Clients + -- 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. + , _tagSupport :: Maybe CompletionItemTagsClientCapabilities } deriving (Show, Read, Eq) $(deriveJSON lspOptions ''CompletionItemClientCapabilities) @@ -910,10 +925,23 @@ -- ------------------------------------- +data PublishDiagnosticsTagsClientCapabilities = + PublishDiagnosticsTagsClientCapabilities + { -- | The tags supported by the client. + _valueSet :: List DiagnosticTag + } deriving (Show, Read, Eq) + +$(deriveJSON lspOptions ''PublishDiagnosticsTagsClientCapabilities) + data PublishDiagnosticsClientCapabilities = PublishDiagnosticsClientCapabilities { -- | Whether the clients accepts diagnostics with related information. _relatedInformation :: Maybe Bool + -- | Client supports the tag property to provide metadata about a + -- diagnostic. + -- + -- Clients supporting tags have to handle unknown tags gracefully. + , _tagSupport :: Maybe PublishDiagnosticsTagsClientCapabilities } deriving (Show, Read, Eq) $(deriveJSON lspOptions ''PublishDiagnosticsClientCapabilities) diff --git a/src/Language/Haskell/LSP/Types/Completion.hs b/src/Language/Haskell/LSP/Types/Completion.hs --- a/src/Language/Haskell/LSP/Types/Completion.hs +++ b/src/Language/Haskell/LSP/Types/Completion.hs @@ -102,7 +102,18 @@ parseJSON (A.Number 25) = pure CiTypeParameter parseJSON _ = mempty +data CompletionItemTag + -- | Render a completion as obsolete, usually using a strike-out. + = CtDeprecated + deriving (Eq, Ord, Show, Read) +instance A.ToJSON CompletionItemTag where + toJSON CtDeprecated = A.Number 1 + +instance A.FromJSON CompletionItemTag where + parseJSON (A.Number 1) = pure CtDeprecated + parseJSON _ = mempty + -- --------------------------------------------------------------------- {- Completion Request @@ -194,6 +205,10 @@ */ kind?: number; /** + * Tags for this completion item. + */ + tags?: CompletionItemTag[]; + /** * A human-readable string with additional information * about this item, like type or symbol information. */ @@ -326,6 +341,7 @@ -- the text that is inserted when selecting this -- completion. , _kind :: Maybe CompletionItemKind + , _tags :: List CompletionItemTag -- ^ Tags for this completion item. , _detail :: Maybe Text -- ^ A human-readable string with additional -- information about this item, like type or -- symbol information. diff --git a/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/src/Language/Haskell/LSP/Types/DataTypesJSON.hs --- a/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.LSP.Types.DataTypesJSON where @@ -15,6 +16,8 @@ import qualified Data.Aeson as A import Data.Aeson.TH import Data.Aeson.Types +import Data.Bits (testBit) +import Data.Scientific (floatingOrInteger) import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.LSP.Types.ClientCapabilities @@ -1092,6 +1095,96 @@ type UnregisterCapabilityRequest = RequestMessage ServerMethod UnregistrationParams () type UnregisterCapabilityResponse = ResponseMessage () + +-- --------------------------------------------------------------------- + +-- /** +-- * Describe options to be used when registering for file system change events. +-- */ +-- export interface DidChangeWatchedFilesRegistrationOptions { +-- /** +-- * The watchers to register. +-- */ +-- watchers: FileSystemWatcher[]; +-- } +-- +-- export interface FileSystemWatcher { +-- /** +-- * The glob pattern to watch. +-- * +-- * Glob patterns can have the following syntax: +-- * - `*` to match one or more characters in a path segment +-- * - `?` to match on one character in a path segment +-- * - `**` to match any number of path segments, including none +-- * - `{}` to group conditions (e.g. `**​/*.{ts,js}` matches all TypeScript and JavaScript files) +-- * - `[]` to declare a range of characters to match in a path segment (e.g., `example.[0-9]` to match on `example.0`, `example.1`, …) +-- * - `[!...]` to negate a range of characters to match in a path segment (e.g., `example.[!0-9]` to match on `example.a`, `example.b`, but not `example.0`) +-- */ +-- globPattern: string; +-- +-- /** +-- * The kind of events of interest. If omitted it defaults +-- * to WatchKind.Create | WatchKind.Change | WatchKind.Delete +-- * which is 7. +-- */ +-- kind?: number; +-- } +-- +-- export namespace WatchKind { +-- /** +-- * Interested in create events. +-- */ +-- export const Create = 1; +-- +-- /** +-- * Interested in change events +-- */ +-- export const Change = 2; +-- +-- /** +-- * Interested in delete events +-- */ +-- export const Delete = 4; +-- } + +data DidChangeWatchedFilesRegistrationOptions = + DidChangeWatchedFilesRegistrationOptions { + _watchers :: List FileSystemWatcher + } deriving (Show, Read, Eq) + +data FileSystemWatcher = + FileSystemWatcher { + _globPattern :: String, + _kind :: Maybe WatchKind + } deriving (Show, Read, Eq) + +data WatchKind = + WatchKind { + -- | Watch for create events + _watchCreate :: Bool, + -- | Watch for change events + _watchChange :: Bool, + -- | Watch for delete events + _watchDelete :: Bool + } deriving (Show, Read, Eq) + +instance A.ToJSON WatchKind where + toJSON wk = A.Number (createNum + changeNum + deleteNum) + where + createNum = if _watchCreate wk then 0x1 else 0x0 + changeNum = if _watchChange wk then 0x2 else 0x0 + deleteNum = if _watchDelete wk then 0x4 else 0x0 + +instance A.FromJSON WatchKind where + parseJSON (A.Number n) + | Right i <- floatingOrInteger n :: Either Double Int + , 0 <= i && i <= 7 = + pure $ WatchKind (testBit i 0x0) (testBit i 0x1) (testBit i 0x2) + | otherwise = mempty + parseJSON _ = mempty + +deriveJSON lspOptions ''DidChangeWatchedFilesRegistrationOptions +deriveJSON lspOptions ''FileSystemWatcher -- --------------------------------------------------------------------- {- diff --git a/src/Language/Haskell/LSP/Types/Diagnostic.hs b/src/Language/Haskell/LSP/Types/Diagnostic.hs --- a/src/Language/Haskell/LSP/Types/Diagnostic.hs +++ b/src/Language/Haskell/LSP/Types/Diagnostic.hs @@ -59,6 +59,49 @@ parseJSON (A.Number 4) = pure DsHint parseJSON _ = mempty +{- +The diagnostic tags. + +export namespace DiagnosticTag { + /** + * Unused or unnecessary code. + * + * Clients are allowed to render diagnostics with this tag faded out instead of having + * an error squiggle. + */ + export const Unnecessary: 1; + /** + * Deprecated or obsolete code. + * + * Clients are allowed to rendered diagnostics with this tag strike through. + */ + export const Deprecated: 2; +} +-} +data DiagnosticTag + -- | Unused or unnecessary code. + -- + -- Clients are allowed to render diagnostics with this tag faded out + -- instead of having an error squiggle. + = DtUnnecessary + -- | Deprecated or obsolete code. + -- + -- Clients are allowed to rendered diagnostics with this tag strike + -- through. + | DtDeprecated + deriving (Eq, Ord, Show, Read, Generic) + +instance NFData DiagnosticTag + +instance A.ToJSON DiagnosticTag where + toJSON DtUnnecessary = A.Number 1 + toJSON DtDeprecated = A.Number 2 + +instance A.FromJSON DiagnosticTag where + parseJSON (A.Number 1) = pure DtUnnecessary + parseJSON (A.Number 2) = pure DtDeprecated + parseJSON _ = mempty + -- --------------------------------------------------------------------- {- Represents a related message and source code location for a diagnostic. This should be @@ -126,6 +169,13 @@ message: string; /** + * Additional metadata about the diagnostic. + * + * @since 3.15.0 + */ + tags?: DiagnosticTag[]; + + /** * An array of related diagnostic information, e.g. when symbol-names within * a scope collide all definitions can be marked via this property. */ @@ -150,6 +200,7 @@ , _code :: Maybe NumberOrString , _source :: Maybe DiagnosticSource , _message :: Text + , _tags :: Maybe (List DiagnosticTag) , _relatedInformation :: Maybe (List DiagnosticRelatedInformation) } deriving (Show, Read, Eq, Ord, Generic) diff --git a/src/Language/Haskell/LSP/Types/Lens.hs b/src/Language/Haskell/LSP/Types/Lens.hs --- a/src/Language/Haskell/LSP/Types/Lens.hs +++ b/src/Language/Haskell/LSP/Types/Lens.hs @@ -32,6 +32,7 @@ makeFieldsNoPrefix ''ExecuteClientCapabilities makeFieldsNoPrefix ''WorkspaceClientCapabilities makeFieldsNoPrefix ''SynchronizationTextDocumentClientCapabilities +makeFieldsNoPrefix ''CompletionItemTagsClientCapabilities makeFieldsNoPrefix ''CompletionItemClientCapabilities makeFieldsNoPrefix ''CompletionItemKindClientCapabilities makeFieldsNoPrefix ''CompletionClientCapabilities @@ -56,6 +57,7 @@ makeFieldsNoPrefix ''ColorProviderClientCapabilities makeFieldsNoPrefix ''RenameClientCapabilities makeFieldsNoPrefix ''PublishDiagnosticsClientCapabilities +makeFieldsNoPrefix ''PublishDiagnosticsTagsClientCapabilities makeFieldsNoPrefix ''TextDocumentClientCapabilities makeFieldsNoPrefix ''ClientCapabilities @@ -77,6 +79,9 @@ makeFieldsNoPrefix ''InitializeResponseCapabilities makeFieldsNoPrefix ''Registration makeFieldsNoPrefix ''RegistrationParams +makeFieldsNoPrefix ''DidChangeWatchedFilesRegistrationOptions +makeFieldsNoPrefix ''FileSystemWatcher +makeFieldsNoPrefix ''WatchKind makeFieldsNoPrefix ''TextDocumentRegistrationOptions makeFieldsNoPrefix ''Unregistration makeFieldsNoPrefix ''UnregistrationParams diff --git a/src/Language/Haskell/LSP/Types/Uri.hs b/src/Language/Haskell/LSP/Types/Uri.hs --- a/src/Language/Haskell/LSP/Types/Uri.hs +++ b/src/Language/Haskell/LSP/Types/Uri.hs @@ -1,15 +1,39 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} -module Language.Haskell.LSP.Types.Uri where +module Language.Haskell.LSP.Types.Uri + ( Uri(..) + , uriToFilePath + , filePathToUri + , NormalizedUri(..) + , toNormalizedUri + , fromNormalizedUri + , NormalizedFilePath(..) + , toNormalizedFilePath + , fromNormalizedFilePath + , normalizedFilePathToUri + , uriToNormalizedFilePath + -- Private functions + , platformAwareUriToFilePath + , platformAwareFilePathToUri + ) + where import Control.DeepSeq import qualified Data.Aeson as A +import Data.Binary (Binary, Get, put, get) import Data.Hashable +import Data.List (isPrefixOf, stripPrefix) +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#endif +import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics import Network.URI hiding (authority) +import qualified System.FilePath as FP import qualified System.FilePath.Posix as FPP import qualified System.FilePath.Windows as FPW import qualified System.Info @@ -19,10 +43,6 @@ instance NFData Uri --- | When URIs are supposed to be used as keys, it is important to normalize --- the percent encoding in the URI since URIs that only differ --- when it comes to the percent-encoding should be treated as equivalent. --- -- If you care about performance then you should use a hash map. The keys -- are cached in order to make hashing very fast. data NormalizedUri = NormalizedUri !Int !Text @@ -35,11 +55,28 @@ instance Hashable NormalizedUri where hash (NormalizedUri h _) = h +instance NFData NormalizedUri + +isUnescapedInUriPath :: SystemOS -> Char -> Bool +isUnescapedInUriPath systemOS c + | systemOS == windowsOS = isUnreserved c || c `elem` [':', '\\', '/'] + | otherwise = isUnreserved c || c == '/' + +-- | When URIs are supposed to be used as keys, it is important to normalize +-- the percent encoding in the URI since URIs that only differ +-- when it comes to the percent-encoding should be treated as equivalent. +normalizeUriEscaping :: String -> String +normalizeUriEscaping uri = + case stripPrefix (fileScheme ++ "//") uri of + Just p -> fileScheme ++ "//" ++ (escapeURIPath $ unEscapeString p) + Nothing -> escapeURIString isUnescapedInURI $ unEscapeString uri + where escapeURIPath = escapeURIString (isUnescapedInUriPath System.Info.os) + toNormalizedUri :: Uri -> NormalizedUri toNormalizedUri uri = NormalizedUri (hash norm) norm where (Uri t) = maybe uri filePathToUri (uriToFilePath uri) - -- To ensure all `Uri`s have the file path like the created ones by `filePathToUri` - norm = T.pack $ escapeURIString isUnescapedInURI $ unEscapeString $ T.unpack t + -- To ensure all `Uri`s have the file path normalized + norm = T.pack (normalizeUriEscaping (T.unpack t)) fromNormalizedUri :: NormalizedUri -> Uri fromNormalizedUri (NormalizedUri _ t) = Uri t @@ -55,6 +92,7 @@ uriToFilePath :: Uri -> Maybe FilePath uriToFilePath = platformAwareUriToFilePath System.Info.os +{-# WARNING platformAwareUriToFilePath "This function is considered private. Use normalizedFilePathToUri instead." #-} platformAwareUriToFilePath :: String -> Uri -> Maybe FilePath platformAwareUriToFilePath systemOS (Uri uri) = do URI{..} <- parseURI $ T.unpack uri @@ -74,12 +112,15 @@ if systemOS /= windowsOS || null srcPath then srcPath else let firstSegment:rest = (FPP.splitDirectories . tail) srcPath -- Drop leading '/' for absolute Windows paths - drive = if FPW.isDrive firstSegment then FPW.addTrailingPathSeparator firstSegment else firstSegment + drive = if FPW.isDrive firstSegment + then FPW.addTrailingPathSeparator firstSegment + else firstSegment in FPW.joinDrive drive $ FPW.joinPath rest filePathToUri :: FilePath -> Uri -filePathToUri = platformAwareFilePathToUri System.Info.os +filePathToUri = (platformAwareFilePathToUri System.Info.os) . FP.normalise +{-# WARNING platformAwareFilePathToUri "This function is considered private. Use normalizedUriToFilePath instead." #-} platformAwareFilePathToUri :: SystemOS -> FilePath -> Uri platformAwareFilePathToUri systemOS fp = Uri . T.pack . show $ URI { uriScheme = fileScheme @@ -94,22 +135,62 @@ | systemOS == windowsOS = '/' : escapedPath | otherwise = escapedPath where - (splitDirectories, splitDrive, normalise) + (splitDirectories, splitDrive) | systemOS == windowsOS = - (FPW.splitDirectories, FPW.splitDrive, FPW.normalise) + (FPW.splitDirectories, FPW.splitDrive) | otherwise = - (FPP.splitDirectories, FPP.splitDrive, FPP.normalise) + (FPP.splitDirectories, FPP.splitDrive) escapedPath = - case splitDrive (normalise srcPath) of + case splitDrive srcPath of (drv, rest) -> convertDrive drv `FPP.joinDrive` - FPP.joinPath (map (escapeURIString unescaped) $ splitDirectories rest) + FPP.joinPath (map (escapeURIString (isUnescapedInUriPath systemOS)) $ splitDirectories rest) -- splitDirectories does not remove the path separator after the drive so -- we do a final replacement of \ to / convertDrive drv | systemOS == windowsOS && FPW.hasTrailingPathSeparator drv = FPP.addTrailingPathSeparator (init drv) | otherwise = drv - unescaped c - | systemOS == windowsOS = isUnreserved c || c `elem` [':', '\\', '/'] - | otherwise = isUnreserved c || c == '/' + +-- | Newtype wrapper around FilePath that always has normalized slashes. +-- The NormalizedUri and hash of the FilePath are cached to avoided +-- repeated normalisation when we need to compute them (which is a lot). +-- +-- This is one of the most performance critical parts of ghcide, do not +-- modify it without profiling. +data NormalizedFilePath = NormalizedFilePath NormalizedUri !FilePath + deriving (Generic, Eq, Ord) + +instance NFData NormalizedFilePath + +instance Binary NormalizedFilePath where + put (NormalizedFilePath _ fp) = put fp + get = do + v <- Data.Binary.get :: Get FilePath + return (toNormalizedFilePath v) + +instance Show NormalizedFilePath where + show (NormalizedFilePath _ fp) = "NormalizedFilePath " ++ show fp + +instance Hashable NormalizedFilePath where + hash (NormalizedFilePath uri _) = hash uri + +instance IsString NormalizedFilePath where + fromString = toNormalizedFilePath + +toNormalizedFilePath :: FilePath -> NormalizedFilePath +toNormalizedFilePath fp = NormalizedFilePath nuri nfp + where nfp = FP.normalise fp + uriPath = platformAdjustToUriPath System.Info.os nfp + nuriStr = T.pack $ fileScheme <> "//" <> uriPath + nuri = NormalizedUri (hash nuriStr) nuriStr + +fromNormalizedFilePath :: NormalizedFilePath -> FilePath +fromNormalizedFilePath (NormalizedFilePath _ fp) = fp + +normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri +normalizedFilePathToUri (NormalizedFilePath uri _) = uri + +uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath +uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri) mbFilePath + where mbFilePath = platformAwareUriToFilePath System.Info.os (fromNormalizedUri nuri)