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

import Control.Lens qualified as Lens
import Control.Monad.Reader (ask)
import Data.Char qualified as Char
import Data.Foldable qualified as Foldable
import Data.List.NonEmpty (pattern (:|))
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.List.NonEmpty.Extra ((|>))
import Data.Map.Strict qualified as Map
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Lazy qualified as Text.Lazy
import Text.Builder qualified
import Text.Pretty.Simple (pShow)
import U.Codebase.Sqlite.DbId (ProjectId)
import Unison.Builtin.Decls qualified as Decls
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, parseAndTypecheck)
import Unison.Codebase (Codebase)
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 (Output)
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.DataDeclaration (DataDeclaration, Decl)
import Unison.DataDeclaration qualified as Decl
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Hash (Hash)
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.Name.Forward (ForwardName (..))
import Unison.Name.Forward qualified as ForwardName
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.Parser.Ann (Ann)
import Unison.Parser.Ann qualified as Ann
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 (addFallback)
import Unison.PrettyPrintEnvDecl.Names qualified as PPED (makePPED)
import Unison.Project (ProjectBranchName)
import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Sqlite (Transaction)
import Unison.Symbol (Symbol)
import Unison.Syntax.Name qualified as Name
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Typechecker qualified as Typechecker
import Unison.UnisonFile (UnisonFile)
import Unison.UnisonFile qualified as UnisonFile
import Unison.Util.Defns (Defns (..), DefnsF)
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 Unison.WatchKind qualified as WK
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

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

  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 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 currentLocalNames :: Names
currentLocalNames = Branch0 IO -> Names
forall (m :: * -> *). Branch0 m -> Names
Branch.toNames (Branch0 IO -> Branch0 IO
forall (m :: * -> *). Branch0 m -> Branch0 m
Branch.deleteLibdeps (Branch0 IO -> Branch0 IO) -> Branch0 IO -> Branch0 IO
forall a b. (a -> b) -> a -> b
$ Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head Branch IO
currentNamespace)
  let currentLocalConstructorNames :: Map ForwardName (Referent, Name)
currentLocalConstructorNames = Names -> Map ForwardName (Referent, Name)
forwardCtorNames Names
currentLocalNames
  let currentDeepNamesSansOld :: Names
currentDeepNamesSansOld = Branch0 IO -> Names
forall (m :: * -> *). Branch0 m -> Names
Branch.toNames Branch0 IO
currentNamespaceSansOld0

  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

  (UnisonFile Symbol Ann
unisonFile, PrettyPrintEnvDecl
printPPE) <-
    ((forall void. Output -> Transaction void)
 -> Transaction (UnisonFile Symbol Ann, PrettyPrintEnvDecl))
-> Cli (UnisonFile Symbol Ann, PrettyPrintEnvDecl)
forall a.
((forall void. Output -> Transaction void) -> Transaction a)
-> Cli a
Cli.runTransactionWithRollback \forall void. Output -> Transaction void
abort -> do
      DefnsF (Relation Name) (Id' Hash) (Id' Hash)
dependents <-
        Names
-> Set TypeReference
-> Transaction (DefnsF (Relation Name) (Id' Hash) (Id' Hash))
getNamespaceDependentsOf
          Names
currentLocalNames
          ( [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
              ]
          )
      UnisonFile Symbol Ann
unisonFile <- do
        (forall void. Output -> Transaction void)
-> Codebase IO Symbol Ann
-> (Maybe Int -> Name -> Either Output [Name])
-> DefnsF (Relation Name) (Id' Hash) (Id' Hash)
-> UnisonFile Symbol Ann
-> Transaction (UnisonFile Symbol Ann)
addDefinitionsToUnisonFile
          Output -> Transaction void
forall void. Output -> Transaction void
abort
          Codebase IO Symbol Ann
codebase
          (UpdateOrUpgrade
-> Names
-> Map ForwardName (Referent, Name)
-> Maybe Int
-> Name
-> Either Output [Name]
findCtorNames UpdateOrUpgrade
Output.UOUUpgrade Names
currentLocalNames Map ForwardName (Referent, Name)
currentLocalConstructorNames)
          DefnsF (Relation Name) (Id' Hash) (Id' Hash)
dependents
          UnisonFile Symbol Ann
forall v a. UnisonFile v a
UnisonFile.emptyUnisonFile
      pure
        ( UnisonFile Symbol Ann
unisonFile,
          let ppe1 :: PrettyPrintEnvDecl
ppe1 =
                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)
              ppe2 :: PrettyPrintEnvDecl
ppe2 =
                Namer -> Suffixifier -> PrettyPrintEnvDecl
PPED.makePPED
                  (Names -> Namer
PPE.namer (DefnsF (Relation Name) (Id' Hash) (Id' Hash) -> Names
Names.fromReferenceIds DefnsF (Relation Name) (Id' Hash) (Id' Hash)
dependents))
                  (Names -> Suffixifier
PPE.suffixifyByName Names
currentDeepNamesSansOld)
              ppe3 :: PrettyPrintEnvDecl
ppe3 =
                Namer -> Suffixifier -> PrettyPrintEnvDecl
PPED.makePPED
                  (Int -> Names -> Namer
PPE.hqNamer Int
10 Names
currentDeepNamesSansOld)
                  (Names -> Suffixifier
PPE.suffixifyByHash Names
currentDeepNamesSansOld)
           in PrettyPrintEnvDecl
ppe1 PrettyPrintEnvDecl -> PrettyPrintEnvDecl -> PrettyPrintEnvDecl
`PPED.addFallback` PrettyPrintEnvDecl
ppe2 PrettyPrintEnvDecl -> PrettyPrintEnvDecl -> PrettyPrintEnvDecl
`PPED.addFallback` PrettyPrintEnvDecl
ppe3
        )

  pp :: ProjectPath
pp@(PP.ProjectPath Project
project ProjectBranch
projectBranch Absolute
_path) <- Cli ProjectPath
Cli.getCurrentProjectPath
  ParsingEnv Transaction
parsingEnv <- ProjectPath -> Names -> Cli (ParsingEnv Transaction)
Cli.makeParsingEnv ProjectPath
pp Names
currentDeepNamesSansOld
  TypecheckedUnisonFile Symbol Ann
typecheckedUnisonFile <- do
    let prettyUnisonFile :: Pretty ColorText
prettyUnisonFile = PrettyPrintEnvDecl -> UnisonFile Symbol Ann -> Pretty ColorText
forall v a.
(Var v, Ord a) =>
PrettyPrintEnvDecl -> UnisonFile v a -> Pretty ColorText
Pretty.prettyUnisonFile PrettyPrintEnvDecl
printPPE UnisonFile Symbol Ann
unisonFile
    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
      let getTemporaryBranchName :: Transaction ProjectBranchName
getTemporaryBranchName = ProjectId
-> NameSegment -> NameSegment -> Transaction ProjectBranchName
findTemporaryBranchName (Project
project Project -> Getting ProjectId Project ProjectId -> ProjectId
forall s a. s -> Getting a s a -> a
^. Getting ProjectId Project ProjectId
#projectId) NameSegment
oldName NameSegment
newName
      (ProjectBranchId
_temporaryBranchId, ProjectBranchName
temporaryBranchName) <-
        Text
-> CreateFrom
-> Project
-> Transaction ProjectBranchName
-> Cli (ProjectBranchId, ProjectBranchName)
HandleInput.Branch.createBranch
          Text
textualDescriptionOfUpgrade
          (ProjectBranch -> Branch IO -> CreateFrom
CreateFrom'NamespaceWithParent ProjectBranch
projectBranch Branch IO
currentNamespaceSansOld)
          Project
project
          Transaction ProjectBranchName
getTemporaryBranchName
      WatchKind
scratchFilePath <-
        Cli (Maybe (WatchKind, Bool))
Cli.getLatestFile Cli (Maybe (WatchKind, Bool))
-> (Maybe (WatchKind, Bool) -> WatchKind) -> Cli WatchKind
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          Maybe (WatchKind, Bool)
Nothing -> WatchKind
"scratch.u"
          Just (WatchKind
file, Bool
_) -> WatchKind
file
      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
$ Text -> Text -> IO ()
writeSource (WatchKind -> Text
Text.pack WatchKind
scratchFilePath) (WatchKind -> Text
Text.pack (WatchKind -> Text) -> WatchKind -> Text
forall a b. (a -> b) -> a -> b
$ Width -> Pretty ColorText -> WatchKind
Pretty.toPlain Width
80 Pretty ColorText
prettyUnisonFile)
      Output -> Cli (TypecheckedUnisonFile Symbol Ann)
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli (TypecheckedUnisonFile Symbol Ann))
-> Output -> Cli (TypecheckedUnisonFile Symbol Ann)
forall a b. (a -> b) -> a -> b
$
        ProjectBranchName
-> ProjectBranchName
-> WatchKind
-> NameSegment
-> NameSegment
-> Output
Output.UpgradeFailure (ProjectBranch
projectBranch ProjectBranch
-> Getting ProjectBranchName ProjectBranch ProjectBranchName
-> ProjectBranchName
forall s a. s -> Getting a s a -> a
^. Getting ProjectBranchName ProjectBranch ProjectBranchName
#name) ProjectBranchName
temporaryBranchName WatchKind
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 Codebase IO Symbol Ann
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
        (UpdateOrUpgrade
-> Names
-> Map ForwardName (Referent, Name)
-> Maybe Int
-> Name
-> Either Output (Maybe [Name])
findCtorNamesMaybe UpdateOrUpgrade
Output.UOUUpgrade Names
currentLocalNames Map ForwardName (Referent, Name)
currentLocalConstructorNames Maybe Int
forall a. Maybe a
Nothing)
        TypecheckedUnisonFile Symbol Ann
typecheckedUnisonFile
  Text -> (ProjectPath, Branch0 IO -> Branch0 IO) -> Cli ()
Cli.stepAt
    Text
textualDescriptionOfUpgrade
    ( ProjectPath -> ProjectPath
PP.toRoot ProjectPath
pp,
      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 -> Output
Output.UpgradeSuccess NameSegment
oldName NameSegment
newName)
  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))
    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)

-- | @addDefinitionsToUnisonFile abort codebase doFindCtorNames definitions file@ adds all @definitions@ to @file@,
-- avoiding overwriting anything already in @file@. Every definition is put into the file with every naming it has in
-- @names@ "on the left-hand-side of the equals" (but yes type decls don't really have a LHS).
--
-- TODO: find a better module for this function, as it's used in a couple places
addDefinitionsToUnisonFile ::
  (forall void. Output -> Transaction void) ->
  Codebase IO Symbol Ann ->
  (Maybe Int -> Name -> Either Output.Output [Name]) ->
  DefnsF (Relation Name) TermReferenceId TypeReferenceId ->
  UnisonFile Symbol Ann ->
  Transaction (UnisonFile Symbol Ann)
addDefinitionsToUnisonFile :: (forall void. Output -> Transaction void)
-> Codebase IO Symbol Ann
-> (Maybe Int -> Name -> Either Output [Name])
-> DefnsF (Relation Name) (Id' Hash) (Id' Hash)
-> UnisonFile Symbol Ann
-> Transaction (UnisonFile Symbol Ann)
addDefinitionsToUnisonFile forall void. Output -> Transaction void
abort Codebase IO Symbol Ann
codebase Maybe Int -> Name -> Either Output [Name]
doFindCtorNames DefnsF (Relation Name) (Id' Hash) (Id' Hash)
newDefns UnisonFile Symbol Ann
oldUF = do
  UnisonFile Symbol Ann
newUF <- (forall void. Output -> Transaction void)
-> Codebase IO Symbol Ann
-> (Maybe Int -> Name -> Either Output [Name])
-> DefnsF (Relation Name) (Id' Hash) (Id' Hash)
-> Transaction (UnisonFile Symbol Ann)
makeUnisonFile Output -> Transaction void
forall void. Output -> Transaction void
abort Codebase IO Symbol Ann
codebase Maybe Int -> Name -> Either Output [Name]
doFindCtorNames DefnsF (Relation Name) (Id' Hash) (Id' Hash)
newDefns
  pure (UnisonFile Symbol Ann
oldUF UnisonFile Symbol Ann
-> UnisonFile Symbol Ann -> UnisonFile Symbol Ann
forall v a.
Ord v =>
UnisonFile v a -> UnisonFile v a -> UnisonFile v a
`UnisonFile.leftBiasedMerge` UnisonFile Symbol Ann
newUF)

makeUnisonFile ::
  (forall void. Output -> Transaction void) ->
  Codebase IO Symbol Ann ->
  (Maybe Int -> Name -> Either Output.Output [Name]) ->
  DefnsF (Relation Name) TermReferenceId TypeReferenceId ->
  Transaction (UnisonFile Symbol Ann)
makeUnisonFile :: (forall void. Output -> Transaction void)
-> Codebase IO Symbol Ann
-> (Maybe Int -> Name -> Either Output [Name])
-> DefnsF (Relation Name) (Id' Hash) (Id' Hash)
-> Transaction (UnisonFile Symbol Ann)
makeUnisonFile forall void. Output -> Transaction void
abort Codebase IO Symbol Ann
codebase Maybe Int -> Name -> Either Output [Name]
doFindCtorNames DefnsF (Relation Name) (Id' Hash) (Id' Hash)
defns = do
  UnisonFile Symbol Ann
file <- (UnisonFile Symbol Ann
 -> Hash -> Transaction (UnisonFile Symbol Ann))
-> UnisonFile Symbol Ann
-> Set Hash
-> Transaction (UnisonFile Symbol Ann)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM UnisonFile Symbol Ann
-> Hash -> Transaction (UnisonFile Symbol Ann)
addTermComponent UnisonFile Symbol Ann
forall v a. UnisonFile v a
UnisonFile.emptyUnisonFile ((Id' Hash -> Hash) -> Set (Id' Hash) -> Set Hash
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Id' Hash -> Hash
Reference.idToHash (Relation Name (Id' Hash) -> Set (Id' Hash)
forall a b. Relation a b -> Set b
Relation.ran DefnsF (Relation Name) (Id' Hash) (Id' Hash)
defns.terms))
  (UnisonFile Symbol Ann
 -> Hash -> Transaction (UnisonFile Symbol Ann))
-> UnisonFile Symbol Ann
-> Set Hash
-> Transaction (UnisonFile Symbol Ann)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM UnisonFile Symbol Ann
-> Hash -> Transaction (UnisonFile Symbol Ann)
addDeclComponent UnisonFile Symbol Ann
file ((Id' Hash -> Hash) -> Set (Id' Hash) -> Set Hash
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Id' Hash -> Hash
Reference.idToHash (Relation Name (Id' Hash) -> Set (Id' Hash)
forall a b. Relation a b -> Set b
Relation.ran DefnsF (Relation Name) (Id' Hash) (Id' Hash)
defns.types))
  where
    addTermComponent :: UnisonFile Symbol Ann -> Hash -> Transaction (UnisonFile Symbol Ann)
    addTermComponent :: UnisonFile Symbol Ann
-> Hash -> Transaction (UnisonFile Symbol Ann)
addTermComponent UnisonFile Symbol Ann
uf Hash
h = do
      [(Term Symbol Ann, Type Symbol Ann)]
termComponent <- 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 Codebase IO Symbol Ann
codebase Hash
h
      pure $ (UnisonFile Symbol Ann
 -> ((Term Symbol Ann, Type Symbol Ann), ConstructorId)
 -> UnisonFile Symbol Ann)
-> UnisonFile Symbol Ann
-> [((Term Symbol Ann, Type Symbol Ann), ConstructorId)]
-> UnisonFile Symbol Ann
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UnisonFile Symbol Ann
-> ((Term Symbol Ann, Type Symbol Ann), ConstructorId)
-> UnisonFile Symbol Ann
addTermElement UnisonFile Symbol Ann
uf ([(Term Symbol Ann, Type Symbol Ann)]
-> [ConstructorId]
-> [((Term Symbol Ann, Type Symbol Ann), ConstructorId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Term Symbol Ann, Type Symbol Ann)]
termComponent [ConstructorId
0 ..])
      where
        addTermElement :: UnisonFile Symbol Ann -> ((Term Symbol Ann, Type Symbol Ann), Reference.Pos) -> UnisonFile Symbol Ann
        addTermElement :: UnisonFile Symbol Ann
-> ((Term Symbol Ann, Type Symbol Ann), ConstructorId)
-> UnisonFile Symbol Ann
addTermElement UnisonFile Symbol Ann
uf ((Term Symbol Ann
tm, Type Symbol Ann
tp), ConstructorId
i) = do
          let termNames :: Set Name
termNames = Id' Hash -> Relation Name (Id' Hash) -> Set Name
forall b a. Ord b => b -> Relation a b -> Set a
Relation.lookupRan (Hash -> ConstructorId -> Id' Hash
forall h. h -> ConstructorId -> Id' h
Reference.Id Hash
h ConstructorId
i) DefnsF (Relation Name) (Id' Hash) (Id' Hash)
defns.terms
          (UnisonFile Symbol Ann -> Name -> UnisonFile Symbol Ann)
-> UnisonFile Symbol Ann -> Set Name -> UnisonFile Symbol Ann
forall b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Term Symbol Ann
-> Type Symbol Ann
-> UnisonFile Symbol Ann
-> Name
-> UnisonFile Symbol Ann
addDefinition Term Symbol Ann
tm Type Symbol Ann
tp) UnisonFile Symbol Ann
uf Set Name
termNames
        addDefinition :: Term Symbol Ann -> Type Symbol Ann -> UnisonFile Symbol Ann -> Name -> UnisonFile Symbol Ann
        addDefinition :: Term Symbol Ann
-> Type Symbol Ann
-> UnisonFile Symbol Ann
-> Name
-> UnisonFile Symbol Ann
addDefinition Term Symbol Ann
tm Type Symbol Ann
tp UnisonFile Symbol Ann
uf (Name -> Symbol
forall v. Var v => Name -> v
Name.toVar -> Symbol
v) =
          let prependTerm :: [(Symbol, Ann, Term Symbol Ann)]
-> [(Symbol, Ann, Term Symbol Ann)]
prependTerm [(Symbol, Ann, Term Symbol Ann)]
to = (Symbol
v, Ann
Ann.External, Term Symbol Ann
tm) (Symbol, Ann, Term Symbol Ann)
-> [(Symbol, Ann, Term Symbol Ann)]
-> [(Symbol, Ann, Term Symbol Ann)]
forall a. a -> [a] -> [a]
: [(Symbol, Ann, Term Symbol Ann)]
to
           in if Type Symbol Ann -> Bool
isTest Type Symbol Ann
tp
                then UnisonFile Symbol Ann
uf UnisonFile Symbol Ann
-> (UnisonFile Symbol Ann -> UnisonFile Symbol Ann)
-> UnisonFile Symbol Ann
forall a b. a -> (a -> b) -> b
& (Map WatchKind [(Symbol, Ann, Term Symbol Ann)]
 -> Identity (Map WatchKind [(Symbol, Ann, Term Symbol Ann)]))
-> UnisonFile Symbol Ann -> Identity (UnisonFile Symbol Ann)
#watches ((Map WatchKind [(Symbol, Ann, Term Symbol Ann)]
  -> Identity (Map WatchKind [(Symbol, Ann, Term Symbol Ann)]))
 -> UnisonFile Symbol Ann -> Identity (UnisonFile Symbol Ann))
-> (([(Symbol, Ann, Term Symbol Ann)]
     -> Identity [(Symbol, Ann, Term Symbol Ann)])
    -> Map WatchKind [(Symbol, Ann, Term Symbol Ann)]
    -> Identity (Map WatchKind [(Symbol, Ann, Term Symbol Ann)]))
-> ([(Symbol, Ann, Term Symbol Ann)]
    -> Identity [(Symbol, Ann, Term Symbol Ann)])
-> UnisonFile Symbol Ann
-> Identity (UnisonFile Symbol Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map WatchKind [(Symbol, Ann, Term Symbol Ann)])
-> Lens'
     (Map WatchKind [(Symbol, Ann, Term Symbol Ann)])
     (Maybe (IxValue (Map WatchKind [(Symbol, Ann, Term Symbol Ann)])))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
Lens.at Index (Map WatchKind [(Symbol, Ann, Term Symbol Ann)])
forall a. (Eq a, IsString a) => a
WK.TestWatch ((Maybe [(Symbol, Ann, Term Symbol Ann)]
  -> Identity (Maybe [(Symbol, Ann, Term Symbol Ann)]))
 -> Map WatchKind [(Symbol, Ann, Term Symbol Ann)]
 -> Identity (Map WatchKind [(Symbol, Ann, Term Symbol Ann)]))
-> (([(Symbol, Ann, Term Symbol Ann)]
     -> Identity [(Symbol, Ann, Term Symbol Ann)])
    -> Maybe [(Symbol, Ann, Term Symbol Ann)]
    -> Identity (Maybe [(Symbol, Ann, Term Symbol Ann)]))
-> ([(Symbol, Ann, Term Symbol Ann)]
    -> Identity [(Symbol, Ann, Term Symbol Ann)])
-> Map WatchKind [(Symbol, Ann, Term Symbol Ann)]
-> Identity (Map WatchKind [(Symbol, Ann, Term Symbol Ann)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Symbol, Ann, Term Symbol Ann)]
-> Iso'
     (Maybe [(Symbol, Ann, Term Symbol Ann)])
     [(Symbol, Ann, Term Symbol Ann)]
forall a. Eq a => a -> Iso' (Maybe a) a
Lens.non [] (([(Symbol, Ann, Term Symbol Ann)]
  -> Identity [(Symbol, Ann, Term Symbol Ann)])
 -> UnisonFile Symbol Ann -> Identity (UnisonFile Symbol Ann))
-> ([(Symbol, Ann, Term Symbol Ann)]
    -> [(Symbol, Ann, Term Symbol Ann)])
-> UnisonFile Symbol Ann
-> UnisonFile Symbol Ann
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
Lens.%~ [(Symbol, Ann, Term Symbol Ann)]
-> [(Symbol, Ann, Term Symbol Ann)]
prependTerm
                else UnisonFile Symbol Ann
uf UnisonFile Symbol Ann
-> (UnisonFile Symbol Ann -> UnisonFile Symbol Ann)
-> UnisonFile Symbol Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (UnisonFile Symbol Ann)
  (UnisonFile Symbol Ann)
  (Map Symbol (Ann, Term Symbol Ann))
  (Map Symbol (Ann, Term Symbol Ann))
#terms ASetter
  (UnisonFile Symbol Ann)
  (UnisonFile Symbol Ann)
  (Map Symbol (Ann, Term Symbol Ann))
  (Map Symbol (Ann, Term Symbol Ann))
-> (Map Symbol (Ann, Term Symbol Ann)
    -> Map Symbol (Ann, Term Symbol Ann))
-> UnisonFile Symbol Ann
-> UnisonFile Symbol Ann
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
Lens.%~ Symbol
-> (Ann, Term Symbol Ann)
-> Map Symbol (Ann, Term Symbol Ann)
-> Map Symbol (Ann, Term Symbol Ann)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Symbol
v (Ann
Ann.External, Term Symbol Ann
tm)

    isTest :: Type Symbol Ann -> Bool
isTest = Type Symbol Ann -> Type Symbol Ann -> Bool
forall v loc. Var v => Type v loc -> Type v loc -> Bool
Typechecker.isEqual (Ann -> Type Symbol Ann
forall v a. Ord v => a -> Type v a
Decls.testResultListType Ann
forall a. Monoid a => a
mempty)

    -- given a dependent hash, include that component in the scratch file
    -- todo: wundefined: cut off constructor name prefixes
    addDeclComponent :: UnisonFile Symbol Ann -> Hash -> Transaction (UnisonFile Symbol Ann)
    addDeclComponent :: UnisonFile Symbol Ann
-> Hash -> Transaction (UnisonFile Symbol Ann)
addDeclComponent UnisonFile Symbol Ann
uf Hash
h = do
      [Decl Symbol Ann]
declComponent <- Maybe [Decl Symbol Ann] -> [Decl Symbol Ann]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Decl Symbol Ann] -> [Decl Symbol Ann])
-> Transaction (Maybe [Decl Symbol Ann])
-> Transaction [Decl Symbol Ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hash -> Transaction (Maybe [Decl Symbol Ann])
Codebase.getDeclComponent Hash
h
      (UnisonFile Symbol Ann
 -> (Decl Symbol Ann, ConstructorId)
 -> Transaction (UnisonFile Symbol Ann))
-> UnisonFile Symbol Ann
-> [(Decl Symbol Ann, ConstructorId)]
-> Transaction (UnisonFile Symbol Ann)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM UnisonFile Symbol Ann
-> (Decl Symbol Ann, ConstructorId)
-> Transaction (UnisonFile Symbol Ann)
addDeclElement UnisonFile Symbol Ann
uf ([Decl Symbol Ann]
-> [ConstructorId] -> [(Decl Symbol Ann, ConstructorId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Decl Symbol Ann]
declComponent [ConstructorId
0 ..])
      where
        -- for each name a decl has, update its constructor names according to what exists in the namespace
        addDeclElement :: UnisonFile Symbol Ann -> (Decl Symbol Ann, Reference.Pos) -> Transaction (UnisonFile Symbol Ann)
        addDeclElement :: UnisonFile Symbol Ann
-> (Decl Symbol Ann, ConstructorId)
-> Transaction (UnisonFile Symbol Ann)
addDeclElement UnisonFile Symbol Ann
uf (Decl Symbol Ann
decl, ConstructorId
i) = do
          let declNames :: Set Name
declNames = Id' Hash -> Relation Name (Id' Hash) -> Set Name
forall b a. Ord b => b -> Relation a b -> Set a
Relation.lookupRan (Hash -> ConstructorId -> Id' Hash
forall h. h -> ConstructorId -> Id' h
Reference.Id Hash
h ConstructorId
i) DefnsF (Relation Name) (Id' Hash) (Id' Hash)
defns.types
          -- look up names for this decl's constructor based on the decl's name, and embed them in the decl definition.
          (UnisonFile Symbol Ann
 -> Name -> Transaction (UnisonFile Symbol Ann))
-> UnisonFile Symbol Ann
-> Set Name
-> Transaction (UnisonFile Symbol Ann)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Decl Symbol Ann
-> UnisonFile Symbol Ann
-> Name
-> Transaction (UnisonFile Symbol Ann)
addRebuiltDefinition Decl Symbol Ann
decl) UnisonFile Symbol Ann
uf Set Name
declNames
          where
            -- skip any definitions that already have names, we don't want to overwrite what the user has supplied
            addRebuiltDefinition :: Decl Symbol Ann -> UnisonFile Symbol Ann -> Name -> Transaction (UnisonFile Symbol Ann)
            addRebuiltDefinition :: Decl Symbol Ann
-> UnisonFile Symbol Ann
-> Name
-> Transaction (UnisonFile Symbol Ann)
addRebuiltDefinition Decl Symbol Ann
decl UnisonFile Symbol Ann
uf Name
name = case Decl Symbol Ann
decl of
              Left EffectDeclaration Symbol Ann
ed ->
                Name
-> DataDeclaration Symbol Ann
-> Transaction (DataDeclaration Symbol Ann)
overwriteConstructorNames Name
name EffectDeclaration Symbol Ann
ed.toDataDecl Transaction (DataDeclaration Symbol Ann)
-> (DataDeclaration Symbol Ann -> UnisonFile Symbol Ann)
-> Transaction (UnisonFile Symbol Ann)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DataDeclaration Symbol Ann
ed' ->
                  UnisonFile Symbol Ann
uf
                    UnisonFile Symbol Ann
-> (UnisonFile Symbol Ann -> UnisonFile Symbol Ann)
-> UnisonFile Symbol Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (UnisonFile Symbol Ann)
  (UnisonFile Symbol Ann)
  (Map Symbol (Id' Hash, EffectDeclaration Symbol Ann))
  (Map Symbol (Id' Hash, EffectDeclaration Symbol Ann))
#effectDeclarationsId
                      ASetter
  (UnisonFile Symbol Ann)
  (UnisonFile Symbol Ann)
  (Map Symbol (Id' Hash, EffectDeclaration Symbol Ann))
  (Map Symbol (Id' Hash, EffectDeclaration Symbol Ann))
-> (Map Symbol (Id' Hash, EffectDeclaration Symbol Ann)
    -> Map Symbol (Id' Hash, EffectDeclaration Symbol Ann))
-> UnisonFile Symbol Ann
-> UnisonFile Symbol Ann
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((Id' Hash, EffectDeclaration Symbol Ann)
 -> (Id' Hash, EffectDeclaration Symbol Ann)
 -> (Id' Hash, EffectDeclaration Symbol Ann))
-> Symbol
-> (Id' Hash, EffectDeclaration Symbol Ann)
-> Map Symbol (Id' Hash, EffectDeclaration Symbol Ann)
-> Map Symbol (Id' Hash, EffectDeclaration Symbol Ann)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\(Id' Hash, EffectDeclaration Symbol Ann)
_new (Id' Hash, EffectDeclaration Symbol Ann)
old -> (Id' Hash, EffectDeclaration Symbol Ann)
old) (Name -> Symbol
forall v. Var v => Name -> v
Name.toVar Name
name) (Hash -> ConstructorId -> Id' Hash
forall h. h -> ConstructorId -> Id' h
Reference.Id Hash
h ConstructorId
i, DataDeclaration Symbol Ann -> EffectDeclaration Symbol Ann
forall v a. DataDeclaration v a -> EffectDeclaration v a
Decl.EffectDeclaration DataDeclaration Symbol Ann
ed')
              Right DataDeclaration Symbol Ann
dd ->
                Name
-> DataDeclaration Symbol Ann
-> Transaction (DataDeclaration Symbol Ann)
overwriteConstructorNames Name
name DataDeclaration Symbol Ann
dd Transaction (DataDeclaration Symbol Ann)
-> (DataDeclaration Symbol Ann -> UnisonFile Symbol Ann)
-> Transaction (UnisonFile Symbol Ann)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DataDeclaration Symbol Ann
dd' ->
                  UnisonFile Symbol Ann
uf
                    UnisonFile Symbol Ann
-> (UnisonFile Symbol Ann -> UnisonFile Symbol Ann)
-> UnisonFile Symbol Ann
forall a b. a -> (a -> b) -> b
& ASetter
  (UnisonFile Symbol Ann)
  (UnisonFile Symbol Ann)
  (Map Symbol (Id' Hash, DataDeclaration Symbol Ann))
  (Map Symbol (Id' Hash, DataDeclaration Symbol Ann))
#dataDeclarationsId
                      ASetter
  (UnisonFile Symbol Ann)
  (UnisonFile Symbol Ann)
  (Map Symbol (Id' Hash, DataDeclaration Symbol Ann))
  (Map Symbol (Id' Hash, DataDeclaration Symbol Ann))
-> (Map Symbol (Id' Hash, DataDeclaration Symbol Ann)
    -> Map Symbol (Id' Hash, DataDeclaration Symbol Ann))
-> UnisonFile Symbol Ann
-> UnisonFile Symbol Ann
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((Id' Hash, DataDeclaration Symbol Ann)
 -> (Id' Hash, DataDeclaration Symbol Ann)
 -> (Id' Hash, DataDeclaration Symbol Ann))
-> Symbol
-> (Id' Hash, DataDeclaration Symbol Ann)
-> Map Symbol (Id' Hash, DataDeclaration Symbol Ann)
-> Map Symbol (Id' Hash, DataDeclaration Symbol Ann)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\(Id' Hash, DataDeclaration Symbol Ann)
_new (Id' Hash, DataDeclaration Symbol Ann)
old -> (Id' Hash, DataDeclaration Symbol Ann)
old) (Name -> Symbol
forall v. Var v => Name -> v
Name.toVar Name
name) (Hash -> ConstructorId -> Id' Hash
forall h. h -> ConstructorId -> Id' h
Reference.Id Hash
h ConstructorId
i, DataDeclaration Symbol Ann
dd')

        -- Constructor names are bogus when pulled from the database, so we set them to what they should be here
        overwriteConstructorNames :: Name -> DataDeclaration Symbol Ann -> Transaction (DataDeclaration Symbol Ann)
        overwriteConstructorNames :: Name
-> DataDeclaration Symbol Ann
-> Transaction (DataDeclaration Symbol Ann)
overwriteConstructorNames Name
name DataDeclaration Symbol Ann
dd =
          let constructorNames :: Transaction [Symbol]
              constructorNames :: Transaction [Symbol]
constructorNames =
                case Maybe Int -> Name -> Either Output [Name]
doFindCtorNames (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ DataDeclaration Symbol Ann -> Int
forall v a. DataDeclaration v a -> Int
Decl.constructorCount DataDeclaration Symbol Ann
dd) Name
name of
                  Left Output
err -> Output -> Transaction [Symbol]
forall void. Output -> Transaction void
abort Output
err
                  Right [Name]
array | (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Name -> Bool) -> (Name -> Maybe Name) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> Maybe Name
Name.stripNamePrefix Name
name) [Name]
array -> [Symbol] -> Transaction [Symbol]
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Name -> Symbol) -> [Name] -> [Symbol]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Symbol
forall v. Var v => Name -> v
Name.toVar [Name]
array)
                  Right [Name]
array -> do
                    WatchKind -> Transaction ()
forall (f :: * -> *). Applicative f => WatchKind -> f ()
traceM WatchKind
"I ran into a situation where a type's constructors didn't match its name,"
                    WatchKind -> Transaction ()
forall (f :: * -> *). Applicative f => WatchKind -> f ()
traceM WatchKind
"in a spot where I didn't expect to be discovering that.\n\n"
                    WatchKind -> Transaction ()
forall (f :: * -> *). Applicative f => WatchKind -> f ()
traceM WatchKind
"Type Name:"
                    WatchKind -> Transaction ()
forall (f :: * -> *). Applicative f => WatchKind -> f ()
traceM (WatchKind -> Transaction ())
-> (Text -> WatchKind) -> Text -> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> WatchKind
Text.Lazy.unpack (Text -> Transaction ()) -> Text -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Name -> Text
forall a. Show a => a -> Text
pShow Name
name
                    WatchKind -> Transaction ()
forall (f :: * -> *). Applicative f => WatchKind -> f ()
traceM WatchKind
"Constructor Names:"
                    WatchKind -> Transaction ()
forall (f :: * -> *). Applicative f => WatchKind -> f ()
traceM (WatchKind -> Transaction ())
-> (Text -> WatchKind) -> Text -> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> WatchKind
Text.Lazy.unpack (Text -> Transaction ()) -> Text -> Transaction ()
forall a b. (a -> b) -> a -> b
$ [Name] -> Text
forall a. Show a => a -> Text
pShow [Name]
array
                    WatchKind -> Transaction [Symbol]
forall a. HasCallStack => WatchKind -> a
error WatchKind
"Sorry for crashing."

              swapConstructorNames :: [(a, b, c)] -> Transaction [(a, Symbol, c)]
swapConstructorNames [(a, b, c)]
oldCtors =
                let ([a]
annotations, [b]
_vars, [c]
types) = [(a, b, c)] -> ([a], [b], [c])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(a, b, c)]
oldCtors
                 in [a] -> [Symbol] -> [c] -> [(a, Symbol, c)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [a]
annotations ([Symbol] -> [c] -> [(a, Symbol, c)])
-> Transaction [Symbol] -> Transaction ([c] -> [(a, Symbol, c)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transaction [Symbol]
constructorNames Transaction ([c] -> [(a, Symbol, c)])
-> Transaction [c] -> Transaction [(a, Symbol, c)]
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [c] -> Transaction [c]
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [c]
types
           in LensLike
  Transaction
  (DataDeclaration Symbol Ann)
  (DataDeclaration Symbol Ann)
  [(Ann, Symbol, Type Symbol Ann)]
  [(Ann, Symbol, Type Symbol Ann)]
-> LensLike
     Transaction
     (DataDeclaration Symbol Ann)
     (DataDeclaration Symbol Ann)
     [(Ann, Symbol, Type Symbol Ann)]
     [(Ann, Symbol, Type Symbol Ann)]
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
Lens.traverseOf LensLike
  Transaction
  (DataDeclaration Symbol Ann)
  (DataDeclaration Symbol Ann)
  [(Ann, Symbol, Type Symbol Ann)]
  [(Ann, Symbol, Type Symbol Ann)]
forall v a (f :: * -> *).
Functor f =>
([(a, v, Type v a)] -> f [(a, v, Type v a)])
-> DataDeclaration v a -> f (DataDeclaration v a)
Decl.constructors_ [(Ann, Symbol, Type Symbol Ann)]
-> Transaction [(Ann, Symbol, Type Symbol Ann)]
forall {a} {b} {c}. [(a, b, c)] -> Transaction [(a, Symbol, c)]
swapConstructorNames DataDeclaration Symbol Ann
dd

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

-- | O(r + c * d) touches all the referents (r), and all the NameSegments (d) of all of the Con referents (c)
forwardCtorNames :: Names -> Map ForwardName (Referent, Name)
forwardCtorNames :: Names -> Map ForwardName (Referent, Name)
forwardCtorNames Names
names =
  [(ForwardName, (Referent, Name))]
-> Map ForwardName (Referent, Name)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ForwardName, (Referent, Name))]
 -> Map ForwardName (Referent, Name))
-> [(ForwardName, (Referent, Name))]
-> Map ForwardName (Referent, Name)
forall a b. (a -> b) -> a -> b
$
    [ (Name -> ForwardName
ForwardName.fromName Name
name, (Referent
r, Name
name))
      | (r :: Referent
r@Referent.Con {}, Set Name
rNames) <- Map Referent (Set Name) -> [(Referent, Set Name)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Referent (Set Name) -> [(Referent, Set Name)])
-> Map Referent (Set Name) -> [(Referent, Set Name)]
forall a b. (a -> b) -> a -> b
$ Relation Name Referent -> Map Referent (Set Name)
forall a b. Relation a b -> Map b (Set a)
Relation.range Names
names.terms,
        Name
name <- Set Name -> [Name]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Set Name
rNames
    ]

-- | given a decl name, find names for all of its constructors, in order.
--
-- Precondition: 'n' is an element of 'names'
findCtorNames :: Output.UpdateOrUpgrade -> Names -> Map ForwardName (Referent, Name) -> Maybe Int -> Name -> Either Output.Output [Name]
findCtorNames :: UpdateOrUpgrade
-> Names
-> Map ForwardName (Referent, Name)
-> Maybe Int
-> Name
-> Either Output [Name]
findCtorNames UpdateOrUpgrade
operation Names
names Map ForwardName (Referent, Name)
forwardCtorNames Maybe Int
ctorCount Name
n =
  let declRef :: TypeReference
declRef = case Set TypeReference -> Maybe TypeReference
forall a. Set a -> Maybe a
Set.lookupMin (Name -> Relation Name TypeReference -> Set TypeReference
forall a b. Ord a => a -> Relation a b -> Set b
Relation.lookupDom Name
n Names
names.types) of
        Maybe TypeReference
Nothing -> WatchKind -> TypeReference
forall a. HasCallStack => WatchKind -> a
error WatchKind
"[findCtorNames] precondition violation: n is not an element of names"
        Just TypeReference
x -> TypeReference
x
      f :: ForwardName
f = Name -> ForwardName
ForwardName.fromName Name
n
      (Map ForwardName (Referent, Name)
_, Map ForwardName (Referent, Name)
centerRight) = ForwardName
-> Map ForwardName (Referent, Name)
-> (Map ForwardName (Referent, Name),
    Map ForwardName (Referent, Name))
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split ForwardName
f Map ForwardName (Referent, Name)
forwardCtorNames
      (Map ForwardName (Referent, Name)
center, Map ForwardName (Referent, Name)
_) = ForwardName
-> Map ForwardName (Referent, Name)
-> (Map ForwardName (Referent, Name),
    Map ForwardName (Referent, Name))
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split (ForwardName -> ForwardName
incrementLastSegmentChar ForwardName
f) Map ForwardName (Referent, Name)
centerRight

      insertShortest :: Map ConstructorId Name -> (Referent, Name) -> Map ConstructorId Name
      insertShortest :: Map ConstructorId Name
-> (Referent, Name) -> Map ConstructorId Name
insertShortest Map ConstructorId Name
m (Referent.Con (ConstructorReference TypeReference
r ConstructorId
cid) ConstructorType
_ct, Name
newName) | TypeReference
r TypeReference -> TypeReference -> Bool
forall a. Eq a => a -> a -> Bool
== TypeReference
declRef =
        case ConstructorId -> Map ConstructorId Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ConstructorId
cid Map ConstructorId Name
m of
          Just Name
existingName
            | NonEmpty NameSegment -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Name -> NonEmpty NameSegment
Name.segments Name
existingName) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> NonEmpty NameSegment -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Name -> NonEmpty NameSegment
Name.segments Name
newName) ->
                ConstructorId
-> Name -> Map ConstructorId Name -> Map ConstructorId Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ConstructorId
cid Name
newName Map ConstructorId Name
m
          Just {} -> Map ConstructorId Name
m
          Maybe Name
Nothing -> ConstructorId
-> Name -> Map ConstructorId Name -> Map ConstructorId Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ConstructorId
cid Name
newName Map ConstructorId Name
m
      insertShortest Map ConstructorId Name
m (Referent, Name)
_ = Map ConstructorId Name
m
      m :: Map ConstructorId Name
m = (Map ConstructorId Name
 -> (Referent, Name) -> Map ConstructorId Name)
-> Map ConstructorId Name
-> [(Referent, Name)]
-> Map ConstructorId Name
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map ConstructorId Name
-> (Referent, Name) -> Map ConstructorId Name
insertShortest Map ConstructorId Name
forall a. Monoid a => a
mempty (Map ForwardName (Referent, Name) -> [(Referent, Name)]
forall a. Map ForwardName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Map ForwardName (Referent, Name)
center)
      ctorCountGuess :: Int
ctorCountGuess = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Map ConstructorId Name -> Int
forall k a. Map k a -> Int
Map.size Map ConstructorId Name
m) Maybe Int
ctorCount
   in if Map ConstructorId Name -> Int
forall k a. Map k a -> Int
Map.size Map ConstructorId Name
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ctorCountGuess Bool -> Bool -> Bool
&& (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Name -> Bool) -> (Int -> Maybe Name) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstructorId -> Map ConstructorId Name -> Maybe Name)
-> Map ConstructorId Name -> ConstructorId -> Maybe Name
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConstructorId -> Map ConstructorId Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map ConstructorId Name
m (ConstructorId -> Maybe Name)
-> (Int -> ConstructorId) -> Int -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ConstructorId
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Int
0 .. Int
ctorCountGuess Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
        then [Name] -> Either Output [Name]
forall a b. b -> Either a b
Right ([Name] -> Either Output [Name]) -> [Name] -> Either Output [Name]
forall a b. (a -> b) -> a -> b
$ Map ConstructorId Name -> [Name]
forall k a. Map k a -> [a]
Map.elems Map ConstructorId Name
m
        else Output -> Either Output [Name]
forall a b. a -> Either a b
Left (Output -> Either Output [Name]) -> Output -> Either Output [Name]
forall a b. (a -> b) -> a -> b
$ UpdateOrUpgrade
-> Name -> Map ConstructorId Name -> Maybe Int -> Output
Output.UpdateIncompleteConstructorSet UpdateOrUpgrade
operation Name
n Map ConstructorId Name
m Maybe Int
ctorCount

findCtorNamesMaybe ::
  Output.UpdateOrUpgrade ->
  Names ->
  Map ForwardName (Referent, Name) ->
  Maybe Int ->
  Name ->
  Either Output.Output (Maybe [Name])
findCtorNamesMaybe :: UpdateOrUpgrade
-> Names
-> Map ForwardName (Referent, Name)
-> Maybe Int
-> Name
-> Either Output (Maybe [Name])
findCtorNamesMaybe UpdateOrUpgrade
operation Names
names Map ForwardName (Referent, Name)
forwardCtorNames Maybe Int
ctorCount Name
name =
  case Name -> Relation Name TypeReference -> Bool
forall a b. Ord a => a -> Relation a b -> Bool
Relation.memberDom Name
name (Names -> Relation Name TypeReference
Names.types Names
names) of
    Bool
True -> [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just ([Name] -> Maybe [Name])
-> Either Output [Name] -> Either Output (Maybe [Name])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdateOrUpgrade
-> Names
-> Map ForwardName (Referent, Name)
-> Maybe Int
-> Name
-> Either Output [Name]
findCtorNames UpdateOrUpgrade
operation Names
names Map ForwardName (Referent, Name)
forwardCtorNames Maybe Int
ctorCount Name
name
    Bool
False -> Maybe [Name] -> Either Output (Maybe [Name])
forall a b. b -> Either a b
Right Maybe [Name]
forall a. Maybe a
Nothing

-- Used by `findCtorNames` to filter `forwardCtorNames` to a narrow range which will be searched linearly.
-- >>> incrementLastSegmentChar $ ForwardName.fromName $ Name.unsafeFromText "foo.bar.quux"
-- ForwardName {toList = "foo" :| ["bar","quuy"]}
incrementLastSegmentChar :: ForwardName -> ForwardName
incrementLastSegmentChar :: ForwardName -> ForwardName
incrementLastSegmentChar (ForwardName NonEmpty NameSegment
segments) =
  let ([NameSegment]
initSegments, NameSegment
lastSegment) = (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
List.NonEmpty.init NonEmpty NameSegment
segments, NonEmpty NameSegment -> NameSegment
forall a. NonEmpty a -> a
List.NonEmpty.last NonEmpty NameSegment
segments)
      incrementedLastSegment :: NameSegment
incrementedLastSegment = NameSegment -> NameSegment
incrementLastCharInSegment NameSegment
lastSegment
   in NonEmpty NameSegment -> ForwardName
ForwardName (NonEmpty NameSegment -> ForwardName)
-> NonEmpty NameSegment -> ForwardName
forall a b. (a -> b) -> a -> b
$
        NonEmpty NameSegment
-> (NonEmpty NameSegment -> NonEmpty NameSegment)
-> Maybe (NonEmpty NameSegment)
-> NonEmpty NameSegment
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (NameSegment -> NonEmpty NameSegment
forall a. a -> NonEmpty a
List.NonEmpty.singleton NameSegment
incrementedLastSegment)
          (NonEmpty NameSegment -> NameSegment -> NonEmpty NameSegment
forall a. NonEmpty a -> a -> NonEmpty a
|> NameSegment
incrementedLastSegment)
          ([NameSegment] -> Maybe (NonEmpty NameSegment)
forall a. [a] -> Maybe (NonEmpty a)
List.NonEmpty.nonEmpty [NameSegment]
initSegments)
  where
    incrementLastCharInSegment :: NameSegment -> NameSegment
    incrementLastCharInSegment :: NameSegment -> NameSegment
incrementLastCharInSegment (NameSegment Text
text) =
      let incrementedText :: Text
incrementedText =
            if Text -> Bool
Text.null Text
text
              then Text
text
              else HasCallStack => Text -> Text
Text -> Text
Text.init Text
text Text -> Text -> Text
`Text.append` Char -> Text
Text.singleton (Char -> Char
forall a. Enum a => a -> a
succ (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Char
Text -> Char
Text.last Text
text)
       in Text -> NameSegment
NameSegment Text
incrementedText