-- | @lib.install@ input handler
module Unison.Codebase.Editor.HandleInput.InstallLib
  ( handleInstallLib,
    handleInstallLocalLib,
  )
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 Data.These (These (..))
import U.Codebase.Causal qualified as UCausal
import U.Codebase.Causal.Squash qualified as UCausal
import U.Codebase.Sqlite.V2.HashHandle qualified as HH
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

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

  libdepBranchName <-
    case fromMaybe ProjectBranchNameOrLatestRelease'LatestRelease 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 =
        ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectName
libdepProjectName ProjectBranchName
libdepBranchName

  libdepProjectBranch <-
    ProjectUtils.expectRemoteProjectBranchByName
      Share.IncludeSquashedHead
      (ProjectAndBranch (libdepProject.projectId, libdepProjectName) libdepBranchName)

  when remind do
    Cli.respond (Output.UseLibInstallNotPull (ProjectAndBranch libdepProjectName libdepBranchName))

  Cli.Env {codebase} <- ask

  causalHash <-
    downloadProjectBranchFromShare Share.IncludeSquashedHead libdepProjectBranch False
      & onLeftM (Cli.returnEarly . Output.ShareError)

  remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase causalHash)
  let 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
  libdepNameSegment <- attachNewLib reflogDescription remoteBranchObject libdepProjectName libdepBranchName Nothing
  Cli.respond (Output.InstalledLibdep libdepProjectAndBranchNames libdepNameSegment)

-- | Attach a new library to the current project branch, under the `lib` namespace, using a fresh name derived from the
-- project and branch names.
attachNewLib :: Text -> Branch.Branch IO -> ProjectName -> ProjectBranchName -> Maybe NameSegment -> Cli NameSegment
attachNewLib :: Text
-> Branch IO
-> ProjectName
-> ProjectBranchName
-> Maybe NameSegment
-> Cli NameSegment
attachNewLib Text
reflogDescription Branch IO
libBranch ProjectName
libdepProjectName ProjectBranchName
libdepBranchName Maybe NameSegment
preferredName = do
  -- 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".
  libdepNameSegment :: NameSegment <- case Maybe NameSegment
preferredName of
    Just NameSegment
name -> NameSegment -> Cli NameSegment
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameSegment
name
    Maybe NameSegment
Nothing -> do
      currentBranchObject <- Cli (Branch0 IO)
Cli.getCurrentProjectRoot0
      pure $
        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 Map.lookup NameSegment.libSegment (currentBranchObject ^. 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_)
          )
          (makeDependencyName libdepProjectName libdepBranchName)

  let libdepPath :: Path.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]

  pp <- Cli.getCurrentProjectPath
  let 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
  _didUpdate <- Cli.updateAt reflogDescription libDepPP (\Branch IO
_empty -> Branch IO
libBranch)
  pure 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]

---------------------------------

handleInstallLocalLib :: (ProjectAndBranch ProjectName ProjectBranchName) -> Maybe NameSegment -> Cli ()
handleInstallLocalLib :: ProjectAndBranch ProjectName ProjectBranchName
-> Maybe NameSegment -> Cli ()
handleInstallLocalLib srcPAB :: ProjectAndBranch ProjectName ProjectBranchName
srcPAB@(ProjectAndBranch ProjectName
projName ProjectBranchName
branchName) Maybe NameSegment
mayDestLibName = do
  sourcePAB <- These ProjectName ProjectBranchName
-> Cli (ProjectAndBranch Project ProjectBranch)
ProjectUtils.expectProjectAndBranchByTheseNames (ProjectName
-> ProjectBranchName -> These ProjectName ProjectBranchName
forall a b. a -> b -> These a b
These ProjectName
projName ProjectBranchName
branchName)
  causalBranchToSquash <- Cli.runTransaction $ Codebase.expectProjectBranchRootCausal sourcePAB.branch
  squashResult <- Cli.runTransaction $ UCausal.squashCausal HH.v2HashHandle causalBranchToSquash
  let reflogDescription = Text
"lib.install.local " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @Text ProjectAndBranch ProjectName ProjectBranchName
srcPAB Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (NameSegment -> Text) -> Maybe NameSegment -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\NameSegment
n -> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NameSegment -> Text
NameSegment.toEscapedText NameSegment
n) Maybe NameSegment
mayDestLibName
  Cli.Env {codebase} <- ask
  squashedBranchIO <- liftIO $ Codebase.expectBranchForHash codebase squashResult.causalHash
  libSegmentName <- attachNewLib reflogDescription squashedBranchIO projName branchName mayDestLibName
  Cli.respond $ Output.InstalledLibdep srcPAB libSegmentName