position mapping improvements

Author: wz1000

ghcide/ghcide.cabal

@@ -81,6 +81,7 @@ library
         utf8-string,
         hslogger,
         Diff,
+        vector,
         bytestring-encoding,
         opentelemetry >=0.6.1,
         heapsize ==0.3.*

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

@@ -30,7 +30,7 @@ import Data.Algorithm.Diff
 import Data.Maybe
 import Data.Bifunctor
 import Control.DeepSeq
-import Debug.Trace
+import qualified Data.Vector as V
 
 -- | Either an exact position, or the range of text that was substituted
 data PositionResult a
@@ -173,33 +173,40 @@ fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine
         newLine = line - lineDiff
 
 deltaFromDiff :: T.Text -> T.Text -> PositionDelta
-deltaFromDiff (T.lines -> old) (T.lines -> new) = PositionDelta (lookupPos lnew old2new) (lookupPos lold new2old)
+deltaFromDiff (T.lines -> old) (T.lines -> new) =
+    PositionDelta (lookupPos lnew o2nPrevs o2nNexts old2new) (lookupPos lold n2oPrevs n2oNexts new2old)
   where
-    diff = getDiff old new
+    !lnew = length new
+    !lold = length old
 
-    (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) = (\x -> traceShow ("lookupPos",line,x) x) $ 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)
+    diff = getDiff old new
 
+    (V.fromList -> !old2new, V.fromList -> !new2old) = go diff 0 0
+
+    -- Compute previous and next lines that mapped successfully
+    !o2nPrevs = V.prescanl' fromMaybe        (-1) old2new
+    !o2nNexts = V.prescanr' (flip fromMaybe) lnew old2new
+
+    !n2oPrevs = V.prescanl' fromMaybe        (-1) new2old
+    !n2oNexts = V.prescanr' (flip fromMaybe) lold new2old
+
+    lookupPos :: Int -> V.Vector Int -> V.Vector Int -> V.Vector (Maybe Int) -> Position -> PositionResult Position
+    lookupPos end prevs nexts xs (Position line col)
+      | line < 0            = PositionRange (Position 0   0) (Position 0   0)
+      | line >= V.length xs = PositionRange (Position end 0) (Position end 0)
+      | otherwise           = case V.unsafeIndex xs line of
+          Just line' -> PositionExact (Position line' col)
+          Nothing ->
+            -- look for the previous and next lines that mapped successfully
+            let !prev = 1 + (prevs V.! line)
+                !next = nexts V.! line
+              in PositionRange (Position prev 0) (Position next 0)
+
+    -- Construct a mapping between lines in the diff
+    go :: [Diff T.Text] -> Int -> Int -> ([Maybe Int], [Maybe Int])
     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)
+    go (Both _ _ : xs) !lold !lnew = bimap  (Just lnew :) (Just lold :) $ go xs (lold+1) (lnew+1)
+    go (First _  : xs) !lold !lnew = first  (Nothing   :)               $ go xs (lold+1) lnew
+    go (Second _ : xs) !lold !lnew = second               (Nothing   :) $ go xs lold     (lnew+1)
 
 

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

@@ -146,7 +146,7 @@ data HieDbWriter
   , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing
   , indexCompleted :: TVar Int -- ^ to report progress
   , indexProgressToken :: Var (Maybe LSP.ProgressToken)
-  -- ^ This is a Var instead of a TVar since we need to do IO so we need a lock
+  -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock
   }
 
 -- | Actions to queue up on the index worker thread