module Unison.Merge.Rename
  ( Rename (..),
    makeRenames,
    SimpleRenames (..),
    makeSimpleRenames,
  )
where

import Control.Lens
import Data.List qualified as List
import Data.Map.Merge.Strict qualified as Map
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Set.NonEmpty (NESet)
import Data.Set.NonEmpty qualified as Set.NonEmpty
import Unison.Merge.Synhashed (Synhashed (..))
import Unison.Merge.ThreeWay (ThreeWay)
import Unison.Merge.ThreeWay qualified as ThreeWay
import Unison.Merge.TwoWay (TwoWay (..))
import Unison.Name (Name)
import Unison.Prelude
import Unison.Reference (TypeReference)
import Unison.Referent (Referent)
import Unison.ReferentPrime qualified as Referent'
import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF, zipDefnsWith)

-- | A "rename" is a venn partition of two non-empty sets of names: both set differences and the set intersection.
--
-- Invariant: the sets are all disjoint
-- Invariant: it is not the case that adds and deletes are both empty
data Rename = Rename
  { Rename -> Set Name
adds :: Set Name,
    Rename -> Set Name
deletes :: Set Name,
    Rename -> Set Name
unchanged :: Set Name
  }

makeRenames ::
  ThreeWay (Defns (BiMultimap (Synhashed Referent) Name) (BiMultimap (Synhashed TypeReference) Name)) ->
  TwoWay (DefnsF [] Rename Rename)
makeRenames :: ThreeWay
  (Defns
     (BiMultimap (Synhashed Referent) Name)
     (BiMultimap (Synhashed TypeReference) Name))
-> TwoWay (DefnsF [] Rename Rename)
makeRenames ThreeWay
  (Defns
     (BiMultimap (Synhashed Referent) Name)
     (BiMultimap (Synhashed TypeReference) Name))
defns =
  (BiMultimap (Synhashed Referent) Name
 -> BiMultimap (Synhashed Referent) Name -> [Rename])
-> (BiMultimap (Synhashed TypeReference) Name
    -> BiMultimap (Synhashed TypeReference) Name -> [Rename])
-> Defns
     (BiMultimap (Synhashed Referent) Name)
     (BiMultimap (Synhashed TypeReference) Name)
-> Defns
     (BiMultimap (Synhashed Referent) Name)
     (BiMultimap (Synhashed TypeReference) Name)
-> DefnsF [] Rename Rename
forall tm1 tm2 tm3 ty1 ty2 ty3.
(tm1 -> tm2 -> tm3)
-> (ty1 -> ty2 -> ty3)
-> Defns tm1 ty1
-> Defns tm2 ty2
-> Defns tm3 ty3
zipDefnsWith ((Synhashed Referent -> NESet Name -> NESet Name -> Maybe Rename)
-> BiMultimap (Synhashed Referent) Name
-> BiMultimap (Synhashed Referent) Name
-> [Rename]
forall ref.
Ord ref =>
(ref -> NESet Name -> NESet Name -> Maybe Rename)
-> BiMultimap ref Name -> BiMultimap ref Name -> [Rename]
f Synhashed Referent -> NESet Name -> NESet Name -> Maybe Rename
termNamingsToRename) ((Synhashed TypeReference
 -> NESet Name -> NESet Name -> Maybe Rename)
-> BiMultimap (Synhashed TypeReference) Name
-> BiMultimap (Synhashed TypeReference) Name
-> [Rename]
forall ref.
Ord ref =>
(ref -> NESet Name -> NESet Name -> Maybe Rename)
-> BiMultimap ref Name -> BiMultimap ref Name -> [Rename]
f \Synhashed TypeReference
_ -> NESet Name -> NESet Name -> Maybe Rename
namingsToRename) ThreeWay
  (Defns
     (BiMultimap (Synhashed Referent) Name)
     (BiMultimap (Synhashed TypeReference) Name))
defns.lca (Defns
   (BiMultimap (Synhashed Referent) Name)
   (BiMultimap (Synhashed TypeReference) Name)
 -> DefnsF [] Rename Rename)
-> TwoWay
     (Defns
        (BiMultimap (Synhashed Referent) Name)
        (BiMultimap (Synhashed TypeReference) Name))
-> TwoWay (DefnsF [] Rename Rename)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThreeWay
  (Defns
     (BiMultimap (Synhashed Referent) Name)
     (BiMultimap (Synhashed TypeReference) Name))
-> TwoWay
     (Defns
        (BiMultimap (Synhashed Referent) Name)
        (BiMultimap (Synhashed TypeReference) Name))
forall a. ThreeWay a -> TwoWay a
ThreeWay.forgetLca ThreeWay
  (Defns
     (BiMultimap (Synhashed Referent) Name)
     (BiMultimap (Synhashed TypeReference) Name))
defns
  where
    f ::
      (Ord ref) =>
      (ref -> NESet Name -> NESet Name -> Maybe Rename) ->
      BiMultimap ref Name ->
      BiMultimap ref Name ->
      [Rename]
    f :: forall ref.
Ord ref =>
(ref -> NESet Name -> NESet Name -> Maybe Rename)
-> BiMultimap ref Name -> BiMultimap ref Name -> [Rename]
f ref -> NESet Name -> NESet Name -> Maybe Rename
g BiMultimap ref Name
old BiMultimap ref Name
new =
      Map ref Rename -> [Rename]
forall k a. Map k a -> [a]
Map.elems (Map ref Rename -> [Rename]) -> Map ref Rename -> [Rename]
forall a b. (a -> b) -> a -> b
$
        SimpleWhenMissing ref (NESet Name) Rename
-> SimpleWhenMissing ref (NESet Name) Rename
-> SimpleWhenMatched ref (NESet Name) (NESet Name) Rename
-> Map ref (NESet Name)
-> Map ref (NESet Name)
-> Map ref Rename
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
          SimpleWhenMissing ref (NESet Name) Rename
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing
          SimpleWhenMissing ref (NESet Name) Rename
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing
          ((ref -> NESet Name -> NESet Name -> Maybe Rename)
-> SimpleWhenMatched ref (NESet Name) (NESet Name) Rename
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> Maybe z) -> WhenMatched f k x y z
Map.zipWithMaybeMatched ref -> NESet Name -> NESet Name -> Maybe Rename
g)
          (BiMultimap ref Name -> Map ref (NESet Name)
forall a b. BiMultimap a b -> Map a (NESet b)
BiMultimap.domain BiMultimap ref Name
old)
          (BiMultimap ref Name -> Map ref (NESet Name)
forall a b. BiMultimap a b -> Map a (NESet b)
BiMultimap.domain BiMultimap ref Name
new)

termNamingsToRename :: Synhashed Referent -> NESet Name -> NESet Name -> Maybe Rename
termNamingsToRename :: Synhashed Referent -> NESet Name -> NESet Name -> Maybe Rename
termNamingsToRename Synhashed Referent
ref NESet Name
old NESet Name
new
  -- Throw away constructors; we don't really capture their renamings in the same way as types an terms, as the
  -- synhash of a constructor is just the synhash of its type.
  | Referent -> Bool
forall r. Referent' r -> Bool
Referent'.isConstructor Synhashed Referent
ref.value = Maybe Rename
forall a. Maybe a
Nothing
  | Bool
otherwise = NESet Name -> NESet Name -> Maybe Rename
namingsToRename NESet Name
old NESet Name
new

namingsToRename :: NESet Name -> NESet Name -> Maybe Rename
namingsToRename :: NESet Name -> NESet Name -> Maybe Rename
namingsToRename NESet Name
old NESet Name
new =
  if Set Name -> Bool
forall a. Set a -> Bool
Set.null Set Name
adds Bool -> Bool -> Bool
&& Set Name -> Bool
forall a. Set a -> Bool
Set.null Set Name
deletes
    then Maybe Rename
forall a. Maybe a
Nothing
    else Rename -> Maybe Rename
forall a. a -> Maybe a
Just Rename {Set Name
$sel:adds:Rename :: Set Name
adds :: Set Name
adds, Set Name
$sel:deletes:Rename :: Set Name
deletes :: Set Name
deletes, Set Name
$sel:unchanged:Rename :: Set Name
unchanged :: Set Name
unchanged}
  where
    adds :: Set Name
adds = NESet Name -> NESet Name -> Set Name
forall a. Ord a => NESet a -> NESet a -> Set a
Set.NonEmpty.difference NESet Name
new NESet Name
old
    deletes :: Set Name
deletes = NESet Name -> NESet Name -> Set Name
forall a. Ord a => NESet a -> NESet a -> Set a
Set.NonEmpty.difference NESet Name
old NESet Name
new
    unchanged :: Set Name
unchanged = NESet Name -> NESet Name -> Set Name
forall a. Ord a => NESet a -> NESet a -> Set a
Set.NonEmpty.intersection NESet Name
old NESet Name
new

-- | A "simple" rename is one that moves one name to another, where neither the before- nor after-name have any aliases.
data SimpleRenames = SimpleRenames
  { SimpleRenames -> Map Name Name
forwards :: !(Map Name Name),
    SimpleRenames -> Map Name Name
backwards :: !(Map Name Name)
  }

makeSimpleRenames :: DefnsF [] Rename Rename -> Defns SimpleRenames SimpleRenames
makeSimpleRenames :: DefnsF [] Rename Rename -> Defns SimpleRenames SimpleRenames
makeSimpleRenames =
  ([Rename] -> SimpleRenames)
-> ([Rename] -> SimpleRenames)
-> DefnsF [] Rename Rename
-> Defns SimpleRenames SimpleRenames
forall a b c d. (a -> b) -> (c -> d) -> Defns a c -> Defns b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [Rename] -> SimpleRenames
makeSimpleRenames1 [Rename] -> SimpleRenames
makeSimpleRenames1

makeSimpleRenames1 :: [Rename] -> SimpleRenames
makeSimpleRenames1 :: [Rename] -> SimpleRenames
makeSimpleRenames1 =
  (SimpleRenames -> Rename -> SimpleRenames)
-> SimpleRenames -> [Rename] -> SimpleRenames
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' SimpleRenames -> Rename -> SimpleRenames
f (Map Name Name -> Map Name Name -> SimpleRenames
SimpleRenames Map Name Name
forall k a. Map k a
Map.empty Map Name Name
forall k a. Map k a
Map.empty)
  where
    f :: SimpleRenames -> Rename -> SimpleRenames
    f :: SimpleRenames -> Rename -> SimpleRenames
f SimpleRenames
acc Rename
rename =
      case (Set Name -> Int
forall a. Set a -> Int
Set.size Rename
rename.adds, Set Name -> Int
forall a. Set a -> Int
Set.size Rename
rename.deletes, Set Name -> Int
forall a. Set a -> Int
Set.size Rename
rename.unchanged) of
        (Int
1, Int
1, Int
0) ->
          let old :: Name
old = Set Name -> Name
forall a. Set a -> a
Set.findMin Rename
rename.deletes
              new :: Name
new = Set Name -> Name
forall a. Set a -> a
Set.findMin Rename
rename.adds
           in Map Name Name -> Map Name Name -> SimpleRenames
SimpleRenames (Name -> Name -> Map Name Name -> Map Name Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
old Name
new SimpleRenames
acc.forwards) (Name -> Name -> Map Name Name -> Map Name Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
new Name
old SimpleRenames
acc.backwards)
        (Int, Int, Int)
_ -> SimpleRenames
acc