Skip to content
This repository has been archived by the owner on Jan 2, 2021. It is now read-only.

Commit

Permalink
Extend position mapping with fuzzy ranges (#785)
Browse files Browse the repository at this point in the history 
* Extend position mapping with fuzzy ranges

* fix tests

* add bangs

* make fields lazy again
  • Loading branch information
@wz1000
wz1000 authored Sep 13, 2020
1 parent 2225d7f commit b980c33
Show file tree
Hide file tree
Showing 2 changed files with 79 additions and 40 deletions.
73 changes: 56 additions & 17 deletions src/Development/IDE/Core/PositionMapping.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,10 @@
-- SPDX-License-Identifier: Apache-2.0
module Development.IDE.Core.PositionMapping
( PositionMapping(..)
, PositionResult(..)
, lowerRange
, upperRange
, positionResultToMaybe
, fromCurrentPosition
, toCurrentPosition
, PositionDelta(..)
Expand All @@ -21,17 +25,50 @@ import qualified Data.Text as T
import Language.Haskell.LSP.Types
import Data.List

-- | Either an exact position, or the range of text that was substituted
data PositionResult a
= PositionRange -- ^ Fields need to be non-strict otherwise bind is exponential
{ unsafeLowerRange :: a
, unsafeUpperRange :: a }
| PositionExact !a
deriving (Eq,Ord,Show,Functor)

lowerRange :: PositionResult a -> a
lowerRange (PositionExact a) = a
lowerRange (PositionRange lower _) = lower

upperRange :: PositionResult a -> a
upperRange (PositionExact a) = a
upperRange (PositionRange _ upper) = upper

positionResultToMaybe :: PositionResult a -> Maybe a
positionResultToMaybe (PositionExact a) = Just a
positionResultToMaybe _ = Nothing

instance Applicative PositionResult where
pure = PositionExact
(PositionExact f) <*> a = fmap f a
(PositionRange f g) <*> (PositionExact a) = PositionRange (f a) (g a)
(PositionRange f g) <*> (PositionRange lower upper) = PositionRange (f lower) (g upper)

instance Monad PositionResult where
(PositionExact a) >>= f = f a
(PositionRange lower upper) >>= f = PositionRange lower' upper'
where
lower' = lowerRange $ f lower
upper' = upperRange $ f upper

-- The position delta is the difference between two versions
data PositionDelta = PositionDelta
{ toDelta :: !(Position -> Maybe Position)
, fromDelta :: !(Position -> Maybe Position)
{ toDelta :: !(Position -> PositionResult Position)
, fromDelta :: !(Position -> PositionResult Position)
}

fromCurrentPosition :: PositionMapping -> Position -> Maybe Position
fromCurrentPosition (PositionMapping pm) = fromDelta pm
fromCurrentPosition (PositionMapping pm) = positionResultToMaybe . fromDelta pm

toCurrentPosition :: PositionMapping -> Position -> Maybe Position
toCurrentPosition (PositionMapping pm) = toDelta pm
toCurrentPosition (PositionMapping pm) = positionResultToMaybe . toDelta pm

-- A position mapping is the difference from the current version to
-- a specific version
Expand Down Expand Up @@ -59,7 +96,7 @@ composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) =
(from1 >=> from2)

idDelta :: PositionDelta
idDelta = PositionDelta Just Just
idDelta = PositionDelta pure pure

-- | Convert a set of changes into a delta from k to k + 1
mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta
Expand All @@ -76,16 +113,16 @@ applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = Po
}
applyChange posMapping _ = posMapping

toCurrent :: Range -> T.Text -> Position -> Maybe Position
toCurrent (Range (Position startLine startColumn) (Position endLine endColumn)) t (Position line column)
toCurrent :: Range -> T.Text -> Position -> PositionResult Position
toCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column)
| line < startLine || line == startLine && column < startColumn =
-- Position is before the change and thereby unchanged.
Just $ Position line column
PositionExact $ Position line column
| line > endLine || line == endLine && column >= endColumn =
-- Position is after the change so increase line and column number
-- as necessary.
Just $ Position (line + lineDiff) newColumn
| otherwise = Nothing
PositionExact $ Position newLine newColumn
| otherwise = PositionRange start end
-- Position is in the region that was changed.
where
lineDiff = linesNew - linesOld
Expand All @@ -94,20 +131,21 @@ toCurrent (Range (Position startLine startColumn) (Position endLine endColumn))
newEndColumn
| linesNew == 0 = startColumn + T.length t
| otherwise = T.length $ T.takeWhileEnd (/= '\n') t
newColumn
!newColumn
| line == endLine = column + newEndColumn - endColumn
| otherwise = column
!newLine = line + lineDiff

fromCurrent :: Range -> T.Text -> Position -> Maybe Position
fromCurrent (Range (Position startLine startColumn) (Position endLine endColumn)) t (Position line column)
fromCurrent :: Range -> T.Text -> Position -> PositionResult Position
fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column)
| line < startLine || line == startLine && column < startColumn =
-- Position is before the change and thereby unchanged
Just $ Position line column
PositionExact $ Position line column
| line > newEndLine || line == newEndLine && column >= newEndColumn =
-- Position is after the change so increase line and column number
-- as necessary.
Just $ Position (line - lineDiff) newColumn
| otherwise = Nothing
PositionExact $ Position newLine newColumn
| otherwise = PositionRange start end
-- Position is in the region that was changed.
where
lineDiff = linesNew - linesOld
Expand All @@ -117,6 +155,7 @@ fromCurrent (Range (Position startLine startColumn) (Position endLine endColumn)
newEndColumn
| linesNew == 0 = startColumn + T.length t
| otherwise = T.length $ T.takeWhileEnd (/= '\n') t
newColumn
!newColumn
| line == newEndLine = column - (newEndColumn - endColumn)
| otherwise = column
!newLine = line - lineDiff
46 changes: 23 additions & 23 deletions test/exe/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,7 @@ import Data.List.Extra
import Data.Maybe
import Data.Rope.UTF16 (Rope)
import qualified Data.Rope.UTF16 as Rope
import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent, PositionResult(..), positionResultToMaybe)
import Development.IDE.Core.Shake (Q(..))
import Development.IDE.GHC.Util
import qualified Data.Text as T
Expand Down Expand Up @@ -3366,94 +3366,94 @@ positionMappingTests =
toCurrent
(Range (Position 0 1) (Position 0 3))
"ab"
(Position 0 0) @?= Just (Position 0 0)
(Position 0 0) @?= PositionExact (Position 0 0)
, testCase "after, same line, same length" $
toCurrent
(Range (Position 0 1) (Position 0 3))
"ab"
(Position 0 3) @?= Just (Position 0 3)
(Position 0 3) @?= PositionExact (Position 0 3)
, testCase "after, same line, increased length" $
toCurrent
(Range (Position 0 1) (Position 0 3))
"abc"
(Position 0 3) @?= Just (Position 0 4)
(Position 0 3) @?= PositionExact (Position 0 4)
, testCase "after, same line, decreased length" $
toCurrent
(Range (Position 0 1) (Position 0 3))
"a"
(Position 0 3) @?= Just (Position 0 2)
(Position 0 3) @?= PositionExact (Position 0 2)
, testCase "after, next line, no newline" $
toCurrent
(Range (Position 0 1) (Position 0 3))
"abc"
(Position 1 3) @?= Just (Position 1 3)
(Position 1 3) @?= PositionExact (Position 1 3)
, testCase "after, next line, newline" $
toCurrent
(Range (Position 0 1) (Position 0 3))
"abc\ndef"
(Position 1 0) @?= Just (Position 2 0)
(Position 1 0) @?= PositionExact (Position 2 0)
, testCase "after, same line, newline" $
toCurrent
(Range (Position 0 1) (Position 0 3))
"abc\nd"
(Position 0 4) @?= Just (Position 1 2)
(Position 0 4) @?= PositionExact (Position 1 2)
, testCase "after, same line, newline + newline at end" $
toCurrent
(Range (Position 0 1) (Position 0 3))
"abc\nd\n"
(Position 0 4) @?= Just (Position 2 1)
(Position 0 4) @?= PositionExact (Position 2 1)
, testCase "after, same line, newline + newline at end" $
toCurrent
(Range (Position 0 1) (Position 0 1))
"abc"
(Position 0 1) @?= Just (Position 0 4)
(Position 0 1) @?= PositionExact (Position 0 4)
]
, testGroup "fromCurrent"
[ testCase "before" $
fromCurrent
(Range (Position 0 1) (Position 0 3))
"ab"
(Position 0 0) @?= Just (Position 0 0)
(Position 0 0) @?= PositionExact (Position 0 0)
, testCase "after, same line, same length" $
fromCurrent
(Range (Position 0 1) (Position 0 3))
"ab"
(Position 0 3) @?= Just (Position 0 3)
(Position 0 3) @?= PositionExact (Position 0 3)
, testCase "after, same line, increased length" $
fromCurrent
(Range (Position 0 1) (Position 0 3))
"abc"
(Position 0 4) @?= Just (Position 0 3)
(Position 0 4) @?= PositionExact (Position 0 3)
, testCase "after, same line, decreased length" $
fromCurrent
(Range (Position 0 1) (Position 0 3))
"a"
(Position 0 2) @?= Just (Position 0 3)
(Position 0 2) @?= PositionExact (Position 0 3)
, testCase "after, next line, no newline" $
fromCurrent
(Range (Position 0 1) (Position 0 3))
"abc"
(Position 1 3) @?= Just (Position 1 3)
(Position 1 3) @?= PositionExact (Position 1 3)
, testCase "after, next line, newline" $
fromCurrent
(Range (Position 0 1) (Position 0 3))
"abc\ndef"
(Position 2 0) @?= Just (Position 1 0)
(Position 2 0) @?= PositionExact (Position 1 0)
, testCase "after, same line, newline" $
fromCurrent
(Range (Position 0 1) (Position 0 3))
"abc\nd"
(Position 1 2) @?= Just (Position 0 4)
(Position 1 2) @?= PositionExact (Position 0 4)
, testCase "after, same line, newline + newline at end" $
fromCurrent
(Range (Position 0 1) (Position 0 3))
"abc\nd\n"
(Position 2 1) @?= Just (Position 0 4)
(Position 2 1) @?= PositionExact (Position 0 4)
, testCase "after, same line, newline + newline at end" $
fromCurrent
(Range (Position 0 1) (Position 0 1))
"abc"
(Position 0 4) @?= Just (Position 0 1)
(Position 0 4) @?= PositionExact (Position 0 1)
]
, adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"
[ testProperty "fromCurrent r t <=< toCurrent r t" $ do
Expand All @@ -3469,9 +3469,9 @@ positionMappingTests =
pure (range, replacement, oldPos)
forAll
(suchThatMap gen
(\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $
(\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $
\(range, replacement, oldPos, newPos) ->
fromCurrent range replacement newPos === Just oldPos
fromCurrent range replacement newPos === PositionExact oldPos
, testProperty "toCurrent r t <=< fromCurrent r t" $ do
let gen = do
rope <- genRope
Expand All @@ -3482,9 +3482,9 @@ positionMappingTests =
pure (range, replacement, newPos)
forAll
(suchThatMap gen
(\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $
(\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $
\(range, replacement, newPos, oldPos) ->
toCurrent range replacement oldPos === Just newPos
toCurrent range replacement oldPos === PositionExact newPos
]
]

Expand Down

0 comments on commit b980c33

Please sign in to comment.