Fixes to persistVirtualFile

src/Language/Haskell/LSP/Core.hs

@@ -177,7 +177,7 @@ data LspFuncs c =
     , 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 @@ getVirtualFile tvarDat uri = Map.lookup uri . vfsMap . vfsData . resVFS <$> read
 
 -- | 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

src/Language/Haskell/LSP/VFS.hs

@@ -17,6 +17,9 @@ module Language.Haskell.LSP.VFS
   (
     VFS(..)
   , VirtualFile(..)
+  , virtualFileText
+  , virtualFileVersion
+  -- * Managing the VFS
   , initVFS
   , openVFS
   , changeFromClientVFS
@@ -63,10 +66,13 @@ import           System.IO.Temp
 
 data VirtualFile =
   VirtualFile {
-      _version :: Int   -- ^ The LSP version of the document
+      _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,6 +81,14 @@ data VFS = VFS { vfsMap :: Map.Map J.NormalizedUri VirtualFile
 
 ---
 
+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)
 
@@ -85,7 +99,7 @@ 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
      , [])
 
 
@@ -99,10 +113,10 @@ changeFromClientVFS vfs (J.NotificationMessage _ _ params) =
     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
@@ -151,26 +165,36 @@ changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do
 
 -- ---------------------------------------------------------------------
 virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath
-virtualFileName prefix uri (VirtualFile ver _) =
-  prefix </> show (hash (J.fromNormalizedUri uri)) ++ "-" ++ show ver ++ ".hs"
-
-persistFileVFS :: VFS -> J.NormalizedUri -> (FilePath, IO ())
+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"
+
+-- | 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 (writeFile tfn (Rope.toString (_text vf)))
+      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])
 
 -- ---------------------------------------------------------------------
 {-
@@ -237,7 +261,7 @@ data PosPrefixInfo = PosPrefixInfo
   } 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
@@ -264,7 +288,7 @@ getCompletionPrefix pos@(J.Position l c) (VirtualFile _ ropetext) =
 -- ---------------------------------------------------------------------
 
 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

test/VspSpec.hs

@@ -31,7 +31,7 @@ mkRange :: Int -> Int -> Int -> Int -> Maybe J.Range
 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)
 
 -- ---------------------------------------------------------------------