module Unison.Merge.Narrow
  ( narrowDefns,
  )
where

import Data.Map.Merge.Strict qualified as Map
import Data.Semialign (unalign)
import Data.These (These (..))
import U.Codebase.Reference (TypeReference)
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.DeclNameLookup (DeclNameLookup)
import Unison.DeclNameLookup qualified as DeclNameLookup
import Unison.Merge.ThreeWay (GThreeWay, ThreeWay)
import Unison.Merge.ThreeWay qualified as ThreeWay
import Unison.Merge.TwoWay (TwoWay)
import Unison.Merge.Updated (GUpdated (..), Updated)
import Unison.Merge.Updated qualified as Updated
import Unison.Name (Name)
import Unison.PartialDeclNameLookup (PartialDeclNameLookup (..))
import Unison.PartialDeclNameLookup qualified as PartialDeclNameLookup
import Unison.Prelude hiding (catMaybes)
import Unison.Reference (Reference' (..), TermReference, TypeReferenceId)
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Util.Defns (Defns (..), DefnsF)
import Unison.Util.Defns qualified as Defns

-- `narrowDefns` takes and old and new namespace (and their respective decl name lookups), and returns old' and new'
-- namespaces, that contain only definitions that have a chance at having different syntactic hashes.
--
-- (It's not quite as simple as retaining only the definitions with non-equal Unison hashes, as a type declaration's
-- syntactic hash changes if any of its constructors are renamed, but its Unison hash does not).
narrowDefns ::
  (HasCallStack) =>
  GThreeWay PartialDeclNameLookup DeclNameLookup ->
  ThreeWay (DefnsF (Map Name) Referent TypeReference) ->
  TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
narrowDefns :: HasCallStack =>
GThreeWay PartialDeclNameLookup DeclNameLookup
-> ThreeWay (DefnsF (Map Name) Referent TypeReference)
-> TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
narrowDefns GThreeWay PartialDeclNameLookup DeclNameLookup
declNameLookups ThreeWay (DefnsF (Map Name) Referent TypeReference)
defns =
  HasCallStack =>
GUpdated PartialDeclNameLookup DeclNameLookup
-> Updated (DefnsF (Map Name) Referent TypeReference)
-> Updated (DefnsF (Map Name) Referent TypeReference)
GUpdated PartialDeclNameLookup DeclNameLookup
-> Updated (DefnsF (Map Name) Referent TypeReference)
-> Updated (DefnsF (Map Name) Referent TypeReference)
narrowDefns1 (GUpdated PartialDeclNameLookup DeclNameLookup
 -> Updated (DefnsF (Map Name) Referent TypeReference)
 -> Updated (DefnsF (Map Name) Referent TypeReference))
-> TwoWay (GUpdated PartialDeclNameLookup DeclNameLookup)
-> TwoWay
     (Updated (DefnsF (Map Name) Referent TypeReference)
      -> Updated (DefnsF (Map Name) Referent TypeReference))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GThreeWay PartialDeclNameLookup DeclNameLookup
-> TwoWay (GUpdated PartialDeclNameLookup DeclNameLookup)
forall a b. GThreeWay a b -> TwoWay (GUpdated a b)
ThreeWay.gtoUpdated GThreeWay PartialDeclNameLookup DeclNameLookup
declNameLookups TwoWay
  (Updated (DefnsF (Map Name) Referent TypeReference)
   -> Updated (DefnsF (Map Name) Referent TypeReference))
-> TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
-> TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
forall a b. TwoWay (a -> b) -> TwoWay a -> TwoWay b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ThreeWay (DefnsF (Map Name) Referent TypeReference)
-> TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
forall a. ThreeWay a -> TwoWay (Updated a)
ThreeWay.toUpdated ThreeWay (DefnsF (Map Name) Referent TypeReference)
defns

narrowDefns1 ::
  (HasCallStack) =>
  GUpdated PartialDeclNameLookup DeclNameLookup ->
  Updated (DefnsF (Map Name) Referent TypeReference) ->
  Updated (DefnsF (Map Name) Referent TypeReference)
narrowDefns1 :: HasCallStack =>
GUpdated PartialDeclNameLookup DeclNameLookup
-> Updated (DefnsF (Map Name) Referent TypeReference)
-> Updated (DefnsF (Map Name) Referent TypeReference)
narrowDefns1 GUpdated PartialDeclNameLookup DeclNameLookup
declNameLookups Updated (DefnsF (Map Name) Referent TypeReference)
defns =
  (Map Name Referent
 -> Map Name TypeReference
 -> DefnsF (Map Name) Referent TypeReference)
-> Updated (Map Name Referent)
-> Updated (Map Name TypeReference)
-> Updated (DefnsF (Map Name) Referent TypeReference)
forall a b c. (a -> b -> c) -> Updated a -> Updated b -> Updated c
Updated.zipWith Map Name Referent
-> Map Name TypeReference
-> DefnsF (Map Name) Referent TypeReference
forall terms types. terms -> types -> Defns terms types
Defns (HasCallStack =>
GUpdated PartialDeclNameLookup DeclNameLookup
-> Updated (Map Name Referent) -> Updated (Map Name Referent)
GUpdated PartialDeclNameLookup DeclNameLookup
-> Updated (Map Name Referent) -> Updated (Map Name Referent)
narrowTerms GUpdated PartialDeclNameLookup DeclNameLookup
declNameLookups Updated (Map Name Referent)
types) (HasCallStack =>
GUpdated PartialDeclNameLookup DeclNameLookup
-> Updated (Map Name TypeReference)
-> Updated (Map Name TypeReference)
GUpdated PartialDeclNameLookup DeclNameLookup
-> Updated (Map Name TypeReference)
-> Updated (Map Name TypeReference)
narrowTypes GUpdated PartialDeclNameLookup DeclNameLookup
declNameLookups Updated (Map Name TypeReference)
terms)
  where
    (Updated (Map Name Referent)
types, Updated (Map Name TypeReference)
terms) =
      (DefnsF (Map Name) Referent TypeReference
 -> (Map Name Referent, Map Name TypeReference))
-> Updated (DefnsF (Map Name) Referent TypeReference)
-> (Updated (Map Name Referent), Updated (Map Name TypeReference))
forall a b c. (a -> (b, c)) -> Updated a -> (Updated b, Updated c)
Updated.unzipWith DefnsF (Map Name) Referent TypeReference
-> (Map Name Referent, Map Name TypeReference)
forall a b. Defns a b -> (a, b)
Defns.toPair Updated (DefnsF (Map Name) Referent TypeReference)
defns

narrowTerms ::
  (HasCallStack) =>
  GUpdated PartialDeclNameLookup DeclNameLookup ->
  Updated (Map Name Referent) ->
  Updated (Map Name Referent)
narrowTerms :: HasCallStack =>
GUpdated PartialDeclNameLookup DeclNameLookup
-> Updated (Map Name Referent) -> Updated (Map Name Referent)
narrowTerms GUpdated PartialDeclNameLookup DeclNameLookup
declNameLookup =
  (Name -> Referent -> Referent -> Bool)
-> Updated (Map Name Referent) -> Updated (Map Name Referent)
forall ref.
HasCallStack =>
(Name -> ref -> ref -> Bool)
-> Updated (Map Name ref) -> Updated (Map Name ref)
filterOutEqualSynhash \Name
name Referent
oldRef Referent
newRef ->
    case (Referent
oldRef, Referent
newRef) of
      -- Drop hash-equal terms
      TwoTerms TypeReference
x TypeReference
y -> TypeReference
x TypeReference -> TypeReference -> Bool
forall a. Eq a => a -> a -> Bool
== TypeReference
y
      TwoBuiltinConstructors Text
x Text
y -> Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
y
      -- Drop equal constructors only if they would have equal synhashes, i.e. their types have the same namings of
      -- constructors
      TwoNonBuiltinConstructors TypeReferenceId
x TypeReferenceId
y -> TypeReferenceId
x TypeReferenceId -> TypeReferenceId -> Bool
forall a. Eq a => a -> a -> Bool
== TypeReferenceId
y Bool -> Bool -> Bool
&& Bool
sameConstructorNames
        where
          sameConstructorNames :: Bool
sameConstructorNames = [Maybe Name]
oldConstructorNames [Maybe Name] -> [Maybe Name] -> Bool
forall a. Eq a => a -> a -> Bool
== (Name -> Maybe Name) -> [Name] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Maybe Name
forall a. a -> Maybe a
Just [Name]
newConstructorNames
          oldConstructorNames :: [Maybe Name]
oldConstructorNames = HasCallStack => PartialDeclNameLookup -> Name -> [Maybe Name]
PartialDeclNameLookup -> Name -> [Maybe Name]
PartialDeclNameLookup.expectConstructorNames GUpdated PartialDeclNameLookup DeclNameLookup
declNameLookup.old Name
oldDeclName
          newConstructorNames :: [Name]
newConstructorNames = HasCallStack => DeclNameLookup -> Name -> [Name]
DeclNameLookup -> Name -> [Name]
DeclNameLookup.expectConstructorNames GUpdated PartialDeclNameLookup DeclNameLookup
declNameLookup.new Name
newDeclName
          oldDeclName :: Name
oldDeclName = HasCallStack => PartialDeclNameLookup -> Name -> Name
PartialDeclNameLookup -> Name -> Name
PartialDeclNameLookup.expectDeclName GUpdated PartialDeclNameLookup DeclNameLookup
declNameLookup.old Name
name
          newDeclName :: Name
newDeclName = HasCallStack => DeclNameLookup -> Name -> Name
DeclNameLookup -> Name -> Name
DeclNameLookup.expectDeclName GUpdated PartialDeclNameLookup DeclNameLookup
declNameLookup.new Name
name
      (Referent, Referent)
_ -> Bool
False

pattern TwoTerms :: TermReference -> TermReference -> (Referent, Referent)
pattern $mTwoTerms :: forall {r}.
(Referent, Referent)
-> (TypeReference -> TypeReference -> r) -> ((# #) -> r) -> r
TwoTerms x y <- (Referent.Ref x, Referent.Ref y)

pattern TwoBuiltinConstructors :: Text -> Text -> (Referent, Referent)
pattern $mTwoBuiltinConstructors :: forall {r}.
(Referent, Referent) -> (Text -> Text -> r) -> ((# #) -> r) -> r
TwoBuiltinConstructors x y <-
  ( Referent.Con (ConstructorReference (ReferenceBuiltin x) _) _,
    Referent.Con (ConstructorReference (ReferenceBuiltin y) _) _
    )

pattern TwoNonBuiltinConstructors :: TypeReferenceId -> TypeReferenceId -> (Referent, Referent)
pattern $mTwoNonBuiltinConstructors :: forall {r}.
(Referent, Referent)
-> (TypeReferenceId -> TypeReferenceId -> r) -> ((# #) -> r) -> r
TwoNonBuiltinConstructors x y <-
  ( Referent.Con (ConstructorReference (ReferenceDerived x) _) _,
    Referent.Con (ConstructorReference (ReferenceDerived y) _) _
    )

narrowTypes ::
  (HasCallStack) =>
  GUpdated PartialDeclNameLookup DeclNameLookup ->
  Updated (Map Name TypeReference) ->
  Updated (Map Name TypeReference)
narrowTypes :: HasCallStack =>
GUpdated PartialDeclNameLookup DeclNameLookup
-> Updated (Map Name TypeReference)
-> Updated (Map Name TypeReference)
narrowTypes GUpdated PartialDeclNameLookup DeclNameLookup
declNameLookup =
  (Name -> TypeReference -> TypeReference -> Bool)
-> Updated (Map Name TypeReference)
-> Updated (Map Name TypeReference)
forall ref.
HasCallStack =>
(Name -> ref -> ref -> Bool)
-> Updated (Map Name ref) -> Updated (Map Name ref)
filterOutEqualSynhash \Name
name TypeReference
oldRef TypeReference
newRef ->
    case (TypeReference
oldRef, TypeReference
newRef) of
      TwoBuiltinTypes Text
x Text
y -> Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
y
      -- Drop equal types only if they would have equal synhashes, i.e. they have the same namings of constructors
      TwoNonBuiltinTypes TypeReferenceId
x TypeReferenceId
y -> TypeReferenceId
x TypeReferenceId -> TypeReferenceId -> Bool
forall a. Eq a => a -> a -> Bool
== TypeReferenceId
y Bool -> Bool -> Bool
&& Bool
sameConstructorNames
        where
          sameConstructorNames :: Bool
sameConstructorNames = [Maybe Name]
oldConstructorNames [Maybe Name] -> [Maybe Name] -> Bool
forall a. Eq a => a -> a -> Bool
== (Name -> Maybe Name) -> [Name] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Maybe Name
forall a. a -> Maybe a
Just [Name]
newConstructorNames
          oldConstructorNames :: [Maybe Name]
oldConstructorNames = HasCallStack => PartialDeclNameLookup -> Name -> [Maybe Name]
PartialDeclNameLookup -> Name -> [Maybe Name]
PartialDeclNameLookup.expectConstructorNames GUpdated PartialDeclNameLookup DeclNameLookup
declNameLookup.old Name
name
          newConstructorNames :: [Name]
newConstructorNames = HasCallStack => DeclNameLookup -> Name -> [Name]
DeclNameLookup -> Name -> [Name]
DeclNameLookup.expectConstructorNames GUpdated PartialDeclNameLookup DeclNameLookup
declNameLookup.new Name
name
      (TypeReference, TypeReference)
_ -> Bool
False

pattern TwoBuiltinTypes :: Text -> Text -> (TypeReference, TypeReference)
pattern $mTwoBuiltinTypes :: forall {r}.
(TypeReference, TypeReference)
-> (Text -> Text -> r) -> ((# #) -> r) -> r
TwoBuiltinTypes x y <-
  (ReferenceBuiltin x, ReferenceBuiltin y)

pattern TwoNonBuiltinTypes :: TypeReferenceId -> TypeReferenceId -> (TypeReference, TypeReference)
pattern $mTwoNonBuiltinTypes :: forall {r}.
(TypeReference, TypeReference)
-> (TypeReferenceId -> TypeReferenceId -> r) -> ((# #) -> r) -> r
TwoNonBuiltinTypes x y <-
  (ReferenceDerived x, ReferenceDerived y)

filterOutEqualSynhash ::
  forall ref.
  (HasCallStack) =>
  (Name -> ref -> ref -> Bool) ->
  Updated (Map Name ref) ->
  Updated (Map Name ref)
filterOutEqualSynhash :: forall ref.
HasCallStack =>
(Name -> ref -> ref -> Bool)
-> Updated (Map Name ref) -> Updated (Map Name ref)
filterOutEqualSynhash Name -> ref -> ref -> Bool
equal Updated (Map Name ref)
defns =
  SimpleWhenMissing Name ref (These ref ref)
-> SimpleWhenMissing Name ref (These ref ref)
-> SimpleWhenMatched Name ref ref (These ref ref)
-> Map Name ref
-> Map Name ref
-> Map Name (These ref ref)
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 ((Name -> ref -> These ref ref)
-> SimpleWhenMissing Name ref (These ref ref)
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing \Name
_ -> ref -> These ref ref
forall a b. a -> These a b
This) ((Name -> ref -> These ref ref)
-> SimpleWhenMissing Name ref (These ref ref)
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing \Name
_ -> ref -> These ref ref
forall a b. b -> These a b
That) ((Name -> ref -> ref -> Maybe (These ref ref))
-> SimpleWhenMatched Name ref ref (These ref ref)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> Maybe z) -> WhenMatched f k x y z
Map.zipWithMaybeMatched Name -> ref -> ref -> Maybe (These ref ref)
f) Updated (Map Name ref)
defns.old Updated (Map Name ref)
defns.new
    Map Name (These ref ref)
-> (Map Name (These ref ref) -> (Map Name ref, Map Name ref))
-> (Map Name ref, Map Name ref)
forall a b. a -> (a -> b) -> b
& Map Name (These ref ref) -> (Map Name ref, Map Name ref)
forall a b. Map Name (These a b) -> (Map Name a, Map Name b)
forall (f :: * -> *) a b. Unalign f => f (These a b) -> (f a, f b)
unalign
    (Map Name ref, Map Name ref)
-> ((Map Name ref, Map Name ref) -> Updated (Map Name ref))
-> Updated (Map Name ref)
forall a b. a -> (a -> b) -> b
& (Map Name ref, Map Name ref) -> Updated (Map Name ref)
forall a b. (a, b) -> GUpdated a b
Updated.fromPair
  where
    f :: Name -> ref -> ref -> Maybe (These ref ref)
    f :: Name -> ref -> ref -> Maybe (These ref ref)
f Name
name ref
oldRef ref
newRef =
      if Name -> ref -> ref -> Bool
equal Name
name ref
oldRef ref
newRef
        then Maybe (These ref ref)
forall a. Maybe a
Nothing
        else These ref ref -> Maybe (These ref ref)
forall a. a -> Maybe a
Just (ref -> ref -> These ref ref
forall a b. a -> b -> These a b
These ref
oldRef ref
newRef)