{-# LANGUAGE
AllowAmbiguousTypes,
DerivingStrategies,
FlexibleContexts,
FlexibleInstances,
GeneralizedNewtypeDeriving,
MultiParamTypeClasses,
ScopedTypeVariables,
StandaloneDeriving,
TypeApplications,
TypeFamilies,
UndecidableInstances #-}
module DiffLoc.Diff
(
ADiff()
, 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
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
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
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)
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)
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
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 :: 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)