mirror of
https://github.com/github/semantic.git
synced 2024-12-23 06:41:45 +03:00
216 lines
9.7 KiB
Haskell
216 lines
9.7 KiB
Haskell
{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies, TypeOperators #-}
|
||
module Diff where
|
||
|
||
import Data.Aeson
|
||
import Data.Bifoldable
|
||
import Data.Bifunctor
|
||
import Data.Bitraversable
|
||
import Data.Foldable (toList)
|
||
import Data.Functor.Classes
|
||
import Data.Functor.Foldable hiding (fold)
|
||
import Data.JSON.Fields
|
||
import Data.Mergeable
|
||
import Data.Record
|
||
import Patch
|
||
import Term
|
||
import Text.Show
|
||
|
||
-- | A recursive structure indicating the changed & unchanged portions of a labelled tree.
|
||
newtype Diff syntax ann1 ann2 = Diff { unDiff :: DiffF syntax ann1 ann2 (Diff syntax ann1 ann2) }
|
||
|
||
-- | A single entry within a recursive 'Diff'.
|
||
data DiffF syntax ann1 ann2 recur
|
||
-- | A changed node, represented as 'Insert'ed, 'Delete'd, or 'Replace'd 'TermF's, consisting of syntax labelled with an annotation.
|
||
= Patch (Patch (TermF syntax ann1 recur)
|
||
(TermF syntax ann2 recur))
|
||
-- | An unchanged node, consisting of syntax labelled with both the original annotations.
|
||
| Merge (TermF syntax (ann1, ann2) recur)
|
||
|
||
-- | Constructs a 'Diff' replacing one 'Term' with another recursively.
|
||
replacing :: Functor syntax => Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2
|
||
replacing (Term (In a1 r1)) (Term (In a2 r2)) = Diff (Patch (Replace (In a1 (deleting <$> r1)) (In a2 (inserting <$> r2))))
|
||
|
||
-- | Constructs a 'Diff' inserting a 'Term' recursively.
|
||
inserting :: Functor syntax => Term syntax ann2 -> Diff syntax ann1 ann2
|
||
inserting = cata insertF
|
||
|
||
-- | Constructs a 'Diff' inserting a single 'TermF' populated by further 'Diff's.
|
||
insertF :: TermF syntax ann2 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
|
||
insertF = Diff . Patch . Insert
|
||
|
||
-- | Constructs a 'Diff' deleting a 'Term' recursively.
|
||
deleting :: Functor syntax => Term syntax ann1 -> Diff syntax ann1 ann2
|
||
deleting = cata deleteF
|
||
|
||
-- | Constructs a 'Diff' deleting a single 'TermF' populated by further 'Diff's.
|
||
deleteF :: TermF syntax ann1 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
|
||
deleteF = Diff . Patch . Delete
|
||
|
||
-- | Constructs a 'Diff' merging two annotations for a single syntax functor populated by further 'Diff's.
|
||
merge :: (ann1, ann2) -> syntax (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
|
||
merge = (Diff .) . (Merge .) . In
|
||
|
||
|
||
diffSum :: (Foldable syntax, Functor syntax) => (forall a b. Patch a b -> Int) -> Diff syntax ann1 ann2 -> Int
|
||
diffSum patchCost = cata $ \ diff -> case diff of
|
||
Patch patch -> patchCost patch + sum (sum <$> patch)
|
||
Merge merge -> sum merge
|
||
|
||
-- | The sum of the node count of the diff’s patches.
|
||
diffCost :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> Int
|
||
diffCost = diffSum (const 1)
|
||
|
||
|
||
diffPatch :: Diff syntax ann1 ann2 -> Maybe (Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2)))
|
||
diffPatch diff = case unDiff diff of
|
||
Patch patch -> Just patch
|
||
_ -> Nothing
|
||
|
||
diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))]
|
||
diffPatches = para $ \ diff -> case diff of
|
||
Patch patch -> bimap (fmap fst) (fmap fst) patch : bifoldMap (foldMap (toList . diffPatch . fst)) (foldMap (toList . diffPatch . fst)) patch
|
||
Merge merge -> foldMap (toList . diffPatch . fst) merge
|
||
|
||
|
||
-- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch.
|
||
mergeMaybe :: (Mergeable syntax, Traversable syntax) => (DiffF syntax ann1 ann2 (Maybe (Term syntax combined)) -> Maybe (Term syntax combined)) -> Diff syntax ann1 ann2 -> Maybe (Term syntax combined)
|
||
mergeMaybe = cata
|
||
|
||
-- | Recover the before state of a diff.
|
||
beforeTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann1)
|
||
beforeTerm = mergeMaybe $ \ diff -> case diff of
|
||
Patch patch -> before patch >>= \ (In a l) -> termIn a <$> sequenceAlt l
|
||
Merge (In (a, _) l) -> termIn a <$> sequenceAlt l
|
||
|
||
-- | Recover the after state of a diff.
|
||
afterTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann2)
|
||
afterTerm = mergeMaybe $ \ diff -> case diff of
|
||
Patch patch -> after patch >>= \ (In b r) -> termIn b <$> sequenceAlt r
|
||
Merge (In (_, b) r) -> termIn b <$> sequenceAlt r
|
||
|
||
|
||
-- | Strips the head annotation off a diff annotated with non-empty records.
|
||
stripDiff :: Functor syntax
|
||
=> Diff syntax (Record (h1 ': t1)) (Record (h2 ': t2))
|
||
-> Diff syntax (Record t1) (Record t2)
|
||
stripDiff = bimap rtail rtail
|
||
|
||
|
||
type instance Base (Diff syntax ann1 ann2) = DiffF syntax ann1 ann2
|
||
|
||
instance Functor syntax => Recursive (Diff syntax ann1 ann2) where project = unDiff
|
||
instance Functor syntax => Corecursive (Diff syntax ann1 ann2) where embed = Diff
|
||
|
||
|
||
instance Eq1 syntax => Eq2 (Diff syntax) where
|
||
liftEq2 eq1 eq2 = go where go (Diff d1) (Diff d2) = liftEq3 eq1 eq2 go d1 d2
|
||
|
||
instance (Eq1 syntax, Eq ann1, Eq ann2) => Eq (Diff syntax ann1 ann2) where
|
||
(==) = eq2
|
||
|
||
instance Eq1 syntax => Eq3 (DiffF syntax) where
|
||
liftEq3 eq1 eq2 eqRecur d1 d2 = case (d1, d2) of
|
||
(Patch p1, Patch p2) -> liftEq2 (liftEq2 eq1 eqRecur) (liftEq2 eq2 eqRecur) p1 p2
|
||
(Merge t1, Merge t2) -> liftEq2 (liftEq2 eq1 eq2) eqRecur t1 t2
|
||
_ -> False
|
||
|
||
instance (Eq1 syntax, Eq ann1, Eq ann2) => Eq1 (DiffF syntax ann1 ann2) where
|
||
liftEq = liftEq3 (==) (==)
|
||
|
||
instance (Eq1 syntax, Eq ann1, Eq ann2, Eq recur) => Eq (DiffF syntax ann1 ann2 recur) where
|
||
(==) = eq3
|
||
|
||
|
||
instance Show1 syntax => Show2 (Diff syntax) where
|
||
liftShowsPrec2 sp1 sl1 sp2 sl2 = go where go d = showsUnaryWith (liftShowsPrec3 sp1 sl1 sp2 sl2 go (showListWith (go 0))) "Diff" d . unDiff
|
||
|
||
instance (Show1 syntax, Show ann1, Show ann2) => Show (Diff syntax ann1 ann2) where
|
||
showsPrec = showsPrec2
|
||
|
||
instance Show1 syntax => Show3 (DiffF syntax) where
|
||
liftShowsPrec3 sp1 sl1 sp2 sl2 spRecur slRecur d diff = case diff of
|
||
Patch patch -> showsUnaryWith (liftShowsPrec2 (liftShowsPrec2 sp1 sl1 spRecur slRecur) (liftShowList2 sp1 sl1 spRecur slRecur) (liftShowsPrec2 sp2 sl2 spRecur slRecur) (liftShowList2 sp2 sl2 spRecur slRecur)) "Patch" d patch
|
||
Merge term -> showsUnaryWith (liftShowsPrec2 spBoth slBoth spRecur slRecur) "Merge" d term
|
||
where spBoth = liftShowsPrec2 sp1 sl1 sp2 sl2
|
||
slBoth = liftShowList2 sp1 sl1 sp2 sl2
|
||
|
||
instance (Show1 syntax, Show ann1, Show ann2) => Show1 (DiffF syntax ann1 ann2) where
|
||
liftShowsPrec = liftShowsPrec3 showsPrec showList showsPrec showList
|
||
|
||
instance (Show1 syntax, Show ann1, Show ann2, Show recur) => Show (DiffF syntax ann1 ann2 recur) where
|
||
showsPrec = showsPrec3
|
||
|
||
|
||
instance Functor syntax => Bifunctor (Diff syntax) where
|
||
bimap f g = go where go = Diff . trimap f g go . unDiff
|
||
|
||
instance Foldable syntax => Bifoldable (Diff syntax) where
|
||
bifoldMap f g = go where go = trifoldMap f g go . unDiff
|
||
|
||
instance Traversable syntax => Bitraversable (Diff syntax) where
|
||
bitraverse f g = go where go = fmap Diff . tritraverse f g go . unDiff
|
||
|
||
|
||
instance Functor syntax => Functor (DiffF syntax ann1 ann2) where
|
||
fmap = trimap id id
|
||
|
||
instance Functor syntax => Trifunctor (DiffF syntax) where
|
||
trimap f g h (Patch patch) = Patch (bimap (bimap f h) (bimap g h) patch)
|
||
trimap f g h (Merge term) = Merge (bimap (bimap f g) h term)
|
||
|
||
instance Foldable syntax => Foldable (DiffF syntax ann1 ann2) where
|
||
foldMap = trifoldMap (const mempty) (const mempty)
|
||
|
||
instance Foldable syntax => Trifoldable (DiffF syntax) where
|
||
trifoldMap f g h (Patch patch) = bifoldMap (bifoldMap f h) (bifoldMap g h) patch
|
||
trifoldMap f g h (Merge term) = bifoldMap (bifoldMap f g) h term
|
||
|
||
instance Traversable syntax => Traversable (DiffF syntax ann1 ann2) where
|
||
traverse = tritraverse pure pure
|
||
|
||
instance Traversable syntax => Tritraversable (DiffF syntax) where
|
||
tritraverse f g h (Patch patch) = Patch <$> bitraverse (bitraverse f h) (bitraverse g h) patch
|
||
tritraverse f g h (Merge term) = Merge <$> bitraverse (bitraverse f g) h term
|
||
|
||
|
||
instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSON (Diff syntax ann1 ann2) where
|
||
toJSON = object . toJSONFields
|
||
toEncoding = pairs . mconcat . toJSONFields
|
||
|
||
instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSONFields (Diff syntax ann1 ann2) where
|
||
toJSONFields = toJSONFields . unDiff
|
||
|
||
instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSONFields1 (DiffF syntax ann1 ann2) where
|
||
toJSONFields1 (Patch patch) = [ "patch" .= JSONFields patch ]
|
||
toJSONFields1 (Merge term) = [ "merge" .= JSONFields term ]
|
||
|
||
instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2, ToJSON recur) => ToJSONFields (DiffF syntax ann1 ann2 recur) where
|
||
toJSONFields = toJSONFields1
|
||
|
||
instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2, ToJSON recur) => ToJSON (DiffF syntax ann1 ann2 recur) where
|
||
toJSON = object . toJSONFields
|
||
toEncoding = pairs . mconcat . toJSONFields
|
||
|
||
|
||
class Eq3 f where
|
||
liftEq3 :: (a1 -> a2 -> Bool) -> (b1 -> b2 -> Bool) -> (c1 -> c2 -> Bool) -> f a1 b1 c1 -> f a2 b2 c2 -> Bool
|
||
|
||
eq3 :: (Eq3 f, Eq a, Eq b, Eq c) => f a b c -> f a b c -> Bool
|
||
eq3 = liftEq3 (==) (==) (==)
|
||
|
||
|
||
class Show3 f where
|
||
liftShowsPrec3 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> (Int -> b -> ShowS) -> ([b] -> ShowS) -> (Int -> c -> ShowS) -> ([c] -> ShowS) -> Int -> f a b c -> ShowS
|
||
|
||
showsPrec3 :: (Show3 f, Show a, Show b, Show c) => Int -> f a b c -> ShowS
|
||
showsPrec3 = liftShowsPrec3 showsPrec showList showsPrec showList showsPrec showList
|
||
|
||
class Trifunctor f where
|
||
trimap :: (a -> a') -> (b -> b') -> (c -> c') -> f a b c -> f a' b' c'
|
||
|
||
class Trifoldable f where
|
||
trifoldMap :: Monoid m => (a -> m) -> (b -> m) -> (c -> m) -> f a b c -> m
|
||
|
||
class Tritraversable f where
|
||
tritraverse :: Applicative g => (a -> g a') -> (b -> g b') -> (c -> g c') -> f a b c -> g (f a' b' c')
|