diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,12 @@ # Revision history for lsp-types + +## 1.6.0.0 + +* Add `isSubRangeOf` and `positionInRange` helper functions +* Add `ServerCancelled`, `RequestFailed` and `ErrorCodeCustom` server error types +* Fix "workspace/semanticTokens/refresh" to be a server method instead of a client method +* Use a packed representation for `NormalizedFilePath` +* Add converions from `OsPath` to `NormalizedFilePath` in `Language.LSP.Types.Uri.OsPath` when using new enough `filepath` ## 1.5.0.0 diff --git a/lsp-types.cabal b/lsp-types.cabal --- a/lsp-types.cabal +++ b/lsp-types.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: lsp-types -version: 1.5.0.0 +version: 1.6.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol, data types description: An implementation of the types to allow language implementors to @@ -16,6 +16,11 @@ build-type: Simple extra-source-files: ChangeLog.md, README.md +flag force-ospath + default: False + manual: False + description: Force a version bound on filepath library, to enable 'OsPath'. + library exposed-modules: Language.LSP.Types , Language.LSP.Types.Capabilities @@ -68,6 +73,7 @@ , Language.LSP.Types.WorkspaceEdit , Language.LSP.Types.WorkspaceFolders , Language.LSP.Types.WorkspaceSymbol + , Language.LSP.Types.Uri.OsPath -- other-extensions: ghc-options: -Wall build-depends: base >= 4.11 && < 5 @@ -78,7 +84,6 @@ , deepseq , Diff >= 0.2 , dlist - , filepath , hashable , lens >= 4.15.2 , mtl < 2.4 @@ -89,9 +94,45 @@ , text , template-haskell , unordered-containers + , exceptions + , safe + if flag(force-ospath) + build-depends: filepath ^>= 1.4.100.0 + else + build-depends: filepath hs-source-dirs: src default-language: Haskell2010 default-extensions: StrictData + +test-suite lsp-types-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Spec + CapabilitiesSpec + JsonSpec + MethodSpec + ServerCapabilitiesSpec + SemanticTokensSpec + TypesSpec + URIFilePathSpec + WorkspaceEditSpec + LocationSpec + build-depends: base + , QuickCheck + -- for instance Arbitrary Value + , aeson >= 2.0.3.0 + , filepath + , hspec + , lsp-types + , lens >= 4.15.2 + , network-uri + , quickcheck-instances + , text + , tuple + build-tool-depends: hspec-discover:hspec-discover + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 source-repository head type: git diff --git a/src/Language/LSP/Types.hs b/src/Language/LSP/Types.hs --- a/src/Language/LSP/Types.hs +++ b/src/Language/LSP/Types.hs @@ -37,6 +37,7 @@ , module Language.LSP.Types.TextDocument , module Language.LSP.Types.TypeDefinition , module Language.LSP.Types.Uri + , module Language.LSP.Types.Uri.OsPath , module Language.LSP.Types.WatchedFiles , module Language.LSP.Types.Window , module Language.LSP.Types.WorkspaceEdit @@ -69,8 +70,8 @@ import Language.LSP.Types.Location import Language.LSP.Types.LspId import Language.LSP.Types.MarkupContent -import Language.LSP.Types.Method import Language.LSP.Types.Message +import Language.LSP.Types.Method import Language.LSP.Types.Parsing import Language.LSP.Types.Progress import Language.LSP.Types.References @@ -83,6 +84,7 @@ import Language.LSP.Types.TextDocument import Language.LSP.Types.TypeDefinition import Language.LSP.Types.Uri +import Language.LSP.Types.Uri.OsPath import Language.LSP.Types.WatchedFiles import Language.LSP.Types.Window import Language.LSP.Types.WorkspaceEdit diff --git a/src/Language/LSP/Types/Location.hs b/src/Language/LSP/Types/Location.hs --- a/src/Language/LSP/Types/Location.hs +++ b/src/Language/LSP/Types/Location.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} module Language.LSP.Types.Location where import Control.DeepSeq import Data.Aeson.TH import Data.Hashable -import GHC.Generics hiding (UInt) +import GHC.Generics hiding (UInt) import Language.LSP.Types.Common import Language.LSP.Types.Uri import Language.LSP.Types.Utils @@ -33,8 +33,8 @@ data Range = Range - { _start :: Position -- ^ The range's start position. - , _end :: Position -- ^ The range's end position. + { _start :: Position -- ^ The range's start position. (inclusive) + , _end :: Position -- ^ The range's end position. (exclusive, see: https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#range ) } deriving (Show, Read, Eq, Ord, Generic) instance NFData Range @@ -65,12 +65,12 @@ -- range at the mouse position. _originSelectionRange :: Maybe Range -- | The target resource identifier of this link. - , _targetUri :: Uri + , _targetUri :: Uri -- | The full target range of this link. If the target for example is a -- symbol then target range is the range enclosing this symbol not including -- leading/trailing whitespace but everything else like comments. This -- information is typically used to highlight the range in the editor. - , _targetRange :: Range + , _targetRange :: Range -- | The range that should be selected and revealed when this link is being -- followed, e.g the name of a function. Must be contained by the the -- 'targetRange'. See also @DocumentSymbol._range@ @@ -84,3 +84,11 @@ -- prop> mkRange l c l' c' = Range (Position l c) (Position l' c') mkRange :: UInt -> UInt -> UInt -> UInt -> Range mkRange l c l' c' = Range (Position l c) (Position l' c') + +-- | 'isSubrangeOf' returns true if for every 'Position' in the first 'Range', it's also in the second 'Range'. +isSubrangeOf :: Range -> Range -> Bool +isSubrangeOf smallRange range = _start smallRange >= _start range && _end smallRange <= _end range + +-- | 'positionInRange' returns true if the given 'Position' is in the 'Range'. +positionInRange :: Position -> Range -> Bool +positionInRange p (Range sp ep) = sp <= p && p < ep -- Range's end position is exclusive. diff --git a/src/Language/LSP/Types/Message.hs b/src/Language/LSP/Types/Message.hs --- a/src/Language/LSP/Types/Message.hs +++ b/src/Language/LSP/Types/Message.hs @@ -60,6 +60,7 @@ import Data.Aeson import Data.Aeson.TH import Data.Text (Text) +import Data.Scientific import Data.String import GHC.Generics @@ -318,6 +319,9 @@ | UnknownErrorCode | RequestCancelled | ContentModified + | ServerCancelled + | RequestFailed + | ErrorCodeCustom Int32 -- ^ Note: server error codes are reserved from -32099 to -32000 deriving (Read,Show,Eq) @@ -333,6 +337,9 @@ toJSON UnknownErrorCode = Number (-32001) toJSON RequestCancelled = Number (-32800) toJSON ContentModified = Number (-32801) + toJSON ServerCancelled = Number (-32802) + toJSON RequestFailed = Number (-32803) + toJSON (ErrorCodeCustom n) = Number (fromIntegral n) instance FromJSON ErrorCode where parseJSON (Number (-32700)) = pure ParseError @@ -346,7 +353,12 @@ parseJSON (Number (-32001)) = pure UnknownErrorCode parseJSON (Number (-32800)) = pure RequestCancelled parseJSON (Number (-32801)) = pure ContentModified - parseJSON _ = fail "ErrorCode" + parseJSON (Number (-32802)) = pure ServerCancelled + parseJSON (Number (-32803)) = pure RequestFailed + parseJSON (Number n ) = case toBoundedInteger n of + Just i -> pure (ErrorCodeCustom i) + Nothing -> fail "Couldn't convert ErrorCode to bounded integer." + parseJSON _ = fail "Couldn't parse ErrorCode" -- ------------------------------------- diff --git a/src/Language/LSP/Types/Method.hs b/src/Language/LSP/Types/Method.hs --- a/src/Language/LSP/Types/Method.hs +++ b/src/Language/LSP/Types/Method.hs @@ -87,7 +87,6 @@ TextDocumentSemanticTokensFull :: Method FromClient Request TextDocumentSemanticTokensFullDelta :: Method FromClient Request TextDocumentSemanticTokensRange :: Method FromClient Request - WorkspaceSemanticTokensRefresh :: Method FromClient Request -- ServerMethods -- Window @@ -108,6 +107,7 @@ WorkspaceWorkspaceFolders :: Method FromServer Request WorkspaceConfiguration :: Method FromServer Request WorkspaceApplyEdit :: Method FromServer Request + WorkspaceSemanticTokensRefresh :: Method FromServer Request -- Document TextDocumentPublishDiagnostics :: Method FromServer Notification @@ -287,7 +287,6 @@ parseJSON (A.String "workspace/didChangeWatchedFiles") = pure $ SomeClientMethod SWorkspaceDidChangeWatchedFiles parseJSON (A.String "workspace/symbol") = pure $ SomeClientMethod SWorkspaceSymbol parseJSON (A.String "workspace/executeCommand") = pure $ SomeClientMethod SWorkspaceExecuteCommand - parseJSON (A.String "workspace/semanticTokens/refresh") = pure $ SomeClientMethod SWorkspaceSemanticTokensRefresh -- Document parseJSON (A.String "textDocument/didOpen") = pure $ SomeClientMethod STextDocumentDidOpen parseJSON (A.String "textDocument/didChange") = pure $ SomeClientMethod STextDocumentDidChange @@ -351,6 +350,7 @@ parseJSON (A.String "workspace/workspaceFolders") = pure $ SomeServerMethod SWorkspaceWorkspaceFolders parseJSON (A.String "workspace/configuration") = pure $ SomeServerMethod SWorkspaceConfiguration parseJSON (A.String "workspace/applyEdit") = pure $ SomeServerMethod SWorkspaceApplyEdit + parseJSON (A.String "workspace/semanticTokens/refresh") = pure $ SomeServerMethod SWorkspaceSemanticTokensRefresh -- Document parseJSON (A.String "textDocument/publishDiagnostics") = pure $ SomeServerMethod STextDocumentPublishDiagnostics @@ -388,7 +388,6 @@ toJSON SWorkspaceDidChangeWatchedFiles = A.String "workspace/didChangeWatchedFiles" toJSON SWorkspaceSymbol = A.String "workspace/symbol" toJSON SWorkspaceExecuteCommand = A.String "workspace/executeCommand" - toJSON SWorkspaceSemanticTokensRefresh = A.String "workspace/semanticTokens/refresh" -- Document toJSON STextDocumentDidOpen = A.String "textDocument/didOpen" toJSON STextDocumentDidChange = A.String "textDocument/didChange" @@ -445,6 +444,7 @@ toJSON SWorkspaceWorkspaceFolders = A.String "workspace/workspaceFolders" toJSON SWorkspaceConfiguration = A.String "workspace/configuration" toJSON SWorkspaceApplyEdit = A.String "workspace/applyEdit" + toJSON SWorkspaceSemanticTokensRefresh = A.String "workspace/semanticTokens/refresh" -- Document toJSON STextDocumentPublishDiagnostics = A.String "textDocument/publishDiagnostics" -- Cancelling diff --git a/src/Language/LSP/Types/Parsing.hs b/src/Language/LSP/Types/Parsing.hs --- a/src/Language/LSP/Types/Parsing.hs +++ b/src/Language/LSP/Types/Parsing.hs @@ -259,12 +259,12 @@ splitClientMethod STextDocumentSemanticTokensFull = IsClientReq splitClientMethod STextDocumentSemanticTokensFullDelta = IsClientReq splitClientMethod STextDocumentSemanticTokensRange = IsClientReq -splitClientMethod SWorkspaceSemanticTokensRefresh = IsClientReq splitClientMethod SCancelRequest = IsClientNot splitClientMethod SCustomMethod{} = IsClientEither {-# INLINE splitServerMethod #-} splitServerMethod :: SServerMethod m -> ServerNotOrReq m +-- Window splitServerMethod SWindowShowMessage = IsServerNot splitServerMethod SWindowShowMessageRequest = IsServerReq splitServerMethod SWindowShowDocument = IsServerReq @@ -272,13 +272,19 @@ splitServerMethod SWindowWorkDoneProgressCreate = IsServerReq splitServerMethod SProgress = IsServerNot splitServerMethod STelemetryEvent = IsServerNot +-- Client splitServerMethod SClientRegisterCapability = IsServerReq splitServerMethod SClientUnregisterCapability = IsServerReq +-- Workspace splitServerMethod SWorkspaceWorkspaceFolders = IsServerReq splitServerMethod SWorkspaceConfiguration = IsServerReq splitServerMethod SWorkspaceApplyEdit = IsServerReq +splitServerMethod SWorkspaceSemanticTokensRefresh = IsServerReq +-- Document splitServerMethod STextDocumentPublishDiagnostics = IsServerNot +-- Cancelling splitServerMethod SCancelRequest = IsServerNot +-- Custom splitServerMethod SCustomMethod{} = IsServerEither -- | Given a witness that two custom methods are of the same type, produce a witness that the methods are the same diff --git a/src/Language/LSP/Types/Uri.hs b/src/Language/LSP/Types/Uri.hs --- a/src/Language/LSP/Types/Uri.hs +++ b/src/Language/LSP/Types/Uri.hs @@ -1,7 +1,11 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} + module Language.LSP.Types.Uri ( Uri(..) , uriToFilePath @@ -10,11 +14,11 @@ , toNormalizedUri , fromNormalizedUri , NormalizedFilePath - , normalizedFilePath , toNormalizedFilePath , fromNormalizedFilePath , normalizedFilePathToUri , uriToNormalizedFilePath + , emptyNormalizedFilePath -- Private functions , platformAwareUriToFilePath , platformAwareFilePathToUri @@ -22,18 +26,19 @@ where import Control.DeepSeq -import qualified Data.Aeson as A -import Data.Binary (Binary, Get, put, get) +import qualified Data.Aeson as A +import Data.Binary (Binary, Get, get, put) import Data.Hashable -import Data.List (stripPrefix) -import Data.String (IsString, fromString) -import Data.Text (Text) -import qualified Data.Text as T +import Data.List (stripPrefix) +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 Network.URI hiding (authority) +import Safe (tailMay) +import qualified System.FilePath as FP +import qualified System.FilePath.Posix as FPP +import qualified System.FilePath.Windows as FPW import qualified System.Info newtype Uri = Uri { getUri :: Text } @@ -67,7 +72,7 @@ normalizeUriEscaping :: String -> String normalizeUriEscaping uri = case stripPrefix (fileScheme ++ "//") uri of - Just p -> fileScheme ++ "//" ++ (escapeURIPath $ unEscapeString p) + Just p -> fileScheme ++ "//" ++ escapeURIPath (unEscapeString p) Nothing -> escapeURIString isUnescapedInURI $ unEscapeString uri where escapeURIPath = escapeURIString (isUnescapedInUriPath System.Info.os) @@ -107,17 +112,19 @@ -> String -- ^ path -> FilePath platformAdjustFromUriPath systemOS authority srcPath = - (maybe id (++) authority) $ - 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 - in FPW.joinDrive drive $ FPW.joinPath rest + maybe id (++) authority $ + if systemOS /= windowsOS + then srcPath + else case FPP.splitDirectories <$> tailMay srcPath of + Just (firstSegment:rest) -> -- Drop leading '/' for absolute Windows paths + let drive = if FPW.isDrive firstSegment + then FPW.addTrailingPathSeparator firstSegment + else firstSegment + in FPW.joinDrive drive $ FPW.joinPath rest + _ -> srcPath filePathToUri :: FilePath -> Uri -filePathToUri = (platformAwareFilePathToUri System.Info.os) . FP.normalise +filePathToUri = platformAwareFilePathToUri System.Info.os . FP.normalise {-# WARNING platformAwareFilePathToUri "This function is considered private. Use normalizedUriToFilePath instead." #-} platformAwareFilePathToUri :: SystemOS -> FilePath -> Uri @@ -151,13 +158,30 @@ FPP.addTrailingPathSeparator (init drv) | otherwise = drv --- | 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 +{-| A file path that is already normalized. + +The 'NormalizedUri' is 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 HLS, do not +modify it without profiling. + +== Adoption Plan of OsPath + +Currently we store 'Text'. We may change it to OsPath in the future if +the following steps are executed. + +1. In the client codebase, use 'osPathToNormalizedFilePath' and 'normalizedFilePathToOsPath' instead of 'fromNormalizedFilePath' + and 'toNormalizedFilePath'. For HLS, we could wait until GHC 9.6 becomes the oldest + GHC we support, then change 'FilePath' to OsPath everywhere in the codebase. +2. Deprecate and remove 'fromNormalizedFilePath' and 'toNormalizedFilePath'. +3. Change 'Text' to OsPath and benchmark it to make sure performance doesn't go down. Don't forget to check Windows, + as OsPath on Windows uses UTF-16, which may consume more memory. + +See [#453](https://github.com/haskell/lsp/pull/453) and [#446](https://github.com/haskell/lsp/pull/446) +for more discussions on this topic. +-} +data NormalizedFilePath = NormalizedFilePath !NormalizedUri {-# UNPACK #-} !Text deriving (Generic, Eq, Ord) instance NFData NormalizedFilePath @@ -165,13 +189,8 @@ instance Binary NormalizedFilePath where put (NormalizedFilePath _ fp) = put fp get = do - v <- Data.Binary.get :: Get FilePath - let nuri = internalNormalizedFilePathToUri v - return (normalizedFilePath nuri v) - --- | A smart constructor that performs UTF-8 encoding and hash consing -normalizedFilePath :: NormalizedUri -> FilePath -> NormalizedFilePath -normalizedFilePath nuri nfp = NormalizedFilePath nuri nfp + v <- Data.Binary.get :: Get Text + return (NormalizedFilePath (internalNormalizedFilePathToUri (T.unpack v)) v) -- | Internal helper that takes a file path that is assumed to -- already be normalized to a URI. It is up to the caller @@ -191,20 +210,32 @@ hashWithSalt salt (NormalizedFilePath uri _) = hashWithSalt salt uri instance IsString NormalizedFilePath where + fromString :: String -> NormalizedFilePath fromString = toNormalizedFilePath toNormalizedFilePath :: FilePath -> NormalizedFilePath -toNormalizedFilePath fp = normalizedFilePath nuri nfp +toNormalizedFilePath fp = NormalizedFilePath nuri . T.pack $ nfp where - nfp = FP.normalise fp - nuri = internalNormalizedFilePathToUri nfp + nfp = FP.normalise fp + nuri = internalNormalizedFilePathToUri nfp +-- | Extracts 'FilePath' from 'NormalizedFilePath'. fromNormalizedFilePath :: NormalizedFilePath -> FilePath -fromNormalizedFilePath (NormalizedFilePath _ fp) = fp +fromNormalizedFilePath (NormalizedFilePath _ fp) = T.unpack fp normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri normalizedFilePathToUri (NormalizedFilePath uri _) = uri uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath -uriToNormalizedFilePath nuri = fmap (normalizedFilePath nuri) mbFilePath +uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri . T.pack) mbFilePath where mbFilePath = platformAwareUriToFilePath System.Info.os (fromNormalizedUri nuri) + +emptyNormalizedUri :: NormalizedUri +emptyNormalizedUri = + let s = "file://" + in NormalizedUri (hash s) s + +-- | 'NormalizedFilePath' that contains an empty file path +emptyNormalizedFilePath :: NormalizedFilePath +emptyNormalizedFilePath = NormalizedFilePath emptyNormalizedUri "" + diff --git a/src/Language/LSP/Types/Uri/OsPath.hs b/src/Language/LSP/Types/Uri/OsPath.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Types/Uri/OsPath.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#if MIN_VERSION_filepath(1,4,100) +#define OS_PATH 1 +#endif + +module Language.LSP.Types.Uri.OsPath + ( +#ifdef OS_PATH + osPathToNormalizedFilePath + , normalizedFilePathToOsPath + , EncodingException +#endif + ) where + +#ifdef OS_PATH + +import Control.Exception hiding (try) +import Control.Monad.Catch +import GHC.IO.Encoding (getFileSystemEncoding) +import Language.LSP.Types.Uri +import System.IO +import System.IO.Unsafe (unsafePerformIO) +import System.OsPath +import System.OsPath.Encoding (EncodingException) + +{-| +Constructs 'NormalizedFilePath' from 'OsPath'. Throws 'EncodingException' if the conversion fails. + +We store a 'Text' in 'NormalizedFilePath', which is UTF-16 or UTF-8 depending on the verion of text library. +'OsPath' may have a different encoding than 'Text', so this function may fail. +But DO NOTE THAT encoding mismatch doesn't always mean an exception will be thrown. +[Possibly your encoding simply won't throw exception on failure](https://hackage.haskell.org/package/base-4.17.0.0/docs/src/GHC.IO.Encoding.html#initFileSystemEncoding). +Possibly the conversion function can't find any invalid byte sequence, giving a sucessful but wrong result. +-} +osPathToNormalizedFilePath :: MonadThrow m => OsPath -> m NormalizedFilePath +osPathToNormalizedFilePath = fmap toNormalizedFilePath . liftException . decodeWith systemEnc utf16le + +{-| +Extracts 'OsPath' from 'NormalizedFilePath'. Throws 'EncodingException' if the conversion fails. +-} +normalizedFilePathToOsPath :: MonadThrow m => NormalizedFilePath -> m OsPath +normalizedFilePathToOsPath = liftException . encodeWith systemEnc utf16le . fromNormalizedFilePath + +liftException :: (MonadThrow m, Exception e) => Either e a -> m a +liftException (Right x) = pure x +liftException (Left err) = throwM err + +systemEnc :: TextEncoding +systemEnc = unsafePerformIO getFileSystemEncoding + +#endif diff --git a/test/CapabilitiesSpec.hs b/test/CapabilitiesSpec.hs new file mode 100644 --- /dev/null +++ b/test/CapabilitiesSpec.hs @@ -0,0 +1,16 @@ +module CapabilitiesSpec where + +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import Test.Hspec + +spec :: Spec +spec = describe "capabilities" $ do + it "gives 3.10 capabilities" $ + let ClientCapabilities _ (Just tdcs) _ _ _ = capsForVersion (LSPVersion 3 10) + Just (DocumentSymbolClientCapabilities _ _ mHierarchical _ _ ) = _documentSymbol tdcs + in mHierarchical `shouldBe` Just True + it "gives pre 3.10 capabilities" $ + let ClientCapabilities _ (Just tdcs) _ _ _ = capsForVersion (LSPVersion 3 9) + Just (DocumentSymbolClientCapabilities _ _ mHierarchical _ _) = _documentSymbol tdcs + in mHierarchical `shouldBe` Nothing diff --git a/test/JsonSpec.hs b/test/JsonSpec.hs new file mode 100644 --- /dev/null +++ b/test/JsonSpec.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- For the use of MarkedString +{-# OPTIONS_GHC -fno-warn-deprecations #-} +-- | Test for JSON serialization +module JsonSpec where + +import Language.LSP.Types + +import qualified Data.Aeson as J +import Data.List(isPrefixOf) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck hiding (Success) +import Test.QuickCheck.Instances () + +-- import Debug.Trace +-- --------------------------------------------------------------------- + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "dispatcher" jsonSpec + describe "ResponseMessage" responseMessageSpec + +-- --------------------------------------------------------------------- + +jsonSpec :: Spec +jsonSpec = do + describe "General JSON instances round trip" $ do + -- DataTypesJSON + prop "LanguageString" (propertyJsonRoundtrip :: LanguageString -> Property) + prop "MarkedString" (propertyJsonRoundtrip :: MarkedString -> Property) + prop "MarkupContent" (propertyJsonRoundtrip :: MarkupContent -> Property) + prop "HoverContents" (propertyJsonRoundtrip :: HoverContents -> Property) + prop "ResponseError" (propertyJsonRoundtrip :: ResponseError -> Property) + prop "WatchedFiles" (propertyJsonRoundtrip :: DidChangeWatchedFilesRegistrationOptions -> Property) + prop "ResponseMessage Initialize" + (propertyJsonRoundtrip :: ResponseMessage 'TextDocumentHover -> Property) + -- prop "ResponseMessage JSON value" + -- (propertyJsonRoundtrip :: ResponseMessage J.Value -> Property) + describe "JSON decoding regressions" $ + it "CompletionItem" $ + (J.decode "{\"jsonrpc\":\"2.0\",\"result\":[{\"label\":\"raisebox\"}],\"id\":1}" :: Maybe (ResponseMessage 'TextDocumentCompletion)) + `shouldNotBe` Nothing + + +responseMessageSpec :: Spec +responseMessageSpec = do + describe "edge cases" $ do + it "decodes result = null" $ do + let input = "{\"jsonrpc\": \"2.0\", \"id\": 123, \"result\": null}" + in J.decode input `shouldBe` Just + ((ResponseMessage "2.0" (Just (IdInt 123)) (Right J.Null)) :: ResponseMessage 'WorkspaceExecuteCommand) + it "handles missing params field" $ do + J.eitherDecode "{ \"jsonrpc\": \"2.0\", \"id\": 15, \"method\": \"shutdown\"}" + `shouldBe` Right (RequestMessage "2.0" (IdInt 15) SShutdown Empty) + describe "invalid JSON" $ do + it "throws if neither result nor error is present" $ do + (J.eitherDecode "{\"jsonrpc\":\"2.0\",\"id\":1}" :: Either String (ResponseMessage 'Initialize)) + `shouldBe` Left ("Error in $: both error and result cannot be Nothing") + it "throws if both result and error are present" $ do + (J.eitherDecode + "{\"jsonrpc\":\"2.0\",\"id\": 1,\"result\":{\"capabilities\": {}},\"error\":{\"code\":-32700,\"message\":\"\",\"data\":null}}" + :: Either String (ResponseMessage 'Initialize)) + `shouldSatisfy` + (either (\err -> "Error in $: both error and result cannot be present" `isPrefixOf` err) (\_ -> False)) + +-- --------------------------------------------------------------------- + +propertyJsonRoundtrip :: (Eq a, Show a, J.ToJSON a, J.FromJSON a) => a -> Property +propertyJsonRoundtrip a = J.Success a === J.fromJSON (J.toJSON a) + +-- --------------------------------------------------------------------- + +instance Arbitrary LanguageString where + arbitrary = LanguageString <$> arbitrary <*> arbitrary + +instance Arbitrary MarkedString where + arbitrary = oneof [PlainString <$> arbitrary, CodeString <$> arbitrary] + +instance Arbitrary MarkupContent where + arbitrary = MarkupContent <$> arbitrary <*> arbitrary + +instance Arbitrary MarkupKind where + arbitrary = oneof [pure MkPlainText,pure MkMarkdown] + +instance Arbitrary HoverContents where + arbitrary = oneof [ HoverContentsMS <$> arbitrary + , HoverContents <$> arbitrary + ] + +instance Arbitrary UInt where + arbitrary = fromInteger <$> arbitrary + +instance Arbitrary Uri where + arbitrary = Uri <$> arbitrary + +instance Arbitrary Position where + arbitrary = Position <$> arbitrary <*> arbitrary + +instance Arbitrary Location where + arbitrary = Location <$> arbitrary <*> arbitrary + +instance Arbitrary Range where + arbitrary = Range <$> arbitrary <*> arbitrary + +instance Arbitrary Hover where + arbitrary = Hover <$> arbitrary <*> arbitrary + +instance Arbitrary (ResponseResult m) => Arbitrary (ResponseMessage m) where + arbitrary = + oneof + [ ResponseMessage + <$> arbitrary + <*> arbitrary + <*> (Right <$> arbitrary) + , ResponseMessage + <$> arbitrary + <*> arbitrary + <*> (Left <$> arbitrary) + ] + +instance Arbitrary (LspId m) where + arbitrary = oneof [IdInt <$> arbitrary, IdString <$> arbitrary] + +instance Arbitrary ResponseError where + arbitrary = ResponseError <$> arbitrary <*> arbitrary <*> pure Nothing + +instance Arbitrary ErrorCode where + arbitrary = + elements + [ ParseError + , InvalidRequest + , MethodNotFound + , InvalidParams + , InternalError + , ServerErrorStart + , ServerErrorEnd + , ServerNotInitialized + , UnknownErrorCode + , RequestCancelled + , ContentModified + ] + +-- | make lists of maximum length 3 for test performance +smallList :: Gen a -> Gen [a] +smallList = resize 3 . listOf + +instance (Arbitrary a) => Arbitrary (List a) where + arbitrary = List <$> arbitrary + +-- --------------------------------------------------------------------- + +instance Arbitrary DidChangeWatchedFilesRegistrationOptions where + arbitrary = DidChangeWatchedFilesRegistrationOptions <$> arbitrary + +instance Arbitrary FileSystemWatcher where + arbitrary = FileSystemWatcher <$> arbitrary <*> arbitrary + +instance Arbitrary WatchKind where + arbitrary = WatchKind <$> arbitrary <*> arbitrary <*> arbitrary + +-- --------------------------------------------------------------------- diff --git a/test/LocationSpec.hs b/test/LocationSpec.hs new file mode 100644 --- /dev/null +++ b/test/LocationSpec.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module LocationSpec where + +import Language.LSP.Types +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "isSubrangeOf" $ do + it "is true if the first range is totally inside the second range" $ + isSubrangeOf (mkRange 1 2 1 5) (mkRange 1 1 1 6) `shouldBe` True + it "is true if two ranges equal" $ + isSubrangeOf (mkRange 1 2 1 5) (mkRange 1 2 1 5) `shouldBe` True + it "is false if the first range is outside of the second" $ + isSubrangeOf (mkRange 1 1 1 5) (mkRange 1 2 1 5) `shouldBe` False + + describe "positionInRange" $ do + it "is false if position is after the end of a single line range" $ + positionInRange (Position 1 10) (Range (Position 1 1) (Position 1 3)) `shouldBe` False + it "is false if position is before the begining of a single line range" $ + positionInRange (Position 1 0) (Range (Position 1 1) (Position 1 6)) `shouldBe` False + it "is true if position is in a single line range" $ + positionInRange (Position 1 5) (Range (Position 1 1) (Position 1 6)) `shouldBe` True + it "is false if position is right at the end of the range" $ + positionInRange (Position 1 5) (Range (Position 1 1) (Position 1 5)) `shouldBe` False + it "is true if position is in the middle of a multiline range" $ + positionInRange (Position 3 5) (Range (Position 1 1) (Position 5 6)) `shouldBe` True + it "is false if position is before the beginning of a multiline range" $ + positionInRange (Position 3 5) (Range (Position 3 6) (Position 4 10)) `shouldBe` False + it "is false if position is right at the end of a multiline range" $ + positionInRange (Position 4 10) (Range (Position 3 6) (Position 4 10)) `shouldBe` False diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.Hspec.Runner +import qualified Spec + +main :: IO () +main = hspec Spec.spec diff --git a/test/MethodSpec.hs b/test/MethodSpec.hs new file mode 100644 --- /dev/null +++ b/test/MethodSpec.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings, DataKinds #-} +module MethodSpec where + + +import Control.Monad +import qualified Data.Aeson as J +import qualified Language.LSP.Types as J +import Test.Hspec +import qualified Data.Text as T + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "Method enum aeson instance consistency" diagnosticsSpec + +-- --------------------------------------------------------------------- + +clientMethods :: [T.Text] +clientMethods = [ + -- General + "initialize" + ,"initialized" + ,"shutdown" + ,"exit" + ,"$/cancelRequest" + -- Workspace + ,"workspace/didChangeConfiguration" + ,"workspace/didChangeWatchedFiles" + ,"workspace/symbol" + ,"workspace/executeCommand" + ,"workspace/semanticTokens/refresh" + -- Document + ,"textDocument/didOpen" + ,"textDocument/didChange" + ,"textDocument/willSave" + ,"textDocument/willSaveWaitUntil" + ,"textDocument/didSave" + ,"textDocument/didClose" + ,"textDocument/completion" + ,"completionItem/resolve" + ,"textDocument/hover" + ,"textDocument/signatureHelp" + ,"textDocument/references" + ,"textDocument/documentHighlight" + ,"textDocument/documentSymbol" + ,"textDocument/formatting" + ,"textDocument/rangeFormatting" + ,"textDocument/onTypeFormatting" + ,"textDocument/definition" + ,"textDocument/codeAction" + ,"textDocument/codeLens" + ,"codeLens/resolve" + ,"textDocument/documentLink" + ,"documentLink/resolve" + ,"textDocument/rename" + ,"textDocument/prepareRename" + ,"textDocument/prepareCallHierarchy" + ,"callHierarchy/incomingCalls" + ,"callHierarchy/outgoingCalls" + + ,"textDocument/semanticTokens" + ,"textDocument/semanticTokens/full" + ,"textDocument/semanticTokens/full/delta" + ,"textDocument/semanticTokens/range" + ] + +serverMethods :: [T.Text] +serverMethods = [ + -- Window + "window/showMessage" + ,"window/showMessageRequest" + ,"window/logMessage" + ,"telemetry/event" + -- Client + ,"client/registerCapability" + ,"client/unregisterCapability" + -- Workspace + ,"workspace/applyEdit" + -- Document + ,"textDocument/publishDiagnostics" + ] + +diagnosticsSpec :: Spec +diagnosticsSpec = do + describe "Client Methods" $ do + it "maintains roundtrip consistency" $ do + forM_ clientMethods $ \m -> do + (J.toJSON <$> (J.fromJSON (J.String m) :: J.Result (J.SomeClientMethod))) + `shouldBe` (J.Success $ J.String m) + describe "Server Methods" $ do + it "maintains roundtrip consistency" $ do + forM_ serverMethods $ \m -> do + (J.toJSON <$> (J.fromJSON (J.String m) :: J.Result (J.SomeServerMethod))) + `shouldBe` (J.Success $ J.String m) + + -- --------------------------------- diff --git a/test/SemanticTokensSpec.hs b/test/SemanticTokensSpec.hs new file mode 100644 --- /dev/null +++ b/test/SemanticTokensSpec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module SemanticTokensSpec where + +import Test.Hspec +import Language.LSP.Types +import Data.List (unfoldr) +import Data.Either (isRight) + +spec :: Spec +spec = do + let exampleLegend = SemanticTokensLegend (List [SttProperty, SttType, SttClass]) (List [StmUnknown "private", StmStatic]) + exampleTokens1 = [ + SemanticTokenAbsolute 2 5 3 SttProperty [StmUnknown "private", StmStatic] + , SemanticTokenAbsolute 2 10 4 SttType [] + , SemanticTokenAbsolute 5 2 7 SttClass [] + ] + exampleTokens2 = [ + SemanticTokenAbsolute 3 5 3 SttProperty [StmUnknown "private", StmStatic] + , SemanticTokenAbsolute 3 10 4 SttType [] + , SemanticTokenAbsolute 6 2 7 SttClass [] + ] + + bigNumber :: UInt + bigNumber = 100000 + bigTokens = + unfoldr (\i -> if i == bigNumber then Nothing else Just (SemanticTokenAbsolute i 1 1 SttType [StmUnknown "private", StmStatic], i+1)) 0 + -- Relativized version of bigTokens + bigTokensRel = + unfoldr (\i -> if i == bigNumber then Nothing else Just (SemanticTokenRelative (if i == 0 then 0 else 1) 1 1 SttType [StmUnknown "private", StmStatic], i+1)) 0 + + -- One more order of magnitude makes diffing more-or-less hang - possibly we need a better diffing algorithm, since this is only ~= 200 tokens at 5 ints per token + -- (I checked and it is the diffing that's slow, not turning it into edits) + smallerBigNumber :: UInt + smallerBigNumber = 1000 + bigInts :: [UInt] + bigInts = + unfoldr (\i -> if i == smallerBigNumber then Nothing else Just (1, i+1)) 0 + bigInts2 :: [UInt] + bigInts2 = + unfoldr (\i -> if i == smallerBigNumber then Nothing else Just (if even i then 2 else 1, i+1)) 0 + + describe "relativize/absolutizeTokens" $ do + it "round-trips" $ do + absolutizeTokens (relativizeTokens exampleTokens1) `shouldBe` exampleTokens1 + absolutizeTokens (relativizeTokens exampleTokens2) `shouldBe` exampleTokens2 + it "handles big tokens" $ relativizeTokens bigTokens `shouldBe` bigTokensRel + + describe "encodeTokens" $ do + context "when running the LSP examples" $ do + it "encodes example 1 correctly" $ + let encoded = encodeTokens exampleLegend (relativizeTokens exampleTokens1) + in encoded `shouldBe` Right [{- token 1 -}2,5,3,0,3,{- token 2 -}0,5,4,1,0,{- token 3 -}3,2,7,2,0] + it "encodes example 2 correctly" $ + let encoded = encodeTokens exampleLegend (relativizeTokens exampleTokens2) + in encoded `shouldBe` Right [{- token 1 -}3,5,3,0,3,{- token 2 -}0,5,4,1,0,{- token 3 -}3,2,7,2,0] + it "handles big tokens" $ encodeTokens exampleLegend bigTokensRel `shouldSatisfy` isRight + + describe "computeEdits" $ do + it "handles an edit in the middle" $ + computeEdits @Int [1,2,3] [1,4,5,3] `shouldBe` [Edit 1 1 [4,5]] + it "handles an edit at the end" $ + computeEdits @Int [1,2,3] [1,2,4,5] `shouldBe` [Edit 2 1 [4,5]] + it "handles an edit at the beginning" $ + computeEdits @Int [1,2,3] [4,5,2,3] `shouldBe` [Edit 0 1 [4,5]] + it "handles an ambiguous edit" $ + computeEdits @Int [1,2,3] [1,3,4,3] `shouldBe` [Edit 1 1 [], Edit 3 0 [4,3]] + it "handles a long edit" $ + computeEdits @Int [1,2,3,4,5] [1,7,7,7,7,7,5] `shouldBe` [Edit 1 3 [7,7,7,7,7]] + it "handles multiple edits" $ + computeEdits @Int [1,2,3,4,5] [1,6,3,7,7,5] `shouldBe` [Edit 1 1 [6], Edit 3 1 [7,7]] + it "handles big tokens" $ + -- It's a little hard to specify a useful predicate here, the main point is that it should not take too long + computeEdits @UInt bigInts bigInts2 `shouldSatisfy` (not . null) diff --git a/test/ServerCapabilitiesSpec.hs b/test/ServerCapabilitiesSpec.hs new file mode 100644 --- /dev/null +++ b/test/ServerCapabilitiesSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +module ServerCapabilitiesSpec where + +import Control.Lens.Operators +import Data.Aeson +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import Language.LSP.Types.Lens +import Test.Hspec + +spec :: Spec +spec = describe "server capabilities" $ do + describe "folding range options" $ do + describe "decodes" $ do + it "just id" $ + let input = "{\"id\": \"abc123\"}" + in decode input `shouldBe` Just (FoldingRangeRegistrationOptions Nothing Nothing (Just "abc123")) + it "id and document selector" $ + let input = "{\"id\": \"foo\", \"documentSelector\": " <> documentFiltersJson <> "}" + in decode input `shouldBe` Just (FoldingRangeRegistrationOptions (Just documentFilters) Nothing (Just "foo")) + it "static boolean" $ + let input = "true" + in decode input `shouldBe` Just True + describe "encodes" $ + it "just id" $ + encode (FoldingRangeRegistrationOptions Nothing Nothing (Just "foo")) `shouldBe` "{\"id\":\"foo\"}" + it "decodes" $ + let input = "{\"hoverProvider\": true, \"colorProvider\": {\"id\": \"abc123\", \"documentSelector\": " <> documentFiltersJson <> "}}" + Just caps = decode input :: Maybe ServerCapabilities + in caps ^. colorProvider `shouldBe` Just (InR $ InR $ DocumentColorRegistrationOptions (Just documentFilters) (Just "abc123") Nothing) + describe "client/registerCapability" $ + it "allows empty registerOptions" $ + let input = "{\"registrations\":[{\"registerOptions\":{},\"method\":\"workspace/didChangeConfiguration\",\"id\":\"4a56f5ca-7188-4f4c-a366-652d6f9d63aa\"}]}" + Just registrationParams = decode input :: Maybe RegistrationParams + in registrationParams ^. registrations `shouldBe` + List [SomeRegistration $ Registration "4a56f5ca-7188-4f4c-a366-652d6f9d63aa" + SWorkspaceDidChangeConfiguration Empty] + where + documentFilters = List [DocumentFilter (Just "haskell") Nothing Nothing] + documentFiltersJson = "[{\"language\": \"haskell\"}]" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} +{- + +See https://github.com/hspec/hspec/tree/master/hspec-discover#readme +to understand this module + +Or http://hspec.github.io/hspec-discover.html + +-} diff --git a/test/TypesSpec.hs b/test/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/TypesSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +module TypesSpec where + +import qualified Language.LSP.Types as J +import Test.Hspec + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = diagnosticsSpec + +-- --------------------------------------------------------------------- + +diagnosticsSpec :: Spec +diagnosticsSpec = do + describe "MarkupContent" $ do + it "appends two plainstrings" $ do + J.unmarkedUpContent "string1\n" <> J.unmarkedUpContent "string2\n" + `shouldBe` J.unmarkedUpContent "string1\nstring2\n" + it "appends a marked up and a plain string" $ do + J.markedUpContent "haskell" "foo :: Int" <> J.unmarkedUpContent "string2\nstring3\n" + `shouldBe` J.MarkupContent J.MkMarkdown "\n```haskell\nfoo :: Int\n```\nstring2 \nstring3 \n" + it "appends a plain string and a marked up string" $ do + J.unmarkedUpContent "string2\n" <> J.markedUpContent "haskell" "foo :: Int" + `shouldBe` J.MarkupContent J.MkMarkdown "string2 \n\n```haskell\nfoo :: Int\n```\n" + +-- --------------------------------------------------------------------- diff --git a/test/URIFilePathSpec.hs b/test/URIFilePathSpec.hs new file mode 100644 --- /dev/null +++ b/test/URIFilePathSpec.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#if MIN_VERSION_filepath(1,4,100) +#define OS_PATH +#endif + +module URIFilePathSpec where + +#ifdef OS_PATH +import qualified System.OsPath as OsPath +#endif + +import Control.Monad (when) +import Data.List +import Data.Text (Text, pack) +import Language.LSP.Types + +import Control.Exception (IOException, throwIO) +import Data.Maybe (fromJust) +import GHC.IO.Encoding (setFileSystemEncoding) +import Network.URI +import System.FilePath (normalise) +import qualified System.FilePath.Windows as FPW +import qualified System.Info +import System.IO +import Test.Hspec +import Test.QuickCheck + +-- --------------------------------------------------------------------- + +isWindows :: Bool +isWindows = System.Info.os == "mingw32" + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Platform aware URI file path functions" platformAwareUriFilePathSpec + describe "URI file path functions" uriFilePathSpec + describe "URI normalization functions" uriNormalizeSpec + describe "Normalized file path functions" normalizedFilePathSpec + +windowsOS :: String +windowsOS = "mingw32" + +testPosixUri :: Uri +testPosixUri = Uri $ pack "file:///home/myself/example.hs" + +testPosixFilePath :: FilePath +testPosixFilePath = "/home/myself/example.hs" + +relativePosixFilePath :: FilePath +relativePosixFilePath = "myself/example.hs" + +testWindowsUri :: Uri +testWindowsUri = Uri $ pack "file:///c:/Users/myself/example.hs" + +testWindowsFilePath :: FilePath +testWindowsFilePath = "c:\\Users\\myself\\example.hs" + +platformAwareUriFilePathSpec :: Spec +platformAwareUriFilePathSpec = do + it "converts a URI to a POSIX file path" $ do + let theFilePath = platformAwareUriToFilePath "posix" testPosixUri + theFilePath `shouldBe` Just testPosixFilePath + + it "converts a POSIX file path to a URI" $ do + let theUri = platformAwareFilePathToUri "posix" testPosixFilePath + theUri `shouldBe` testPosixUri + + it "converts a URI to a Windows file path" $ do + let theFilePath = platformAwareUriToFilePath windowsOS testWindowsUri + theFilePath `shouldBe` Just testWindowsFilePath + + it "converts a Windows file path to a URI" $ do + let theUri = platformAwareFilePathToUri windowsOS testWindowsFilePath + theUri `shouldBe` testWindowsUri + + it "converts a POSIX file path to a URI" $ do + let theFilePath = platformAwareFilePathToUri "posix" "./Functional.hs" + theFilePath `shouldBe` (Uri "file://./Functional.hs") + + it "converts a Windows file path to a URI" $ do + let theFilePath = platformAwareFilePathToUri windowsOS "./Functional.hs" + theFilePath `shouldBe` (Uri "file:///./Functional.hs") + + it "converts a Windows file path to a URI" $ do + let theFilePath = platformAwareFilePathToUri windowsOS "c:/Functional.hs" + theFilePath `shouldBe` (Uri "file:///c:/Functional.hs") + + it "converts a POSIX file path to a URI and back" $ do + let theFilePath = platformAwareFilePathToUri "posix" "./Functional.hs" + theFilePath `shouldBe` (Uri "file://./Functional.hs") + let Just (URI scheme' auth' path' query' frag') = parseURI "file://./Functional.hs" + (scheme',auth',path',query',frag') `shouldBe` + ("file:" + ,Just (URIAuth {uriUserInfo = "", uriRegName = ".", uriPort = ""}) -- AZ: Seems odd + ,"/Functional.hs" + ,"" + ,"") + Just "./Functional.hs" `shouldBe` platformAwareUriToFilePath "posix" theFilePath + + it "converts a Posix file path to a URI and back" $ property $ forAll genPosixFilePath $ \fp -> do + let uri = platformAwareFilePathToUri "posix" fp + platformAwareUriToFilePath "posix" uri `shouldBe` Just fp + + it "converts a Windows file path to a URI and back" $ property $ forAll genWindowsFilePath $ \fp -> do + let uri = platformAwareFilePathToUri windowsOS fp + -- We normalise to account for changes in the path separator. + -- But driver letters are *not* normalized so we skip them + when (not $ "c:" `isPrefixOf` fp) $ + platformAwareUriToFilePath windowsOS uri `shouldBe` Just (FPW.normalise fp) + + it "converts a relative POSIX file path to a URI and back" $ do + let uri = platformAwareFilePathToUri "posix" relativePosixFilePath + uri `shouldBe` Uri "file://myself/example.hs" + let back = platformAwareUriToFilePath "posix" uri + back `shouldBe` Just relativePosixFilePath + + +testUri :: Uri +testUri | isWindows = Uri "file:///C:/Users/myself/example.hs" + | otherwise = Uri "file:///home/myself/example.hs" + +testFilePath :: FilePath +testFilePath | isWindows = "C:\\Users\\myself\\example.hs" + | otherwise = "/home/myself/example.hs" + +withCurrentDirFilePath :: FilePath +withCurrentDirFilePath | isWindows = "C:\\Users\\.\\myself\\.\\.\\example.hs" + | otherwise = "/home/./myself/././example.hs" + +fromRelativefilePathUri :: Uri +fromRelativefilePathUri | isWindows = Uri "file:///myself/example.hs" + | otherwise = Uri "file://myself/example.hs" + +relativeFilePath :: FilePath +relativeFilePath | isWindows = "myself\\example.hs" + | otherwise = "myself/example.hs" + +withLowerCaseDriveLetterFilePath :: FilePath +withLowerCaseDriveLetterFilePath = "c:\\Users\\.\\myself\\.\\.\\example.hs" + +withInitialCurrentDirUriStr :: String +withInitialCurrentDirUriStr | isWindows = "file:///Functional.hs" + | otherwise = "file://Functional.hs" + +withInitialCurrentDirUriParts :: (String, Maybe URIAuth, String, String, String) +withInitialCurrentDirUriParts + | isWindows = + ("file:" + ,Just (URIAuth {uriUserInfo = "", uriRegName = "", uriPort = ""}) -- JNS: And asymmetrical + ,"/Functional.hs","","") + | otherwise = + ("file:" + ,Just (URIAuth {uriUserInfo = "", uriRegName = "Functional.hs", uriPort = ""}) -- AZ: Seems odd + ,"","","") + +withInitialCurrentDirFilePath :: FilePath +withInitialCurrentDirFilePath | isWindows = ".\\Functional.hs" + | otherwise = "./Functional.hs" + +noNormalizedUriTxt :: Text +noNormalizedUriTxt | isWindows = "file:///c:/Users/./myself/././example.hs" + | otherwise = "file:///home/./myself/././example.hs" + +noNormalizedUri :: Uri +noNormalizedUri = Uri noNormalizedUriTxt + +uriFilePathSpec :: Spec +uriFilePathSpec = do + it "converts a URI to a file path" $ do + let theFilePath = uriToFilePath testUri + theFilePath `shouldBe` Just testFilePath + + it "converts a file path to a URI" $ do + let theUri = filePathToUri testFilePath + theUri `shouldBe` testUri + + it "removes unnecessary current directory paths" $ do + let theUri = filePathToUri withCurrentDirFilePath + theUri `shouldBe` testUri + + when isWindows $ + it "make the drive letter upper case when converting a Windows file path to a URI" $ do + let theUri = filePathToUri withLowerCaseDriveLetterFilePath + theUri `shouldBe` testUri + + it "converts a file path to a URI and back" $ property $ forAll genFilePath $ \fp -> do + let uri = filePathToUri fp + uriToFilePath uri `shouldBe` Just (normalise fp) + + it "converts a relative file path to a URI and back" $ do + let uri = filePathToUri relativeFilePath + uri `shouldBe` fromRelativefilePathUri + let back = uriToFilePath uri + back `shouldBe` Just relativeFilePath + + it "converts a file path with initial current dir to a URI and back" $ do + let uri = filePathToUri withInitialCurrentDirFilePath + uri `shouldBe` (Uri (pack withInitialCurrentDirUriStr)) + let Just (URI scheme' auth' path' query' frag') = parseURI withInitialCurrentDirUriStr + (scheme',auth',path',query',frag') `shouldBe` withInitialCurrentDirUriParts + Just "Functional.hs" `shouldBe` uriToFilePath uri + +uriNormalizeSpec :: Spec +uriNormalizeSpec = do + + it "ignores differences in percent-encoding" $ property $ \uri -> + toNormalizedUri (Uri $ pack $ escapeURIString isUnescapedInURI uri) `shouldBe` + toNormalizedUri (Uri $ pack $ escapeURIString (const False) uri) + + it "ignores differences in percent-encoding (examples)" $ do + toNormalizedUri (Uri $ pack "http://server/path%C3%B1?param=%C3%B1") `shouldBe` + toNormalizedUri (Uri $ pack "http://server/path%c3%b1?param=%c3%b1") + toNormalizedUri (Uri $ pack "file:///path%2A") `shouldBe` + toNormalizedUri (Uri $ pack "file:///path%2a") + + it "normalizes uri file path when converting from uri to normalized uri" $ do + let (NormalizedUri _ uri) = toNormalizedUri noNormalizedUri + let (Uri nuri) = testUri + uri `shouldBe` nuri + + it "converts a file path with reserved uri chars to a normalized URI and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "path;part#fragmen?param=val" + let nuri = toNormalizedUri (filePathToUri fp) + uriToFilePath (fromNormalizedUri nuri) `shouldBe` Just fp + + it "converts a file path with substrings that looks like uri escaped chars and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "ca%C3%B1a" + let nuri = toNormalizedUri (filePathToUri fp) + uriToFilePath (fromNormalizedUri nuri) `shouldBe` Just fp + + it "converts a file path to a normalized URI and back" $ property $ forAll genFilePath $ \fp -> do + let nuri = toNormalizedUri (filePathToUri fp) + case uriToFilePath (fromNormalizedUri nuri) of + Just nfp -> nfp `shouldBe` (normalise fp) + Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now + +genFilePath :: Gen FilePath +genFilePath | isWindows = genWindowsFilePath + | otherwise = genPosixFilePath + +genWindowsFilePath :: Gen FilePath +genWindowsFilePath = do + segments <- listOf1 pathSegment + pathSep <- elements ['/', '\\'] + driveLetter <- elements ["C:", "c:"] + pure (driveLetter <> [pathSep] <> intercalate [pathSep] segments) + where pathSegment = listOf1 (genValidUnicodeChar `suchThat` (`notElem` ['/', '\\', ':'])) + +genPosixFilePath :: Gen FilePath +genPosixFilePath = do + segments <- listOf1 pathSegment + pure ("/" <> intercalate "/" segments) + where pathSegment = listOf1 (genValidUnicodeChar `suchThat` (`notElem` ['/'])) + +genValidUnicodeChar :: Gen Char +genValidUnicodeChar = arbitraryUnicodeChar `suchThat` isCharacter + where isCharacter x = x /= '\65534' && x /= '\65535' + +normalizedFilePathSpec :: Spec +normalizedFilePathSpec = beforeAll (setFileSystemEncoding utf8) $ do + it "makes file path normalized" $ property $ forAll genFilePath $ \fp -> do + let nfp = toNormalizedFilePath fp + fromNormalizedFilePath nfp `shouldBe` (normalise fp) + + it "converts to a normalized uri and back" $ property $ forAll genFilePath $ \fp -> do + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + case uriToNormalizedFilePath nuri of + Just nfp -> fromNormalizedFilePath nfp `shouldBe` (normalise fp) + Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now + + it "converts a file path with reserved uri chars to a normalized URI and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "path;part#fragmen?param=val" + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp + + it "converts a file path with substrings that looks like uri escaped chars and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "ca%C3%B1a" + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp + + it "creates the same NormalizedUri than the older implementation" $ property $ forAll genFilePath $ \fp -> do + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + let oldNuri = toNormalizedUri (filePathToUri fp) + nuri `shouldBe` oldNuri + +#ifdef OS_PATH + it "converts to NormalizedFilePath and back sucessfully" $ property $ forAll genFilePath $ \fp -> do + let osPath = fromJust (OsPath.encodeUtf fp) + osPath' <- osPathToNormalizedFilePath osPath >>= normalizedFilePathToOsPath + osPath' `shouldBe` OsPath.normalise osPath + + it "can not convert OsPath in non-standard encoding to NormalizedFilePath" $ + -- Windows always use UTF16LE, the following test case doesn't apply + when (not isWindows) $ + -- \184921 is an example that the raw bytes of UTF16 is not valid UTF8. + -- Case like this is not very common. I found it with the help of QuickCheck. + case OsPath.encodeWith utf16be utf16be "\184921" of + Left err -> throwIO err + Right osPath -> do + osPathToNormalizedFilePath osPath `shouldThrow` \(_ :: EncodingException) -> True +#endif diff --git a/test/WorkspaceEditSpec.hs b/test/WorkspaceEditSpec.hs new file mode 100644 --- /dev/null +++ b/test/WorkspaceEditSpec.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module WorkspaceEditSpec where + +import Test.Hspec +import Language.LSP.Types + +spec :: Spec +spec = do + describe "applyTextEdit" $ do + it "inserts text" $ + let te = TextEdit (Range (Position 1 2) (Position 1 2)) "foo" + in applyTextEdit te "lorem\nipsum\ndolor" `shouldBe` "lorem\nipfoosum\ndolor" + it "deletes text" $ + let te = TextEdit (Range (Position 0 2) (Position 1 2)) "" + in applyTextEdit te "lorem\nipsum\ndolor" `shouldBe` "losum\ndolor" + it "edits a multiline text" $ + let te = TextEdit (Range (Position 1 0) (Position 2 0)) "slorem" + in applyTextEdit te "lorem\nipsum\ndolor" `shouldBe` "lorem\nsloremdolor" + it "inserts text past the last line" $ + let te = TextEdit (Range (Position 3 2) (Position 3 2)) "foo" + in applyTextEdit te "lorem\nipsum\ndolor" `shouldBe` "lorem\nipsum\ndolorfoo" + + describe "editTextEdit" $ + it "edits a multiline text edit" $ + let orig = TextEdit (Range (Position 1 1) (Position 2 2)) "hello\nworld" + inner = TextEdit (Range (Position 0 3) (Position 1 3)) "ios\ngo" + expected = TextEdit (Range (Position 1 1) (Position 2 2)) "helios\ngold" + in editTextEdit orig inner `shouldBe` expected