-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
module Development.IDE.Core.PositionMapping
  ( PositionMapping(..)
  , PositionResult(..)
  , lowerRange
  , upperRange
  , positionResultToMaybe
  , fromCurrentPosition
  , toCurrentPosition
  , PositionDelta(..)
  , addDelta
  , mkDelta
  , toCurrentRange
  , fromCurrentRange
  , applyChange
  , zeroMapping
  -- toCurrent and fromCurrent are mainly exposed for testing
  , toCurrent
  , fromCurrent
  ) where

import Control.Monad
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
  { PositionResult a -> a
unsafeLowerRange :: a
  , PositionResult a -> a
unsafeUpperRange :: a }
  | PositionExact !a
  deriving (PositionResult a -> PositionResult a -> Bool
(PositionResult a -> PositionResult a -> Bool)
-> (PositionResult a -> PositionResult a -> Bool)
-> Eq (PositionResult a)
forall a. Eq a => PositionResult a -> PositionResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PositionResult a -> PositionResult a -> Bool
$c/= :: forall a. Eq a => PositionResult a -> PositionResult a -> Bool
== :: PositionResult a -> PositionResult a -> Bool
$c== :: forall a. Eq a => PositionResult a -> PositionResult a -> Bool
Eq,Eq (PositionResult a)
Eq (PositionResult a)
-> (PositionResult a -> PositionResult a -> Ordering)
-> (PositionResult a -> PositionResult a -> Bool)
-> (PositionResult a -> PositionResult a -> Bool)
-> (PositionResult a -> PositionResult a -> Bool)
-> (PositionResult a -> PositionResult a -> Bool)
-> (PositionResult a -> PositionResult a -> PositionResult a)
-> (PositionResult a -> PositionResult a -> PositionResult a)
-> Ord (PositionResult a)
PositionResult a -> PositionResult a -> Bool
PositionResult a -> PositionResult a -> Ordering
PositionResult a -> PositionResult a -> PositionResult a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (PositionResult a)
forall a. Ord a => PositionResult a -> PositionResult a -> Bool
forall a. Ord a => PositionResult a -> PositionResult a -> Ordering
forall a.
Ord a =>
PositionResult a -> PositionResult a -> PositionResult a
min :: PositionResult a -> PositionResult a -> PositionResult a
$cmin :: forall a.
Ord a =>
PositionResult a -> PositionResult a -> PositionResult a
max :: PositionResult a -> PositionResult a -> PositionResult a
$cmax :: forall a.
Ord a =>
PositionResult a -> PositionResult a -> PositionResult a
>= :: PositionResult a -> PositionResult a -> Bool
$c>= :: forall a. Ord a => PositionResult a -> PositionResult a -> Bool
> :: PositionResult a -> PositionResult a -> Bool
$c> :: forall a. Ord a => PositionResult a -> PositionResult a -> Bool
<= :: PositionResult a -> PositionResult a -> Bool
$c<= :: forall a. Ord a => PositionResult a -> PositionResult a -> Bool
< :: PositionResult a -> PositionResult a -> Bool
$c< :: forall a. Ord a => PositionResult a -> PositionResult a -> Bool
compare :: PositionResult a -> PositionResult a -> Ordering
$ccompare :: forall a. Ord a => PositionResult a -> PositionResult a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (PositionResult a)
Ord,Int -> PositionResult a -> ShowS
[PositionResult a] -> ShowS
PositionResult a -> String
(Int -> PositionResult a -> ShowS)
-> (PositionResult a -> String)
-> ([PositionResult a] -> ShowS)
-> Show (PositionResult a)
forall a. Show a => Int -> PositionResult a -> ShowS
forall a. Show a => [PositionResult a] -> ShowS
forall a. Show a => PositionResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PositionResult a] -> ShowS
$cshowList :: forall a. Show a => [PositionResult a] -> ShowS
show :: PositionResult a -> String
$cshow :: forall a. Show a => PositionResult a -> String
showsPrec :: Int -> PositionResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PositionResult a -> ShowS
Show,a -> PositionResult b -> PositionResult a
(a -> b) -> PositionResult a -> PositionResult b
(forall a b. (a -> b) -> PositionResult a -> PositionResult b)
-> (forall a b. a -> PositionResult b -> PositionResult a)
-> Functor PositionResult
forall a b. a -> PositionResult b -> PositionResult a
forall a b. (a -> b) -> PositionResult a -> PositionResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PositionResult b -> PositionResult a
$c<$ :: forall a b. a -> PositionResult b -> PositionResult a
fmap :: (a -> b) -> PositionResult a -> PositionResult b
$cfmap :: forall a b. (a -> b) -> PositionResult a -> PositionResult b
Functor)

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

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

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

instance Applicative PositionResult where
  pure :: a -> PositionResult a
pure = a -> PositionResult a
forall a. a -> PositionResult a
PositionExact
  (PositionExact a -> b
f) <*> :: PositionResult (a -> b) -> PositionResult a -> PositionResult b
<*> PositionResult a
a = (a -> b) -> PositionResult a -> PositionResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f PositionResult a
a
  (PositionRange a -> b
f a -> b
g) <*> (PositionExact a
a) = b -> b -> PositionResult b
forall a. a -> a -> PositionResult a
PositionRange (a -> b
f a
a) (a -> b
g a
a)
  (PositionRange a -> b
f a -> b
g) <*> (PositionRange a
lower a
upper) = b -> b -> PositionResult b
forall a. a -> a -> PositionResult a
PositionRange (a -> b
f a
lower) (a -> b
g a
upper)

instance Monad PositionResult where
  (PositionExact a
a) >>= :: PositionResult a -> (a -> PositionResult b) -> PositionResult b
>>= a -> PositionResult b
f = a -> PositionResult b
f a
a
  (PositionRange a
lower a
upper) >>= a -> PositionResult b
f = b -> b -> PositionResult b
forall a. a -> a -> PositionResult a
PositionRange b
lower' b
upper'
    where
      lower' :: b
lower' = PositionResult b -> b
forall a. PositionResult a -> a
lowerRange (PositionResult b -> b) -> PositionResult b -> b
forall a b. (a -> b) -> a -> b
$ a -> PositionResult b
f a
lower
      upper' :: b
upper' = PositionResult b -> b
forall a. PositionResult a -> a
upperRange (PositionResult b -> b) -> PositionResult b -> b
forall a b. (a -> b) -> a -> b
$ a -> PositionResult b
f a
upper

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

fromCurrentPosition :: PositionMapping -> Position -> Maybe Position
fromCurrentPosition :: PositionMapping -> Position -> Maybe Position
fromCurrentPosition (PositionMapping PositionDelta
pm) = PositionResult Position -> Maybe Position
forall a. PositionResult a -> Maybe a
positionResultToMaybe (PositionResult Position -> Maybe Position)
-> (Position -> PositionResult Position)
-> Position
-> Maybe Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionDelta -> Position -> PositionResult Position
fromDelta PositionDelta
pm

toCurrentPosition :: PositionMapping -> Position -> Maybe Position
toCurrentPosition :: PositionMapping -> Position -> Maybe Position
toCurrentPosition (PositionMapping PositionDelta
pm) = PositionResult Position -> Maybe Position
forall a. PositionResult a -> Maybe a
positionResultToMaybe (PositionResult Position -> Maybe Position)
-> (Position -> PositionResult Position)
-> Position
-> Maybe Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionDelta -> Position -> PositionResult Position
toDelta PositionDelta
pm

-- A position mapping is the difference from the current version to
-- a specific version
newtype PositionMapping = PositionMapping PositionDelta

toCurrentRange :: PositionMapping -> Range -> Maybe Range
toCurrentRange :: PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
mapping (Range Position
a Position
b) =
    Position -> Position -> Range
Range (Position -> Position -> Range)
-> Maybe Position -> Maybe (Position -> Range)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PositionMapping -> Position -> Maybe Position
toCurrentPosition PositionMapping
mapping Position
a Maybe (Position -> Range) -> Maybe Position -> Maybe Range
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PositionMapping -> Position -> Maybe Position
toCurrentPosition PositionMapping
mapping Position
b

fromCurrentRange :: PositionMapping -> Range -> Maybe Range
fromCurrentRange :: PositionMapping -> Range -> Maybe Range
fromCurrentRange PositionMapping
mapping (Range Position
a Position
b) =
    Position -> Position -> Range
Range (Position -> Position -> Range)
-> Maybe Position -> Maybe (Position -> Range)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PositionMapping -> Position -> Maybe Position
fromCurrentPosition PositionMapping
mapping Position
a Maybe (Position -> Range) -> Maybe Position -> Maybe Range
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PositionMapping -> Position -> Maybe Position
fromCurrentPosition PositionMapping
mapping Position
b

zeroMapping :: PositionMapping
zeroMapping :: PositionMapping
zeroMapping = PositionDelta -> PositionMapping
PositionMapping PositionDelta
idDelta

-- | Compose two position mappings. Composes in the same way as function
-- composition (ie the second argument is applyed to the position first).
composeDelta :: PositionDelta
                -> PositionDelta
                -> PositionDelta
composeDelta :: PositionDelta -> PositionDelta -> PositionDelta
composeDelta (PositionDelta Position -> PositionResult Position
to1 Position -> PositionResult Position
from1) (PositionDelta Position -> PositionResult Position
to2 Position -> PositionResult Position
from2) =
  (Position -> PositionResult Position)
-> (Position -> PositionResult Position) -> PositionDelta
PositionDelta (Position -> PositionResult Position
to1 (Position -> PositionResult Position)
-> (Position -> PositionResult Position)
-> Position
-> PositionResult Position
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Position -> PositionResult Position
to2)
                (Position -> PositionResult Position
from1 (Position -> PositionResult Position)
-> (Position -> PositionResult Position)
-> Position
-> PositionResult Position
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Position -> PositionResult Position
from2)

idDelta :: PositionDelta
idDelta :: PositionDelta
idDelta = (Position -> PositionResult Position)
-> (Position -> PositionResult Position) -> PositionDelta
PositionDelta Position -> PositionResult Position
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position -> PositionResult Position
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Convert a set of changes into a delta from k  to k + 1
mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta
mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta
mkDelta [TextDocumentContentChangeEvent]
cs = (PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta)
-> PositionDelta
-> [TextDocumentContentChangeEvent]
-> PositionDelta
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta
applyChange PositionDelta
idDelta [TextDocumentContentChangeEvent]
cs

-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n
addDelta :: PositionDelta -> PositionMapping -> PositionMapping
addDelta :: PositionDelta -> PositionMapping -> PositionMapping
addDelta PositionDelta
delta (PositionMapping PositionDelta
pm) = PositionDelta -> PositionMapping
PositionMapping (PositionDelta -> PositionDelta -> PositionDelta
composeDelta PositionDelta
delta PositionDelta
pm)

applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta
applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta
applyChange PositionDelta{Position -> PositionResult Position
fromDelta :: Position -> PositionResult Position
toDelta :: Position -> PositionResult Position
fromDelta :: PositionDelta -> Position -> PositionResult Position
toDelta :: PositionDelta -> Position -> PositionResult Position
..} (TextDocumentContentChangeEvent (Just Range
r) Maybe Int
_ Text
t) = PositionDelta :: (Position -> PositionResult Position)
-> (Position -> PositionResult Position) -> PositionDelta
PositionDelta
    { toDelta :: Position -> PositionResult Position
toDelta = Range -> Text -> Position -> PositionResult Position
toCurrent Range
r Text
t (Position -> PositionResult Position)
-> (Position -> PositionResult Position)
-> Position
-> PositionResult Position
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Position -> PositionResult Position
toDelta
    , fromDelta :: Position -> PositionResult Position
fromDelta = Position -> PositionResult Position
fromDelta (Position -> PositionResult Position)
-> (Position -> PositionResult Position)
-> Position
-> PositionResult Position
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Range -> Text -> Position -> PositionResult Position
fromCurrent Range
r Text
t
    }
applyChange PositionDelta
posMapping TextDocumentContentChangeEvent
_ = PositionDelta
posMapping

toCurrent :: Range -> T.Text -> Position -> PositionResult Position
toCurrent :: Range -> Text -> Position -> PositionResult Position
toCurrent (Range start :: Position
start@(Position Int
startLine Int
startColumn) end :: Position
end@(Position Int
endLine Int
endColumn)) Text
t (Position Int
line Int
column)
    | Int
line Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
startLine Bool -> Bool -> Bool
|| Int
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
startLine Bool -> Bool -> Bool
&& Int
column Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
startColumn =
      -- Position is before the change and thereby unchanged.
      Position -> PositionResult Position
forall a. a -> PositionResult a
PositionExact (Position -> PositionResult Position)
-> Position -> PositionResult Position
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Position
Position Int
line Int
column
    | Int
line Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
endLine Bool -> Bool -> Bool
|| Int
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
endLine Bool -> Bool -> Bool
&& Int
column Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
endColumn =
      -- Position is after the change so increase line and column number
      -- as necessary.
      Position -> PositionResult Position
forall a. a -> PositionResult a
PositionExact (Position -> PositionResult Position)
-> Position -> PositionResult Position
forall a b. (a -> b) -> a -> b
$ Int
newLine Int -> Position -> Position
`seq` Int
newColumn Int -> Position -> Position
`seq` Int -> Int -> Position
Position Int
newLine Int
newColumn
    | Bool
otherwise = Position -> Position -> PositionResult Position
forall a. a -> a -> PositionResult a
PositionRange Position
start Position
end
    -- Position is in the region that was changed.
    where
        lineDiff :: Int
lineDiff = Int
linesNew Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
linesOld
        linesNew :: Int
linesNew = Text -> Text -> Int
T.count Text
"\n" Text
t
        linesOld :: Int
linesOld = Int
endLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
startLine
        newEndColumn :: Int
newEndColumn
          | Int
linesNew Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int
startColumn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
t
          | Bool
otherwise = Text -> Int
T.length (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') Text
t
        newColumn :: Int
newColumn
          | Int
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
endLine = Int
column Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
newEndColumn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
endColumn
          | Bool
otherwise = Int
column
        newLine :: Int
newLine = Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lineDiff

fromCurrent :: Range -> T.Text -> Position -> PositionResult Position
fromCurrent :: Range -> Text -> Position -> PositionResult Position
fromCurrent (Range start :: Position
start@(Position Int
startLine Int
startColumn) end :: Position
end@(Position Int
endLine Int
endColumn)) Text
t (Position Int
line Int
column)
    | Int
line Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
startLine Bool -> Bool -> Bool
|| Int
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
startLine Bool -> Bool -> Bool
&& Int
column Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
startColumn =
      -- Position is before the change and thereby unchanged
      Position -> PositionResult Position
forall a. a -> PositionResult a
PositionExact (Position -> PositionResult Position)
-> Position -> PositionResult Position
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Position
Position Int
line Int
column
    | Int
line Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
newEndLine Bool -> Bool -> Bool
|| Int
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
newEndLine Bool -> Bool -> Bool
&& Int
column Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
newEndColumn =
      -- Position is after the change so increase line and column number
      -- as necessary.
      Position -> PositionResult Position
forall a. a -> PositionResult a
PositionExact (Position -> PositionResult Position)
-> Position -> PositionResult Position
forall a b. (a -> b) -> a -> b
$ Int
newLine Int -> Position -> Position
`seq` Int
newColumn Int -> Position -> Position
`seq` Int -> Int -> Position
Position Int
newLine Int
newColumn
    | Bool
otherwise = Position -> Position -> PositionResult Position
forall a. a -> a -> PositionResult a
PositionRange Position
start Position
end
    -- Position is in the region that was changed.
    where
        lineDiff :: Int
lineDiff = Int
linesNew Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
linesOld
        linesNew :: Int
linesNew = Text -> Text -> Int
T.count Text
"\n" Text
t
        linesOld :: Int
linesOld = Int
endLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
startLine
        newEndLine :: Int
newEndLine = Int
endLine Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lineDiff
        newEndColumn :: Int
newEndColumn
          | Int
linesNew Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int
startColumn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
t
          | Bool
otherwise = Text -> Int
T.length (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') Text
t
        newColumn :: Int
newColumn
          | Int
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
newEndLine = Int
column Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
newEndColumn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
endColumn)
          | Bool
otherwise = Int
column
        newLine :: Int
newLine = Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lineDiff