-- | @upgrade@ input handler.
module Unison.Codebase.Editor.HandleInput.Upgrade
  ( handleUpgrade,
  )
where

import Control.Lens ((?=))
import Control.Lens qualified as Lens
import Control.Monad.Reader (ask)
import Control.Monad.State.Strict (State)
import Control.Monad.State.Strict qualified as State
import Control.Monad.Trans.Writer.CPS (WriterT)
import Control.Monad.Trans.Writer.CPS qualified as Writer
import Data.Char qualified as Char
import Data.Containers.ListUtils qualified as List
import Data.List qualified as List
import Data.List.NonEmpty (pattern (:|))
import Data.List.NonEmpty qualified as List (NonEmpty)
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import Text.Builder qualified
import U.Codebase.Sqlite.DbId (ProjectId)
import U.Codebase.Sqlite.Project (Project (..))
import U.Util.Text qualified as Text (unsafeToInt)
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.Pretty qualified as Pretty
import Unison.Cli.ProjectUtils qualified as Cli
import Unison.Cli.UpdateUtils (getNamespaceDependentsOf, hydrateRefs, makeUniqueTypeGuids, nameHydratedRefIds, parseAndTypecheck, subtractDependents)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch0)
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..))
import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch
import Unison.Codebase.Editor.HandleInput.Update2 (typecheckedUnisonFileToBranchUpdates)
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.CommandLine.InputPatterns qualified as InputPatterns
import Unison.DeclCoherencyCheck qualified as DeclCoherencyCheck
import Unison.DeclNameLookup (DeclNameLookup (..))
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment
import Unison.NameSegment.Internal (NameSegment (NameSegment))
import Unison.Names qualified as Names
import Unison.NamesUtils qualified as NamesUtils
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.Project (ProjectBranchName)
import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Sqlite (Transaction)
import Unison.Syntax.FilePrinter (renderDefnsForUnisonFile)
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
import Unison.UnconflictedLocalDefnsView qualified
import Unison.Util.Alphabetical (sortAlphabeticallyOn)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF, zipDefnsWith)
import Unison.Util.Map qualified as Map
import Unison.Util.Pretty (ColorText, Pretty)
import Unison.Util.Pretty qualified as Pretty
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as Relation
import Unison.Util.Set qualified as Set
import Witch (unsafeFrom)

handleUpgrade :: [NameSegment] -> Cli ()
handleUpgrade :: [NameSegment] -> Cli ()
handleUpgrade [NameSegment]
names0 = do
  [(NameSegment, NameSegment)]
namePairs <-
    let loop :: [NameSegment] -> Cli [(NameSegment, NameSegment)]
loop = \case
          NameSegment
old : NameSegment
new : [NameSegment]
names1 -> do
            Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NameSegment
old NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
new) do
              Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$
                Pretty ColorText -> Output
Output.Literal (Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
Pretty.wrap (Pretty ColorText
"I can't upgrade" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> NameSegment -> Pretty ColorText
Pretty.prettyLibdepName NameSegment
old Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"to itself!"))
            ((NameSegment
old, NameSegment
new) (NameSegment, NameSegment)
-> [(NameSegment, NameSegment)] -> [(NameSegment, NameSegment)]
forall a. a -> [a] -> [a]
:) ([(NameSegment, NameSegment)] -> [(NameSegment, NameSegment)])
-> Cli [(NameSegment, NameSegment)]
-> Cli [(NameSegment, NameSegment)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NameSegment] -> Cli [(NameSegment, NameSegment)]
loop [NameSegment]
names1
          [] -> [(NameSegment, NameSegment)] -> Cli [(NameSegment, NameSegment)]
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          [NameSegment
_] ->
            Output -> Cli [(NameSegment, NameSegment)]
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli [(NameSegment, NameSegment)])
-> Output -> Cli [(NameSegment, NameSegment)]
forall a b. (a -> b) -> a -> b
$
              Pretty ColorText -> Output
Output.Literal (Pretty ColorText -> Output) -> Pretty ColorText -> Output
forall a b. (a -> b) -> a -> b
$
                Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
Pretty.wrap
                  (InputPattern -> Pretty ColorText
InputPatterns.makeExample' InputPattern
InputPatterns.upgrade Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"takes an even number of arguments.")
     in [NameSegment] -> Cli [(NameSegment, NameSegment)]
loop [NameSegment]
names0
  case [(NameSegment, NameSegment)]
-> Maybe (NonEmpty (NameSegment, NameSegment))
forall a. [a] -> Maybe (NonEmpty a)
List.NonEmpty.nonEmpty ([(NameSegment, NameSegment)] -> [(NameSegment, NameSegment)]
forall a. Ord a => [a] -> [a]
List.nubOrd [(NameSegment, NameSegment)]
namePairs) of
    Just NonEmpty (NameSegment, NameSegment)
namePairs1 -> NonEmpty (NameSegment, NameSegment) -> Cli ()
handleUpgrade1 NonEmpty (NameSegment, NameSegment)
namePairs1
    -- I don't think the CLI actually lets you get here, because zero-arg `upgrade` kicks off FZF
    Maybe (NonEmpty (NameSegment, NameSegment))
Nothing ->
      Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$
        Pretty ColorText -> Output
Output.Literal (Pretty ColorText -> Output) -> Pretty ColorText -> Output
forall a b. (a -> b) -> a -> b
$
          Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
Pretty.wrap (InputPattern -> Pretty ColorText
InputPatterns.makeExample' InputPattern
InputPatterns.upgrade Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"takes at least two arguments.")

handleUpgrade1 :: List.NonEmpty (NameSegment, NameSegment) -> Cli ()
handleUpgrade1 :: NonEmpty (NameSegment, NameSegment) -> Cli ()
handleUpgrade1 NonEmpty (NameSegment, NameSegment)
namePairs = do
  Env
env <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  ProjectPath
pp <- Cli ProjectPath
Cli.getCurrentProjectPath

  Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ProjectPath
pp.branch.isUpdate (Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (Text -> Text -> Output
Output.CantDoThatDuring Text
"an update" Text
"update"))
  Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ProjectPath
pp.branch.isUpgrade (Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (Text -> Text -> Output
Output.CantDoThatDuring Text
"an upgrade" Text
"upgrade"))
  Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ProjectPath
pp.branch.isMerge (Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (Text -> Text -> Output
Output.CantDoThatDuring Text
"a merge" Text
"merge"))

  let makeUpgradeInfo :: (NameSegment, NameSegment) -> Cli UpgradeInfo
makeUpgradeInfo (NameSegment
oldName, NameSegment
newName) = do
        let oldPath :: Absolute
oldPath = Path -> Absolute
Path.Absolute ([NameSegment] -> Path
Path.fromList [NameSegment
NameSegment.libSegment, NameSegment
oldName])
        let newPath :: Absolute
newPath = Path -> Absolute
Path.Absolute ([NameSegment] -> Path
Path.fromList [NameSegment
NameSegment.libSegment, NameSegment
newName])

        Branch0 IO
oldNamespace <- Path' -> Cli (Branch0 IO)
Cli.expectBranch0AtPath' (Absolute -> Path'
Path.AbsolutePath' Absolute
oldPath)
        Defns (Relation Referent Name) (Relation TypeReference Name)
newLocalDefns <- Branch0 IO
-> Defns (Relation Referent Name) (Relation TypeReference Name)
forall (m :: * -> *).
Branch0 m
-> Defns (Relation Referent Name) (Relation TypeReference Name)
Branch.deepDefns (Branch0 IO
 -> Defns (Relation Referent Name) (Relation TypeReference Name))
-> (Branch0 IO -> Branch0 IO)
-> Branch0 IO
-> Defns (Relation Referent Name) (Relation TypeReference Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch0 IO -> Branch0 IO
forall (m :: * -> *). Branch0 m -> Branch0 m
Branch.deleteLibdeps (Branch0 IO
 -> Defns (Relation Referent Name) (Relation TypeReference Name))
-> Cli (Branch0 IO)
-> Cli
     (Defns (Relation Referent Name) (Relation TypeReference Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path' -> Cli (Branch0 IO)
Cli.expectBranch0AtPath' (Absolute -> Path'
Path.AbsolutePath' Absolute
newPath)

        UpgradeInfo -> Cli UpgradeInfo
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          UpgradeInfo
            { NameSegment
oldName :: NameSegment
$sel:oldName:UpgradeInfo :: NameSegment
oldName,
              Branch0 IO
oldNamespace :: Branch0 IO
$sel:oldNamespace:UpgradeInfo :: Branch0 IO
oldNamespace,
              $sel:oldDeepDefns:UpgradeInfo :: Defns (Relation Referent Name) (Relation TypeReference Name)
oldDeepDefns = Branch0 IO
-> Defns (Relation Referent Name) (Relation TypeReference Name)
forall (m :: * -> *).
Branch0 m
-> Defns (Relation Referent Name) (Relation TypeReference Name)
Branch.deepDefns Branch0 IO
oldNamespace,
              $sel:oldLocalDefns:UpgradeInfo :: Defns (Relation Referent Name) (Relation TypeReference Name)
oldLocalDefns = Branch0 IO
-> Defns (Relation Referent Name) (Relation TypeReference Name)
forall (m :: * -> *).
Branch0 m
-> Defns (Relation Referent Name) (Relation TypeReference Name)
Branch.deepDefns (Branch0 IO -> Branch0 IO
forall (m :: * -> *). Branch0 m -> Branch0 m
Branch.deleteLibdeps Branch0 IO
oldNamespace),
              NameSegment
newName :: NameSegment
$sel:newName:UpgradeInfo :: NameSegment
newName,
              Defns (Relation Referent Name) (Relation TypeReference Name)
newLocalDefns :: Defns (Relation Referent Name) (Relation TypeReference Name)
$sel:newLocalDefns:UpgradeInfo :: Defns (Relation Referent Name) (Relation TypeReference Name)
newLocalDefns
            }

  Branch IO
currentNamespace <- Cli (Branch IO)
Cli.getCurrentProjectRoot
  let currentNamespace0 :: Branch0 IO
currentNamespace0 = Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head Branch IO
currentNamespace

  NonEmpty UpgradeInfo
upgradeInfos <-
    ((NameSegment, NameSegment) -> Cli UpgradeInfo)
-> NonEmpty (NameSegment, NameSegment)
-> Cli (NonEmpty UpgradeInfo)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (NameSegment, NameSegment) -> Cli UpgradeInfo
makeUpgradeInfo NonEmpty (NameSegment, NameSegment)
namePairs

  let deleteAllOlds :: Branch0 IO -> Branch0 IO
deleteAllOlds Branch0 IO
namespace =
        (Branch0 IO -> UpgradeInfo -> Branch0 IO)
-> Branch0 IO -> NonEmpty UpgradeInfo -> Branch0 IO
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Branch0 IO
acc UpgradeInfo
info -> NameSegment -> Branch0 IO -> Branch0 IO
forall (m :: * -> *). NameSegment -> Branch0 m -> Branch0 m
Branch.deleteLibdep UpgradeInfo
info.oldName Branch0 IO
acc) Branch0 IO
namespace NonEmpty UpgradeInfo
upgradeInfos

  let currentNamespaceSansOlds0 :: Branch0 IO
currentNamespaceSansOlds0 = Branch0 IO -> Branch0 IO
deleteAllOlds Branch0 IO
currentNamespace0
  let currentDeepDefnsSansOlds :: Defns (Relation Referent Name) (Relation TypeReference Name)
currentDeepDefnsSansOlds = Branch0 IO
-> Defns (Relation Referent Name) (Relation TypeReference Name)
forall (m :: * -> *).
Branch0 m
-> Defns (Relation Referent Name) (Relation TypeReference Name)
Branch.deepDefns Branch0 IO
currentNamespaceSansOlds0

  -- Assert that the namespace doesn't have any conflicted names
  UnconflictedLocalDefnsView
unconflictedView <-
    Branch0 IO
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
     UnconflictedLocalDefnsView
forall (m :: * -> *).
Branch0 m
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
     UnconflictedLocalDefnsView
Branch.asUnconflicted Branch0 IO
currentNamespace0
      Either
  (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
  UnconflictedLocalDefnsView
-> (Either
      (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
      UnconflictedLocalDefnsView
    -> Cli UnconflictedLocalDefnsView)
-> Cli UnconflictedLocalDefnsView
forall a b. a -> (a -> b) -> b
& (Defn (Conflicted Name Referent) (Conflicted Name TypeReference)
 -> Cli UnconflictedLocalDefnsView)
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
     UnconflictedLocalDefnsView
-> Cli UnconflictedLocalDefnsView
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> Either a b -> m b
onLeft (Output -> Cli UnconflictedLocalDefnsView
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli UnconflictedLocalDefnsView)
-> (Defn (Conflicted Name Referent) (Conflicted Name TypeReference)
    -> Output)
-> Defn (Conflicted Name Referent) (Conflicted Name TypeReference)
-> Cli UnconflictedLocalDefnsView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defn (Conflicted Name Referent) (Conflicted Name TypeReference)
-> Output
Output.ConflictedDefn)

  -- High-level idea: we are trying to perform substitution in every term that depends on something in `old` with the
  -- corresponding thing in `new`, by first rendering the user's code with a particular pretty-print environment, then
  -- parsing it back in a particular parsing environment.
  --
  -- For example, if a user with the namespace
  --
  --     lib.old.foo#oldfoo = 17
  --     lib.new.foo#newfoo = 18
  --     mything#mything    = #oldfoo + 10
  --
  -- runs `upgrade old new`, we will first render
  --
  --     mything#mything    = #oldfoo + 10
  --
  -- as
  --
  --     mything = foo + 10
  --
  -- (note, "foo" here is the shortest unambiguous suffix of all names minus those in `old`), then parse it back in the
  -- parsing environment with names
  --
  --     lib.new.foo = #newfoo
  --
  -- resulting in
  --
  --     mything#mything2 = #newfoo + 10

  (DeclNameLookup
declNameLookup, DefnsF (Map Name) TermReferenceId TermReferenceId
dependents, DefnsF Set TermReferenceId TermReferenceId
dependentsRefs, DefnsF
  (Map Name)
  (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
  (TermReferenceId, Decl Symbol Ann)
hydratedDependents) <-
    ((forall void. Output -> Transaction void)
 -> Transaction
      (DeclNameLookup, DefnsF (Map Name) TermReferenceId TermReferenceId,
       DefnsF Set TermReferenceId TermReferenceId,
       DefnsF
         (Map Name)
         (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
         (TermReferenceId, Decl Symbol Ann)))
-> Cli
     (DeclNameLookup, DefnsF (Map Name) TermReferenceId TermReferenceId,
      DefnsF Set TermReferenceId TermReferenceId,
      DefnsF
        (Map Name)
        (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
        (TermReferenceId, Decl Symbol Ann))
forall a.
((forall void. Output -> Transaction void) -> Transaction a)
-> Cli a
Cli.runTransactionWithRollback \forall void. Output -> Transaction void
rollback -> do
      -- Assert that the namespace doesn't have any incoherent decls
      DeclNameLookup
declNameLookup <-
        Codebase IO Symbol Ann
-> BranchHash
-> UnconflictedLocalDefnsView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
forall (m :: * -> *) v a.
Codebase m v a
-> BranchHash
-> UnconflictedLocalDefnsView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
Codebase.getBranchDeclNameLookup Env
env.codebase (Branch IO -> BranchHash
forall (m :: * -> *). Branch m -> BranchHash
Branch.namespaceHash Branch IO
currentNamespace) UnconflictedLocalDefnsView
unconflictedView
          Transaction (Either IncoherentDeclReasons DeclNameLookup)
-> (Transaction (Either IncoherentDeclReasons DeclNameLookup)
    -> Transaction DeclNameLookup)
-> Transaction DeclNameLookup
forall a b. a -> (a -> b) -> b
& (IncoherentDeclReasons -> Transaction DeclNameLookup)
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
-> Transaction DeclNameLookup
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM (Output -> Transaction DeclNameLookup
forall void. Output -> Transaction void
rollback (Output -> Transaction DeclNameLookup)
-> (IncoherentDeclReasons -> Output)
-> IncoherentDeclReasons
-> Transaction DeclNameLookup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IncoherentDeclReason -> Output
Output.IncoherentDeclDuringUpgrade (IncoherentDeclReason -> Output)
-> (IncoherentDeclReasons -> IncoherentDeclReason)
-> IncoherentDeclReasons
-> Output
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IncoherentDeclReasons -> IncoherentDeclReason
DeclCoherencyCheck.asOneRandomIncoherentDeclReason)

      DefnsF (Map Name) TermReferenceId TermReferenceId
dependents <-
        Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
-> DefnsF Set TypeReference TypeReference
-> Transaction (DefnsF (Map Name) TermReferenceId TermReferenceId)
getNamespaceDependentsOf
          UnconflictedLocalDefnsView
unconflictedView.defns
          (NonEmpty UpgradeInfo
-> DefnsF Set TypeReference TypeReference
-> DefnsF Set TypeReference TypeReference
upgradeInfosToDependencies NonEmpty UpgradeInfo
upgradeInfos (Branch0 IO -> DefnsF Set TypeReference TypeReference
forall (m :: * -> *).
Branch0 m -> DefnsF Set TypeReference TypeReference
Branch.deepDefnsRefs Branch0 IO
currentNamespaceSansOlds0))

      let dependentsRefs :: DefnsF Set TermReferenceId TypeReferenceId
          dependentsRefs :: DefnsF Set TermReferenceId TermReferenceId
dependentsRefs =
            (Map Name TermReferenceId -> Set TermReferenceId)
-> (Map Name TermReferenceId -> Set TermReferenceId)
-> DefnsF (Map Name) TermReferenceId TermReferenceId
-> DefnsF Set TermReferenceId TermReferenceId
forall a b c d. (a -> b) -> (c -> d) -> Defns a c -> Defns b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Map Name TermReferenceId -> Set TermReferenceId
forall v k. Ord v => Map k v -> Set v
Map.elemsSet Map Name TermReferenceId -> Set TermReferenceId
forall v k. Ord v => Map k v -> Set v
Map.elemsSet DefnsF (Map Name) TermReferenceId TermReferenceId
dependents

      Defns
  (Map TermReferenceId (Term Symbol Ann, Type Symbol Ann))
  (Map TermReferenceId (Decl Symbol Ann))
hydratedDependents0 <-
        Codebase IO Symbol Ann
-> DefnsF Set TermReferenceId TermReferenceId
-> Transaction
     (Defns
        (Map TermReferenceId (Term Symbol Ann, Type Symbol Ann))
        (Map TermReferenceId (Decl Symbol Ann)))
forall (m :: * -> *) v a.
Codebase m v a
-> DefnsF Set TermReferenceId TermReferenceId
-> Transaction
     (Defns
        (Map TermReferenceId (Term v a, Type v a))
        (Map TermReferenceId (Decl v a)))
hydrateRefs Env
env.codebase DefnsF Set TermReferenceId TermReferenceId
dependentsRefs

      let hydratedDependents1 :: DefnsF
  (Map Name)
  (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
  (TermReferenceId, Decl Symbol Ann)
hydratedDependents1 =
            DefnsF (Map Name) TermReferenceId TermReferenceId
-> Defns
     (Map TermReferenceId (Term Symbol Ann, Type Symbol Ann))
     (Map TermReferenceId (Decl Symbol Ann))
-> DefnsF
     (Map Name)
     (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
     (TermReferenceId, Decl Symbol Ann)
forall name term typ.
DefnsF (Map name) TermReferenceId TermReferenceId
-> Defns (Map TermReferenceId term) (Map TermReferenceId typ)
-> DefnsF (Map name) (TermReferenceId, term) (TermReferenceId, typ)
nameHydratedRefIds DefnsF (Map Name) TermReferenceId TermReferenceId
dependents Defns
  (Map TermReferenceId (Term Symbol Ann, Type Symbol Ann))
  (Map TermReferenceId (Decl Symbol Ann))
hydratedDependents0

      (DeclNameLookup, DefnsF (Map Name) TermReferenceId TermReferenceId,
 DefnsF Set TermReferenceId TermReferenceId,
 DefnsF
   (Map Name)
   (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
   (TermReferenceId, Decl Symbol Ann))
-> Transaction
     (DeclNameLookup, DefnsF (Map Name) TermReferenceId TermReferenceId,
      DefnsF Set TermReferenceId TermReferenceId,
      DefnsF
        (Map Name)
        (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
        (TermReferenceId, Decl Symbol Ann))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeclNameLookup
declNameLookup, DefnsF (Map Name) TermReferenceId TermReferenceId
dependents, DefnsF Set TermReferenceId TermReferenceId
dependentsRefs, DefnsF
  (Map Name)
  (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
  (TermReferenceId, Decl Symbol Ann)
hydratedDependents1)

  let prettyUnisonFile :: Pretty ColorText
prettyUnisonFile =
        DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
-> Pretty ColorText
makePrettyUnisonFile (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
 -> Pretty ColorText)
-> DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
-> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
          DeclNameLookup
-> PrettyPrintEnvDecl
-> Set Name
-> DefnsF
     (Map Name)
     (Term Symbol Ann, Type Symbol Ann)
     (TermReferenceId, Decl Symbol Ann)
-> DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
forall a v.
(Var v, Monoid a) =>
DeclNameLookup
-> PrettyPrintEnvDecl
-> Set Name
-> DefnsF
     (Map Name) (Term v a, Type v a) (TermReferenceId, Decl v a)
-> DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
renderDefnsForUnisonFile
            DeclNameLookup
declNameLookup
            ( [PrettyPrintEnvDecl] -> PrettyPrintEnvDecl
PPED.leftBiased
                [ NonEmpty UpgradeInfo
-> Defns (Relation Referent Name) (Relation TypeReference Name)
-> PrettyPrintEnvDecl
makeOldDepPPE NonEmpty UpgradeInfo
upgradeInfos Defns (Relation Referent Name) (Relation TypeReference Name)
currentDeepDefnsSansOlds,
                  Namer -> Suffixifier -> PrettyPrintEnvDecl
PPED.makePPED
                    (Names -> Namer
PPE.namer (DefnsF (Map Name) TermReferenceId TermReferenceId -> Names
Names.fromUnconflictedReferenceIds DefnsF (Map Name) TermReferenceId TermReferenceId
dependents))
                    (Names -> Suffixifier
PPE.suffixifyByName (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Names
Names.fromRelations Defns (Relation Referent Name) (Relation TypeReference Name)
currentDeepDefnsSansOlds)),
                  Namer -> Suffixifier -> PrettyPrintEnvDecl
PPED.makePPED
                    (Int -> Names -> Namer
PPE.hqNamer Int
10 (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Names
Names.fromRelations Defns (Relation Referent Name) (Relation TypeReference Name)
currentDeepDefnsSansOlds))
                    (Names -> Suffixifier
PPE.suffixifyByHash (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Names
Names.fromRelations Defns (Relation Referent Name) (Relation TypeReference Name)
currentDeepDefnsSansOlds))
                ]
            )
            Set Name
forall a. Set a
Set.empty
            (ASetter
  (DefnsF
     (Map Name)
     (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
     (TermReferenceId, Decl Symbol Ann))
  (DefnsF
     (Map Name)
     (Term Symbol Ann, Type Symbol Ann)
     (TermReferenceId, Decl Symbol Ann))
  (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
  (Term Symbol Ann, Type Symbol Ann)
-> ((TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
    -> (Term Symbol Ann, Type Symbol Ann))
-> DefnsF
     (Map Name)
     (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
     (TermReferenceId, Decl Symbol Ann)
-> DefnsF
     (Map Name)
     (Term Symbol Ann, Type Symbol Ann)
     (TermReferenceId, Decl Symbol Ann)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Map Name (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
 -> Identity (Map Name (Term Symbol Ann, Type Symbol Ann)))
-> DefnsF
     (Map Name)
     (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
     (TermReferenceId, Decl Symbol Ann)
-> Identity
     (DefnsF
        (Map Name)
        (Term Symbol Ann, Type Symbol Ann)
        (TermReferenceId, Decl Symbol Ann))
#terms ((Map Name (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
  -> Identity (Map Name (Term Symbol Ann, Type Symbol Ann)))
 -> DefnsF
      (Map Name)
      (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
      (TermReferenceId, Decl Symbol Ann)
 -> Identity
      (DefnsF
         (Map Name)
         (Term Symbol Ann, Type Symbol Ann)
         (TermReferenceId, Decl Symbol Ann)))
-> (((TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
     -> Identity (Term Symbol Ann, Type Symbol Ann))
    -> Map Name (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
    -> Identity (Map Name (Term Symbol Ann, Type Symbol Ann)))
-> ASetter
     (DefnsF
        (Map Name)
        (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
        (TermReferenceId, Decl Symbol Ann))
     (DefnsF
        (Map Name)
        (Term Symbol Ann, Type Symbol Ann)
        (TermReferenceId, Decl Symbol Ann))
     (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
     (Term Symbol Ann, Type Symbol Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
 -> Identity (Term Symbol Ann, Type Symbol Ann))
-> Map Name (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
-> Identity (Map Name (Term Symbol Ann, Type Symbol Ann))
Setter
  (Map Name (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)))
  (Map Name (Term Symbol Ann, Type Symbol Ann))
  (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
  (Term Symbol Ann, Type Symbol Ann)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
Lens.mapped) (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
-> (Term Symbol Ann, Type Symbol Ann)
forall a b. (a, b) -> b
snd DefnsF
  (Map Name)
  (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
  (TermReferenceId, Decl Symbol Ann)
hydratedDependents)

  ParsingEnv Transaction
parsingEnv <-
    ProjectPath -> Names -> Cli (ParsingEnv Transaction)
Cli.makeParsingEnv ProjectPath
pp (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Names
Names.fromRelations Defns (Relation Referent Name) (Relation TypeReference Name)
currentDeepDefnsSansOlds)

  TypecheckedUnisonFile Symbol Ann
typecheckedUnisonFile <- do
    Pretty ColorText
-> ParsingEnv Transaction
-> Cli (Maybe (TypecheckedUnisonFile Symbol Ann))
parseAndTypecheck Pretty ColorText
prettyUnisonFile ParsingEnv Transaction
parsingEnv Cli (Maybe (TypecheckedUnisonFile Symbol Ann))
-> (Cli (Maybe (TypecheckedUnisonFile Symbol Ann))
    -> Cli (TypecheckedUnisonFile Symbol Ann))
-> Cli (TypecheckedUnisonFile Symbol Ann)
forall a b. a -> (a -> b) -> b
& Cli (TypecheckedUnisonFile Symbol Ann)
-> Cli (Maybe (TypecheckedUnisonFile Symbol Ann))
-> Cli (TypecheckedUnisonFile Symbol Ann)
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
onNothingM do
      Map Name Text
uniqueTypeGuidsByName <-
        Transaction (Map Name Text) -> Cli (Map Name Text)
forall a. Transaction a -> Cli a
Cli.runTransaction (Map Name TypeReference -> Transaction (Map Name Text)
makeUniqueTypeGuids (BiMultimap TypeReference Name -> Map Name TypeReference
forall a b. BiMultimap a b -> Map b a
BiMultimap.range UnconflictedLocalDefnsView
unconflictedView.defns.types))

      (ProjectAndBranch ProjectId ProjectBranchId, ProjectBranchName)
_ <-
        Text
-> CreateFrom
-> Project
-> Transaction ProjectBranchName
-> Cli
     (ProjectAndBranch ProjectId ProjectBranchId, ProjectBranchName)
HandleInput.Branch.createBranch
          (NonEmpty UpgradeInfo -> Text
textualDescriptionOfUpgrade NonEmpty UpgradeInfo
upgradeInfos)
          ( (ProjectBranch, CausalHash, Map Name Text)
-> Branch IO -> CreateFrom
CreateFrom'Upgrade
              (ProjectPath
pp.branch, Branch IO -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash Branch IO
currentNamespace, Map Name Text
uniqueTypeGuidsByName)
              ( UnconflictedLocalDefnsView
unconflictedView.defns
                  Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
-> (Defns
      (BiMultimap Referent Name) (BiMultimap TypeReference Name)
    -> DefnsF (Map Name) Referent TypeReference)
-> DefnsF (Map Name) Referent TypeReference
forall a b. a -> (a -> b) -> b
& Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
-> DefnsF (Map Name) Referent TypeReference
forall terms name types.
Defns (BiMultimap terms name) (BiMultimap types name)
-> DefnsF (Map name) terms types
NamesUtils.byName
                  DefnsF (Map Name) Referent TypeReference
-> (DefnsF (Map Name) Referent TypeReference
    -> DefnsF (Map Name) Referent TypeReference)
-> DefnsF (Map Name) Referent TypeReference
forall a b. a -> (a -> b) -> b
& DefnsF Set TermReferenceId TermReferenceId
-> DefnsF (Map Name) Referent TypeReference
-> DefnsF (Map Name) Referent TypeReference
subtractDependents DefnsF Set TermReferenceId TermReferenceId
dependentsRefs
                  DefnsF (Map Name) Referent TypeReference
-> (DefnsF (Map Name) Referent TypeReference -> Branch0 IO)
-> Branch0 IO
forall a b. a -> (a -> b) -> b
& DefnsF (Map Name) Referent TypeReference -> Branch0 IO
forall (m :: * -> *).
DefnsF (Map Name) Referent TypeReference -> Branch0 m
Branch.fromUnconflictedDefns
                  Branch0 IO -> (Branch0 IO -> Branch0 IO) -> Branch0 IO
forall a b. a -> (a -> b) -> b
& Branch0 IO -> Branch0 IO -> Branch0 IO
forall (m :: * -> *). Branch0 m -> Branch0 m -> Branch0 m
Branch.setLibdeps
                    (Path -> Branch0 IO -> Branch0 IO
forall (m :: * -> *). Path -> Branch0 m -> Branch0 m
Branch.getAt0 (NameSegment -> Path
Path.singleton NameSegment
NameSegment.libSegment) Branch0 IO
currentNamespaceSansOlds0)
                  Branch0 IO -> (Branch0 IO -> Branch IO) -> Branch IO
forall a b. a -> (a -> b) -> b
& (Branch0 IO -> Branch IO -> Branch IO
forall (m :: * -> *).
Applicative m =>
Branch0 m -> Branch m -> Branch m
`Branch.cons` Branch IO
currentNamespace)
              )
          )
          ProjectPath
pp.project
          (ProjectId
-> NonEmpty (NameSegment, NameSegment)
-> Transaction ProjectBranchName
findTemporaryBranchName ProjectPath
pp.project.projectId ((\UpgradeInfo
info -> (UpgradeInfo
info.oldName, UpgradeInfo
info.newName)) (UpgradeInfo -> (NameSegment, NameSegment))
-> NonEmpty UpgradeInfo -> NonEmpty (NameSegment, NameSegment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty UpgradeInfo
upgradeInfos))
      FilePath
scratchFilePath <-
        Cli (Maybe (FilePath, Bool))
Cli.getLatestFile Cli (Maybe (FilePath, Bool))
-> (Maybe (FilePath, Bool) -> FilePath) -> Cli FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          Maybe (FilePath, Bool)
Nothing -> FilePath
"scratch.u"
          Just (FilePath
file, Bool
_) -> FilePath
file
      #latestFile ?= (scratchFilePath, True)
      IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ()) -> IO () -> Cli ()
forall a b. (a -> b) -> a -> b
$ Env
env.writeSource (FilePath -> Text
Text.pack FilePath
scratchFilePath) (Width -> Pretty ColorText -> Text
Pretty.toPlain Width
80 Pretty ColorText
prettyUnisonFile) Bool
True
      Output -> Cli (TypecheckedUnisonFile Symbol Ann)
forall a. Output -> Cli a
Cli.returnEarly
        ( ProjectBranchName
-> FilePath -> NonEmpty (NameSegment, NameSegment) -> Output
Output.UpgradeFailure
            ProjectPath
pp.branch.name
            FilePath
scratchFilePath
            ((\UpgradeInfo
info -> (UpgradeInfo
info.oldName, UpgradeInfo
info.newName)) (UpgradeInfo -> (NameSegment, NameSegment))
-> NonEmpty UpgradeInfo -> NonEmpty (NameSegment, NameSegment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty UpgradeInfo
upgradeInfos)
        )

  [(Path, Branch0 IO -> Branch0 IO)]
branchUpdates <-
    ((forall void. Output -> Transaction void)
 -> Transaction [(Path, Branch0 IO -> Branch0 IO)])
-> Cli [(Path, Branch0 IO -> Branch0 IO)]
forall a.
((forall void. Output -> Transaction void) -> Transaction a)
-> Cli a
Cli.runTransactionWithRollback \forall void. Output -> Transaction void
abort -> do
      Codebase IO Symbol Ann
-> TypecheckedUnisonFile Symbol Ann -> Transaction ()
forall (m :: * -> *) v a.
(Var v, Show a) =>
Codebase m v a -> TypecheckedUnisonFile v a -> Transaction ()
Codebase.addDefsToCodebase Env
env.codebase TypecheckedUnisonFile Symbol Ann
typecheckedUnisonFile
      (forall void. Output -> Transaction void)
-> (Name -> Either Output (Maybe [Name]))
-> TypecheckedUnisonFile Symbol Ann
-> Transaction [(Path, Branch0 IO -> Branch0 IO)]
forall (m :: * -> *).
(forall void. Output -> Transaction void)
-> (Name -> Either Output (Maybe [Name]))
-> TypecheckedUnisonFile Symbol Ann
-> Transaction [(Path, Branch0 m -> Branch0 m)]
typecheckedUnisonFileToBranchUpdates
        Output -> Transaction void
forall void. Output -> Transaction void
abort
        (\Name
typeName -> Maybe [Name] -> Either Output (Maybe [Name])
forall a b. b -> Either a b
Right (Name -> Map Name [Name] -> Maybe [Name]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
typeName DeclNameLookup
declNameLookup.declToConstructors))
        TypecheckedUnisonFile Symbol Ann
typecheckedUnisonFile

  let (Map NameSegment NameSegment
unmanglings, Map NameSegment (Branch IO)
newLibdeps) =
        Branch0 IO
currentNamespace0
          -- Start with the current namespace's libdeps
          Branch0 IO
-> (Branch0 IO -> Map NameSegment (Branch IO))
-> Map NameSegment (Branch IO)
forall a b. a -> (a -> b) -> b
& Getting
  (Map NameSegment (Branch IO))
  (Branch0 IO)
  (Map NameSegment (Branch IO))
-> Branch0 IO -> Map NameSegment (Branch IO)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Map NameSegment (Branch IO))
  (Branch0 IO)
  (Map NameSegment (Branch IO))
forall (m :: * -> *) (f :: * -> *).
Applicative f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.libdeps_
          -- Delete all "old"
          Map NameSegment (Branch IO)
-> (Map NameSegment (Branch IO) -> Map NameSegment (Branch IO))
-> Map NameSegment (Branch IO)
forall a b. a -> (a -> b) -> b
& (Map NameSegment (Branch IO)
-> Set NameSegment -> Map NameSegment (Branch IO)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` (UpgradeInfo -> Set NameSegment)
-> NonEmpty UpgradeInfo -> Set NameSegment
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\UpgradeInfo
info -> NameSegment -> Set NameSegment
forall a. a -> Set a
Set.singleton UpgradeInfo
info.oldName) NonEmpty UpgradeInfo
upgradeInfos)
          -- Unmangle all "new", if possible, e.g. rename `foo__2` to `foo` if `foo` is available
          Map NameSegment (Branch IO)
-> (Map NameSegment (Branch IO)
    -> (Map NameSegment NameSegment, Map NameSegment (Branch IO)))
-> (Map NameSegment NameSegment, Map NameSegment (Branch IO))
forall a b. a -> (a -> b) -> b
& State (Map NameSegment (Branch IO)) (Map NameSegment NameSegment)
-> Map NameSegment (Branch IO)
-> (Map NameSegment NameSegment, Map NameSegment (Branch IO))
forall s a. State s a -> s -> (a, s)
State.runState (WriterT
  (Map NameSegment NameSegment)
  (StateT (Map NameSegment (Branch IO)) Identity)
  ()
-> State
     (Map NameSegment (Branch IO)) (Map NameSegment NameSegment)
forall (m :: * -> *) w a.
(Monad m, Monoid w) =>
WriterT w m a -> m w
Writer.execWriterT ((UpgradeInfo
 -> WriterT
      (Map NameSegment NameSegment)
      (StateT (Map NameSegment (Branch IO)) Identity)
      ())
-> NonEmpty UpgradeInfo
-> WriterT
     (Map NameSegment NameSegment)
     (StateT (Map NameSegment (Branch IO)) Identity)
     ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\UpgradeInfo
info -> NameSegment
-> WriterT
     (Map NameSegment NameSegment)
     (StateT (Map NameSegment (Branch IO)) Identity)
     ()
forall libdep.
NameSegment
-> WriterT
     (Map NameSegment NameSegment) (State (Map NameSegment libdep)) ()
maybeUnmangle UpgradeInfo
info.newName) NonEmpty UpgradeInfo
upgradeInfos))
        where
          -- If new name ends in `__N`, that looks like a name we generated due to a name clash (e.g. by installing a
          -- `main` branch of an unreleased dependency more than once), so we remove it, if possible.
          maybeUnmangle :: NameSegment -> WriterT (Map NameSegment NameSegment) (State (Map NameSegment libdep)) ()
          maybeUnmangle :: forall libdep.
NameSegment
-> WriterT
     (Map NameSegment NameSegment) (State (Map NameSegment libdep)) ()
maybeUnmangle NameSegment
newName =
            Maybe (Text, Int)
-> ((Text, Int)
    -> WriterT
         (Map NameSegment NameSegment) (State (Map NameSegment libdep)) ())
-> WriterT
     (Map NameSegment NameSegment) (State (Map NameSegment libdep)) ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Text -> Maybe (Text, Int)
unsnocUnderscoreUnderscoreNumber (NameSegment -> Text
NameSegment.toUnescapedText NameSegment
newName)) \(Text -> NameSegment
NameSegment -> NameSegment
newNameWithoutSuffix, Int
_) -> do
              Map NameSegment libdep
libdeps <- WriterT
  (Map NameSegment NameSegment)
  (State (Map NameSegment libdep))
  (Map NameSegment libdep)
forall s (m :: * -> *). MonadState s m => m s
State.get
              Bool
-> WriterT
     (Map NameSegment NameSegment) (State (Map NameSegment libdep)) ()
-> WriterT
     (Map NameSegment NameSegment) (State (Map NameSegment libdep)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NameSegment -> Map NameSegment libdep -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember NameSegment
newNameWithoutSuffix Map NameSegment libdep
libdeps) do
                let (libdep
libdep, Map NameSegment libdep
libdeps1) = NameSegment
-> Map NameSegment libdep -> (libdep, Map NameSegment libdep)
forall k v. (HasCallStack, Ord k) => k -> Map k v -> (v, Map k v)
Map.deleteLookupJust NameSegment
newName Map NameSegment libdep
libdeps
                Map NameSegment NameSegment
-> WriterT
     (Map NameSegment NameSegment) (State (Map NameSegment libdep)) ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
Writer.tell (NameSegment -> NameSegment -> Map NameSegment NameSegment
forall k a. k -> a -> Map k a
Map.singleton NameSegment
newName NameSegment
newNameWithoutSuffix)
                Map NameSegment libdep
-> WriterT
     (Map NameSegment NameSegment) (State (Map NameSegment libdep)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (NameSegment
-> libdep -> Map NameSegment libdep -> Map NameSegment libdep
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NameSegment
newNameWithoutSuffix libdep
libdep Map NameSegment libdep
libdeps1)

  Text -> (ProjectPath, Branch0 IO -> Branch0 IO) -> Cli ()
Cli.stepAt
    (NonEmpty UpgradeInfo -> Text
textualDescriptionOfUpgrade NonEmpty UpgradeInfo
upgradeInfos)
    ( ProjectPath -> ProjectPath
PP.toRoot ProjectPath
pp,
      ASetter
  (Branch0 IO)
  (Branch0 IO)
  (Map NameSegment (Branch IO))
  (Map NameSegment (Branch IO))
-> Map NameSegment (Branch IO) -> Branch0 IO -> Branch0 IO
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (Branch0 IO)
  (Branch0 IO)
  (Map NameSegment (Branch IO))
  (Map NameSegment (Branch IO))
forall (m :: * -> *) (f :: * -> *).
Applicative f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.libdeps_ Map NameSegment (Branch IO)
newLibdeps (Branch0 IO -> Branch0 IO)
-> (Branch0 IO -> Branch0 IO) -> Branch0 IO -> Branch0 IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Path, Branch0 IO -> Branch0 IO)] -> Branch0 IO -> Branch0 IO
forall (f :: * -> *) (m :: * -> *).
(Monad m, Foldable f) =>
f (Path, Branch0 m -> Branch0 m) -> Branch0 m -> Branch0 m
Branch.batchUpdates [(Path, Branch0 IO -> Branch0 IO)]
branchUpdates
    )

  Output -> Cli ()
Cli.respond (NonEmpty (NameSegment, NameSegment)
-> Map NameSegment NameSegment -> Output
Output.UpgradeSuccess NonEmpty (NameSegment, NameSegment)
namePairs Map NameSegment NameSegment
unmanglings)
  where
    textualDescriptionOfUpgrade :: List.NonEmpty UpgradeInfo -> Text
    textualDescriptionOfUpgrade :: NonEmpty UpgradeInfo -> Text
textualDescriptionOfUpgrade NonEmpty UpgradeInfo
infos =
      [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        Text
"upgrade"
          Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (UpgradeInfo -> [Text]) -> [UpgradeInfo] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
            (\UpgradeInfo
info -> [NameSegment -> Text
NameSegment.toEscapedText UpgradeInfo
info.oldName, NameSegment -> Text
NameSegment.toEscapedText UpgradeInfo
info.newName])
            (NonEmpty UpgradeInfo -> [UpgradeInfo]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty UpgradeInfo
infos)

makePrettyUnisonFile :: DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText) -> Pretty ColorText
makePrettyUnisonFile :: DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
-> Pretty ColorText
makePrettyUnisonFile DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
dependents =
  Pretty ColorText
"-- The definitions below no longer typecheck after upgrading."
    Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
forall s. IsString s => Pretty s
Pretty.newline
    Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"-- Please fix the errors, then run `update`."
    Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
forall s. IsString s => Pretty s
Pretty.newline
    Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
forall s. IsString s => Pretty s
Pretty.newline
    Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Map Name (Pretty ColorText) -> Pretty ColorText
renderDefns DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
dependents.types
    Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Map Name (Pretty ColorText) -> Pretty ColorText
renderDefns DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
dependents.terms
  where
    renderDefns :: Map Name (Pretty ColorText) -> Pretty ColorText
    renderDefns :: Map Name (Pretty ColorText) -> Pretty ColorText
renderDefns =
      ((Name, Pretty ColorText) -> Pretty ColorText)
-> [(Name, Pretty ColorText)] -> Pretty ColorText
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Name
_, Pretty ColorText
defn) -> Pretty ColorText
defn Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
forall s. IsString s => Pretty s
Pretty.newline Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
forall s. IsString s => Pretty s
Pretty.newline)
        ([(Name, Pretty ColorText)] -> Pretty ColorText)
-> (Map Name (Pretty ColorText) -> [(Name, Pretty ColorText)])
-> Map Name (Pretty ColorText)
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, Pretty ColorText) -> Name)
-> [(Name, Pretty ColorText)] -> [(Name, Pretty ColorText)]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (Name, Pretty ColorText) -> Name
forall a b. (a, b) -> a
fst
        ([(Name, Pretty ColorText)] -> [(Name, Pretty ColorText)])
-> (Map Name (Pretty ColorText) -> [(Name, Pretty ColorText)])
-> Map Name (Pretty ColorText)
-> [(Name, Pretty ColorText)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name (Pretty ColorText) -> [(Name, Pretty ColorText)]
forall k a. Map k a -> [(k, a)]
Map.toList

data UpgradeInfo = UpgradeInfo
  { UpgradeInfo -> NameSegment
oldName :: NameSegment,
    UpgradeInfo -> Branch0 IO
oldNamespace :: Branch0 IO,
    UpgradeInfo
-> Defns (Relation Referent Name) (Relation TypeReference Name)
oldDeepDefns :: Defns (Relation Referent Name) (Relation TypeReference Name),
    UpgradeInfo
-> Defns (Relation Referent Name) (Relation TypeReference Name)
oldLocalDefns :: Defns (Relation Referent Name) (Relation TypeReference Name),
    UpgradeInfo -> NameSegment
newName :: NameSegment,
    UpgradeInfo
-> Defns (Relation Referent Name) (Relation TypeReference Name)
newLocalDefns :: Defns (Relation Referent Name) (Relation TypeReference Name)
  }

upgradeInfosToDependencies :: List.NonEmpty UpgradeInfo -> DefnsF Set TermReference TypeReference -> DefnsF Set TermReference TypeReference
upgradeInfosToDependencies :: NonEmpty UpgradeInfo
-> DefnsF Set TypeReference TypeReference
-> DefnsF Set TypeReference TypeReference
upgradeInfosToDependencies NonEmpty UpgradeInfo
infos DefnsF Set TypeReference TypeReference
currentNamespaceSansOlds =
  [DefnsF Set TypeReference TypeReference]
-> DefnsF Set TypeReference TypeReference
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ -- old definitions that aren't in their new counterpart
      (UpgradeInfo -> DefnsF Set TypeReference TypeReference)
-> NonEmpty UpgradeInfo -> DefnsF Set TypeReference TypeReference
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        ( \UpgradeInfo
info ->
            (Relation Referent Name
 -> Relation Referent Name -> Set TypeReference)
-> (Relation TypeReference Name
    -> Relation TypeReference Name -> Set TypeReference)
-> Defns (Relation Referent Name) (Relation TypeReference Name)
-> Defns (Relation Referent Name) (Relation TypeReference Name)
-> DefnsF Set TypeReference TypeReference
forall tm1 tm2 tm3 ty1 ty2 ty3.
(tm1 -> tm2 -> tm3)
-> (ty1 -> ty2 -> ty3)
-> Defns tm1 ty1
-> Defns tm2 ty2
-> Defns tm3 ty3
zipDefnsWith
              ( let f :: Relation Referent b -> Set TypeReference
f = (Referent -> Maybe TypeReference)
-> Set Referent -> Set TypeReference
forall b a. Ord b => (a -> Maybe b) -> Set a -> Set b
Set.mapMaybe Referent -> Maybe TypeReference
forall r. Referent' r -> Maybe r
Referent.toTermReference (Set Referent -> Set TypeReference)
-> (Relation Referent b -> Set Referent)
-> Relation Referent b
-> Set TypeReference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation Referent b -> Set Referent
forall a b. Relation a b -> Set a
Relation.dom
                 in \Relation Referent Name
old Relation Referent Name
new -> Relation Referent Name -> Set TypeReference
forall {b}. Relation Referent b -> Set TypeReference
f Relation Referent Name
old Set TypeReference -> Set TypeReference -> Set TypeReference
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Relation Referent Name -> Set TypeReference
forall {b}. Relation Referent b -> Set TypeReference
f Relation Referent Name
new
              )
              (\Relation TypeReference Name
old Relation TypeReference Name
new -> Relation TypeReference Name -> Set TypeReference
forall a b. Relation a b -> Set a
Relation.dom Relation TypeReference Name
old Set TypeReference -> Set TypeReference -> Set TypeReference
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Relation TypeReference Name -> Set TypeReference
forall a b. Relation a b -> Set a
Relation.dom Relation TypeReference Name
new)
              UpgradeInfo
info.oldLocalDefns
              UpgradeInfo
info.newLocalDefns
        )
        NonEmpty UpgradeInfo
infos,
      -- transitive deps that aren't named in current namespace after subtracting all old definitions
      (Set TypeReference -> Set TypeReference -> Set TypeReference)
-> (Set TypeReference -> Set TypeReference -> Set TypeReference)
-> DefnsF Set TypeReference TypeReference
-> DefnsF Set TypeReference TypeReference
-> DefnsF Set TypeReference TypeReference
forall tm1 tm2 tm3 ty1 ty2 ty3.
(tm1 -> tm2 -> tm3)
-> (ty1 -> ty2 -> ty3)
-> Defns tm1 ty1
-> Defns tm2 ty2
-> Defns tm3 ty3
zipDefnsWith Set TypeReference -> Set TypeReference -> Set TypeReference
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set TypeReference -> Set TypeReference -> Set TypeReference
forall a. Ord a => Set a -> Set a -> Set a
Set.difference DefnsF Set TypeReference TypeReference
transitiveDeps DefnsF Set TypeReference TypeReference
currentNamespaceSansOlds
    ]
  where
    transitiveDeps :: DefnsF Set TermReference TypeReference
    transitiveDeps :: DefnsF Set TypeReference TypeReference
transitiveDeps =
      (UpgradeInfo -> DefnsF Set TypeReference TypeReference)
-> NonEmpty UpgradeInfo -> DefnsF Set TypeReference TypeReference
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap UpgradeInfo -> DefnsF Set TypeReference TypeReference
transitiveDepsOf NonEmpty UpgradeInfo
infos

    transitiveDepsOf :: UpgradeInfo -> DefnsF Set TermReference TypeReference
    transitiveDepsOf :: UpgradeInfo -> DefnsF Set TypeReference TypeReference
transitiveDepsOf UpgradeInfo
info =
      UpgradeInfo
info.oldNamespace
        Branch0 IO
-> (Branch0 IO -> Map NameSegment (Branch IO))
-> Map NameSegment (Branch IO)
forall a b. a -> (a -> b) -> b
& Getting
  (Map NameSegment (Branch IO))
  (Branch0 IO)
  (Map NameSegment (Branch IO))
-> Branch0 IO -> Map NameSegment (Branch IO)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Map NameSegment (Branch IO))
  (Branch0 IO)
  (Map NameSegment (Branch IO))
forall (m :: * -> *) (f :: * -> *).
Applicative f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.libdeps_
        Map NameSegment (Branch IO)
-> (Map NameSegment (Branch IO)
    -> DefnsF Set TypeReference TypeReference)
-> DefnsF Set TypeReference TypeReference
forall a b. a -> (a -> b) -> b
& (Branch IO -> DefnsF Set TypeReference TypeReference)
-> Map NameSegment (Branch IO)
-> DefnsF Set TypeReference TypeReference
forall m a. Monoid m => (a -> m) -> Map NameSegment a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Branch0 IO -> DefnsF Set TypeReference TypeReference
forall (m :: * -> *).
Branch0 m -> DefnsF Set TypeReference TypeReference
Branch.deepDefnsRefs (Branch0 IO -> DefnsF Set TypeReference TypeReference)
-> (Branch IO -> Branch0 IO)
-> Branch IO
-> DefnsF Set TypeReference TypeReference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head)

makeOldDepPPE :: List.NonEmpty UpgradeInfo -> Defns (Relation Referent Name) (Relation TypeReference Name) -> PrettyPrintEnvDecl
makeOldDepPPE :: NonEmpty UpgradeInfo
-> Defns (Relation Referent Name) (Relation TypeReference Name)
-> PrettyPrintEnvDecl
makeOldDepPPE NonEmpty UpgradeInfo
infos Defns (Relation Referent Name) (Relation TypeReference Name)
currentDeepNamesSansOlds =
  let makePPE :: Suffixifier -> PrettyPrintEnv
makePPE Suffixifier
suffixifier =
        (Referent -> [(HashQualified Name, HashQualified Name)])
-> (TypeReference -> [(HashQualified Name, HashQualified Name)])
-> PrettyPrintEnv
PPE.PrettyPrintEnv Referent -> [(HashQualified Name, HashQualified Name)]
termToNames TypeReference -> [(HashQualified Name, HashQualified Name)]
typeToNames
        where
          inOldAndNewNamespaces ::
            (Ord ref) =>
            (Defns (Relation Referent Name) (Relation TypeReference Name) -> Relation ref Name) ->
            ref ->
            UpgradeInfo ->
            Bool
          inOldAndNewNamespaces :: forall ref.
Ord ref =>
(Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation ref Name)
-> ref -> UpgradeInfo -> Bool
inOldAndNewNamespaces Defns (Relation Referent Name) (Relation TypeReference Name)
-> Relation ref Name
which ref
ref UpgradeInfo
info =
            ref -> Relation ref Name -> Bool
forall a b. Ord a => a -> Relation a b -> Bool
Relation.memberDom ref
ref (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Relation ref Name
which UpgradeInfo
info.oldDeepDefns)
              Bool -> Bool -> Bool
&& ref -> Relation ref Name -> Bool
forall a b. Ord a => a -> Relation a b -> Bool
Relation.memberDom ref
ref (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Relation ref Name
which UpgradeInfo
info.newLocalDefns)

          hasNewLocalDefnsForOldLocalNames ::
            (Ord ref) =>
            (Defns (Relation Referent Name) (Relation TypeReference Name) -> Relation ref Name) ->
            ref ->
            UpgradeInfo ->
            Bool
          hasNewLocalDefnsForOldLocalNames :: forall ref.
Ord ref =>
(Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation ref Name)
-> ref -> UpgradeInfo -> Bool
hasNewLocalDefnsForOldLocalNames Defns (Relation Referent Name) (Relation TypeReference Name)
-> Relation ref Name
which ref
ref UpgradeInfo
info =
            Bool -> Bool
not (Map Name (Set ref) -> Bool
forall k a. Map k a -> Bool
Map.null (Relation ref Name -> Map Name (Set ref)
forall a b. Relation a b -> Map b (Set a)
Relation.range (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Relation ref Name
which UpgradeInfo
info.newLocalDefns) Map Name (Set ref) -> Set Name -> Map Name (Set ref)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set Name
theOldLocalNames))
            where
              theOldLocalNames :: Set Name
theOldLocalNames = ref -> Relation ref Name -> Set Name
forall a b. Ord a => a -> Relation a b -> Set b
Relation.lookupDom ref
ref (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Relation ref Name
which UpgradeInfo
info.oldLocalDefns)

          onlyInOldNamespace ::
            (Ord ref) =>
            (Defns (Relation Referent Name) (Relation TypeReference Name) -> Relation ref Name) ->
            ref ->
            UpgradeInfo ->
            Bool
          onlyInOldNamespace :: forall ref.
Ord ref =>
(Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation ref Name)
-> ref -> UpgradeInfo -> Bool
onlyInOldNamespace Defns (Relation Referent Name) (Relation TypeReference Name)
-> Relation ref Name
which ref
ref UpgradeInfo
info =
            Bool
inOldNamespace Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
inCurrentNamespaceSansOlds
            where
              inOldNamespace :: Bool
              inOldNamespace :: Bool
inOldNamespace =
                ref -> Relation ref Name -> Bool
forall a b. Ord a => a -> Relation a b -> Bool
Relation.memberDom ref
ref (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Relation ref Name
which UpgradeInfo
info.oldDeepDefns)

              inCurrentNamespaceSansOlds :: Bool
              inCurrentNamespaceSansOlds :: Bool
inCurrentNamespaceSansOlds =
                ref -> Relation ref Name -> Bool
forall a b. Ord a => a -> Relation a b -> Bool
Relation.memberDom ref
ref (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Relation ref Name
which Defns (Relation Referent Name) (Relation TypeReference Name)
currentDeepNamesSansOlds)

          termToNames :: Referent -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)]
          termToNames :: Referent -> [(HashQualified Name, HashQualified Name)]
termToNames Referent
ref
            | (UpgradeInfo -> Bool) -> NonEmpty UpgradeInfo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation Referent Name)
-> Referent -> UpgradeInfo -> Bool
forall ref.
Ord ref =>
(Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation ref Name)
-> ref -> UpgradeInfo -> Bool
inOldAndNewNamespaces (.terms) Referent
ref) NonEmpty UpgradeInfo
infos = []
            | Just UpgradeInfo
info <- (UpgradeInfo -> Bool) -> NonEmpty UpgradeInfo -> Maybe UpgradeInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation Referent Name)
-> Referent -> UpgradeInfo -> Bool
forall ref.
Ord ref =>
(Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation ref Name)
-> ref -> UpgradeInfo -> Bool
hasNewLocalDefnsForOldLocalNames (.terms) Referent
ref) NonEmpty UpgradeInfo
infos =
                Namer
-> Suffixifier
-> Referent
-> [(HashQualified Name, HashQualified Name)]
PPE.makeTermNames (UpgradeInfo -> Namer
forall {r}.
(HasField "newName" r NameSegment,
 HasField
   "oldLocalDefns"
   r
   (Defns (Relation Referent Name) (Relation TypeReference Name))) =>
r -> Namer
fakeLocalNames UpgradeInfo
info) Suffixifier
suffixifier Referent
ref
            | Just UpgradeInfo
info <- (UpgradeInfo -> Bool) -> NonEmpty UpgradeInfo -> Maybe UpgradeInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation Referent Name)
-> Referent -> UpgradeInfo -> Bool
forall ref.
Ord ref =>
(Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation ref Name)
-> ref -> UpgradeInfo -> Bool
onlyInOldNamespace (.terms) Referent
ref) NonEmpty UpgradeInfo
infos =
                Namer
-> Suffixifier
-> Referent
-> [(HashQualified Name, HashQualified Name)]
PPE.makeTermNames (UpgradeInfo -> Namer
forall {r}.
(HasField "oldName" r NameSegment,
 HasField
   "oldDeepDefns"
   r
   (Defns (Relation Referent Name) (Relation TypeReference Name))) =>
r -> Namer
fullOldDeepNames UpgradeInfo
info) Suffixifier
PPE.dontSuffixify Referent
ref
            | Bool
otherwise = []

          typeToNames :: TypeReference -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)]
          typeToNames :: TypeReference -> [(HashQualified Name, HashQualified Name)]
typeToNames TypeReference
ref
            | (UpgradeInfo -> Bool) -> NonEmpty UpgradeInfo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation TypeReference Name)
-> TypeReference -> UpgradeInfo -> Bool
forall ref.
Ord ref =>
(Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation ref Name)
-> ref -> UpgradeInfo -> Bool
inOldAndNewNamespaces (.types) TypeReference
ref) NonEmpty UpgradeInfo
infos = []
            | Just UpgradeInfo
info <- (UpgradeInfo -> Bool) -> NonEmpty UpgradeInfo -> Maybe UpgradeInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation TypeReference Name)
-> TypeReference -> UpgradeInfo -> Bool
forall ref.
Ord ref =>
(Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation ref Name)
-> ref -> UpgradeInfo -> Bool
hasNewLocalDefnsForOldLocalNames (.types) TypeReference
ref) NonEmpty UpgradeInfo
infos =
                Namer
-> Suffixifier
-> TypeReference
-> [(HashQualified Name, HashQualified Name)]
PPE.makeTypeNames (UpgradeInfo -> Namer
forall {r}.
(HasField "newName" r NameSegment,
 HasField
   "oldLocalDefns"
   r
   (Defns (Relation Referent Name) (Relation TypeReference Name))) =>
r -> Namer
fakeLocalNames UpgradeInfo
info) Suffixifier
suffixifier TypeReference
ref
            | Just UpgradeInfo
info <- (UpgradeInfo -> Bool) -> NonEmpty UpgradeInfo -> Maybe UpgradeInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation TypeReference Name)
-> TypeReference -> UpgradeInfo -> Bool
forall ref.
Ord ref =>
(Defns (Relation Referent Name) (Relation TypeReference Name)
 -> Relation ref Name)
-> ref -> UpgradeInfo -> Bool
onlyInOldNamespace (.types) TypeReference
ref) NonEmpty UpgradeInfo
infos =
                Namer
-> Suffixifier
-> TypeReference
-> [(HashQualified Name, HashQualified Name)]
PPE.makeTypeNames (UpgradeInfo -> Namer
forall {r}.
(HasField "oldName" r NameSegment,
 HasField
   "oldDeepDefns"
   r
   (Defns (Relation Referent Name) (Relation TypeReference Name))) =>
r -> Namer
fullOldDeepNames UpgradeInfo
info) Suffixifier
PPE.dontSuffixify TypeReference
ref
            | Bool
otherwise = []
   in PrettyPrintEnvDecl
        { $sel:unsuffixifiedPPE:PrettyPrintEnvDecl :: PrettyPrintEnv
unsuffixifiedPPE = Suffixifier -> PrettyPrintEnv
makePPE Suffixifier
PPE.dontSuffixify,
          $sel:suffixifiedPPE:PrettyPrintEnvDecl :: PrettyPrintEnv
suffixifiedPPE = Suffixifier -> PrettyPrintEnv
makePPE (Names -> Suffixifier
PPE.suffixifyByHash (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Names
Names.fromRelations Defns (Relation Referent Name) (Relation TypeReference Name)
currentDeepNamesSansOlds))
        }
  where
    -- "full" means "with lib.old.* prefix"
    fullOldDeepNames :: r -> Namer
fullOldDeepNames r
info =
      Names -> Namer
PPE.namer (Names -> Namer) -> Names -> Namer
forall a b. (a -> b) -> a -> b
$
        Name -> Names -> Names
Names.prefix0
          (NonEmpty NameSegment -> Name
Name.fromReverseSegments (r
info.oldName NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
:| [NameSegment
NameSegment.libSegment]))
          (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Names
Names.fromRelations r
info.oldDeepDefns)
    fakeLocalNames :: r -> Namer
fakeLocalNames r
info =
      Names -> Namer
PPE.namer (Names -> Namer) -> Names -> Namer
forall a b. (a -> b) -> a -> b
$
        Name -> Names -> Names
Names.prefix0
          (NonEmpty NameSegment -> Name
Name.fromReverseSegments (r
info.newName NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
:| [NameSegment
NameSegment.libSegment]))
          (Defns (Relation Referent Name) (Relation TypeReference Name)
-> Names
Names.fromRelations r
info.oldLocalDefns)

-- @findTemporaryBranchName projectId names@ finds some unused branch name in @projectId@ with a name
-- like "upgrade-<oldDepName>-to-<newDepName>", if names is a singleton list (the common case of upgrading one library).
-- If multiple libraries are being upgraded simultaneously, though, we just use a a generic name like "upgrade-2", since
-- otherwise the name might get too long.
findTemporaryBranchName :: ProjectId -> List.NonEmpty (NameSegment, NameSegment) -> Transaction ProjectBranchName
findTemporaryBranchName :: ProjectId
-> NonEmpty (NameSegment, NameSegment)
-> Transaction ProjectBranchName
findTemporaryBranchName ProjectId
projectId = \case
  (NameSegment
oldDepName, NameSegment
newDepName) :| [] -> do
    ProjectId -> ProjectBranchName -> Transaction ProjectBranchName
Cli.findTemporaryBranchName ProjectId
projectId (ProjectBranchName -> Transaction ProjectBranchName)
-> ProjectBranchName -> Transaction ProjectBranchName
forall a b. (a -> b) -> a -> b
$
      -- First try something like
      --
      --   upgrade-unison_base_3_0_0-to-unison_base_4_0_0
      --
      -- and if that fails (which it shouldn't, but may because of symbols or something), back off to some
      -- more-guaranteed-to-work mangled name like
      --
      --   upgrade-unisonbase300-to-unisonbase400
      forall source target.
TryFrom source target =>
source -> Either (TryFromException source target) target
tryFrom @Text (Text -> Text -> Text
mk Text
oldDepText Text
newDepText)
        Either (TryFromException Text ProjectBranchName) ProjectBranchName
-> (Either
      (TryFromException Text ProjectBranchName) ProjectBranchName
    -> ProjectBranchName)
-> ProjectBranchName
forall a b. a -> (a -> b) -> b
& ProjectBranchName
-> Either
     (TryFromException Text ProjectBranchName) ProjectBranchName
-> ProjectBranchName
forall b a. b -> Either a b -> b
fromRight (forall source target.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeFrom @Text (Text -> Text -> Text
mk (Text -> Text
scrub Text
oldDepText) (Text -> Text
scrub Text
newDepText)))
    where
      mk :: Text -> Text -> Text
      mk :: Text -> Text -> Text
mk Text
old Text
new =
        Builder -> Text
Text.Builder.run (Builder
"upgrade-" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
old Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"-to-" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
new)

      scrub :: Text -> Text
      scrub :: Text -> Text
scrub =
        (Char -> Bool) -> Text -> Text
Text.filter Char -> Bool
Char.isAlphaNum

      oldDepText :: Text
oldDepText = NameSegment -> Text
NameSegment.toEscapedText NameSegment
oldDepName
      newDepText :: Text
newDepText = NameSegment -> Text
NameSegment.toEscapedText NameSegment
newDepName
  NonEmpty (NameSegment, NameSegment)
_ ->
    ProjectId -> ProjectBranchName -> Transaction ProjectBranchName
Cli.findTemporaryBranchName ProjectId
projectId (forall source target.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeFrom @Text @ProjectBranchName Text
"upgrade")

-- >>> unsnocUnderscoreUnderscoreNumber "unison_base_main__13"
-- Just ("unison_base_main",13)
--
-- >>> unsnocUnderscoreUnderscoreNumber "unison_base_4_0_2"
-- Nothing
unsnocUnderscoreUnderscoreNumber :: Text -> Maybe (Text, Int)
unsnocUnderscoreUnderscoreNumber :: Text -> Maybe (Text, Int)
unsnocUnderscoreUnderscoreNumber Text
text =
  let digits :: Text
digits = (Char -> Bool) -> Text -> Text
Text.takeWhileEnd Char -> Bool
Char.isDigit Text
text
      numDigits :: Int
numDigits = Text -> Int
Text.length Text
digits
   in if Int
numDigits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& (Text
"__" Text -> Text -> Bool
`Text.isSuffixOf` Int -> Text -> Text
Text.dropEnd Int
numDigits Text
text)
        then (Text, Int) -> Maybe (Text, Int)
forall a. a -> Maybe a
Just (Int -> Text -> Text
Text.dropEnd (Int
numDigits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Text
text, HasCallStack => Text -> Int
Text -> Int
Text.unsafeToInt Text
digits)
        else Maybe (Text, Int)
forall a. Maybe a
Nothing