Fix positionMapping in stale data

ghcide/ghcide.cabal

@@ -336,6 +336,7 @@ test-suite ghcide-tests
     , containers
     , data-default
     , directory
+    , enummapset
     , extra
     , filepath
     , fuzzy

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

@@ -11,6 +11,7 @@ module Development.IDE.Core.PositionMapping
   , toCurrentPosition
   , PositionDelta(..)
   , addDelta
+  , addOldDelta
   , idDelta
   , composeDelta
   , mkDelta
@@ -123,6 +124,10 @@ mkDelta cs = foldl' applyChange idDelta cs
 addDelta :: PositionDelta -> PositionMapping -> PositionMapping
 addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm)
 
+-- | Add a old delta onto a Mapping k n to make a Mapping (k - 1) n
+addOldDelta :: PositionDelta -> PositionMapping -> PositionMapping
+addOldDelta delta (PositionMapping pm) = PositionMapping (composeDelta pm delta)
+
 -- TODO: We currently ignore the right hand side (if there is only text), as
 -- that was what was done with lsp* 1.6 packages
 applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta

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

@@ -62,6 +62,7 @@ module Development.IDE.Core.Shake(
     FileVersion(..),
     Priority(..),
     updatePositionMapping,
+    updatePositionMappingHelper,
     deleteValue, recordDirtyKeys,
     WithProgressFunc, WithIndefiniteProgressFunc,
     ProgressEvent(..),
@@ -266,7 +267,7 @@ data ShakeExtras = ShakeExtras
     -- ^ Map from a text document version to a PositionMapping that describes how to map
     -- positions in a version of that document to positions in the latest version
     -- First mapping is delta from previous version and second one is an
-    -- accumulation of all previous mappings.
+    -- accumulation to the current version.
     ,progress :: ProgressReporting
     ,ideTesting :: IdeTesting
     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
@@ -443,7 +444,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
                               `catch` (\(_ :: IOException) -> pure Nothing)
                 atomicallyNamed "lastValueIO 2" $ do
                   STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) state
-                  Just . (v,) . addDelta del <$> mappingForVersion positionMapping file actual_version
+                  Just . (v,) . addOldDelta del <$> mappingForVersion positionMapping file actual_version
 
         -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics
         alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics
@@ -459,7 +460,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
         Succeeded ver (fromDynamic -> Just v) ->
             atomicallyNamed "lastValueIO 5"  $ Just . (v,) <$> mappingForVersion positionMapping file ver
         Stale del ver (fromDynamic -> Just v) ->
-            atomicallyNamed "lastValueIO 6"  $ Just . (v,) . maybe id addDelta del <$> mappingForVersion positionMapping file ver
+            atomicallyNamed "lastValueIO 6"  $ Just . (v,) . maybe id addOldDelta del <$> mappingForVersion positionMapping file ver
         Failed p | not p -> readPersistent
         _ -> pure Nothing
 
@@ -1352,12 +1353,18 @@ updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} Versi
     STM.focus (Focus.alter f) uri positionMapping
       where
         uri = toNormalizedUri _uri
-        f = Just . f' . fromMaybe mempty
-        f' mappingForUri = snd $
-                -- Very important to use mapAccum here so that the tails of
-                -- each mapping can be shared, otherwise quadratic space is
-                -- used which is evident in long running sessions.
-                EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))
-                  zeroMapping
-                  (EM.insert _version (shared_change, zeroMapping) mappingForUri)
-        shared_change = mkDelta changes
+        f = Just . updatePositionMappingHelper _version changes . fromMaybe mempty
+
+
+updatePositionMappingHelper ::
+    Int32
+    -> [TextDocumentContentChangeEvent]
+    -> EnumMap Int32 (PositionDelta, PositionMapping)
+    -> EnumMap Int32 (PositionDelta, PositionMapping)
+updatePositionMappingHelper ver changes mappingForUri = snd $
+        -- Very important to use mapAccum here so that the tails of
+        -- each mapping can be shared, otherwise quadratic space is
+        -- used which is evident in long running sessions.
+        EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addOldDelta delta acc in (new, (delta, acc)))
+            zeroMapping
+            (EM.insert ver (mkDelta changes, zeroMapping) mappingForUri)

ghcide/test/exe/PositionMappingTests.hs

@@ -3,14 +3,16 @@
 
 module PositionMappingTests (tests) where
 
+import qualified Data.EnumMap.Strict                  as EM
 import           Data.Row
 import qualified Data.Text                            as T
 import           Data.Text.Utf16.Rope                 (Rope)
 import qualified Data.Text.Utf16.Rope                 as Rope
 import           Development.IDE.Core.PositionMapping (PositionResult (..),
                                                        fromCurrent,
                                                        positionResultToMaybe,
-                                                       toCurrent)
+                                                       toCurrent,
+                                                       toCurrentPosition)
 import           Development.IDE.Types.Location
 import           Language.LSP.Protocol.Types          hiding
                                                       (SemanticTokenAbsolute (..),
@@ -20,15 +22,36 @@ import           Language.LSP.Protocol.Types          hiding
 import           Language.LSP.VFS                     (applyChange)
 import           Test.QuickCheck
 -- import Test.QuickCheck.Instances ()
+import           Control.Arrow                        (second)
 import           Data.Functor.Identity                (runIdentity)
+import           Data.Text                            (Text)
+import           Development.IDE.Core.Shake           (updatePositionMappingHelper)
 import           Test.Tasty
 import           Test.Tasty.HUnit
 import           Test.Tasty.QuickCheck
 
+enumMapMappingTest :: TestTree
+enumMapMappingTest = testCase "enumMapMappingTest" $ do
+  let mkChangeEvent :: Range -> Text -> TextDocumentContentChangeEvent
+      mkChangeEvent r t = TextDocumentContentChangeEvent $ InL $ #range .== r .+ #rangeLength .== Nothing .+ #text .== t
+      mkCE :: UInt -> UInt -> UInt -> UInt -> Text -> TextDocumentContentChangeEvent
+      mkCE l1 c1 l2 c2 = mkChangeEvent (Range (Position l1 c1) (Position l2 c2))
+      events :: [(Int32, [TextDocumentContentChangeEvent])]
+      events = map (second return) [(0, mkCE 0 0 0 0 ""), (1, mkCE 0 1 0 1 " "), (2, mkCE 0 2 0 2 " "), (3, mkCE 0 3 0 3 " "), (4, mkCE 0 4 0 4 " "), (5, mkCE 0 5 0 5 " ")]
+      finalMap = Prelude.foldl (\m (i, e) -> updatePositionMappingHelper i e m) mempty events
+  let updatePose fromPos = do
+        mapping <- snd <$> EM.lookup 0 finalMap
+        toCurrentPosition mapping fromPos
+  updatePose (Position 0 4) @?= Just (Position 0 9)
+  updatePose (Position 0 5) @?= Just (Position 0 10)
+
+
 tests ::  TestTree
 tests =
     testGroup "position mapping"
-        [ testGroup "toCurrent"
+        [
+        enumMapMappingTest
+        , testGroup "toCurrent"
               [ testCase "before" $
                 toCurrent
                     (Range (Position 0 1) (Position 0 3))