diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for lsp +## 1.6.0.0 + +* Pinned to lsp-types 1.6 +* Tests moved to `lsp-types` + ## 1.5.0.0 * VFS module moved to `lsp` from `lsp-types`. diff --git a/lsp.cabal b/lsp.cabal --- a/lsp.cabal +++ b/lsp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: lsp -version: 1.5.0.0 +version: 1.6.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -44,19 +44,16 @@ , exceptions , filepath , hashable - , lsp-types == 1.5.* + , lsp-types == 1.6.* , lens >= 4.15.2 , mtl < 2.4 - , network-uri , prettyprinter , sorted-list == 0.2.1.* , stm == 2.5.* - , scientific , temporary , text , text-rope , transformers >= 0.5.6 && < 0.7 - , time , unordered-containers , unliftio-core >= 0.2.0.0 -- used for generating random uuids for dynamic registration @@ -101,44 +98,21 @@ default: False -test-suite unit-test +test-suite lsp-test type: exitcode-stdio-1.0 - -- hs-source-dirs: test src hs-source-dirs: test main-is: Main.hs other-modules: Spec - CapabilitiesSpec - JsonSpec DiagnosticsSpec - MethodSpec - ServerCapabilitiesSpec - SemanticTokensSpec - TypesSpec - URIFilePathSpec VspSpec - WorkspaceEditSpec build-depends: base - , QuickCheck - -- for instance Arbitrary Value - , aeson >= 2.0.3.0 , containers - , filepath , lsp , hspec - -- , hspec-jenkins - , lens >= 4.15.2 - , network-uri - , quickcheck-instances , sorted-list == 0.2.1.* , text , text-rope , unordered-containers - -- For GHCI tests - -- , async - -- , haskell-lsp-types - -- , temporary - -- , time - -- , unordered-containers build-tool-depends: hspec-discover:hspec-discover ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 diff --git a/test/CapabilitiesSpec.hs b/test/CapabilitiesSpec.hs deleted file mode 100644 --- a/test/CapabilitiesSpec.hs +++ /dev/null @@ -1,16 +0,0 @@ -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 deleted file mode 100644 --- a/test/JsonSpec.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# 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/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,22 +1,7 @@ module Main where - --- import Test.Hspec.Formatters.Jenkins import Test.Hspec.Runner import qualified Spec --- --------------------------------------------------------------------- - main :: IO () main = hspec Spec.spec - --- main :: IO () --- main = do --- summary <- withFile "results.xml" WriteMode $ \h -> do --- let c = defaultConfig --- { configFormatter = xmlFormatter --- , configHandle = h --- } --- hspecWith c Spec.spec --- unless (summaryFailures summary == 0) $ --- exitFailure diff --git a/test/MethodSpec.hs b/test/MethodSpec.hs deleted file mode 100644 --- a/test/MethodSpec.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/SemanticTokensSpec.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/ServerCapabilitiesSpec.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# 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/TypesSpec.hs b/test/TypesSpec.hs deleted file mode 100644 --- a/test/TypesSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/URIFilePathSpec.hs +++ /dev/null @@ -1,278 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module URIFilePathSpec where - -import Control.Monad (when) -import Data.List -import Data.Text (Text, pack) -import Language.LSP.Types - -import Network.URI -import Test.Hspec -import Test.QuickCheck -import qualified System.FilePath.Windows as FPW -import System.FilePath (normalise) -import qualified System.Info --- --------------------------------------------------------------------- - -isWindows :: Bool -isWindows = System.Info.os == "mingw32" - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "Platform aware URI file path functions" platformAwareUriFilePathSpec - describe "URI file path functions" uriFilePathSpec - describe "URI normalization functions" uriNormalizeSpec - describe "Normalized file path functions" normalizedFilePathSpec - -windowsOS :: String -windowsOS = "mingw32" - -testPosixUri :: Uri -testPosixUri = Uri $ pack "file:///home/myself/example.hs" - -testPosixFilePath :: FilePath -testPosixFilePath = "/home/myself/example.hs" - -relativePosixFilePath :: FilePath -relativePosixFilePath = "myself/example.hs" - -testWindowsUri :: Uri -testWindowsUri = Uri $ pack "file:///c:/Users/myself/example.hs" - -testWindowsFilePath :: FilePath -testWindowsFilePath = "c:\\Users\\myself\\example.hs" - -platformAwareUriFilePathSpec :: Spec -platformAwareUriFilePathSpec = do - it "converts a URI to a POSIX file path" $ do - let theFilePath = platformAwareUriToFilePath "posix" testPosixUri - theFilePath `shouldBe` Just testPosixFilePath - - it "converts a POSIX file path to a URI" $ do - let theUri = platformAwareFilePathToUri "posix" testPosixFilePath - theUri `shouldBe` testPosixUri - - it "converts a URI to a Windows file path" $ do - let theFilePath = platformAwareUriToFilePath windowsOS testWindowsUri - theFilePath `shouldBe` Just testWindowsFilePath - - it "converts a Windows file path to a URI" $ do - let theUri = platformAwareFilePathToUri windowsOS testWindowsFilePath - theUri `shouldBe` testWindowsUri - - it "converts a POSIX file path to a URI" $ do - let theFilePath = platformAwareFilePathToUri "posix" "./Functional.hs" - theFilePath `shouldBe` (Uri "file://./Functional.hs") - - it "converts a Windows file path to a URI" $ do - let theFilePath = platformAwareFilePathToUri windowsOS "./Functional.hs" - theFilePath `shouldBe` (Uri "file:///./Functional.hs") - - it "converts a Windows file path to a URI" $ do - let theFilePath = platformAwareFilePathToUri windowsOS "c:/Functional.hs" - theFilePath `shouldBe` (Uri "file:///c:/Functional.hs") - - it "converts a POSIX file path to a URI and back" $ do - let theFilePath = platformAwareFilePathToUri "posix" "./Functional.hs" - theFilePath `shouldBe` (Uri "file://./Functional.hs") - let Just (URI scheme' auth' path' query' frag') = parseURI "file://./Functional.hs" - (scheme',auth',path',query',frag') `shouldBe` - ("file:" - ,Just (URIAuth {uriUserInfo = "", uriRegName = ".", uriPort = ""}) -- AZ: Seems odd - ,"/Functional.hs" - ,"" - ,"") - Just "./Functional.hs" `shouldBe` platformAwareUriToFilePath "posix" theFilePath - - it "converts a Posix file path to a URI and back" $ property $ forAll genPosixFilePath $ \fp -> do - let uri = platformAwareFilePathToUri "posix" fp - platformAwareUriToFilePath "posix" uri `shouldBe` Just fp - - it "converts a Windows file path to a URI and back" $ property $ forAll genWindowsFilePath $ \fp -> do - let uri = platformAwareFilePathToUri windowsOS fp - -- We normalise to account for changes in the path separator. - -- But driver letters are *not* normalized so we skip them - when (not $ "c:" `isPrefixOf` fp) $ - platformAwareUriToFilePath windowsOS uri `shouldBe` Just (FPW.normalise fp) - - it "converts a relative POSIX file path to a URI and back" $ do - let uri = platformAwareFilePathToUri "posix" relativePosixFilePath - uri `shouldBe` Uri "file://myself/example.hs" - let back = platformAwareUriToFilePath "posix" uri - back `shouldBe` Just relativePosixFilePath - - -testUri :: Uri -testUri | isWindows = Uri "file:///C:/Users/myself/example.hs" - | otherwise = Uri "file:///home/myself/example.hs" - -testFilePath :: FilePath -testFilePath | isWindows = "C:\\Users\\myself\\example.hs" - | otherwise = "/home/myself/example.hs" - -withCurrentDirFilePath :: FilePath -withCurrentDirFilePath | isWindows = "C:\\Users\\.\\myself\\.\\.\\example.hs" - | otherwise = "/home/./myself/././example.hs" - -fromRelativefilePathUri :: Uri -fromRelativefilePathUri | isWindows = Uri "file:///myself/example.hs" - | otherwise = Uri "file://myself/example.hs" - -relativeFilePath :: FilePath -relativeFilePath | isWindows = "myself\\example.hs" - | otherwise = "myself/example.hs" - -withLowerCaseDriveLetterFilePath :: FilePath -withLowerCaseDriveLetterFilePath = "c:\\Users\\.\\myself\\.\\.\\example.hs" - -withInitialCurrentDirUriStr :: String -withInitialCurrentDirUriStr | isWindows = "file:///Functional.hs" - | otherwise = "file://Functional.hs" - -withInitialCurrentDirUriParts :: (String, Maybe URIAuth, String, String, String) -withInitialCurrentDirUriParts - | isWindows = - ("file:" - ,Just (URIAuth {uriUserInfo = "", uriRegName = "", uriPort = ""}) -- JNS: And asymmetrical - ,"/Functional.hs","","") - | otherwise = - ("file:" - ,Just (URIAuth {uriUserInfo = "", uriRegName = "Functional.hs", uriPort = ""}) -- AZ: Seems odd - ,"","","") - -withInitialCurrentDirFilePath :: FilePath -withInitialCurrentDirFilePath | isWindows = ".\\Functional.hs" - | otherwise = "./Functional.hs" - -noNormalizedUriTxt :: Text -noNormalizedUriTxt | isWindows = "file:///c:/Users/./myself/././example.hs" - | otherwise = "file:///home/./myself/././example.hs" - -noNormalizedUri :: Uri -noNormalizedUri = Uri noNormalizedUriTxt - -uriFilePathSpec :: Spec -uriFilePathSpec = do - it "converts a URI to a file path" $ do - let theFilePath = uriToFilePath testUri - theFilePath `shouldBe` Just testFilePath - - it "converts a file path to a URI" $ do - let theUri = filePathToUri testFilePath - theUri `shouldBe` testUri - - it "removes 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 = do - it "makes file path normalized" $ property $ forAll genFilePath $ \fp -> do - let nfp = toNormalizedFilePath fp - fromNormalizedFilePath nfp `shouldBe` (normalise fp) - - it "converts to a normalized uri and back" $ property $ forAll genFilePath $ \fp -> do - let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) - case uriToNormalizedFilePath nuri of - Just nfp -> fromNormalizedFilePath nfp `shouldBe` (normalise fp) - Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now - - it "converts a file path with reserved uri chars to a normalized URI and back" $ do - let start = if isWindows then "C:\\" else "/" - let fp = start ++ "path;part#fragmen?param=val" - let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) - fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp - - it "converts a file path with substrings that looks like uri escaped chars and back" $ do - let start = if isWindows then "C:\\" else "/" - let fp = start ++ "ca%C3%B1a" - let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) - fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp - - it "creates the same NormalizedUri than the older implementation" $ property $ forAll genFilePath $ \fp -> do - let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) - let oldNuri = toNormalizedUri (filePathToUri fp) - nuri `shouldBe` oldNuri diff --git a/test/WorkspaceEditSpec.hs b/test/WorkspaceEditSpec.hs deleted file mode 100644 --- a/test/WorkspaceEditSpec.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# 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