mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-02 08:53:07 +03:00
Extend position mapping with fuzzy ranges (#785)
* Extend position mapping with fuzzy ranges * fix tests * add bangs * make fields lazy again
This commit is contained in:
wz1000
GitHub
parent
2225d7fe72
commit
b980c33cb9
@ -2,6 +2,10 @@
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
module Development.IDE.Core.PositionMapping
|
||||
( PositionMapping(..)
|
||||
, PositionResult(..)
|
||||
, lowerRange
|
||||
, upperRange
|
||||
, positionResultToMaybe
|
||||
, fromCurrentPosition
|
||||
, toCurrentPosition
|
||||
, PositionDelta(..)
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user