-- | @lib.install@ input handler
module Unison.Codebase.Editor.HandleInput.InstallLib
  ( handleInstallLib,
  )
where

import Control.Monad.Reader (ask)
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Unison.Cli.DownloadUtils
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Cli.Share.Projects qualified as Share
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Core.Project (ProjectBranchName)
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment (libSegment)
import Unison.NameSegment.Internal qualified as NameSegment
import Unison.Prelude
import Unison.Project
  ( ProjectAndBranch (..),
    ProjectBranchNameKind (..),
    ProjectBranchNameOrLatestRelease (..),
    ProjectName,
    Semver (..),
    classifyProjectBranchName,
    projectNameToUserProjectSlugs,
  )
import Unison.Syntax.NameSegment qualified as NameSegment (unsafeParseText)

handleInstallLib :: Bool -> ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease) -> Cli ()
handleInstallLib :: Bool
-> ProjectAndBranch
     ProjectName (Maybe ProjectBranchNameOrLatestRelease)
-> Cli ()
handleInstallLib Bool
remind (ProjectAndBranch ProjectName
libdepProjectName Maybe ProjectBranchNameOrLatestRelease
unresolvedLibdepBranchName) = do
  RemoteProject
libdepProject <- ProjectName -> Cli RemoteProject
ProjectUtils.expectRemoteProjectByName ProjectName
libdepProjectName

  ProjectBranchName
libdepBranchName <-
    case ProjectBranchNameOrLatestRelease
-> Maybe ProjectBranchNameOrLatestRelease
-> ProjectBranchNameOrLatestRelease
forall a. a -> Maybe a -> a
fromMaybe ProjectBranchNameOrLatestRelease
ProjectBranchNameOrLatestRelease'LatestRelease Maybe ProjectBranchNameOrLatestRelease
unresolvedLibdepBranchName of
      ProjectBranchNameOrLatestRelease'Name ProjectBranchName
name -> ProjectBranchName -> Cli ProjectBranchName
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranchName
name
      ProjectBranchNameOrLatestRelease
ProjectBranchNameOrLatestRelease'LatestRelease -> RemoteProject -> Cli ProjectBranchName
ProjectUtils.expectLatestReleaseBranchName RemoteProject
libdepProject

  let libdepProjectAndBranchNames :: ProjectAndBranch ProjectName ProjectBranchName
libdepProjectAndBranchNames =
        ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectName
libdepProjectName ProjectBranchName
libdepBranchName

  RemoteProjectBranch
libdepProjectBranch <-
    IncludeSquashedHead
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Cli RemoteProjectBranch
ProjectUtils.expectRemoteProjectBranchByName
      IncludeSquashedHead
Share.IncludeSquashedHead
      ((RemoteProjectId, ProjectName)
-> ProjectBranchName
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (RemoteProject
libdepProject.projectId, ProjectName
libdepProjectName) ProjectBranchName
libdepBranchName)

  Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
remind do
    Output -> Cli ()
Cli.respond (ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.UseLibInstallNotPull (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectName
libdepProjectName ProjectBranchName
libdepBranchName))

  Cli.Env {Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
$sel:codebase:Env :: Env -> Codebase IO Symbol Ann
codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask

  CausalHash
causalHash <-
    HasCallStack =>
IncludeSquashedHead
-> RemoteProjectBranch -> Cli (Either ShareError CausalHash)
IncludeSquashedHead
-> RemoteProjectBranch -> Cli (Either ShareError CausalHash)
downloadProjectBranchFromShare IncludeSquashedHead
Share.IncludeSquashedHead RemoteProjectBranch
libdepProjectBranch
      Cli (Either ShareError CausalHash)
-> (Cli (Either ShareError CausalHash) -> Cli CausalHash)
-> Cli CausalHash
forall a b. a -> (a -> b) -> b
& (ShareError -> Cli CausalHash)
-> Cli (Either ShareError CausalHash) -> Cli CausalHash
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM (Output -> Cli CausalHash
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli CausalHash)
-> (ShareError -> Output) -> ShareError -> Cli CausalHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShareError -> Output
Output.ShareError)

  Branch IO
remoteBranchObject <- IO (Branch IO) -> Cli (Branch IO)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Codebase IO Symbol Ann -> CausalHash -> IO (Branch IO)
forall (m :: * -> *) v a.
Monad m =>
Codebase m v a -> CausalHash -> m (Branch m)
Codebase.expectBranchForHash Codebase IO Symbol Ann
codebase CausalHash
causalHash)

  -- Find the best available dependency name, starting with the best one (e.g. "unison_base_1_0_0"), and tacking on a
  -- "__2", "__3", etc. suffix.
  --
  -- For example, if the best name is "foo", and libdeps "foo" and "foo__2" already exist, then we'll get "foo__3".
  NameSegment
libdepNameSegment :: NameSegment <- do
    Branch0 IO
currentBranchObject <- Cli (Branch0 IO)
Cli.getCurrentProjectRoot0
    pure $
      (Int -> NameSegment -> NameSegment)
-> Set NameSegment -> NameSegment -> NameSegment
forall a. Ord a => (Int -> a -> a) -> Set a -> a -> a
fresh
        (\Int
i -> Text -> NameSegment
NameSegment.unsafeParseText (Text -> NameSegment)
-> (NameSegment -> Text) -> NameSegment -> NameSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"__" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tShow Int
i) (Text -> Text) -> (NameSegment -> Text) -> NameSegment -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSegment -> Text
NameSegment.toUnescapedText)
        ( case NameSegment -> Map NameSegment (Branch IO) -> Maybe (Branch IO)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NameSegment
NameSegment.libSegment (Branch0 IO
currentBranchObject Branch0 IO
-> Getting
     (Map NameSegment (Branch IO))
     (Branch0 IO)
     (Map NameSegment (Branch IO))
-> Map NameSegment (Branch IO)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (Branch IO))
  (Branch0 IO)
  (Map NameSegment (Branch IO))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children) of
            Maybe (Branch IO)
Nothing -> Set NameSegment
forall a. Set a
Set.empty
            Just Branch IO
libdeps -> Map NameSegment (Branch IO) -> Set NameSegment
forall k a. Map k a -> Set k
Map.keysSet ((Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head Branch IO
libdeps) Branch0 IO
-> Getting
     (Map NameSegment (Branch IO))
     (Branch0 IO)
     (Map NameSegment (Branch IO))
-> Map NameSegment (Branch IO)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (Branch IO))
  (Branch0 IO)
  (Map NameSegment (Branch IO))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children)
        )
        (ProjectName -> ProjectBranchName -> NameSegment
makeDependencyName ProjectName
libdepProjectName ProjectBranchName
libdepBranchName)

  let libdepPath :: Path.Absolute
      libdepPath :: Absolute
libdepPath = Path -> Absolute
Path.Absolute (Path -> Absolute) -> Path -> Absolute
forall a b. (a -> b) -> a -> b
$ [NameSegment] -> Path
Path.fromList [NameSegment
NameSegment.libSegment, NameSegment
libdepNameSegment]

  let reflogDescription :: Text
reflogDescription = Text
"lib.install " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @Text ProjectAndBranch ProjectName ProjectBranchName
libdepProjectAndBranchNames
  ProjectPath
pp <- Cli ProjectPath
Cli.getCurrentProjectPath
  let libDepPP :: ProjectPath
libDepPP = ProjectPath
pp ProjectPath -> (ProjectPath -> ProjectPath) -> ProjectPath
forall a b. a -> (a -> b) -> b
& (Absolute -> Identity Absolute)
-> ProjectPath -> Identity ProjectPath
forall p b (f :: * -> *).
Functor f =>
(Absolute -> f Absolute)
-> ProjectPathG p b -> f (ProjectPathG p b)
PP.absPath_ ((Absolute -> Identity Absolute)
 -> ProjectPath -> Identity ProjectPath)
-> Absolute -> ProjectPath -> ProjectPath
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Absolute
libdepPath
  Bool
_didUpdate <- Text -> ProjectPath -> (Branch IO -> Branch IO) -> Cli Bool
Cli.updateAt Text
reflogDescription ProjectPath
libDepPP (\Branch IO
_empty -> Branch IO
remoteBranchObject)

  Output -> Cli ()
Cli.respond (ProjectAndBranch ProjectName ProjectBranchName
-> NameSegment -> Output
Output.InstalledLibdep ProjectAndBranch ProjectName ProjectBranchName
libdepProjectAndBranchNames NameSegment
libdepNameSegment)

fresh :: (Ord a) => (Int -> a -> a) -> Set a -> a -> a
fresh :: forall a. Ord a => (Int -> a -> a) -> Set a -> a -> a
fresh Int -> a -> a
bump Set a
taken a
x =
  Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust ((a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\a
y -> Bool -> Bool
not (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
y Set a
taken)) (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Int -> a -> a
bump Int
i a
x) [Int
2 ..]))

-- This function mangles the dependency (a project name + a branch name) to a flat string without special characters,
-- suitable for sticking in the `lib` namespace.
--
-- >>> makeDependencyName (unsafeFrom @Text "@unison/base") (unsafeFrom @Text "main")
-- unison_base_main
--
-- >>> makeDependencyName (unsafeFrom @Text "@unison/base") (unsafeFrom @Text "releases/1.0.0")
-- unison_base_1_0_0
--
-- >>> makeDependencyName (unsafeFrom @Text "@unison/base") (unsafeFrom @Text "releases/drafts/1.0.0")
-- unison_base_1_0_0_draft
--
-- >>> makeDependencyName (unsafeFrom @Text "@unison/base") (unsafeFrom @Text "@person/topic")
-- unison_base_person_topic
makeDependencyName :: ProjectName -> ProjectBranchName -> NameSegment
makeDependencyName :: ProjectName -> ProjectBranchName -> NameSegment
makeDependencyName ProjectName
projectName ProjectBranchName
branchName =
  Text -> NameSegment
NameSegment.unsafeParseText (Text -> NameSegment) -> Text -> NameSegment
forall a b. (a -> b) -> a -> b
$
    HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"-" Text
"_" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
      Text -> [Text] -> Text
Text.intercalate Text
"_" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        [[Text]] -> [Text]
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
          [ case ProjectName -> (Text, Text)
projectNameToUserProjectSlugs ProjectName
projectName of
              (Text
user, Text
project) ->
                [[Text]] -> [Text]
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
                  [ if Text -> Bool
Text.null Text
user then [] else [Text
user],
                    [Text
project]
                  ],
            case ProjectBranchName -> ProjectBranchNameKind
classifyProjectBranchName ProjectBranchName
branchName of
              ProjectBranchNameKind'Contributor Text
user ProjectBranchName
branch -> [Text
user, forall target source. From source target => source -> target
into @Text ProjectBranchName
branch]
              ProjectBranchNameKind'DraftRelease Semver
ver -> Semver -> [Text]
semverSegments Semver
ver [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"draft"]
              ProjectBranchNameKind'Release Semver
ver -> Semver -> [Text]
semverSegments Semver
ver
              ProjectBranchNameKind
ProjectBranchNameKind'NothingSpecial -> [forall target source. From source target => source -> target
into @Text ProjectBranchName
branchName]
          ]
  where
    semverSegments :: Semver -> [Text]
    semverSegments :: Semver -> [Text]
semverSegments (Semver Int
x Int
y Int
z) =
      [Int -> Text
forall a. Show a => a -> Text
tShow Int
x, Int -> Text
forall a. Show a => a -> Text
tShow Int
y, Int -> Text
forall a. Show a => a -> Text
tShow Int
z]