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

Extend position mapping with fuzzy ranges #785

Merged
merged 4 commits into from
Sep 13, 2020
Merged

Extend position mapping with fuzzy ranges #785

Show file tree
Hide file tree
Changes from 2 commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
2804625
Extend position mapping with fuzzy ranges
wz1000 Sep 12, 2020
0d90da9
fix tests
wz1000 Sep 12, 2020
20b1cc9
add bangs
wz1000 Sep 13, 2020
281d195
make fields lazy again
wz1000 Sep 13, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
62 changes: 47 additions & 15 deletions src/Development/IDE/Core/PositionMapping.hs
View file
Open in desktop
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,45 @@ import qualified Data.Text as T
import Language.Haskell.LSP.Types
import Data.List

data PositionResult a = PositionRange { unsafeLowerRange :: a, unsafeUpperRange :: a } | PositionExact a
wz1000 marked this conversation as resolved.
Show resolved Hide resolved
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 +91,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 +108,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 (line + lineDiff) newColumn
| otherwise = PositionRange start end
-- Position is in the region that was changed.
where
lineDiff = linesNew - linesOld
Expand All @@ -98,16 +130,16 @@ toCurrent (Range (Position startLine startColumn) (Position endLine endColumn))
| line == endLine = column + newEndColumn - endColumn
| otherwise = column

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 (line - lineDiff) newColumn
| otherwise = PositionRange start end
-- Position is in the region that was changed.
where
lineDiff = linesNew - linesOld
Expand Down
46 changes: 23 additions & 23 deletions test/exe/Main.hs
View file
Open in desktop
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 @@ -3351,94 +3351,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 @@ -3454,9 +3454,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 @@ -3467,9 +3467,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