{-# LANGUAGE
  AllowAmbiguousTypes,
  DerivingStrategies,
  FlexibleContexts,
  FlexibleInstances,
  GeneralizedNewtypeDeriving,
  MultiParamTypeClasses,
  ScopedTypeVariables,
  StandaloneDeriving,
  TypeApplications,
  TypeFamilies,
  UndecidableInstances #-}

-- | Mapping intervals across diffs
module DiffLoc.Diff
  ( -- * Types
    ADiff()

    -- * Operations
  , emptyDiff
  , addDiff
  , mapDiff
  , comapDiff
  , listToDiff
  ) where

import Data.Coerce
import Data.Foldable (toList)
import Data.Maybe (fromMaybe)
import Data.FingerTree (FingerTree)
import Text.Show.Combinators (showCon, (@|))
import qualified Data.FingerTree as FT

import DiffLoc.Shift

-- $setup
-- >>> import Control.Monad ((<=<))
-- >>> import Test.QuickCheck
-- >>> import Test.QuickCheck.HigherOrder
-- >>> import DiffLoc
-- >>> import DiffLoc.Unsafe
-- >>> import DiffLoc.Test
-- >>> type NN' = Colline N N'
-- >>> quickCheck = quickCheckWith' stdArgs{maxSuccess=3000}

-- | A diff represents a transformation from one file to another.
--
-- Example diff between "abcdefgh" and "appcfgzzh":
--
-- > source ab cdefg  h
-- >      -  b  de
-- >      +  pp     zz
-- > target appc  fgzzh
--
-- It consists of three replacements:
--
-- 1. replace "b" with "pp" at location 1, @mkReplace 1 1 2@;
-- 2. replace "de" with "" at location 3, @mkReplace 3 2 0@;
-- 3. replace "" with "zz" at location 7, @mkReplace 7 0 2@.
--
-- >>> :{
--   let d :: Diff N
--       d = addDiff (Replace 1 (offset 1) (offset 2))  -- at location 1, replace "b" (length 1) with "pp" (length 2)
--         $ addDiff (Replace 3 (offset 2) (offset 0))  -- at location 3, replace "de" with ""
--         $ addDiff (Replace 7 (offset 0) (offset 2))  -- at location 7, replace "" with "zz"
--         $ emptyDiff
--   -- N.B.: replacements should be inserted right to left.
-- :}
--
-- 'ADiff' is an abstract representation to be instantiated with
-- a concrete representation of atomic replacements.
--
-- == __Internal details__
--
-- Internally, a diff is a sequence of /disjoint/ and /nonempty/ replacements,
-- /ordered/ by their source locations.
-- The monoid annotation in the fingertree gives the endpoints of the replacements.
newtype ADiff r = ADiff (FingerTree (Maybe r) (R r))
  deriving ADiff r -> ADiff r -> Bool
forall r. Eq r => ADiff r -> ADiff r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ADiff r -> ADiff r -> Bool
$c/= :: forall r. Eq r => ADiff r -> ADiff r -> Bool
== :: ADiff r -> ADiff r -> Bool
$c== :: forall r. Eq r => ADiff r -> ADiff r -> Bool
Eq

instance Show r => Show (ADiff r) where
  showsPrec :: Int -> ADiff r -> ShowS
showsPrec = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ \ADiff r
d -> String -> Int -> ShowS
showCon String
"listToDiff" forall a. Show a => (Int -> ShowS) -> a -> Int -> ShowS
@| forall r. ADiff r -> [r]
diffToList ADiff r
d

-- | The empty diff.
emptyDiff :: Semigroup r => ADiff r
emptyDiff :: forall r. Semigroup r => ADiff r
emptyDiff = forall r. FingerTree (Maybe r) (R r) -> ADiff r
ADiff forall v a. Measured v a => FingerTree v a
FT.empty

-- | A newtype to carry a 'FT.Measured' instance.
newtype R r = R r
  deriving newtype (R r -> R r -> Bool
forall r. Eq r => R r -> R r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: R r -> R r -> Bool
$c/= :: forall r. Eq r => R r -> R r -> Bool
== :: R r -> R r -> Bool
$c== :: forall r. Eq r => R r -> R r -> Bool
Eq, Int -> R r -> ShowS
[R r] -> ShowS
R r -> String
forall r. Show r => Int -> R r -> ShowS
forall r. Show r => [R r] -> ShowS
forall r. Show r => R r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [R r] -> ShowS
$cshowList :: forall r. Show r => [R r] -> ShowS
show :: R r -> String
$cshow :: forall r. Show r => R r -> String
showsPrec :: Int -> R r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> R r -> ShowS
Show)

instance Semigroup r => FT.Measured (Maybe r) (R r) where
  measure :: R r -> Maybe r
measure (R r
r) = forall a. a -> Maybe a
Just r
r

coshiftR' :: Shift r => Maybe r -> r -> r
coshiftR' :: forall r. Shift r => Maybe r -> r -> r
coshiftR' Maybe r
Nothing = forall a. a -> a
id
coshiftR' (Just r
r) = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"failed to shift disjoint intervals") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Shift r => r -> r -> Maybe r
coshiftR r
r

addDiffL :: forall r. Shift r => r -> ADiff r -> ADiff r
addDiffL :: forall r. Shift r => r -> ADiff r -> ADiff r
addDiffL r
r (ADiff FingerTree (Maybe r) (R r)
d0) = case forall v a.
Measured v a =>
FingerTree v a -> ViewL (FingerTree v) a
FT.viewl FingerTree (Maybe r) (R r)
d0 of
  ViewL (FingerTree (Maybe r)) (R r)
FT.EmptyL -> forall r. FingerTree (Maybe r) (R r) -> ADiff r
ADiff (forall v a. Measured v a => a -> FingerTree v a
FT.singleton (forall r. r -> R r
R r
r))
  R r
s FT.:< FingerTree (Maybe r) (R r)
d | forall r. Shift r => r -> Block r
src r
r forall b. BlockOrder b => b -> b -> Bool
`distantlyPrecedes` forall r. Shift r => r -> Block r
src r
s -> forall r. FingerTree (Maybe r) (R r) -> ADiff r
ADiff (forall r. r -> R r
R r
r forall v a. Measured v a => a -> FingerTree v a -> FingerTree v a
FT.<| FingerTree (Maybe r) (R r)
d0)
              | Bool
otherwise -> forall r. Shift r => r -> ADiff r -> ADiff r
addDiffL (r
r forall a. Semigroup a => a -> a -> a
<> r
s) (forall r. FingerTree (Maybe r) (R r) -> ADiff r
ADiff FingerTree (Maybe r) (R r)
d)

-- | Add a replacement to a diff. The replacement is performed /after/ the diff.
--
-- === Properties
--
-- prop> not (isZeroLength x) ==> mapDiff (addDiff r d) x == (shiftBlock r <=< mapDiff (d :: Diff N)) x
-- prop> not (isZeroLength x) ==> comapDiff (addDiff r d) x == (comapDiff d <=< coshiftBlock (r :: Replace N)) x
addDiff :: forall r. Shift r => r -> ADiff r -> ADiff r
addDiff :: forall r. Shift r => r -> ADiff r -> ADiff r
addDiff r
r (ADiff FingerTree (Maybe r) (R r)
d) = case forall v a.
Measured v a =>
(v -> v -> Bool) -> FingerTree v a -> SearchResult v a
FT.search (\Maybe r
r1 Maybe r
_-> Maybe r
r1 forall {r} {r}.
(Block r ~ Block r, Shift r, Shift r) =>
Maybe r -> r -> Bool
`notPrecedes_` r
r) FingerTree (Maybe r) (R r)
d of
  FT.Position FingerTree (Maybe r) (R r)
d1 R r
s FingerTree (Maybe r) (R r)
d2 -> coerce :: forall a b. Coercible a b => a -> b
coerce (FingerTree (Maybe r) (R r)
d1 forall a. Semigroup a => a -> a -> a
<>) (forall r. Shift r => r -> ADiff r -> ADiff r
addDiffL (forall r. Shift r => Maybe r -> r -> r
coshiftR' (forall v a. Measured v a => a -> v
FT.measure FingerTree (Maybe r) (R r)
d1) r
r) (forall r. FingerTree (Maybe r) (R r) -> ADiff r
ADiff (R r
s forall v a. Measured v a => a -> FingerTree v a -> FingerTree v a
FT.<| FingerTree (Maybe r) (R r)
d2)))
  SearchResult (Maybe r) (R r)
FT.OnLeft -> forall r. Shift r => r -> ADiff r -> ADiff r
addDiffL r
r (forall r. FingerTree (Maybe r) (R r) -> ADiff r
ADiff FingerTree (Maybe r) (R r)
d)
  SearchResult (Maybe r) (R r)
FT.OnRight -> forall r. FingerTree (Maybe r) (R r) -> ADiff r
ADiff (FingerTree (Maybe r) (R r)
d forall v a. Measured v a => FingerTree v a -> a -> FingerTree v a
FT.|> forall r. r -> R r
R (forall r. Shift r => Maybe r -> r -> r
coshiftR' (forall v a. Measured v a => a -> v
FT.measure FingerTree (Maybe r) (R r)
d) r
r))
  SearchResult (Maybe r) (R r)
FT.Nowhere -> forall a. HasCallStack => String -> a
error String
"Broken invariant"
  where
    notPrecedes_ :: Maybe r -> r -> Bool
notPrecedes_ Maybe r
Nothing r
_ = Bool
False
    notPrecedes_ (Just r
r1) r
i = Bool -> Bool
not (forall r. Shift r => r -> Block r
tgt r
r1 forall b. BlockOrder b => b -> b -> Bool
`distantlyPrecedes` forall r. Shift r => r -> Block r
tgt r
i)
    -- Using distantlyPrecedes here and in addDiffL lets us merge adjacent intervals.

-- $hidden
-- prop> not (isZeroLength x) ==> mapDiff (addDiff r d) x == (shiftBlock r <=< mapDiff (d :: Diff NN')) x
-- prop> not (isZeroLength x) ==> comapDiff (addDiff r d) x == (comapDiff d <=< coshiftBlock (r :: Replace NN')) x

-- | Translate a span in the source of a diff to a span in its target.
-- @Nothing@ if the span overlaps with a replacement.
--
-- For exaple, given the following 'ADiff' (or 'DiffLoc.Interval.Replace') from "aAacCc" to "aAabbbcCc":
--
-- > source aAa   cCc
-- >      - 
-- >      +    bbb
-- > target aAabbbcCc
--
-- >>> r0 = Replace 3 (offset 0) (offset 3) :: Replace N
-- >>> d0 = addDiff r0 emptyDiff
--
-- The span of \"A\" remains unchanged.
--
-- >>> mapDiff d0 (1 :.. offset 1)
-- Just (1 :.. offset 1)
-- >>> shiftBlock r0 (1 :.. offset 1)
-- Just (1 :.. offset 1)
-- >>> comapDiff d0 (1 :.. offset 1)
-- Just (1 :.. offset 1)
-- >>> coshiftBlock r0 (1 :.. offset 1)
-- Just (1 :.. offset 1)
--
-- The span of \"C\" is shifted by 3 characters.
--
-- >>> mapDiff d0 (4 :.. offset 1)
-- Just (7 :.. offset 1)
-- >>> shiftBlock r0 (4 :.. offset 1)
-- Just (7 :.. offset 1)
-- >>> comapDiff d0 (7 :.. offset 1)
-- Just (4 :.. offset 1)
-- >>> coshiftBlock r0 (7 :.. offset 1)
-- Just (4 :.. offset 1)
--
-- The span of "ac" overlaps with the replacement, so the mapping is undefined.
--
-- >>> mapDiff d0 (2 :.. offset 2)
-- Nothing
-- >>> shiftBlock r0 (2 :.. offset 2)
-- Nothing
-- >>> comapDiff d0 (2 :.. offset 5)
-- Nothing
-- >>> coshiftBlock r0 (2 :.. offset 5)
-- Nothing
--
-- === Properties
--
-- prop> \(FSN d s) -> not (isZeroLength s) ==> partialSemiInverse (mapDiff d) (comapDiff d) s
-- prop> \(FSN d s) -> not (isZeroLength s) ==> partialSemiInverse (comapDiff d) (mapDiff d) s
--
-- where @partialSemiInverse f g x@ is the property
--
-- > if   f x == Just y   -- for some y
-- > then g y == Just x
mapDiff :: Shift r => ADiff r -> Block r -> Maybe (Block r)
mapDiff :: forall r. Shift r => ADiff r -> Block r -> Maybe (Block r)
mapDiff = forall r.
Shift r =>
Variance -> ADiff r -> Block r -> Maybe (Block r)
mapDiff_ Variance
Cov

-- $hidden
--
-- prop> \(FSV d s) -> not (isZeroLength s) ==> partialSemiInverse (mapDiff d) (comapDiff d) s
-- prop> \(FSV d s) -> not (isZeroLength s) ==> partialSemiInverse (comapDiff d) (mapDiff d) s

-- | Translate a span in the target of a diff to a span in its source.
-- @Nothing@ if the span overlaps with a replacement.
--
-- See also 'mapDiff'.
comapDiff :: Shift r => ADiff r -> Block r -> Maybe (Block r)
comapDiff :: forall r. Shift r => ADiff r -> Block r -> Maybe (Block r)
comapDiff = forall r.
Shift r =>
Variance -> ADiff r -> Block r -> Maybe (Block r)
mapDiff_ Variance
Contrav

data Variance = Cov | Contrav

srcV :: Shift r => Variance -> r -> Block r
srcV :: forall r. Shift r => Variance -> r -> Block r
srcV Variance
Cov = forall r. Shift r => r -> Block r
src
srcV Variance
Contrav = forall r. Shift r => r -> Block r
tgt

shiftBlockV' :: Shift r => Variance -> Maybe r -> Block r -> Block r
shiftBlockV' :: forall r. Shift r => Variance -> Maybe r -> Block r -> Block r
shiftBlockV' Variance
_ Maybe r
Nothing = forall a. a -> a
id
shiftBlockV' Variance
Cov (Just r
r) = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"failed to shift disjoint intervals") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Shift r => r -> Block r -> Maybe (Block r)
shiftBlock r
r
shiftBlockV' Variance
Contrav (Just r
r) = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"failed to shift disjoint intervals") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Shift r => r -> Block r -> Maybe (Block r)
coshiftBlock r
r

mapDiff_ :: forall r. Shift r => Variance -> ADiff r -> Block r -> Maybe (Block r)
mapDiff_ :: forall r.
Shift r =>
Variance -> ADiff r -> Block r -> Maybe (Block r)
mapDiff_ Variance
v (ADiff FingerTree (Maybe r) (R r)
d) Block r
i = case forall v a.
Measured v a =>
(v -> v -> Bool) -> FingerTree v a -> SearchResult v a
FT.search (\Maybe r
r1 Maybe r
_ -> Maybe r
r1 Maybe r -> Block r -> Bool
`notPrecedes_` Block r
i) FingerTree (Maybe r) (R r)
d of
  FT.Position FingerTree (Maybe r) (R r)
d1 (R r
s) FingerTree (Maybe r) (R r)
_
    | Block r
j forall b. BlockOrder b => b -> b -> Bool
`precedes` (forall r. Shift r => Variance -> r -> Block r
srcV Variance
v r
s) -> forall a. a -> Maybe a
Just Block r
i'
    | Bool
otherwise -> forall a. Maybe a
Nothing
    where i' :: Block r
i' = forall r. Shift r => Variance -> Maybe r -> Block r -> Block r
shiftBlockV' Variance
v (forall v a. Measured v a => a -> v
FT.measure FingerTree (Maybe r) (R r)
d1) Block r
i
          j :: Block r
j = case Variance
v of Variance
Cov -> Block r
i ; Variance
Contrav -> Block r
i'
  SearchResult (Maybe r) (R r)
FT.OnLeft -> forall a. a -> Maybe a
Just Block r
i
  SearchResult (Maybe r) (R r)
FT.OnRight -> forall a. a -> Maybe a
Just (forall r. Shift r => Variance -> Maybe r -> Block r -> Block r
shiftBlockV' Variance
v (forall v a. Measured v a => a -> v
FT.measure FingerTree (Maybe r) (R r)
d) Block r
i)
  SearchResult (Maybe r) (R r)
FT.Nowhere -> forall a. HasCallStack => String -> a
error String
"Broken invariant"
  where
    notPrecedes_ :: Maybe r -> Block r -> Bool
notPrecedes_ Maybe r
Nothing Block r
_ = Bool
False
    notPrecedes_ (Just r
r1) Block r
i1 = Bool -> Bool
not (forall r. Shift r => Variance -> r -> Block r
srcV Variance
v r
r1 forall b. BlockOrder b => b -> b -> Bool
`precedes` Block r
i1)

-- |
--
-- @
-- 'listToDiff' = foldr 'addDiff' 'emptyDiff'
-- @
listToDiff :: Shift r => [r] -> ADiff r
listToDiff :: forall r. Shift r => [r] -> ADiff r
listToDiff = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall r. Shift r => r -> ADiff r -> ADiff r
addDiff forall r. Semigroup r => ADiff r
emptyDiff

diffToList :: ADiff r -> [r]
diffToList :: forall r. ADiff r -> [r]
diffToList (ADiff FingerTree (Maybe r) (R r)
d) = coerce :: forall a b. Coercible a b => a -> b
coerce (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList FingerTree (Maybe r) (R r)
d)