diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for haskell-lsp +## 0.19.0.0 -- 2019-12-14 + +* Fix vfs line endings (@jneira) +* Fix typo in .cabal (@turion) +* Normalize file paths before converting to Uri's (@jneira) +* Fixes to persistVirtualFile (@mpickering) + ## 0.18.0.0 -- 2019-11-17 * Explain the use of NonEmpty in diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -1,5 +1,5 @@ name: haskell-lsp -version: 0.18.0.0 +version: 0.19.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -7,7 +7,7 @@ Protocol for their specific language. . An example of this is for Haskell via the Haskell IDE - Engine, at https://github.com//haskell-ide-engine + Engine, at https://github.com/haskell/haskell-ide-engine homepage: https://github.com/alanz/haskell-lsp license: MIT @@ -46,7 +46,7 @@ , filepath , hslogger , hashable - , haskell-lsp-types == 0.18.* + , haskell-lsp-types == 0.19.* , lens >= 4.15.2 , mtl , network-uri diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -177,7 +177,7 @@ , getVirtualFileFunc :: !(J.NormalizedUri -> IO (Maybe VirtualFile)) -- ^ Function to return the 'VirtualFile' associated with a -- given 'NormalizedUri', if there is one. - , persistVirtualFileFunc :: !(J.NormalizedUri -> IO FilePath) + , persistVirtualFileFunc :: !(J.NormalizedUri -> IO (Maybe FilePath)) , reverseFileMapFunc :: !(IO (FilePath -> FilePath)) , publishDiagnosticsFunc :: !PublishDiagnosticsFunc , flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc @@ -524,23 +524,25 @@ -- | Dump the current text for a given VFS file to a temporary file, -- and return the path to the file. -persistVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO FilePath +persistVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO (Maybe FilePath) persistVirtualFile tvarDat uri = join $ atomically $ do st <- readTVar tvarDat let vfs_data = resVFS st cur_vfs = vfsData vfs_data revMap = reverseMap vfs_data - let (fn, write) = persistFileVFS cur_vfs uri - let revMap' = + case persistFileVFS cur_vfs uri of + Nothing -> return (return Nothing) + Just (fn, write) -> do + let revMap' = -- TODO: Does the VFS make sense for URIs which are not files? -- The reverse map should perhaps be (FilePath -> URI) - case J.uriToFilePath (J.fromNormalizedUri uri) of - Just uri_fp -> Map.insert fn uri_fp revMap - Nothing -> revMap + case J.uriToFilePath (J.fromNormalizedUri uri) of + Just uri_fp -> Map.insert fn uri_fp revMap + Nothing -> revMap - modifyVFSData tvarDat (\d -> (d { reverseMap = revMap' }, ())) - return (fn <$ write) + modifyVFSData tvarDat (\d -> (d { reverseMap = revMap' }, ())) + return ((Just fn) <$ write) -- TODO: should this function return a URI? -- | If the contents of a VFS has been dumped to a temporary file, map diff --git a/src/Language/Haskell/LSP/VFS.hs b/src/Language/Haskell/LSP/VFS.hs --- a/src/Language/Haskell/LSP/VFS.hs +++ b/src/Language/Haskell/LSP/VFS.hs @@ -17,6 +17,9 @@ ( VFS(..) , VirtualFile(..) + , virtualFileText + , virtualFileVersion + -- * Managing the VFS , initVFS , openVFS , changeFromClientVFS @@ -54,6 +57,7 @@ import System.FilePath import Data.Hashable import System.Directory +import System.IO import System.IO.Temp -- --------------------------------------------------------------------- @@ -63,10 +67,13 @@ data VirtualFile = VirtualFile { - _version :: Int - , _text :: Rope + _lsp_version :: !Int -- ^ The LSP version of the document + , _file_version :: !Int -- ^ This number is only incremented whilst the file + -- remains in the map. + , _text :: Rope -- ^ The full contents of the document } deriving (Show) + type VFSMap = Map.Map J.NormalizedUri VirtualFile data VFS = VFS { vfsMap :: Map.Map J.NormalizedUri VirtualFile @@ -75,21 +82,31 @@ --- +virtualFileText :: VirtualFile -> Text +virtualFileText vf = Rope.toText (_text vf) + +virtualFileVersion :: VirtualFile -> Int +virtualFileVersion vf = _lsp_version vf + +--- + initVFS :: (VFS -> IO r) -> IO r initVFS k = withSystemTempDirectory "haskell-lsp" $ \temp_dir -> k (VFS mempty temp_dir) -- --------------------------------------------------------------------- +-- ^ Applies the changes from a 'DidOpenTextDocumentNotification' to the 'VFS' openVFS :: VFS -> J.DidOpenTextDocumentNotification -> (VFS, [String]) openVFS vfs (J.NotificationMessage _ _ params) = let J.DidOpenTextDocumentParams (J.TextDocumentItem uri _ version text) = params - in (updateVFS (Map.insert (J.toNormalizedUri uri) (VirtualFile version (Rope.fromText text))) vfs + in (updateVFS (Map.insert (J.toNormalizedUri uri) (VirtualFile version 0 (Rope.fromText text))) vfs , []) -- --------------------------------------------------------------------- +-- ^ Applies a 'DidChangeTextDocumentNotification' to the 'VFS' changeFromClientVFS :: VFS -> J.DidChangeTextDocumentNotification -> (VFS,[String]) changeFromClientVFS vfs (J.NotificationMessage _ _ params) = let @@ -97,10 +114,10 @@ J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) version = vid in case Map.lookup uri (vfsMap vfs) of - Just (VirtualFile _ str) -> + Just (VirtualFile _ file_ver str) -> let str' = applyChanges str changes -- the client shouldn't be sending over a null version, only the server. - in (updateVFS (Map.insert uri (VirtualFile (fromMaybe 0 version) str')) vfs, []) + in (updateVFS (Map.insert uri (VirtualFile (fromMaybe 0 version) (file_ver + 1) str')) vfs, []) Nothing -> -- logs $ "haskell-lsp:changeVfs:can't find uri:" ++ show uri -- return vfs @@ -111,6 +128,7 @@ -- --------------------------------------------------------------------- +-- ^ Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS' changeFromServerVFS :: VFS -> J.ApplyWorkspaceEditRequest -> IO VFS changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do let J.ApplyWorkspaceEditParams edit = params @@ -148,26 +166,44 @@ -- --------------------------------------------------------------------- virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath -virtualFileName prefix uri (VirtualFile ver _) = - prefix show (hash (J.fromNormalizedUri uri)) ++ "-" ++ show ver ++ ".hs" +virtualFileName prefix uri (VirtualFile _ file_ver _) = + let uri_raw = J.fromNormalizedUri uri + basename = maybe "" takeFileName (J.uriToFilePath uri_raw) + -- Given a length and a version number, pad the version number to + -- the given n. Does nothing if the version number string is longer + -- than the given length. + padLeft :: Int -> Int -> String + padLeft n num = + let numString = show num + in replicate (n - length numString) '0' ++ numString + in prefix basename ++ "-" ++ padLeft 5 file_ver ++ "-" ++ show (hash uri_raw) ++ ".hs" -persistFileVFS :: VFS -> J.NormalizedUri -> (FilePath, IO ()) +-- | Write a virtual file to a temporary file if it exists in the VFS. +persistFileVFS :: VFS -> J.NormalizedUri -> Maybe (FilePath, IO ()) persistFileVFS vfs uri = case Map.lookup uri (vfsMap vfs) of - Nothing -> error ("File not found in VFS: " ++ show uri ++ show vfs) - Just vf@(VirtualFile _v txt) -> + Nothing -> Nothing + Just vf -> let tfn = virtualFileName (vfsTempDir vfs) uri vf action = do exists <- doesFileExist tfn - unless exists (writeFile tfn (Rope.toString txt)) - in (tfn, action) + unless exists $ do + let contents = Rope.toString (_text vf) + writeRaw h = do + -- We honour original file line endings + hSetNewlineMode h noNewlineTranslation + hPutStr h contents + logs $ "haskell-lsp:persistFileVFS: Writing virtual file: " + ++ "uri = " ++ show uri ++ ", virtual file = " ++ show tfn + withFile tfn WriteMode writeRaw + in Just (tfn, action) -- --------------------------------------------------------------------- closeVFS :: VFS -> J.DidCloseTextDocumentNotification -> (VFS, [String]) closeVFS vfs (J.NotificationMessage _ _ params) = let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier uri) = params - in (updateVFS (Map.delete (J.toNormalizedUri uri)) vfs,[]) + in (updateVFS (Map.delete (J.toNormalizedUri uri)) vfs,["Closed: " ++ show uri]) -- --------------------------------------------------------------------- {- @@ -234,7 +270,7 @@ } deriving (Show,Eq) getCompletionPrefix :: (Monad m) => J.Position -> VirtualFile -> m (Maybe PosPrefixInfo) -getCompletionPrefix pos@(J.Position l c) (VirtualFile _ ropetext) = +getCompletionPrefix pos@(J.Position l c) (VirtualFile _ _ ropetext) = return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad let headMaybe [] = Nothing headMaybe (x:_) = Just x @@ -261,7 +297,7 @@ -- --------------------------------------------------------------------- rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text -rangeLinesFromVfs (VirtualFile _ ropetext) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r +rangeLinesFromVfs (VirtualFile _ _ ropetext) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r where (_ ,s1) = Rope.splitAtLine lf ropetext (s2, _) = Rope.splitAtLine (lt - lf) s1 diff --git a/test/URIFilePathSpec.hs b/test/URIFilePathSpec.hs --- a/test/URIFilePathSpec.hs +++ b/test/URIFilePathSpec.hs @@ -11,7 +11,9 @@ import qualified System.FilePath.Windows as FPW import Test.Hspec import Test.QuickCheck - +#if !MIN_VERSION_QuickCheck(2,10,0) +import Data.Char (GeneralCategory(..), generalCategory) +#endif -- --------------------------------------------------------------------- @@ -33,12 +35,21 @@ relativePosixFilePath :: FilePath relativePosixFilePath = "myself/example.hs" +withCurrentDirPosixFilePath :: FilePath +withCurrentDirPosixFilePath = "/home/./myself/././example.hs" + testWindowsUri :: Uri -testWindowsUri = Uri $ pack "file:///c:/Users/myself/example.hs" +testWindowsUri = Uri $ pack "file:///C:/Users/myself/example.hs" testWindowsFilePath :: FilePath -testWindowsFilePath = "c:\\Users\\myself\\example.hs" +testWindowsFilePath = "C:\\Users\\myself\\example.hs" +testWindowsFilePathDriveLowerCase :: FilePath +testWindowsFilePathDriveLowerCase = "c:\\Users\\myself\\example.hs" + +withCurrentDirWindowsFilePath :: FilePath +withCurrentDirWindowsFilePath = "C:\\Users\\.\\myself\\.\\.\\example.hs" + uriFilePathSpec :: Spec uriFilePathSpec = do it "converts a URI to a POSIX file path" $ do @@ -57,31 +68,43 @@ let theUri = platformAwareFilePathToUri windowsOS testWindowsFilePath theUri `shouldBe` testWindowsUri + it "removes unnecesary current directory paths" $ do + let theUri = platformAwareFilePathToUri "posix" withCurrentDirPosixFilePath + theUri `shouldBe` testPosixUri + + it "removes unnecesary current directory paths in windows" $ do + let theUri = platformAwareFilePathToUri windowsOS withCurrentDirWindowsFilePath + theUri `shouldBe` testWindowsUri + + it "make the drive letter upper case when converting a Windows file path to a URI" $ do + let theUri = platformAwareFilePathToUri windowsOS testWindowsFilePathDriveLowerCase + theUri `shouldBe` testWindowsUri + filePathUriSpec :: Spec filePathUriSpec = do it "converts a POSIX file path to a URI" $ do let theFilePath = platformAwareFilePathToUri "posix" "./Functional.hs" - theFilePath `shouldBe` (Uri "file://./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") + 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") + 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" + 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 (URIAuth {uriUserInfo = "", uriRegName = "Functional.hs", uriPort = ""}) -- AZ: Seems odd ,"" + ,"" ,"") - Just "./Functional.hs" `shouldBe` platformAwareUriToFilePath "posix" theFilePath + 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 @@ -108,16 +131,24 @@ genWindowsFilePath = do segments <- listOf pathSegment pathSep <- elements ['/', '\\'] - pure ("C:" <> [pathSep] <> intercalate [pathSep] segments) - where pathSegment = listOf1 (arbitraryASCIIChar `suchThat` (`notElem` ['/', '\\', '.', ':'])) + driveLetter <- elements ["C:", "c:"] + pure (driveLetter <> [pathSep] <> intercalate [pathSep] segments) + where pathSegment = listOf1 (genValidUnicodeChar `suchThat` (`notElem` ['/', '\\', ':'])) genPosixFilePath :: Gen FilePath genPosixFilePath = do segments <- listOf pathSegment pure ("/" <> intercalate "/" segments) - where pathSegment = listOf1 (arbitraryASCIIChar `suchThat` (`notElem` ['/', '.'])) + where pathSegment = listOf1 (genValidUnicodeChar `suchThat` (`notElem` ['/'])) +genValidUnicodeChar :: Gen Char +genValidUnicodeChar = arbitraryUnicodeChar `suchThat` isCharacter + where isCharacter x = x /= '\65534' && x /= '\65535' + #if !MIN_VERSION_QuickCheck(2,10,0) -arbitraryASCIIChar :: Gen Char -arbitraryASCIIChar = arbitrary +arbitraryUnicodeChar :: Gen Char +arbitraryUnicodeChar = + arbitraryBoundedEnum `suchThat` (not . isSurrogate) + where + isSurrogate c = generalCategory c == Surrogate #endif diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -31,7 +31,7 @@ mkRange ls cs le ce = Just $ J.Range (J.Position ls cs) (J.Position le ce) vfsFromText :: T.Text -> VirtualFile -vfsFromText text = VirtualFile 0 (Rope.fromText text) +vfsFromText text = VirtualFile 0 0 (Rope.fromText text) -- ---------------------------------------------------------------------