-- | @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 Data.Bifoldable (bifoldMap)
import Data.Char qualified as Char
import Data.List qualified as List
import Data.List.NonEmpty (pattern (:|))
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.ProjectUtils qualified as Cli
import Unison.Cli.UpdateUtils (getNamespaceDependentsOf, hydrateRefs, makeUniqueTypeGuids, nameHydratedRefIds, parseAndTypecheck, subtractDependents)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Names 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.Codebase.SqliteCodebase.Operations qualified as Operations
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 (Names (..))
import Unison.Names qualified as Names
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.Name qualified as Name
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
import Unison.UnconflictedLocalDefnsView qualified
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF)
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 -> NameSegment -> Cli ()
handleUpgrade :: NameSegment -> NameSegment -> Cli ()
handleUpgrade NameSegment
oldName NameSegment
newName = do
  Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NameSegment
oldName NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
newName) do
    Cli ()
forall a. Cli a
Cli.returnEarlyWithoutOutput

  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 Bool -> Bool -> Bool
|| ProjectPath
pp.branch.isUpgrade) 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
"Sorry, I can't do that during an upgrade. Please complete the upgrade, then try again."

  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])

  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
  let currentNamespaceSansOld :: Branch IO
currentNamespaceSansOld = Branch IO
currentNamespace Branch IO -> (Branch IO -> Branch IO) -> Branch IO
forall a b. a -> (a -> b) -> b
& (Branch0 IO -> Branch0 IO) -> Branch IO -> Branch IO
forall (m :: * -> *).
Applicative m =>
(Branch0 m -> Branch0 m) -> Branch m -> Branch m
Branch.step (NameSegment -> Branch0 IO -> Branch0 IO
forall (m :: * -> *). NameSegment -> Branch0 m -> Branch0 m
Branch.deleteLibdep NameSegment
oldName)
  let currentNamespaceSansOld0 :: Branch0 IO
currentNamespaceSansOld0 = Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head Branch IO
currentNamespaceSansOld
  let currentDeepTermsSansOld :: Relation Referent Name
currentDeepTermsSansOld = Branch0 IO -> Relation Referent Name
forall (m :: * -> *). Branch0 m -> Relation Referent Name
Branch.deepTerms Branch0 IO
currentNamespaceSansOld0
  let currentDeepTypesSansOld :: Relation TypeReference Name
currentDeepTypesSansOld = Branch0 IO -> Relation TypeReference Name
forall (m :: * -> *). Branch0 m -> Relation TypeReference Name
Branch.deepTypes Branch0 IO
currentNamespaceSansOld0
  let currentDeepNamesSansOld :: Names
currentDeepNamesSansOld = Branch0 IO -> Names
forall (m :: * -> *). Branch0 m -> Names
Branch.toNames Branch0 IO
currentNamespaceSansOld0

  -- 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
. Text
-> Defn (Conflicted Name Referent) (Conflicted Name TypeReference)
-> Output
Output.ConflictedDefn Text
"upgrade")

  Branch0 IO
oldNamespace <- Path' -> Cli (Branch0 IO)
Cli.expectBranch0AtPath' (Absolute -> Path'
Path.AbsolutePath' Absolute
oldPath)
  let oldLocalNamespace :: Branch0 IO
oldLocalNamespace = Branch0 IO -> Branch0 IO
forall (m :: * -> *). Branch0 m -> Branch0 m
Branch.deleteLibdeps Branch0 IO
oldNamespace
  let oldLocalTerms :: Relation Referent Name
oldLocalTerms = Branch0 IO -> Relation Referent Name
forall (m :: * -> *). Branch0 m -> Relation Referent Name
Branch.deepTerms Branch0 IO
oldLocalNamespace
  let oldLocalTypes :: Relation TypeReference Name
oldLocalTypes = Branch0 IO -> Relation TypeReference Name
forall (m :: * -> *). Branch0 m -> Relation TypeReference Name
Branch.deepTypes Branch0 IO
oldLocalNamespace
  let oldNamespaceMinusLocal :: Branch0 IO
oldNamespaceMinusLocal = Branch0 IO
-> (Branch IO -> Branch0 IO) -> Maybe (Branch IO) -> Branch0 IO
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Branch0 IO
forall (m :: * -> *). Branch0 m
Branch.empty0 Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head (NameSegment -> Map NameSegment (Branch IO) -> Maybe (Branch IO)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NameSegment
NameSegment.libSegment (Branch0 IO
oldNamespace 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_))
  let oldDeepMinusLocalTerms :: Relation Referent Name
oldDeepMinusLocalTerms = Branch0 IO -> Relation Referent Name
forall (m :: * -> *). Branch0 m -> Relation Referent Name
Branch.deepTerms Branch0 IO
oldNamespaceMinusLocal
  let oldDeepMinusLocalTypes :: Relation TypeReference Name
oldDeepMinusLocalTypes = Branch0 IO -> Relation TypeReference Name
forall (m :: * -> *). Branch0 m -> Relation TypeReference Name
Branch.deepTypes Branch0 IO
oldNamespaceMinusLocal

  Branch0 IO
newNamespace <- Path' -> Cli (Branch0 IO)
Cli.expectBranch0AtPath' (Absolute -> Path'
Path.AbsolutePath' Absolute
newPath)
  let newLocalNamespace :: Branch0 IO
newLocalNamespace = Branch0 IO -> Branch0 IO
forall (m :: * -> *). Branch0 m -> Branch0 m
Branch.deleteLibdeps Branch0 IO
newNamespace
  let newLocalTerms :: Relation Referent Name
newLocalTerms = Branch0 IO -> Relation Referent Name
forall (m :: * -> *). Branch0 m -> Relation Referent Name
Branch.deepTerms Branch0 IO
newLocalNamespace
  let newLocalTypes :: Relation TypeReference Name
newLocalTypes = Branch0 IO -> Relation TypeReference Name
forall (m :: * -> *). Branch0 m -> Relation TypeReference Name
Branch.deepTypes Branch0 IO
newLocalNamespace

  -- 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)
-> Set TypeReference
-> Transaction (DefnsF (Map Name) TermReferenceId TermReferenceId)
getNamespaceDependentsOf
          UnconflictedLocalDefnsView
unconflictedView.defns
          ( [Set TypeReference] -> Set TypeReference
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
              [ Relation Referent Name
-> Relation Referent Name -> Set TypeReference
keepOldLocalTermsNotInNew Relation Referent Name
oldLocalTerms Relation Referent Name
newLocalTerms,
                Relation TypeReference Name
-> Relation TypeReference Name -> Set TypeReference
keepOldLocalTypesNotInNew Relation TypeReference Name
oldLocalTypes Relation TypeReference Name
newLocalTypes,
                Relation Referent Name
-> Relation Referent Name -> Set TypeReference
keepOldDeepTermsStillInUse Relation Referent Name
oldDeepMinusLocalTerms Relation Referent Name
currentDeepTermsSansOld,
                Relation TypeReference Name
-> Relation TypeReference Name -> Set TypeReference
keepOldDeepTypesStillInUse Relation TypeReference Name
oldDeepMinusLocalTypes Relation TypeReference Name
currentDeepTypesSansOld
              ]
          )

      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 ([TermReferenceId] -> Set TermReferenceId
forall a. Ord a => [a] -> Set a
Set.fromList ([TermReferenceId] -> Set TermReferenceId)
-> (Map Name TermReferenceId -> [TermReferenceId])
-> Map Name TermReferenceId
-> Set TermReferenceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name TermReferenceId -> [TermReferenceId]
forall k a. Map k a -> [a]
Map.elems) ([TermReferenceId] -> Set TermReferenceId
forall a. Ord a => [a] -> Set a
Set.fromList ([TermReferenceId] -> Set TermReferenceId)
-> (Map Name TermReferenceId -> [TermReferenceId])
-> Map Name TermReferenceId
-> Set TermReferenceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name TermReferenceId -> [TermReferenceId]
forall k a. Map k a -> [a]
Map.elems) DefnsF (Map Name) TermReferenceId TermReferenceId
dependents

      Defns
  (Map TermReferenceId (Term Symbol Ann, Type Symbol Ann))
  (Map TermReferenceId (Decl Symbol Ann))
hydratedDependents0 <-
        (Hash -> Transaction [(Term Symbol Ann, Type Symbol Ann)])
-> (Hash -> Transaction [Decl Symbol Ann])
-> DefnsF Set TermReferenceId TermReferenceId
-> Transaction
     (Defns
        (Map TermReferenceId (Term Symbol Ann, Type Symbol Ann))
        (Map TermReferenceId (Decl Symbol Ann)))
forall (m :: * -> *) term typ.
Monad m =>
(Hash -> m [term])
-> (Hash -> m [typ])
-> DefnsF Set TermReferenceId TermReferenceId
-> m (Defns (Map TermReferenceId term) (Map TermReferenceId typ))
hydrateRefs
          (Codebase IO Symbol Ann
-> Hash -> Transaction [(Term Symbol Ann, Type Symbol Ann)]
forall (m :: * -> *) v a.
HasCallStack =>
Codebase m v a -> Hash -> Transaction [(Term v a, Type v a)]
Codebase.unsafeGetTermComponent Env
env.codebase)
          HasCallStack => Hash -> Transaction [Decl Symbol Ann]
Hash -> Transaction [Decl Symbol Ann]
Operations.expectDeclComponent
          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
                [ NameSegment
-> NameSegment
-> Names
-> Names
-> Names
-> Names
-> PrettyPrintEnvDecl
makeOldDepPPE
                    NameSegment
oldName
                    NameSegment
newName
                    Names
currentDeepNamesSansOld
                    (Branch0 IO -> Names
forall (m :: * -> *). Branch0 m -> Names
Branch.toNames Branch0 IO
oldNamespace)
                    (Branch0 IO -> Names
forall (m :: * -> *). Branch0 m -> Names
Branch.toNames Branch0 IO
oldLocalNamespace)
                    (Branch0 IO -> Names
forall (m :: * -> *). Branch0 m -> Names
Branch.toNames Branch0 IO
newLocalNamespace),
                  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 Names
currentDeepNamesSansOld),
                  Namer -> Suffixifier -> PrettyPrintEnvDecl
PPED.makePPED
                    (Int -> Names -> Namer
PPE.hqNamer Int
10 Names
currentDeepNamesSansOld)
                    (Names -> Suffixifier
PPE.suffixifyByHash Names
currentDeepNamesSansOld)
                ]
            )
            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 Names
currentDeepNamesSansOld
  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
_temporaryBranchId, ProjectBranchName
temporaryBranchName) <-
        Text
-> CreateFrom
-> Project
-> Transaction ProjectBranchName
-> Cli
     (ProjectAndBranch ProjectId ProjectBranchId, ProjectBranchName)
HandleInput.Branch.createBranch
          Text
textualDescriptionOfUpgrade
          ( (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)
    -> Defns (Map Name Referent) (Map Name TypeReference))
-> Defns (Map Name Referent) (Map Name TypeReference)
forall a b. a -> (a -> b) -> b
& (BiMultimap Referent Name -> Map Name Referent)
-> (BiMultimap TypeReference Name -> Map Name TypeReference)
-> Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
-> Defns (Map Name Referent) (Map Name TypeReference)
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 BiMultimap Referent Name -> Map Name Referent
forall a b. BiMultimap a b -> Map b a
BiMultimap.range BiMultimap TypeReference Name -> Map Name TypeReference
forall a b. BiMultimap a b -> Map b a
BiMultimap.range
                  Defns (Map Name Referent) (Map Name TypeReference)
-> (Defns (Map Name Referent) (Map Name TypeReference)
    -> Defns (Map Name Referent) (Map Name TypeReference))
-> Defns (Map Name Referent) (Map Name TypeReference)
forall a b. a -> (a -> b) -> b
& DefnsF Set TermReferenceId TermReferenceId
-> Defns (Map Name Referent) (Map Name TypeReference)
-> Defns (Map Name Referent) (Map Name TypeReference)
subtractDependents DefnsF Set TermReferenceId TermReferenceId
dependentsRefs
                  Defns (Map Name Referent) (Map Name TypeReference)
-> (Defns (Map Name Referent) (Map Name TypeReference)
    -> Branch0 IO)
-> Branch0 IO
forall a b. a -> (a -> b) -> b
& Defns (Map Name Referent) (Map Name TypeReference) -> Branch0 IO
forall (m :: * -> *).
Defns (Map Name Referent) (Map Name 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
currentNamespaceSansOld0)
                  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
-> NameSegment -> NameSegment -> Transaction ProjectBranchName
findTemporaryBranchName ProjectPath
pp.project.projectId NameSegment
oldName NameSegment
newName)
      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) (FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Width -> Pretty ColorText -> FilePath
Pretty.toPlain Width
80 Pretty ColorText
prettyUnisonFile) Bool
True
      Output -> Cli (TypecheckedUnisonFile Symbol Ann)
forall a. Output -> Cli a
Cli.returnEarly (ProjectBranchName
-> ProjectBranchName
-> FilePath
-> NameSegment
-> NameSegment
-> Output
Output.UpgradeFailure ProjectPath
pp.branch.name ProjectBranchName
temporaryBranchName FilePath
scratchFilePath NameSegment
oldName NameSegment
newName)

  [(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

  -- 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.
  let maybeFinalName :: Maybe NameSegment
maybeFinalName = do
        (Text -> NameSegment
NameSegment -> NameSegment
newNameWithoutSuffix, Int
_) <-
          Text -> Maybe (Text, Int)
unsnocUnderscoreUnderscoreNumber (NameSegment -> Text
NameSegment.toUnescapedText NameSegment
newName)
        -- If the new name is `foo__2`, then we've parsed it into (`foo`, 2). We can use the name `foo` if either:
        --
        --   1. `foo` is the old name (which we're deleting, so we can reuse the name)
        --   2. `foo` isn't already taken.
        --
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$
          [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
            [ NameSegment
newNameWithoutSuffix NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
oldName,
              Bool -> Bool
not (Getting Any (Branch0 IO) (Branch IO) -> Branch0 IO -> Bool
forall s a. Getting Any s a -> s -> Bool
Lens.has ((Map NameSegment (Branch IO)
 -> Const Any (Map NameSegment (Branch IO)))
-> Branch0 IO -> Const Any (Branch0 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)
  -> Const Any (Map NameSegment (Branch IO)))
 -> Branch0 IO -> Const Any (Branch0 IO))
-> ((Branch IO -> Const Any (Branch IO))
    -> Map NameSegment (Branch IO)
    -> Const Any (Map NameSegment (Branch IO)))
-> Getting Any (Branch0 IO) (Branch IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NameSegment (Branch IO))
-> Traversal'
     (Map NameSegment (Branch IO))
     (IxValue (Map NameSegment (Branch IO)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
Lens.ix Index (Map NameSegment (Branch IO))
NameSegment
newNameWithoutSuffix) Branch0 IO
currentNamespace0)
            ]
        NameSegment -> Maybe NameSegment
forall a. a -> Maybe a
Just NameSegment
newNameWithoutSuffix

  let finalNameBranchStep :: Branch0 IO -> Branch0 IO
finalNameBranchStep =
        case Maybe NameSegment
maybeFinalName of
          Maybe NameSegment
Nothing -> Branch0 IO -> Branch0 IO
forall a. a -> a
id
          Just NameSegment
finalName ->
            ASetter
  (Branch0 IO)
  (Branch0 IO)
  (Map NameSegment (Branch 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 -> (a -> b) -> s -> t
over
              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_
              ( NameSegment
-> Map NameSegment (Branch IO)
-> (Branch IO, Map NameSegment (Branch IO))
forall k v. (HasCallStack, Ord k) => k -> Map k v -> (v, Map k v)
Map.deleteLookupJust NameSegment
newName
                  (Map NameSegment (Branch IO)
 -> (Branch IO, Map NameSegment (Branch IO)))
-> ((Branch IO, Map NameSegment (Branch IO))
    -> Map NameSegment (Branch IO))
-> Map NameSegment (Branch IO)
-> Map NameSegment (Branch IO)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \(Branch IO
newLibdep, Map NameSegment (Branch IO)
libdepsWithoutNewName) -> NameSegment
-> Branch IO
-> Map NameSegment (Branch IO)
-> Map NameSegment (Branch IO)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NameSegment
finalName Branch IO
newLibdep Map NameSegment (Branch IO)
libdepsWithoutNewName
              )

  Text -> (ProjectPath, Branch0 IO -> Branch0 IO) -> Cli ()
Cli.stepAt
    Text
textualDescriptionOfUpgrade
    ( ProjectPath -> ProjectPath
PP.toRoot ProjectPath
pp,
      Branch0 IO -> Branch0 IO
finalNameBranchStep (Branch0 IO -> Branch0 IO)
-> (Branch0 IO -> Branch0 IO) -> Branch0 IO -> Branch0 IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSegment -> Branch0 IO -> Branch0 IO
forall (m :: * -> *). NameSegment -> Branch0 m -> Branch0 m
Branch.deleteLibdep NameSegment
oldName (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 (NameSegment -> NameSegment -> Maybe NameSegment -> Output
Output.UpgradeSuccess NameSegment
oldName NameSegment
newName Maybe NameSegment
maybeFinalName)
  where
    textualDescriptionOfUpgrade :: Text
    textualDescriptionOfUpgrade :: Text
textualDescriptionOfUpgrade =
      [Text] -> Text
Text.unwords [Text
"upgrade", NameSegment -> Text
NameSegment.toEscapedText NameSegment
oldName, NameSegment -> Text
NameSegment.toEscapedText NameSegment
newName]

keepOldLocalTermsNotInNew :: Relation Referent Name -> Relation Referent Name -> Set TermReference
keepOldLocalTermsNotInNew :: Relation Referent Name
-> Relation Referent Name -> Set TypeReference
keepOldLocalTermsNotInNew Relation Referent Name
oldLocalTerms Relation Referent Name
newLocalTerms =
  Relation Referent Name -> Set TypeReference
f Relation Referent Name
oldLocalTerms Set TypeReference -> Set TypeReference -> Set TypeReference
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Relation Referent Name -> Set TypeReference
f Relation Referent Name
newLocalTerms
  where
    f :: Relation Referent Name -> Set TermReference
    f :: Relation Referent Name -> 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 Name -> Set Referent)
-> Relation Referent Name
-> Set TypeReference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation Referent Name -> Set Referent
forall a b. Relation a b -> Set a
Relation.dom

keepOldLocalTypesNotInNew :: Relation TypeReference Name -> Relation TypeReference Name -> Set TypeReference
keepOldLocalTypesNotInNew :: Relation TypeReference Name
-> Relation TypeReference Name -> Set TypeReference
keepOldLocalTypesNotInNew Relation TypeReference Name
oldLocalTypes Relation TypeReference Name
newLocalTypes =
  Relation TypeReference Name -> Set TypeReference
forall a b. Relation a b -> Set a
Relation.dom Relation TypeReference Name
oldLocalTypes 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
newLocalTypes

keepOldDeepTermsStillInUse :: Relation Referent Name -> Relation Referent Name -> Set TermReference
keepOldDeepTermsStillInUse :: Relation Referent Name
-> Relation Referent Name -> Set TypeReference
keepOldDeepTermsStillInUse Relation Referent Name
oldDeepMinusLocalTerms Relation Referent Name
currentDeepTermsSansOld =
  Relation Referent Name -> Set Referent
forall a b. Relation a b -> Set a
Relation.dom Relation Referent Name
oldDeepMinusLocalTerms Set Referent
-> (Set Referent -> Set TypeReference) -> Set TypeReference
forall a b. a -> (a -> b) -> b
& (Referent -> Maybe TypeReference)
-> Set Referent -> Set TypeReference
forall b a. Ord b => (a -> Maybe b) -> Set a -> Set b
Set.mapMaybe \Referent
referent -> do
    TypeReference
ref <- Referent -> Maybe TypeReference
forall r. Referent' r -> Maybe r
Referent.toTermReference Referent
referent
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Referent -> Relation Referent Name -> Bool
forall a b. Ord a => a -> Relation a b -> Bool
Relation.memberDom Referent
referent Relation Referent Name
currentDeepTermsSansOld))
    TypeReference -> Maybe TypeReference
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeReference
ref

keepOldDeepTypesStillInUse :: Relation TypeReference Name -> Relation TypeReference Name -> Set TypeReference
keepOldDeepTypesStillInUse :: Relation TypeReference Name
-> Relation TypeReference Name -> Set TypeReference
keepOldDeepTypesStillInUse Relation TypeReference Name
oldDeepMinusLocalTypes Relation TypeReference Name
currentDeepTypesSansOld =
  Relation TypeReference Name -> Set TypeReference
forall a b. Relation a b -> Set a
Relation.dom Relation TypeReference Name
oldDeepMinusLocalTypes
    Set TypeReference
-> (Set TypeReference -> Set TypeReference) -> Set TypeReference
forall a b. a -> (a -> b) -> b
& (TypeReference -> Bool) -> Set TypeReference -> Set TypeReference
forall a. (a -> Bool) -> Set a -> Set a
Set.filter \TypeReference
typ -> Bool -> Bool
not (TypeReference -> Relation TypeReference Name -> Bool
forall a b. Ord a => a -> Relation a b -> Bool
Relation.memberDom TypeReference
typ Relation TypeReference Name
currentDeepTypesSansOld)

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
<> ( DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
dependents
           DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
-> (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
    -> DefnsF [] (Pretty ColorText) (Pretty ColorText))
-> DefnsF [] (Pretty ColorText) (Pretty ColorText)
forall a b. a -> (a -> b) -> b
& DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
-> DefnsF [] (Pretty ColorText) (Pretty ColorText)
forall a b. DefnsF (Map Name) a b -> DefnsF [] a b
inAlphabeticalOrder
           DefnsF [] (Pretty ColorText) (Pretty ColorText)
-> (DefnsF [] (Pretty ColorText) (Pretty ColorText)
    -> Pretty ColorText)
-> Pretty ColorText
forall a b. a -> (a -> b) -> b
& let f :: [Pretty ColorText] -> Pretty ColorText
f = (Pretty ColorText -> Pretty ColorText)
-> [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 (\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) in ([Pretty ColorText] -> Pretty ColorText)
-> ([Pretty ColorText] -> Pretty ColorText)
-> DefnsF [] (Pretty ColorText) (Pretty ColorText)
-> Pretty ColorText
forall m a b. Monoid m => (a -> m) -> (b -> m) -> Defns a b -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap [Pretty ColorText] -> Pretty ColorText
f [Pretty ColorText] -> Pretty ColorText
f
       )
  where
    inAlphabeticalOrder :: DefnsF (Map Name) a b -> DefnsF [] a b
    inAlphabeticalOrder :: forall a b. DefnsF (Map Name) a b -> DefnsF [] a b
inAlphabeticalOrder =
      (Map Name a -> [a])
-> (Map Name b -> [b])
-> Defns (Map Name a) (Map Name b)
-> Defns [a] [b]
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 a -> [a]
forall {b}. Map Name b -> [b]
f Map Name b -> [b]
forall {b}. Map Name b -> [b]
f
      where
        f :: Map Name b -> [b]
f = ((Name, b) -> b) -> [(Name, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Name, b) -> b
forall a b. (a, b) -> b
snd ([(Name, b)] -> [b])
-> (Map Name b -> [(Name, b)]) -> Map Name b -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, b) -> Text) -> [(Name, b)] -> [(Name, b)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Name -> Text
Name.toText (Name -> Text) -> ((Name, b) -> Name) -> (Name, b) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, b) -> Name
forall a b. (a, b) -> a
fst) ([(Name, b)] -> [(Name, b)])
-> (Map Name b -> [(Name, b)]) -> Map Name b -> [(Name, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name b -> [(Name, b)]
forall k a. Map k a -> [(k, a)]
Map.toList

makeOldDepPPE ::
  NameSegment ->
  NameSegment ->
  Names ->
  Names ->
  Names ->
  Names ->
  PrettyPrintEnvDecl
makeOldDepPPE :: NameSegment
-> NameSegment
-> Names
-> Names
-> Names
-> Names
-> PrettyPrintEnvDecl
makeOldDepPPE NameSegment
oldName NameSegment
newName Names
currentDeepNamesSansOld Names
oldDeepNames Names
oldLocalNames Names
newLocalNames =
  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
          termToNames :: Referent -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)]
          termToNames :: Referent -> [(HashQualified Name, HashQualified Name)]
termToNames Referent
ref
            | Bool
inNewNamespace = []
            | Bool
hasNewLocalTermsForOldLocalNames = Namer
-> Suffixifier
-> Referent
-> [(HashQualified Name, HashQualified Name)]
PPE.makeTermNames Namer
fakeLocalNames Suffixifier
suffixifier Referent
ref
            | Bool
onlyInOldNamespace = Namer
-> Suffixifier
-> Referent
-> [(HashQualified Name, HashQualified Name)]
PPE.makeTermNames Namer
fullOldDeepNames Suffixifier
PPE.dontSuffixify Referent
ref
            | Bool
otherwise = []
            where
              inNewNamespace :: Bool
inNewNamespace = Referent -> Relation Name Referent -> Bool
forall b a. Ord b => b -> Relation a b -> Bool
Relation.memberRan Referent
ref (Names -> Relation Name Referent
Names.terms Names
newLocalNames)
              hasNewLocalTermsForOldLocalNames :: Bool
hasNewLocalTermsForOldLocalNames =
                Bool -> Bool
not (Map Name (Set Referent) -> Bool
forall k a. Map k a -> Bool
Map.null (Relation Name Referent -> Map Name (Set Referent)
forall a b. Relation a b -> Map a (Set b)
Relation.domain (Names -> Relation Name Referent
Names.terms Names
newLocalNames) Map Name (Set Referent) -> Set Name -> Map Name (Set Referent)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set Name
theOldLocalNames))
              theOldLocalNames :: Set Name
theOldLocalNames = Referent -> Relation Name Referent -> Set Name
forall b a. Ord b => b -> Relation a b -> Set a
Relation.lookupRan Referent
ref (Names -> Relation Name Referent
Names.terms Names
oldLocalNames)
              onlyInOldNamespace :: Bool
onlyInOldNamespace = Bool
inOldNamespace Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
inCurrentNamespaceSansOld
              inOldNamespace :: Bool
inOldNamespace = Referent -> Relation Name Referent -> Bool
forall b a. Ord b => b -> Relation a b -> Bool
Relation.memberRan Referent
ref (Names -> Relation Name Referent
Names.terms Names
oldDeepNames)
              inCurrentNamespaceSansOld :: Bool
inCurrentNamespaceSansOld = Referent -> Relation Name Referent -> Bool
forall b a. Ord b => b -> Relation a b -> Bool
Relation.memberRan Referent
ref (Names -> Relation Name Referent
Names.terms Names
currentDeepNamesSansOld)
          typeToNames :: TypeReference -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)]
          typeToNames :: TypeReference -> [(HashQualified Name, HashQualified Name)]
typeToNames TypeReference
ref
            | Bool
inNewNamespace = []
            | Bool
hasNewLocalTypesForOldLocalNames = Namer
-> Suffixifier
-> TypeReference
-> [(HashQualified Name, HashQualified Name)]
PPE.makeTypeNames Namer
fakeLocalNames Suffixifier
suffixifier TypeReference
ref
            | Bool
onlyInOldNamespace = Namer
-> Suffixifier
-> TypeReference
-> [(HashQualified Name, HashQualified Name)]
PPE.makeTypeNames Namer
fullOldDeepNames Suffixifier
PPE.dontSuffixify TypeReference
ref
            | Bool
otherwise = []
            where
              inNewNamespace :: Bool
inNewNamespace = TypeReference -> Relation Name TypeReference -> Bool
forall b a. Ord b => b -> Relation a b -> Bool
Relation.memberRan TypeReference
ref (Names -> Relation Name TypeReference
Names.types Names
newLocalNames)
              hasNewLocalTypesForOldLocalNames :: Bool
hasNewLocalTypesForOldLocalNames =
                Bool -> Bool
not (Map Name (Set TypeReference) -> Bool
forall k a. Map k a -> Bool
Map.null (Relation Name TypeReference -> Map Name (Set TypeReference)
forall a b. Relation a b -> Map a (Set b)
Relation.domain (Names -> Relation Name TypeReference
Names.types Names
newLocalNames) Map Name (Set TypeReference)
-> Set Name -> Map Name (Set TypeReference)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set Name
theOldLocalNames))
              theOldLocalNames :: Set Name
theOldLocalNames = TypeReference -> Relation Name TypeReference -> Set Name
forall b a. Ord b => b -> Relation a b -> Set a
Relation.lookupRan TypeReference
ref (Names -> Relation Name TypeReference
Names.types Names
oldLocalNames)
              onlyInOldNamespace :: Bool
onlyInOldNamespace = Bool
inOldNamespace Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
inCurrentNamespaceSansOld
              inOldNamespace :: Bool
inOldNamespace = TypeReference -> Relation Name TypeReference -> Bool
forall b a. Ord b => b -> Relation a b -> Bool
Relation.memberRan TypeReference
ref (Names -> Relation Name TypeReference
Names.types Names
oldDeepNames)
              inCurrentNamespaceSansOld :: Bool
inCurrentNamespaceSansOld = TypeReference -> Relation Name TypeReference -> Bool
forall b a. Ord b => b -> Relation a b -> Bool
Relation.memberRan TypeReference
ref (Names -> Relation Name TypeReference
Names.types Names
currentDeepNamesSansOld)
   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 Names
currentDeepNamesSansOld)
        }
  where
    -- "full" means "with lib.old.* prefix"
    fullOldDeepNames :: Namer
fullOldDeepNames = Names -> Namer
PPE.namer (Name -> Names -> Names
Names.prefix0 (NonEmpty NameSegment -> Name
Name.fromReverseSegments (NameSegment
oldName NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
:| [NameSegment
NameSegment.libSegment])) Names
oldDeepNames)
    fakeLocalNames :: Namer
fakeLocalNames = Names -> Namer
PPE.namer (Name -> Names -> Names
Names.prefix0 (NonEmpty NameSegment -> Name
Name.fromReverseSegments (NameSegment
newName NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
:| [NameSegment
NameSegment.libSegment])) Names
oldLocalNames)

-- @findTemporaryBranchName projectId oldDepName newDepName@ finds some unused branch name in @projectId@ with a name
-- like "upgrade-<oldDepName>-to-<newDepName>".
findTemporaryBranchName :: ProjectId -> NameSegment -> NameSegment -> Transaction ProjectBranchName
findTemporaryBranchName :: ProjectId
-> NameSegment -> NameSegment -> Transaction ProjectBranchName
findTemporaryBranchName ProjectId
projectId 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

-- >>> 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