Indexing improvments, persistent rules, diff mapping

Author: wz1000

ghcide/ghcide.cabal

@@ -59,7 +59,7 @@ library
         hie-compat,
         hls-plugin-api >= 0.6,
         lens,
-        hiedb,
+        hiedb == 0.2.0.*,
         mtl,
         network-uri,
         parallel,
@@ -80,6 +80,8 @@ library
         unordered-containers >= 0.2.10.0,
         utf8-string,
         hslogger,
+        Diff,
+        bytestring-encoding,
         opentelemetry >=0.6.1,
         heapsize ==0.3.*
     if flag(ghc-lib)

ghcide/src/Development/IDE/Core/Compile.hs

@@ -109,8 +109,11 @@ import qualified Data.HashMap.Strict as HashMap
 import qualified Language.Haskell.LSP.Messages as LSP
 import qualified Language.Haskell.LSP.Types as LSP
 import Control.Concurrent.STM hiding (orElse)
+import Control.Concurrent.Extra
 import Data.Functor
 import Data.Unique
+import GHC.Fingerprint
+import Debug.Trace
 
 -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
 parseModule
@@ -471,66 +474,66 @@ spliceExpresions Splices{..} =
         , DL.fromList $ map fst awSplices
         ]
 
-indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Compat.HieFile -> IO ()
-indexHieFile se mod_summary srcPath hf = atomically $ do
+indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Fingerprint -> Compat.HieFile -> IO ()
+indexHieFile se mod_summary srcPath hash hf = atomically $ do
   pending <- readTVar indexPending
   case HashMap.lookup srcPath pending of
-    Just mtime | mtime >= modtime -> pure () -- An index is already scheduled
+    Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled
     _ -> do
-      modifyTVar' indexPending $ HashMap.insert srcPath modtime
+      modifyTVar' indexPending $ HashMap.insert srcPath hash
       writeTQueue indexQueue $ \db -> do
         -- We are now in the worker thread
+        -- Check if a newer index of this file has been scheduled, and if so skip this one
         newerScheduled <- atomically $ do
           pending <- readTVar indexPending
-          case HashMap.lookup srcPath pending of
-            Nothing -> pure False
-            Just mtime -> pure $ mtime > modtime
-        -- Check if a newer index of this file has been scheduled, and if so skip this one
+          pure $ case HashMap.lookup srcPath pending of
+            Nothing -> False
+            -- If the hash in the pending list doesn't match the current hash, then skip
+            Just pendingHash -> pendingHash /= hash
         unless newerScheduled $ do
           tok <- pre
-          addRefsFromLoaded db targetPath (Just $ fromNormalizedFilePath srcPath) True modtime hf
+          addRefsFromLoaded db targetPath (Just $ fromNormalizedFilePath srcPath) True hash hf
           post tok
   where
-    modtime         = ms_hs_date mod_summary
     mod_location    = ms_location mod_summary
     targetPath      = Compat.ml_hie_file mod_location
     HieDbWriter{..} = hiedbWriter se
 
     -- Get a progress token to report progress and update it for the current file
     pre = do
-      (!oldTok, !done, !remaining) <- atomically $ do
-        oldTok <- readTVar indexProgressToken
-        done <- readTVar indexCompleted
-        remaining <- HashMap.size <$> readTVar indexPending
-        pure (oldTok, done, remaining)
-      tok <- case oldTok of
-        Just x -> pure x
+      tok <- modifyVar indexProgressToken $ \case
+        x@(Just tok) -> pure (x, tok)
+        -- Create a token if we don't already have one
         Nothing -> do
-          lspId <- getLspId se
           u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> newUnique
-          eventer se $ LSP.ReqWorkDoneProgressCreate $
+          lspId <- getLspId se
+          eventer se $ traceShowId $ LSP.ReqWorkDoneProgressCreate $
             LSP.fmServerWorkDoneProgressCreateRequest lspId $
               LSP.WorkDoneProgressCreateParams { _token = u }
-          eventer se $ LSP.NotWorkDoneProgressBegin $
+          eventer se $ traceShowId $ LSP.NotWorkDoneProgressBegin $
             LSP.fmServerWorkDoneProgressBeginNotification
               LSP.ProgressParams
                   { _token = u
                   , _value = LSP.WorkDoneProgressBeginParams
-                    { _title = "Indexing References"
+                    { _title = "Indexing references from:"
                     , _cancellable = Nothing
                     , _message = Nothing
                     , _percentage = Nothing
                     }
                   }
-          pure u
+          pure (Just u, u)
+      (!done, !remaining) <- atomically $ do
+        done <- readTVar indexCompleted
+        remaining <- HashMap.size <$> readTVar indexPending
+        pure (done, remaining)
       let progress = " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..."
-      eventer se $ LSP.NotWorkDoneProgressReport $
+      eventer se $ traceShowId $ LSP.NotWorkDoneProgressReport $
         LSP.fmServerWorkDoneProgressReportNotification
           LSP.ProgressParams
               { _token = tok
               , _value = LSP.WorkDoneProgressReportParams
                 { _cancellable = Nothing
-                , _message = Just $ "Indexing " <> T.pack (show srcPath) <> progress
+                , _message = Just $ T.pack (show srcPath) <> progress
                 , _percentage = Nothing
                 }
               }
@@ -540,7 +543,7 @@ indexHieFile se mod_summary srcPath hf = atomically $ do
     post tok = do
       mdone <- atomically $ do
         -- Remove current element from pending
-        modifyTVar' indexPending $ HashMap.update (\qTime -> guard (qTime <= modtime) $> qTime) srcPath
+        modifyTVar' indexPending $ HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) srcPath
         pending <- readTVar indexPending
         if HashMap.null pending
         then Just <$> swapTVar indexCompleted 0
@@ -549,22 +552,27 @@ indexHieFile se mod_summary srcPath hf = atomically $ do
           pure Nothing
       case mdone of
         Nothing -> pure ()
-        Just done -> eventer se $ LSP.NotWorkDoneProgressEnd $
-          LSP.fmServerWorkDoneProgressEndNotification
-            LSP.ProgressParams
-                { _token = tok
-                , _value = LSP.WorkDoneProgressEndParams
-                  { _message = Just $ "Finished indexing " <> T.pack (show done) <> "files"
-                  }
-                }
+        Just done ->
+          modifyVar_ indexProgressToken $ \_ -> do
+            eventer se $ traceShowId $ LSP.NotWorkDoneProgressEnd $
+              LSP.fmServerWorkDoneProgressEndNotification
+                LSP.ProgressParams
+                    { _token = tok
+                    , _value = LSP.WorkDoneProgressEndParams
+                      { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files"
+                      }
+                    }
+            -- We are done with the current indexing cycle, so destroy the token
+            pure Nothing
 
 writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]
 writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source =
   handleGenerationErrors dflags "extended interface write/compression" $ do
     hf <- runHsc hscEnv $
       GHC.mkHieFile' mod_summary exports ast source
     atomicFileWrite targetPath $ flip GHC.writeHieFile hf
-    indexHieFile se mod_summary srcPath hf
+    hash <- getFileHash targetPath
+    indexHieFile se mod_summary srcPath hash hf
   where
     dflags       = hsc_dflags hscEnv
     mod_location = ms_location mod_summary

ghcide/src/Development/IDE/Core/FileStore.hs

@@ -59,19 +59,6 @@ import qualified Development.IDE.Types.Logger as L
 import Language.Haskell.LSP.Core
 import Language.Haskell.LSP.VFS
 
--- | haskell-lsp manages the VFS internally and automatically so we cannot use
--- the builtin VFS without spawning up an LSP server. To be able to test things
--- like `setBufferModified` we abstract over the VFS implementation.
-data VFSHandle = VFSHandle
-    { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
-        -- ^ get the contents of a virtual file
-    , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())
-        -- ^ set a specific file to a value. If Nothing then we are ignoring these
-        --   signals anyway so can just say something was modified
-    }
-
-instance IsIdeGlobal VFSHandle
-
 makeVFSHandle :: IO VFSHandle
 makeVFSHandle = do
     vfsVar <- newVar (1, Map.empty)

ghcide/src/Development/IDE/Core/PositionMapping.hs

@@ -15,6 +15,7 @@ module Development.IDE.Core.PositionMapping
   , fromCurrentRange
   , applyChange
   , zeroMapping
+  , mappingFromDiff
   -- toCurrent and fromCurrent are mainly exposed for testing
   , toCurrent
   , fromCurrent
@@ -24,6 +25,9 @@ import Control.Monad
 import qualified Data.Text as T
 import Language.Haskell.LSP.Types
 import Data.List
+import Data.Algorithm.Diff
+import Data.Maybe
+import Data.Bifunctor
 
 -- | Either an exact position, or the range of text that was substituted
 data PositionResult a
@@ -158,3 +162,35 @@ fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine
           | line == newEndLine = column - (newEndColumn - endColumn)
           | otherwise = column
         newLine = line - lineDiff
+
+mappingFromDiff :: T.Text -> T.Text -> PositionMapping
+mappingFromDiff (T.lines -> old) (T.lines -> new) = PositionMapping (PositionDelta (lookupPos lnew old2new) (lookupPos lold new2old))
+  where
+    diff = getDiff old new
+
+    (old2new, new2old) = go diff 0 0
+
+    lnew = length new
+    lold = length old
+
+    lookupPos :: Int -> [(Int,Maybe Int)] -> Position -> PositionResult Position
+    lookupPos maxNew xs (Position line col) = go (-1) xs
+      where
+        go prev [] = PositionRange (Position (prev+1) 0) (Position maxNew 0)
+        go prev ((l,b):xs)
+          | l == line = case b of
+            Just l' -> PositionExact $ Position l' col
+            Nothing ->
+              let next = case mapMaybe snd xs of
+                    [] -> maxNew
+                    (x:_) -> x
+                in PositionRange (Position (prev+1) 0) (Position next 0)
+          | l < line = go (maybe prev id b) xs
+          | otherwise = error $ "lookupPos: monotonicity invariant violated: " ++ show (l,line,old,new)
+
+    go [] _ _ = ([],[])
+    go (Both _ _ : xs) lold lnew = bimap  ((lold,Just lnew) :) ((lnew,Just lold) :) $ go xs (lold+1) (lnew+1)
+    go (First _  : xs) lold lnew = first  ((lold,Nothing) :) $ go xs (lold+1) lnew
+    go (Second _ : xs) lold lnew = second ((lnew,Nothing) :) $ go xs lold (lnew+1)
+
+