diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index ab6c761a5..1319db3a0 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -9,8 +9,17 @@ jobs: strategy: fail-fast: false matrix: - ghc: ['9.2.1', '9.0.1', '8.10.7', '8.8.4', '8.6.5'] + ghc: ['9.2.4', '9.0.2', '8.10.7', '8.8.4', '8.6.5'] os: [ubuntu-latest, macOS-latest, windows-latest] + ospath: [true, false] + exclude: + # newer 'entropy' doesn't work with old 'unix', and it doesn't have a correct version bound. + - ospath: true + ghc: 8.6.5 + # "cabal build" always timeout + - ospath: true + ghc: 8.8.4 + os: windows-latest steps: - uses: actions/checkout@v2 @@ -41,6 +50,12 @@ jobs: - name: Cabal update run: cabal update + - name: Cabal configure + shell: bash + run: | + if [ ${{ matrix.ospath }} = "true" ]; then + cabal configure --constraint="filepath ^>= 1.4.100.0" + fi - name: Build using cabal run: cabal build all - name: Test diff --git a/cabal.project b/cabal.project index c6b74a36a..37b5d32fa 100644 --- a/cabal.project +++ b/cabal.project @@ -6,6 +6,8 @@ packages: package lsp flags: +demo +index-state: 2022-08-25T22:25:05Z + tests: True benchmarks: True test-show-details: direct diff --git a/lsp-test/lsp-test.cabal b/lsp-test/lsp-test.cabal index e2b2867e9..e0687931b 100644 --- a/lsp-test/lsp-test.cabal +++ b/lsp-test/lsp-test.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: lsp-test -version: 0.14.0.3 +version: 0.14.1.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against diff --git a/lsp-types/lsp-types.cabal b/lsp-types/lsp-types.cabal index e71284c0a..b71798582 100644 --- a/lsp-types/lsp-types.cabal +++ b/lsp-types/lsp-types.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: lsp-types -version: 1.5.0.0 +version: 1.5.1.0 synopsis: Haskell library for the Microsoft Language Server Protocol, data types description: An implementation of the types to allow language implementors to @@ -68,6 +68,7 @@ library , 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 @@ -89,6 +90,9 @@ library , text , template-haskell , unordered-containers + , exceptions + , safe + , bytestring hs-source-dirs: src default-language: Haskell2010 default-extensions: StrictData @@ -106,6 +110,7 @@ test-suite lsp-types-test TypesSpec URIFilePathSpec WorkspaceEditSpec + LocationSpec build-depends: base , QuickCheck -- for instance Arbitrary Value @@ -117,6 +122,7 @@ test-suite lsp-types-test , network-uri , quickcheck-instances , text + , tuple build-tool-depends: hspec-discover:hspec-discover ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 diff --git a/lsp-types/src/Language/LSP/Types.hs b/lsp-types/src/Language/LSP/Types.hs index 3c2525ead..4c4975765 100644 --- a/lsp-types/src/Language/LSP/Types.hs +++ b/lsp-types/src/Language/LSP/Types.hs @@ -37,6 +37,7 @@ module Language.LSP.Types , 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.Initialize 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.StaticRegistrationOptions 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/lsp-types/src/Language/LSP/Types/Uri.hs b/lsp-types/src/Language/LSP/Types/Uri.hs index 8d2d43f4e..4f80348cb 100644 --- a/lsp-types/src/Language/LSP/Types/Uri.hs +++ b/lsp-types/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 @@ module Language.LSP.Types.Uri , toNormalizedUri , fromNormalizedUri , NormalizedFilePath - , normalizedFilePath , toNormalizedFilePath , fromNormalizedFilePath , normalizedFilePathToUri , uriToNormalizedFilePath + , emptyNormalizedFilePath -- Private functions , platformAwareUriToFilePath , platformAwareFilePathToUri @@ -22,20 +26,27 @@ module Language.LSP.Types.Uri 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.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as BS 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 qualified Data.Text.Encoding as T +import Data.Text.Encoding.Error (UnicodeException) 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 GHC.Stack (HasCallStack) +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 } deriving (Eq,Ord,Read,Show,Generic,A.FromJSON,A.ToJSON,Hashable,A.ToJSONKey,A.FromJSONKey) @@ -67,7 +78,7 @@ isUnescapedInUriPath systemOS c 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 +118,19 @@ platformAdjustFromUriPath :: SystemOS -> 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 +164,14 @@ platformAdjustToUriPath systemOS srcPath 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 +-- | A file path that is already normalized. It is stored as an UTF-8 encoded 'ShortByteString' +-- +-- 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 ghcide, do not -- modify it without profiling. -data NormalizedFilePath = NormalizedFilePath NormalizedUri !FilePath +data NormalizedFilePath = NormalizedFilePath !NormalizedUri {-# UNPACK #-} !ShortByteString deriving (Generic, Eq, Ord) instance NFData NormalizedFilePath @@ -165,13 +179,17 @@ instance NFData NormalizedFilePath 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) + v <- Data.Binary.get :: Get ShortByteString + case decodeFilePath v of + Left e -> fail (show e) + Right v' -> + return (NormalizedFilePath (internalNormalizedFilePathToUri v') v) + +encodeFilePath :: String -> ShortByteString +encodeFilePath = BS.toShort . T.encodeUtf8 . T.pack --- | A smart constructor that performs UTF-8 encoding and hash consing -normalizedFilePath :: NormalizedUri -> FilePath -> NormalizedFilePath -normalizedFilePath nuri nfp = NormalizedFilePath nuri nfp +decodeFilePath :: ShortByteString -> Either UnicodeException String +decodeFilePath = fmap T.unpack . T.decodeUtf8' . BS.fromShort -- | 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 +209,36 @@ instance Hashable NormalizedFilePath where 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 . encodeFilePath $ nfp where - nfp = FP.normalise fp - nuri = internalNormalizedFilePathToUri nfp + nfp = FP.normalise fp + nuri = internalNormalizedFilePathToUri nfp -fromNormalizedFilePath :: NormalizedFilePath -> FilePath -fromNormalizedFilePath (NormalizedFilePath _ fp) = fp +-- | Extracts 'FilePath' from 'NormalizedFilePath'. +-- The function is total. The 'HasCallStack' constraint is added for debugging purpose only. +fromNormalizedFilePath :: HasCallStack => NormalizedFilePath -> FilePath +fromNormalizedFilePath (NormalizedFilePath _ fp) = + case decodeFilePath fp of + Left e -> error $ show e + Right x -> x normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri normalizedFilePathToUri (NormalizedFilePath uri _) = uri uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath -uriToNormalizedFilePath nuri = fmap (normalizedFilePath nuri) mbFilePath +uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri . encodeFilePath) 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/lsp-types/src/Language/LSP/Types/Uri/OsPath.hs b/lsp-types/src/Language/LSP/Types/Uri/OsPath.hs new file mode 100644 index 000000000..bdb7fb7c0 --- /dev/null +++ b/lsp-types/src/Language/LSP/Types/Uri/OsPath.hs @@ -0,0 +1,47 @@ +{-# 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 +#endif + ) where + +#ifdef OS_PATH + +import Control.DeepSeq (NFData, force) +import Control.Exception hiding (try) +import Control.Monad.Catch +import Language.LSP.Types.Uri +import System.IO.Unsafe (unsafePerformIO) +import System.OsPath + +{-| +Constructs 'NormalizedFilePath' from 'OsPath'. Throws 'IOException' if the conversion fails. +-} +osPathToNormalizedFilePath :: MonadThrow m => OsPath -> m NormalizedFilePath +osPathToNormalizedFilePath = fmap toNormalizedFilePath . unsafePerformIO' . decodeFS + +{-| +Extracts 'OsPath' from 'NormalizedFilePath'. Throws 'IOException' if the conversion fails. +-} +normalizedFilePathToOsPath :: MonadThrow m => NormalizedFilePath -> m OsPath +normalizedFilePathToOsPath = unsafePerformIO' . encodeFS . fromNormalizedFilePath + +unsafePerformIO' :: (MonadThrow m, NFData a) => IO a -> m a +unsafePerformIO' action = + case fp of + Left (e :: SomeException) -> throwM e + Right fp' -> pure fp' + where + fp = unsafePerformIO . try $ do + x <- action + evaluate . force $ x + +#endif diff --git a/lsp-types/test/URIFilePathSpec.hs b/lsp-types/test/URIFilePathSpec.hs index c2951afde..f63104609 100644 --- a/lsp-types/test/URIFilePathSpec.hs +++ b/lsp-types/test/URIFilePathSpec.hs @@ -1,17 +1,33 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#if MIN_VERSION_filepath(1,4,100) +#define OS_PATH +#endif + module URIFilePathSpec where -import Control.Monad (when) -import Data.List -import Data.Text (Text, pack) -import Language.LSP.Types +#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 Network.URI -import Test.Hspec -import Test.QuickCheck +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 System.FilePath (normalise) import qualified System.Info +import System.IO +import Test.Hspec +import Test.QuickCheck + -- --------------------------------------------------------------------- isWindows :: Bool @@ -224,7 +240,7 @@ uriNormalizeSpec = 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 + Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now genFilePath :: Gen FilePath genFilePath | isWindows = genWindowsFilePath @@ -249,7 +265,7 @@ genValidUnicodeChar = arbitraryUnicodeChar `suchThat` isCharacter where isCharacter x = x /= '\65534' && x /= '\65535' normalizedFilePathSpec :: Spec -normalizedFilePathSpec = do +normalizedFilePathSpec = beforeAll (setFileSystemEncoding utf8) $ do it "makes file path normalized" $ property $ forAll genFilePath $ \fp -> do let nfp = toNormalizedFilePath fp fromNormalizedFilePath nfp `shouldBe` (normalise fp) @@ -258,7 +274,7 @@ normalizedFilePathSpec = 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 + 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 "/" @@ -276,3 +292,20 @@ normalizedFilePathSpec = 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` \(_ :: IOException) -> True +#endif diff --git a/lsp/lsp.cabal b/lsp/lsp.cabal index 397f57f20..96a58f7d7 100644 --- a/lsp/lsp.cabal +++ b/lsp/lsp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: lsp -version: 1.5.0.0 +version: 1.5.1.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to