module Unison.Codebase.Editor.HandleInput.AliasType (handleAliasType) where

import Control.Lens
import Control.Monad.Reader (ask)
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.BranchUtil qualified as BranchUtil
import Unison.Codebase.Editor.Output
import Unison.Codebase.Path (Path' (..))
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath (ProjectPathG (..))
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.ConstructorType (ConstructorType)
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.DataDeclaration.ConstructorId qualified as ConstructorId
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment qualified as NameSegment
import Unison.PartialDeclNameLookup (PartialDeclNameLookup (..))
import Unison.Prelude
import Unison.Reference (TypeReference)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Server.Backend qualified as Backend
import Unison.ShortHash qualified as SH
import Unison.Util.Relation qualified as Relation
import Unison.Util.Set qualified as Set

handleAliasType :: Bool -> Either SH.ShortHash (HQ'.HashQualified (Path.Split Path')) -> Path.Split Path' -> Cli ()
handleAliasType :: Bool
-> Either ShortHash (HashQualified (Split Path'))
-> Split Path'
-> Cli ()
handleAliasType Bool
force Either ShortHash (HashQualified (Split Path'))
src' Split Path'
dest' = do
  env <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  pp <- Cli.getCurrentProjectPath
  projectNamespace <- Cli.getCurrentProjectRoot
  projectNamespace0 <- Cli.getCurrentProjectRoot0

  (srcType, maybeSrcConstructors) <-
    case src' of
      Right HashQualified (Split Path')
name -> do
        -- Resolve the name relative to the project root
        let hqPathToType :: HQ'.HashQualified (Path.Split Path.Path)
            hqPathToType :: HashQualified (Split Path)
hqPathToType =
              ASetter
  (HashQualified (Split Path'))
  (HashQualified (Split Path))
  Path'
  Path
-> (Path' -> Path)
-> HashQualified (Split Path')
-> HashQualified (Split Path)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Split Path' -> Identity (Split Path))
-> HashQualified (Split Path')
-> Identity (HashQualified (Split Path))
Setter
  (HashQualified (Split Path'))
  (HashQualified (Split Path))
  (Split Path')
  (Split Path)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((Split Path' -> Identity (Split Path))
 -> HashQualified (Split Path')
 -> Identity (HashQualified (Split Path)))
-> ((Path' -> Identity Path)
    -> Split Path' -> Identity (Split Path))
-> ASetter
     (HashQualified (Split Path'))
     (HashQualified (Split Path))
     Path'
     Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path' -> Identity Path) -> Split Path' -> Identity (Split Path)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Split Path') (Split Path) Path' Path
_1) (Absolute -> Path
Path.unabsolute (Absolute -> Path) -> (Path' -> Absolute) -> Path' -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Absolute -> Path' -> Absolute
forall l r o. Resolve l r o => l -> r -> o
Path.resolve ProjectPath
pp.absPath) HashQualified (Split Path')
name

        let pathToType :: Path.Split Path.Path
            pathToType :: Split Path
pathToType =
              HashQualified (Split Path) -> Split Path
forall n. HashQualified n -> n
HQ'.toName HashQualified (Split Path)
hqPathToType

        let actualTypeName :: Name
            actualTypeName :: Name
actualTypeName =
              Split Path -> Name
forall path. Namey path => Split path -> Name
Path.nameFromSplit Split Path
pathToType

        -- Look up all types at the path
        let types :: Set TypeReference
            types :: Set (Reference' Text Hash)
types =
              HashQualified (Split Path)
-> Branch0 IO -> Set (Reference' Text Hash)
forall (m :: * -> *).
HashQualified (Split Path)
-> Branch0 m -> Set (Reference' Text Hash)
BranchUtil.getType HashQualified (Split Path)
hqPathToType Branch0 IO
projectNamespace0

        -- Fail if there are 0, or 2+
        typ <-
          Set (Reference' Text Hash) -> Maybe (Reference' Text Hash)
forall a. Set a -> Maybe a
Set.asSingleton Set (Reference' Text Hash)
types Maybe (Reference' Text Hash)
-> (Maybe (Reference' Text Hash) -> Cli (Reference' Text Hash))
-> Cli (Reference' Text Hash)
forall a b. a -> (a -> b) -> b
& Cli (Reference' Text Hash)
-> Maybe (Reference' Text Hash) -> Cli (Reference' Text Hash)
forall (m :: * -> *) a. Applicative m => m a -> Maybe a -> m a
onNothing do
            Output -> Cli (Reference' Text Hash)
forall a. Output -> Cli a
Cli.returnEarly
              if Set (Reference' Text Hash) -> Bool
forall a. Set a -> Bool
Set.null Set (Reference' Text Hash)
types
                then HashQualified (Split Path') -> Output
TypeNotFound HashQualified (Split Path')
name
                else Int
-> HashQualified (Split Path')
-> Set Referent
-> Set (Reference' Text Hash)
-> Output
DeleteNameAmbiguous Int
10 HashQualified (Split Path')
name Set Referent
forall a. Set a
Set.empty Set (Reference' Text Hash)
types

        constructorNames :: Maybe (ConstructorType, [Maybe Name]) <-
          case Reference.toId typ of
            Maybe Id
Nothing -> Maybe (ConstructorType, [Maybe Name])
-> Cli (Maybe (ConstructorType, [Maybe Name]))
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ConstructorType, [Maybe Name])
forall a. Maybe a
Nothing
            Just Id
typId -> do
              -- expectDeclNumConstructors :: TypeReferenceId -> Sqlite.Transaction Int,
              if Name -> NameSegment -> Bool
Name.beginsWithSegment Name
actualTypeName NameSegment
NameSegment.libSegment
                then do
                  (declType, numConstructors) <-
                    Transaction (ConstructorType, Int) -> Cli (ConstructorType, Int)
forall a. Transaction a -> Cli a
Cli.runTransaction do
                      (,)
                        (ConstructorType -> Int -> (ConstructorType, Int))
-> Transaction ConstructorType
-> Transaction (Int -> (ConstructorType, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Codebase IO Symbol Ann
-> Reference' Text Hash -> Transaction ConstructorType
forall (m :: * -> *) v a.
Codebase m v a
-> Reference' Text Hash -> Transaction ConstructorType
Codebase.getDeclType Env
env.codebase Reference' Text Hash
typ
                        Transaction (Int -> (ConstructorType, Int))
-> Transaction Int -> Transaction (ConstructorType, Int)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Codebase IO Symbol Ann -> Id -> Transaction Int
forall (m :: * -> *) v a. Codebase m v a -> Id -> Transaction Int
Codebase.expectDeclNumConstructors Env
env.codebase Id
typId
                  let constructorReferents :: [Referent]
                      constructorReferents =
                        Int
numConstructors
                          Int -> (Int -> [ConstructorId]) -> [ConstructorId]
forall a b. a -> (a -> b) -> b
& Int -> [ConstructorId]
ConstructorId.fromNumConstructors
                          [ConstructorId] -> ([ConstructorId] -> [Referent]) -> [Referent]
forall a b. a -> (a -> b) -> b
& (ConstructorId -> Referent) -> [ConstructorId] -> [Referent]
forall a b. (a -> b) -> [a] -> [b]
map (\ConstructorId
cid -> ConstructorReference -> ConstructorType -> Referent
Referent.Con (Reference' Text Hash -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference Reference' Text Hash
typ ConstructorId
cid) ConstructorType
declType)
                  pure case BranchUtil.getBranch pathToType projectNamespace0 of
                    Just Branch IO
namespaceUnderneathType ->
                      let bestNameForConstructorReferent :: Referent -> Maybe Name
                          bestNameForConstructorReferent :: Referent -> Maybe Name
bestNameForConstructorReferent =
                            let terms :: Relation Referent Name
terms = Branch0 IO -> Relation Referent Name
forall (m :: * -> *). Branch0 m -> Relation Referent Name
Branch.deepTerms (Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head Branch IO
namespaceUnderneathType)
                             in \Referent
constructorReferent ->
                                  Relation Referent Name
terms
                                    Relation Referent Name
-> (Relation Referent Name -> Set Name) -> Set Name
forall a b. a -> (a -> b) -> b
& Referent -> Relation Referent Name -> Set Name
forall a b. Ord a => a -> Relation a b -> Set b
Relation.lookupDom Referent
constructorReferent
                                    Set Name -> (Set Name -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
& Set Name -> [Name]
forall a. Set a -> [a]
Set.toList
                                    [Name] -> ([Name] -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
& (Name -> Int) -> [Name] -> [Name]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Name -> Int
Name.countSegments
                                    [Name] -> ([Name] -> Maybe Name) -> Maybe Name
forall a b. a -> (a -> b) -> b
& [Name] -> Maybe Name
forall a. [a] -> Maybe a
listToMaybe
                       in (ConstructorType, [Maybe Name])
-> Maybe (ConstructorType, [Maybe Name])
forall a. a -> Maybe a
Just (ConstructorType
declType, (Referent -> Maybe Name) -> [Referent] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map Referent -> Maybe Name
bestNameForConstructorReferent [Referent]
constructorReferents)
                    Maybe (Branch IO)
Nothing -> Maybe (ConstructorType, [Maybe Name])
forall a. Maybe a
Nothing
                else case Branch0 IO
-> Either
     (Defn
        (Conflicted Name Referent)
        (Conflicted Name (Reference' Text Hash)))
     UnconflictedLocalDefnsView
forall (m :: * -> *).
Branch0 m
-> Either
     (Defn
        (Conflicted Name Referent)
        (Conflicted Name (Reference' Text Hash)))
     UnconflictedLocalDefnsView
Branch.asUnconflicted Branch0 IO
projectNamespace0 of
                  Right UnconflictedLocalDefnsView
defns -> do
                    (declType, declNameLookup) <-
                      Transaction (ConstructorType, PartialDeclNameLookup)
-> Cli (ConstructorType, PartialDeclNameLookup)
forall a. Transaction a -> Cli a
Cli.runTransaction do
                        (,)
                          (ConstructorType
 -> PartialDeclNameLookup
 -> (ConstructorType, PartialDeclNameLookup))
-> Transaction ConstructorType
-> Transaction
     (PartialDeclNameLookup -> (ConstructorType, PartialDeclNameLookup))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Codebase IO Symbol Ann
-> Reference' Text Hash -> Transaction ConstructorType
forall (m :: * -> *) v a.
Codebase m v a
-> Reference' Text Hash -> Transaction ConstructorType
Codebase.getDeclType Env
env.codebase Reference' Text Hash
typ
                          Transaction
  (PartialDeclNameLookup -> (ConstructorType, PartialDeclNameLookup))
-> Transaction PartialDeclNameLookup
-> Transaction (ConstructorType, PartialDeclNameLookup)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Codebase IO Symbol Ann
-> BranchHash
-> UnconflictedLocalDefnsView
-> Transaction PartialDeclNameLookup
forall (m :: * -> *) v a.
Codebase m v a
-> BranchHash
-> UnconflictedLocalDefnsView
-> Transaction PartialDeclNameLookup
Codebase.getBranchPartialDeclNameLookup
                            Env
env.codebase
                            (Branch IO -> BranchHash
forall (m :: * -> *). Branch m -> BranchHash
Branch.namespaceHash Branch IO
projectNamespace)
                            UnconflictedLocalDefnsView
defns
                    declNameLookup.declToConstructors
                      & Map.lookup actualTypeName
                      & maybe [] (map (>>= Name.stripNamePrefix actualTypeName))
                      & (declType,)
                      & Just
                      & pure
                  Left Defn
  (Conflicted Name Referent) (Conflicted Name (Reference' Text Hash))
_ -> Maybe (ConstructorType, [Maybe Name])
-> Cli (Maybe (ConstructorType, [Maybe Name]))
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ConstructorType, [Maybe Name])
forall a. Maybe a
Nothing

        pure (typ, constructorNames)
      Left ShortHash
hash -> do
        types <- Transaction (Set (Reference' Text Hash))
-> Cli (Set (Reference' Text Hash))
forall a. Transaction a -> Cli a
Cli.runTransaction (ShortHash -> Transaction (Set (Reference' Text Hash))
Backend.typeReferencesByShortHash ShortHash
hash)
        typ <-
          Set.asSingleton types & onNothing do
            Cli.returnEarly do
              if Set.null types
                then (TypeNotFound' hash)
                else HashAmbiguous hash (Set.map Referent.Ref types)
        pure (typ, Nothing)

  let dest :: Path.Split Path.Absolute
      dest =
        ASetter (Split Path') (Split Absolute) Path' Absolute
-> (Path' -> Absolute) -> Split Path' -> Split Absolute
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Split Path') (Split Absolute) Path' Absolute
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Split Path') (Split Absolute) Path' Absolute
_1 (Absolute -> Path' -> Absolute
forall l r o. Resolve l r o => l -> r -> o
Path.resolve ProjectPath
pp.absPath) Split Path'
dest'

  let destConstructors :: [(Path.Split Path.Absolute, Referent)]
      destConstructors =
        case Maybe (ConstructorType, [Maybe Name])
maybeSrcConstructors of
          Just (ConstructorType
declType, [Maybe Name]
srcConstructors) ->
            [Maybe Name]
srcConstructors
              [Maybe Name]
-> ([Maybe Name] -> [(ConstructorId, Maybe Name)])
-> [(ConstructorId, Maybe Name)]
forall a b. a -> (a -> b) -> b
& [ConstructorId] -> [Maybe Name] -> [(ConstructorId, Maybe Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(ConstructorId
0 :: ConstructorId) ..]
              [(ConstructorId, Maybe Name)]
-> ([(ConstructorId, Maybe Name)] -> [(Split Absolute, Referent)])
-> [(Split Absolute, Referent)]
forall a b. a -> (a -> b) -> b
& ((ConstructorId, Maybe Name) -> Maybe (Split Absolute, Referent))
-> [(ConstructorId, Maybe Name)] -> [(Split Absolute, Referent)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe \(ConstructorId
cid, Maybe Name
maybeConstructorName) -> do
                constructorName <- Maybe Name
maybeConstructorName
                Just
                  ( Path.resolve
                      dest
                      (Path.splitFromName constructorName),
                    Referent.Con (ConstructorReference srcType cid) declType
                  )
          Maybe (ConstructorType, [Maybe Name])
Nothing -> []

  when (not force) do
    let destTypes :: Set TypeReference
        destTypes =
          HashQualified (Split Path)
-> Branch0 IO -> Set (Reference' Text Hash)
forall (m :: * -> *).
HashQualified (Split Path)
-> Branch0 m -> Set (Reference' Text Hash)
BranchUtil.getType (Split Path -> HashQualified (Split Path)
forall n. n -> HashQualified n
HQ'.NameOnly (ASetter (Split Absolute) (Split Path) Absolute Path
-> (Absolute -> Path) -> Split Absolute -> Split Path
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Split Absolute) (Split Path) Absolute Path
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Split Absolute) (Split Path) Absolute Path
_1 Absolute -> Path
Path.unabsolute Split Absolute
dest)) Branch0 IO
projectNamespace0

    when (not (Set.null destTypes)) do
      Cli.returnEarly (TypeAlreadyExists dest' destTypes)

    for_ destConstructors \(Split Absolute
constructorPath, Referent
constructorReferent) -> do
      let existingTerms :: Set Referent
existingTerms = HashQualified (Split Path) -> Branch0 IO -> Set Referent
forall (m :: * -> *).
HashQualified (Split Path) -> Branch0 m -> Set Referent
BranchUtil.getTerm (Split Path -> HashQualified (Split Path)
forall n. n -> HashQualified n
HQ'.fromName (ASetter (Split Absolute) (Split Path) Absolute Path
-> (Absolute -> Path) -> Split Absolute -> Split Path
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Split Absolute) (Split Path) Absolute Path
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Split Absolute) (Split Path) Absolute Path
_1 Absolute -> Path
Path.unabsolute Split Absolute
constructorPath)) Branch0 IO
projectNamespace0
          numExistingTerms :: Int
numExistingTerms = Set Referent -> Int
forall a. Set a -> Int
Set.size Set Referent
existingTerms
      Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numExistingTerms Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| Int
numExistingTerms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Set Referent -> Referent
forall a. Set a -> a
Set.findMin Set Referent
existingTerms Referent -> Referent -> Bool
forall a. Eq a => a -> a -> Bool
/= Referent
constructorReferent) do
        Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (Split Path' -> Set Referent -> Output
TermAlreadyExists (ASetter (Split Absolute) (Split Path') Absolute Path'
-> (Absolute -> Path') -> Split Absolute -> Split Path'
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Split Absolute) (Split Path') Absolute Path'
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Split Absolute) (Split Path') Absolute Path'
_1 Absolute -> Path'
Path.absoluteToPath' Split Absolute
constructorPath) Set Referent
existingTerms)

  Cli.stepManyAt
    pp.branch
    ( ( if force
          then "debug.alias.type.force "
          else "alias.type "
      )
        <> either SH.toText (HQ'.toTextWith (Path.toText . Path.unsplit)) src'
        <> " "
        <> into @Text (Path.unsplit dest)
    )
    (BranchUtil.makeAddTypeName dest srcType : map (\(Split Absolute
p, Referent
r) -> Split Absolute -> Referent -> (Absolute, Branch0 IO -> Branch0 IO)
forall p (m :: * -> *).
Split p -> Referent -> (p, Branch0 m -> Branch0 m)
BranchUtil.makeAddTermName Split Absolute
p Referent
r) destConstructors)

  Cli.respond Success