-- | Utilities for displaying diffs between definitions.
module Unison.Server.Backend.DefinitionDiff
  ( diffDisplayObjects,
  )
where

import Data.Algorithm.Diff qualified as Diff
import Data.Foldable qualified as Foldable
import Data.Function
import Data.List qualified as List
import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
import Unison.Prelude
import Unison.Server.Syntax (SyntaxText)
import Unison.Server.Syntax qualified as Syntax
import Unison.Server.Types (DisplayObjectDiff (..), SemanticSyntaxDiff (..))
import Unison.Util.AnnotatedText (AnnotatedText (..))
import Unison.Util.AnnotatedText qualified as AT

diffDisplayObjects :: (HasCallStack) => DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff
diffDisplayObjects :: HasCallStack =>
DisplayObject SyntaxText SyntaxText
-> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff
diffDisplayObjects DisplayObject SyntaxText SyntaxText
from DisplayObject SyntaxText SyntaxText
to = case (DisplayObject SyntaxText SyntaxText
from, DisplayObject SyntaxText SyntaxText
to) of
  (BuiltinObject SyntaxText
fromST, BuiltinObject SyntaxText
toST) -> DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff]
-> DisplayObjectDiff
DisplayObjectDiff ([SemanticSyntaxDiff]
-> DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff]
forall b a. b -> DisplayObject b a
BuiltinObject (SyntaxText -> SyntaxText -> [SemanticSyntaxDiff]
diffSyntaxText SyntaxText
fromST SyntaxText
toST))
  (MissingObject ShortHash
fromSH, MissingObject ShortHash
toSH)
    | ShortHash
fromSH ShortHash -> ShortHash -> Bool
forall a. Eq a => a -> a -> Bool
== ShortHash
toSH -> DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff]
-> DisplayObjectDiff
DisplayObjectDiff (ShortHash
-> DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff]
forall b a. ShortHash -> DisplayObject b a
MissingObject ShortHash
fromSH)
    | Bool
otherwise -> DisplayObject SyntaxText SyntaxText
-> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff
MismatchedDisplayObjects (ShortHash -> DisplayObject SyntaxText SyntaxText
forall b a. ShortHash -> DisplayObject b a
MissingObject ShortHash
fromSH) (ShortHash -> DisplayObject SyntaxText SyntaxText
forall b a. ShortHash -> DisplayObject b a
MissingObject ShortHash
toSH)
  (UserObject SyntaxText
fromST, UserObject SyntaxText
toST) -> DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff]
-> DisplayObjectDiff
DisplayObjectDiff ([SemanticSyntaxDiff]
-> DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff]
forall b a. a -> DisplayObject b a
UserObject (SyntaxText -> SyntaxText -> [SemanticSyntaxDiff]
diffSyntaxText SyntaxText
fromST SyntaxText
toST))
  (DisplayObject SyntaxText SyntaxText
l, DisplayObject SyntaxText SyntaxText
r) -> DisplayObject SyntaxText SyntaxText
-> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff
MismatchedDisplayObjects DisplayObject SyntaxText SyntaxText
l DisplayObject SyntaxText SyntaxText
r

diffSyntaxText :: SyntaxText -> SyntaxText -> [SemanticSyntaxDiff]
diffSyntaxText :: SyntaxText -> SyntaxText -> [SemanticSyntaxDiff]
diffSyntaxText (AnnotatedText Seq (Segment Element)
fromST) (AnnotatedText Seq (Segment Element)
toST) =
  (Segment Element -> Segment Element -> Bool)
-> [Segment Element]
-> [Segment Element]
-> [PolyDiff [Segment Element] [Segment Element]]
forall a b. (a -> b -> Bool) -> [a] -> [b] -> [PolyDiff [a] [b]]
Diff.getGroupedDiffBy
    Segment Element -> Segment Element -> Bool
diffEq
    (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList @Seq Seq (Segment Element)
fromST)
    (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList @Seq Seq (Segment Element)
toST)
    [PolyDiff [Segment Element] [Segment Element]]
-> ([PolyDiff [Segment Element] [Segment Element]]
    -> [SemanticSyntaxDiff])
-> [SemanticSyntaxDiff]
forall a b. a -> (a -> b) -> b
& [PolyDiff [Segment Element] [Segment Element]]
-> [SemanticSyntaxDiff]
expandSpecialCases
  where
    -- We special-case situations where the name of a definition changed but its hash didn't;
    -- and cases where the name didn't change but the hash did.
    -- So, we treat these elements as equal then detect them in a post-processing step.
    diffEq :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Bool
    diffEq :: Segment Element -> Segment Element -> Bool
diffEq (AT.Segment {segment :: forall a. Segment a -> String
segment = String
fromSegment, annotation :: forall a. Segment a -> Maybe a
annotation = Maybe Element
fromAnnotation}) (AT.Segment {segment :: forall a. Segment a -> String
segment = String
toSegment, annotation :: forall a. Segment a -> Maybe a
annotation = Maybe Element
toAnnotation}) =
      String
fromSegment String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
toSegment Bool -> Bool -> Bool
|| Maybe Element
fromAnnotation Maybe Element -> Maybe Element -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Element
toAnnotation

    expandSpecialCases :: [Diff.Diff [AT.Segment (Syntax.Element)]] -> [SemanticSyntaxDiff]
    expandSpecialCases :: [PolyDiff [Segment Element] [Segment Element]]
-> [SemanticSyntaxDiff]
expandSpecialCases [PolyDiff [Segment Element] [Segment Element]]
xs =
      [PolyDiff [Segment Element] [Segment Element]]
xs
        [PolyDiff [Segment Element] [Segment Element]]
-> ([PolyDiff [Segment Element] [Segment Element]]
    -> [SemanticSyntaxDiff])
-> [SemanticSyntaxDiff]
forall a b. a -> (a -> b) -> b
& (PolyDiff [Segment Element] [Segment Element]
 -> [SemanticSyntaxDiff])
-> [PolyDiff [Segment Element] [Segment Element]]
-> [SemanticSyntaxDiff]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \case
          Diff.First [Segment Element]
ys -> [[Segment Element] -> SemanticSyntaxDiff
Old [Segment Element]
ys]
          Diff.Second [Segment Element]
ys -> [[Segment Element] -> SemanticSyntaxDiff
New [Segment Element]
ys]
          Diff.Both [Segment Element]
from [Segment Element]
to ->
            -- Each list should always be the same length.
            (Segment Element
 -> Segment Element -> Either (Segment Element) SemanticSyntaxDiff)
-> [Segment Element]
-> [Segment Element]
-> [Either (Segment Element) SemanticSyntaxDiff]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Segment Element
-> Segment Element -> Either (Segment Element) SemanticSyntaxDiff
detectSpecialCase [Segment Element]
from [Segment Element]
to
              [Either (Segment Element) SemanticSyntaxDiff]
-> ([Either (Segment Element) SemanticSyntaxDiff]
    -> [SemanticSyntaxDiff])
-> [SemanticSyntaxDiff]
forall a b. a -> (a -> b) -> b
& (((Either (Segment Element) SemanticSyntaxDiff
  -> [SemanticSyntaxDiff] -> [SemanticSyntaxDiff])
 -> [SemanticSyntaxDiff]
 -> [Either (Segment Element) SemanticSyntaxDiff]
 -> [SemanticSyntaxDiff])
-> [SemanticSyntaxDiff]
-> (Either (Segment Element) SemanticSyntaxDiff
    -> [SemanticSyntaxDiff] -> [SemanticSyntaxDiff])
-> [Either (Segment Element) SemanticSyntaxDiff]
-> [SemanticSyntaxDiff]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either (Segment Element) SemanticSyntaxDiff
 -> [SemanticSyntaxDiff] -> [SemanticSyntaxDiff])
-> [SemanticSyntaxDiff]
-> [Either (Segment Element) SemanticSyntaxDiff]
-> [SemanticSyntaxDiff]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
List.foldr [])
                ( \Either (Segment Element) SemanticSyntaxDiff
next [SemanticSyntaxDiff]
acc -> case ([SemanticSyntaxDiff]
acc, Either (Segment Element) SemanticSyntaxDiff
next) of
                    (Both [Segment Element]
xs : [SemanticSyntaxDiff]
rest, Left Segment Element
seg) -> [Segment Element] -> SemanticSyntaxDiff
Both (Segment Element
seg Segment Element -> [Segment Element] -> [Segment Element]
forall a. a -> [a] -> [a]
: [Segment Element]
xs) SemanticSyntaxDiff -> [SemanticSyntaxDiff] -> [SemanticSyntaxDiff]
forall a. a -> [a] -> [a]
: [SemanticSyntaxDiff]
rest
                    ([SemanticSyntaxDiff]
_, Left Segment Element
seg) -> [Segment Element] -> SemanticSyntaxDiff
Both [Segment Element
seg] SemanticSyntaxDiff -> [SemanticSyntaxDiff] -> [SemanticSyntaxDiff]
forall a. a -> [a] -> [a]
: [SemanticSyntaxDiff]
acc
                    ([SemanticSyntaxDiff]
_, Right SemanticSyntaxDiff
diff) -> SemanticSyntaxDiff
diff SemanticSyntaxDiff -> [SemanticSyntaxDiff] -> [SemanticSyntaxDiff]
forall a. a -> [a] -> [a]
: [SemanticSyntaxDiff]
acc
                )
    detectSpecialCase :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Either (AT.Segment Syntax.Element) SemanticSyntaxDiff
    detectSpecialCase :: Segment Element
-> Segment Element -> Either (Segment Element) SemanticSyntaxDiff
detectSpecialCase Segment Element
fromSegment Segment Element
toSegment
      | Segment Element
fromSegment Segment Element -> Segment Element -> Bool
forall a. Eq a => a -> a -> Bool
== Segment Element
toSegment = Segment Element -> Either (Segment Element) SemanticSyntaxDiff
forall a b. a -> Either a b
Left Segment Element
fromSegment
      | Segment Element -> Maybe Element
forall a. Segment a -> Maybe a
AT.annotation Segment Element
fromSegment Maybe Element -> Maybe Element -> Bool
forall a. Eq a => a -> a -> Bool
== Segment Element -> Maybe Element
forall a. Segment a -> Maybe a
AT.annotation Segment Element
toSegment = SemanticSyntaxDiff -> Either (Segment Element) SemanticSyntaxDiff
forall a b. b -> Either a b
Right ((String, String) -> Maybe Element -> SemanticSyntaxDiff
SegmentChange (Segment Element -> String
forall a. Segment a -> String
AT.segment Segment Element
fromSegment, Segment Element -> String
forall a. Segment a -> String
AT.segment Segment Element
toSegment) (Segment Element -> Maybe Element
forall a. Segment a -> Maybe a
AT.annotation Segment Element
fromSegment))
      -- We only emit an annotation change if it's a change in just the hash of the element (optionally the KIND of hash reference can change too).
      | Segment Element -> String
forall a. Segment a -> String
AT.segment Segment Element
fromSegment String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Segment Element -> String
forall a. Segment a -> String
AT.segment Segment Element
toSegment,
        Just UnisonHash
_fromHash <- Segment Element -> Maybe Element
forall a. Segment a -> Maybe a
AT.annotation Segment Element
fromSegment Maybe Element -> (Element -> Maybe UnisonHash) -> Maybe UnisonHash
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Element -> Maybe UnisonHash
elementHash,
        Just UnisonHash
_toHash <- Segment Element -> Maybe Element
forall a. Segment a -> Maybe a
AT.annotation Segment Element
toSegment Maybe Element -> (Element -> Maybe UnisonHash) -> Maybe UnisonHash
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Element -> Maybe UnisonHash
elementHash =
          SemanticSyntaxDiff -> Either (Segment Element) SemanticSyntaxDiff
forall a b. b -> Either a b
Right (String -> (Maybe Element, Maybe Element) -> SemanticSyntaxDiff
AnnotationChange (Segment Element -> String
forall a. Segment a -> String
AT.segment Segment Element
fromSegment) (Segment Element -> Maybe Element
forall a. Segment a -> Maybe a
AT.annotation Segment Element
fromSegment, Segment Element -> Maybe Element
forall a. Segment a -> Maybe a
AT.annotation Segment Element
toSegment))
      | Bool
otherwise = String -> Either (Segment Element) SemanticSyntaxDiff
forall a. HasCallStack => String -> a
error String
"diffSyntaxText: found Syntax Elements in 'both' which have nothing in common."
      where
        elementHash :: Syntax.Element -> Maybe Syntax.UnisonHash
        elementHash :: Element -> Maybe UnisonHash
elementHash = \case
          Syntax.TypeReference UnisonHash
hash -> UnisonHash -> Maybe UnisonHash
forall a. a -> Maybe a
Just UnisonHash
hash
          Syntax.TermReference UnisonHash
hash -> UnisonHash -> Maybe UnisonHash
forall a. a -> Maybe a
Just UnisonHash
hash
          Syntax.DataConstructorReference UnisonHash
hash -> UnisonHash -> Maybe UnisonHash
forall a. a -> Maybe a
Just UnisonHash
hash
          Syntax.AbilityConstructorReference UnisonHash
hash -> UnisonHash -> Maybe UnisonHash
forall a. a -> Maybe a
Just UnisonHash
hash
          Element
_ -> Maybe UnisonHash
forall a. Maybe a
Nothing