-- | 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.
    --
    -- The diff algorithm only understands whether items are equal or not, so in order to add this special behavior we
    -- treat these special cases as equal, then we can detect and expand 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
|| case (Maybe Element
fromAnnotation, Maybe Element
toAnnotation) of
          (Maybe Element
Nothing, Maybe Element
_) -> Bool
False
          (Maybe Element
_, Maybe Element
Nothing) -> Bool
False
          (Just Element
a, Just Element
b) ->
            case Element
a of
              -- The set of annotations we want to special-case
              Syntax.TypeReference {} -> Element
a Element -> Element -> Bool
forall a. Eq a => a -> a -> Bool
== Element
b
              Syntax.TermReference {} -> Element
a Element -> Element -> Bool
forall a. Eq a => a -> a -> Bool
== Element
b
              Syntax.DataConstructorReference {} -> Element
a Element -> Element -> Bool
forall a. Eq a => a -> a -> Bool
== Element
b
              Syntax.AbilityConstructorReference {} -> Element
a Element -> Element -> Bool
forall a. Eq a => a -> a -> Bool
== Element
b
              Syntax.HashQualifier {} -> Element
a Element -> Element -> Bool
forall a. Eq a => a -> a -> Bool
== Element
b
              Element
_ -> Bool
False

    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 =
          -- the annotation changed, but it's not a recognized hash change.
          -- This can happen in certain special cases, e.g. a paren changed from being a syntax element into being part
          -- of a unit.
          -- We just emit both as old/new segments.
          [SemanticSyntaxDiff]
-> Either (Segment Element) [SemanticSyntaxDiff]
forall a b. b -> Either a b
Right [[Segment Element] -> SemanticSyntaxDiff
Old [Segment Element
fromSegment], [Segment Element] -> SemanticSyntaxDiff
New [Segment Element
toSegment]]
      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