-- | @project.create@ input handler
module Unison.Codebase.Editor.HandleInput.ProjectCreate
  ( projectCreate,
  )
where

import Control.Lens
import Control.Monad.Reader (ask)
import Data.Text qualified as Text
import System.Random.Shuffle qualified as RandomShuffle
import U.Codebase.Sqlite.DbId
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranchRow (..))
import U.Codebase.Sqlite.Queries (expectCausalHashIdByCausalHash)
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.Share.Projects qualified as Share
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Causal qualified as Causal
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
import Unison.NameSegment qualified as NameSegment
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectName, defaultBranchName)
import Unison.Share.API.Hash qualified as Share.API
import Unison.Sync.Common qualified as Sync.Common
import Witch (unsafeFrom)

-- | Create a new project.
--
-- 1. If a project already exists with the given name, bail.
--
-- 2. Otherwise, create a scaffold out a new project with a "main" branch, and add it to the namespace (at a magic
--    location that the user isn't supposed to look at).
--
-- Big danger: we first commit the project identity and metadata (like its name) to the codebase, then manipulate our
-- in-memory namespace and flush its contents out in a separate transaction. This means that if lightning strikes at the
-- wrong time, we'll be in an inconsistent state.
--
-- This could be fixed in a few different ways:
--
--   1. Make a better `stepAt` helper that can mutate the namespace in a transaction.
--
--   2. Add more code to detect the inconsistency and work around it. For example, if we ever see that a project id
--      exists in the codebase but not at its corresponding place in the namespace, we could consider it garbage and
--      delete it. Then, any user who tried to create a project called "foo" shortly before getting hit by lightning
--      could simply try creating "foo" again later.
--
--   3. Don't store projects in the root namespace at all. We don't even want them there, it's just a little too
--      convenient because *not* storing them in the root namespace would require a lot of reworking and rewriting. We'd
--      rather hit some shorter-term project milestones and clean our mess up Later (TM).
--
-- For now, it doesn't seem worth it to do (1) or (2), since we want to do (3) eventually, and we'd rather not waste too
-- much time getting everything perfectly correct before we get there.
projectCreate :: Bool -> Maybe ProjectName -> Cli (ProjectAndBranch ProjectId ProjectBranchId)
projectCreate :: Bool
-> Maybe ProjectName
-> Cli (ProjectAndBranch ProjectId ProjectBranchId)
projectCreate Bool
tryDownloadingBase Maybe ProjectName
maybeProjectName = do
  let branchName :: ProjectBranchName
branchName = ProjectBranchName
defaultBranchName
  (_, emptyCausalHashId) <- Transaction (CausalHash, CausalHashId)
-> Cli (CausalHash, CausalHashId)
forall a. Transaction a -> Cli a
Cli.runTransaction Transaction (CausalHash, CausalHashId)
Codebase.emptyCausalHash

  (project, branch) <-
    case maybeProjectName of
      Maybe ProjectName
Nothing -> do
        randomProjectNames <- IO [ProjectName] -> Cli [ProjectName]
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [ProjectName]
generateRandomProjectNames
        Cli.runTransaction do
          let loop = \case
                [] -> [Char] -> Transaction (Project, ProjectBranchRow)
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Char] -> [Char]
reportBug [Char]
"E066388" [Char]
"project name supply is supposed to be infinite")
                ProjectName
projectName : [ProjectName]
projectNames ->
                  ProjectName -> Transaction (Maybe Project)
Queries.loadProjectByName ProjectName
projectName Transaction (Maybe Project)
-> (Maybe Project -> Transaction (Project, ProjectBranchRow))
-> Transaction (Project, ProjectBranchRow)
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Maybe Project
Nothing -> do
                      (project, branch) <- ProjectName
-> ProjectBranchName
-> CausalHashId
-> Transaction (Project, ProjectBranchRow)
Ops.insertProjectAndBranch ProjectName
projectName ProjectBranchName
branchName CausalHashId
emptyCausalHashId
                      pure (project, branch)
                    Just Project
_project -> [ProjectName] -> Transaction (Project, ProjectBranchRow)
loop [ProjectName]
projectNames
          loop randomProjectNames
      Just ProjectName
projectName -> do
        ((forall void. Output -> Transaction void)
 -> Transaction (Project, ProjectBranchRow))
-> Cli (Project, ProjectBranchRow)
forall a.
((forall void. Output -> Transaction void) -> Transaction a)
-> Cli a
Cli.runTransactionWithRollback \forall void. Output -> Transaction void
rollback -> do
          ProjectName -> Transaction Bool
Queries.projectExistsByName ProjectName
projectName Transaction Bool
-> (Bool -> Transaction (Project, ProjectBranchRow))
-> Transaction (Project, ProjectBranchRow)
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
False -> do
              ProjectName
-> ProjectBranchName
-> CausalHashId
-> Transaction (Project, ProjectBranchRow)
Ops.insertProjectAndBranch ProjectName
projectName ProjectBranchName
branchName CausalHashId
emptyCausalHashId
            Bool
True -> Output -> Transaction (Project, ProjectBranchRow)
forall void. Output -> Transaction void
rollback (ProjectName -> Output
Output.ProjectNameAlreadyExists ProjectName
projectName)

  Cli.respond (Output.CreatedProject (isNothing maybeProjectName) project.name)
  Cli.switchProject (ProjectAndBranch project.projectId branch.branchId)

  maybeBaseLatestReleaseBranchObject <-
    if tryDownloadingBase
      then do
        Cli.respond Output.FetchingLatestReleaseOfBase

        -- Make an effort to pull the latest release of base, which can go wrong in a number of ways, the most likely of
        -- which is that the user is offline.
        maybeBaseLatestReleaseBranchObject <-
          Cli.label \forall void. Maybe (Branch IO) -> Cli void
done -> do
            baseProject <-
              ProjectName -> Cli (Either ClientError (Maybe RemoteProject))
Share.getProjectByName' (forall source target.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeFrom @Text Text
"@unison/base") Cli (Either ClientError (Maybe RemoteProject))
-> (Either ClientError (Maybe RemoteProject) -> Cli RemoteProject)
-> Cli RemoteProject
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Right (Just RemoteProject
baseProject) -> RemoteProject -> Cli RemoteProject
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RemoteProject
baseProject
                Either ClientError (Maybe RemoteProject)
_ -> Maybe (Branch IO) -> Cli RemoteProject
forall void. Maybe (Branch IO) -> Cli void
done Maybe (Branch IO)
forall a. Maybe a
Nothing
            ver <- baseProject ^. #latestRelease & onNothing (done Nothing)
            let baseProjectId = RemoteProject
baseProject RemoteProject
-> Getting RemoteProjectId RemoteProject RemoteProjectId
-> RemoteProjectId
forall s a. s -> Getting a s a -> a
^. Getting RemoteProjectId RemoteProject RemoteProjectId
#projectId
            let baseLatestReleaseBranchName = forall source target.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeFrom @Text (Text
"releases/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @Text Semver
ver)
            response <-
              Share.getProjectBranchByName' Share.NoSquashedHead (ProjectAndBranch baseProjectId baseLatestReleaseBranchName)
                & onLeftM \ClientError
_err -> Maybe (Branch IO) -> Cli GetProjectBranchResponse
forall void. Maybe (Branch IO) -> Cli void
done Maybe (Branch IO)
forall a. Maybe a
Nothing
            baseLatestReleaseBranch <-
              case response of
                GetProjectBranchResponse
Share.GetProjectBranchResponseBranchNotFound -> Maybe (Branch IO) -> Cli RemoteProjectBranch
forall void. Maybe (Branch IO) -> Cli void
done Maybe (Branch IO)
forall a. Maybe a
Nothing
                GetProjectBranchResponse
Share.GetProjectBranchResponseProjectNotFound -> Maybe (Branch IO) -> Cli RemoteProjectBranch
forall void. Maybe (Branch IO) -> Cli void
done Maybe (Branch IO)
forall a. Maybe a
Nothing
                Share.GetProjectBranchResponseSuccess RemoteProjectBranch
branch -> RemoteProjectBranch -> Cli RemoteProjectBranch
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RemoteProjectBranch
branch
            _hash <-
              downloadProjectBranchFromShare Share.NoSquashedHead baseLatestReleaseBranch False
                & onLeftM (Cli.returnEarly . Output.ShareError)
            Cli.Env {codebase} <- ask
            baseLatestReleaseBranchObject <-
              liftIO $
                Codebase.expectBranchForHash
                  codebase
                  (Sync.Common.hash32ToCausalHash (Share.API.hashJWTHash (baseLatestReleaseBranch ^. #branchHead)))
            pure (Just baseLatestReleaseBranchObject)
        when (isNothing maybeBaseLatestReleaseBranchObject) do
          Cli.respond Output.FailedToFetchLatestReleaseOfBase
        pure maybeBaseLatestReleaseBranchObject
      else pure Nothing

  for_ maybeBaseLatestReleaseBranchObject \Branch IO
baseLatestReleaseBranchObject -> do
    -- lib.base
    let projectBranchLibBaseObject :: Branch0 IO
projectBranchLibBaseObject =
          Branch0 IO
forall (m :: * -> *). Branch0 m
Branch.empty0
            Branch0 IO -> (Branch0 IO -> Branch0 IO) -> Branch0 IO
forall a b. a -> (a -> b) -> b
& (Map NameSegment (Branch IO)
 -> Identity (Map NameSegment (Branch IO)))
-> Branch0 IO -> Identity (Branch0 IO)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children_
              ((Map NameSegment (Branch IO)
  -> Identity (Map NameSegment (Branch IO)))
 -> Branch0 IO -> Identity (Branch0 IO))
-> ((Maybe (Branch IO) -> Identity (Maybe (Branch IO)))
    -> Map NameSegment (Branch IO)
    -> Identity (Map NameSegment (Branch IO)))
-> (Maybe (Branch IO) -> Identity (Maybe (Branch IO)))
-> Branch0 IO
-> Identity (Branch0 IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NameSegment (Branch IO))
-> Lens'
     (Map NameSegment (Branch IO))
     (Maybe (IxValue (Map NameSegment (Branch IO))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NameSegment (Branch IO))
NameSegment
NameSegment.baseSegment
              ((Maybe (Branch IO) -> Identity (Maybe (Branch IO)))
 -> Branch0 IO -> Identity (Branch0 IO))
-> Maybe (Branch IO) -> Branch0 IO -> Branch0 IO
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Branch IO -> Maybe (Branch IO)
forall a. a -> Maybe a
Just Branch IO
baseLatestReleaseBranchObject
        projectBranchLibObject :: Branch IO
projectBranchLibObject = Branch0 IO -> Branch IO -> Branch IO
forall (m :: * -> *).
Applicative m =>
Branch0 m -> Branch m -> Branch m
Branch.cons Branch0 IO
projectBranchLibBaseObject Branch IO
forall (m :: * -> *). Branch m
Branch.empty
    let branchWithBase :: Branch IO
branchWithBase =
          Branch IO
forall (m :: * -> *). Branch m
Branch.empty
            Branch IO -> (Branch IO -> Branch IO) -> Branch IO
forall a b. a -> (a -> b) -> b
& (UnwrappedBranch IO -> Identity (UnwrappedBranch IO))
-> Branch IO -> Identity (Branch IO)
forall (m :: * -> *) (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (UnwrappedBranch m) (f (UnwrappedBranch m))
-> p (Branch m) (f (Branch m))
Branch.history_
              ((UnwrappedBranch IO -> Identity (UnwrappedBranch IO))
 -> Branch IO -> Identity (Branch IO))
-> ((Maybe (Branch IO) -> Identity (Maybe (Branch IO)))
    -> UnwrappedBranch IO -> Identity (UnwrappedBranch IO))
-> (Maybe (Branch IO) -> Identity (Maybe (Branch IO)))
-> Branch IO
-> Identity (Branch IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Branch0 IO -> Identity (Branch0 IO))
-> UnwrappedBranch IO -> Identity (UnwrappedBranch IO)
forall e (m :: * -> *).
ContentAddressable e =>
Lens' (Causal m e) e
Lens' (UnwrappedBranch IO) (Branch0 IO)
Causal.head_
              ((Branch0 IO -> Identity (Branch0 IO))
 -> UnwrappedBranch IO -> Identity (UnwrappedBranch IO))
-> ((Maybe (Branch IO) -> Identity (Maybe (Branch IO)))
    -> Branch0 IO -> Identity (Branch0 IO))
-> (Maybe (Branch IO) -> Identity (Maybe (Branch IO)))
-> UnwrappedBranch IO
-> Identity (UnwrappedBranch IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map NameSegment (Branch IO)
 -> Identity (Map NameSegment (Branch IO)))
-> Branch0 IO -> Identity (Branch0 IO)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children_
              ((Map NameSegment (Branch IO)
  -> Identity (Map NameSegment (Branch IO)))
 -> Branch0 IO -> Identity (Branch0 IO))
-> ((Maybe (Branch IO) -> Identity (Maybe (Branch IO)))
    -> Map NameSegment (Branch IO)
    -> Identity (Map NameSegment (Branch IO)))
-> (Maybe (Branch IO) -> Identity (Maybe (Branch IO)))
-> Branch0 IO
-> Identity (Branch0 IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NameSegment (Branch IO))
-> Lens'
     (Map NameSegment (Branch IO))
     (Maybe (IxValue (Map NameSegment (Branch IO))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NameSegment (Branch IO))
NameSegment
NameSegment.libSegment
              ((Maybe (Branch IO) -> Identity (Maybe (Branch IO)))
 -> Branch IO -> Identity (Branch IO))
-> Maybe (Branch IO) -> Branch IO -> Branch IO
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Branch IO -> Maybe (Branch IO)
forall a. a -> Maybe a
Just Branch IO
projectBranchLibObject
    Cli.Env {codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
    liftIO $ Codebase.putBranch codebase branchWithBase
    Cli.runTransaction $ do
      baseBranchCausalHashId <- expectCausalHashIdByCausalHash (Branch.headHash branchWithBase)
      Queries.setProjectBranchHead "Include latest base library" project.projectId branch.branchId baseBranchCausalHashId

  Cli.respond Output.HappyCoding
  pure ProjectAndBranch {project = project.projectId, branch = branch.branchId}

-- An infinite list of random project names that looks like
--
--   [
--     -- We have some reasonable amount of base names...
--     "happy-giraffe",   "happy-gorilla",   "silly-giraffe",   "silly-gorilla",
--
--     -- But if we need more, we just add append a number, and so on...
--     "happy-giraffe-2", "happy-gorilla-2", "silly-giraffe-2", "silly-gorilla-2",
--
--     ...
--   ]
--
-- It's in IO because the base supply (without numbers) gets shuffled.
generateRandomProjectNames :: IO [ProjectName]
generateRandomProjectNames :: IO [ProjectName]
generateRandomProjectNames = do
  baseNames <-
    [Text] -> IO [Text]
forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
RandomShuffle.shuffleM do
      adjective <-
        [ Text
"adept",
          Text
"adorable",
          Text
"ambitious",
          Text
"beautiful",
          Text
"brave",
          Text
"brilliant",
          Text
"courageous",
          Text
"charming",
          Text
"dazzling",
          Text
"delightful",
          Text
"determined",
          Text
"devoted",
          Text
"elegant",
          Text
"enchanting",
          Text
"energetic",
          Text
"engaging",
          Text
"excited",
          Text
"fantastic",
          Text
"fortuitous",
          Text
"friendly",
          Text
"gentle",
          Text
"helpful",
          Text
"heartwarming",
          Text
"hilarious",
          Text
"humorous",
          Text
"incredible",
          Text
"imaginative",
          Text
"innocent",
          Text
"insightful",
          Text
"jolly",
          Text
"joyous",
          Text
"kind",
          Text
"lucky",
          Text
"magnificent",
          Text
"marvelous",
          Text
"nice",
          Text
"outstanding",
          Text
"patient",
          Text
"philosophical",
          Text
"pleasant",
          Text
"proficient",
          Text
"quiet",
          Text
"relaxed",
          Text
"resourceful",
          Text
"responsible",
          Text
"silly",
          Text
"sincere",
          Text
"sensible",
          Text
"sparkling",
          Text
"spectacular",
          Text
"spellbinding",
          Text
"stellar",
          Text
"thoughtful",
          Text
"useful",
          Text
"vibrant",
          Text
"warm-hearted",
          Text
"witty",
          Text
"wondrous",
          Text
"zestful"
        ]
      noun <-
        [ "alpaca",
          "armadillo",
          "axolotl",
          "badger",
          "blobfish",
          "bobcat",
          "camel",
          "capybara",
          "caracal",
          "cheetah",
          "chameleon",
          "chinchilla",
          "chipmunk",
          "donkey",
          "dormouse",
          "earwig",
          "egret",
          "elk",
          "ferret",
          "fennec",
          "fox",
          "frog",
          "gecko",
          "gerbil",
          "gibbon",
          "giraffe",
          "hamster",
          "hedgehog",
          "herron",
          "hippo",
          "ibis",
          "jaguar",
          "kangaroo",
          "kiwi",
          "koala",
          "ladybug",
          "lemur",
          "leopard",
          "lizard",
          "llama",
          "mallard",
          "marmot",
          "mole",
          "moonrat",
          "moose",
          "mouse",
          "narwhal",
          "ocelot",
          "ostrich",
          "otter",
          "owl",
          "panda",
          "pangolin",
          "penguin",
          "platypus",
          "polecat",
          "porcupine",
          "possum",
          "puffin",
          "quahog",
          "racoon",
          "reindeer",
          "rhino",
          "seahorse",
          "seal",
          "serval",
          "shrew",
          "sloth",
          "starling",
          "tapir",
          "tiger",
          "toad",
          "toucan",
          "turkey",
          "turtle",
          "urchin",
          "vole",
          "walrus",
          "wallaby",
          "wallaroo",
          "weasel",
          "woodchuck",
          "wolverine",
          "wombat",
          "yak",
          "zebra"
        ]

      pure (adjective <> "-" <> noun)

  let namesWithNumbers = do
        n <- [(Int
2 :: Int) ..]
        name <- baseNames
        pure (name <> "-" <> Text.pack (show n))

  pure (map (unsafeFrom @Text) (baseNames ++ namesWithNumbers))