mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
get dependents to upgrade
This commit is contained in:
parent
251850c483
commit
17ada33de9
@ -78,6 +78,7 @@ module Unison.Codebase.Branch
|
||||
|
||||
-- ** Term/type queries
|
||||
deepReferents,
|
||||
deepTermReferences,
|
||||
deepTypeReferences,
|
||||
consBranchSnapshot,
|
||||
)
|
||||
@ -120,13 +121,15 @@ import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude hiding (empty)
|
||||
import Unison.Reference (TypeReference)
|
||||
import Unison.Reference (TermReference, TypeReference)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Util.List qualified as List
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
import Unison.Util.Relation qualified as R
|
||||
import Unison.Util.Relation qualified as Relation
|
||||
import Unison.Util.Relation4 qualified as R4
|
||||
import Unison.Util.Set qualified as Set
|
||||
import Unison.Util.Star3 qualified as Star3
|
||||
import Prelude hiding (head, read, subtract)
|
||||
|
||||
@ -143,6 +146,10 @@ instance Hashing.ContentAddressable (Branch0 m) where
|
||||
deepReferents :: Branch0 m -> Set Referent
|
||||
deepReferents = R.dom . deepTerms
|
||||
|
||||
deepTermReferences :: Branch0 m -> Set TermReference
|
||||
deepTermReferences =
|
||||
Set.mapMaybe Referent.toTermReference . deepReferents
|
||||
|
||||
deepTypeReferences :: Branch0 m -> Set TypeReference
|
||||
deepTypeReferences = R.dom . deepTypes
|
||||
|
||||
|
@ -86,6 +86,7 @@ dependencies:
|
||||
- unison-sqlite
|
||||
- unison-syntax
|
||||
- unison-util-base32hex
|
||||
- unison-util-nametree
|
||||
- unison-util-relation
|
||||
- unliftio
|
||||
- unordered-containers
|
||||
|
@ -33,6 +33,8 @@ module Unison.Cli.MonadUtils
|
||||
getMaybeBranchAt,
|
||||
expectBranchAtPath,
|
||||
expectBranchAtPath',
|
||||
expectBranch0AtPath,
|
||||
expectBranch0AtPath',
|
||||
assertNoBranchAtPath',
|
||||
branchExistsAtPath',
|
||||
|
||||
@ -298,6 +300,16 @@ expectBranchAtPath' path0 = do
|
||||
path <- resolvePath' path0
|
||||
getMaybeBranchAt path & onNothingM (Cli.returnEarly (Output.BranchNotFound path0))
|
||||
|
||||
-- | Get the branch0 at an absolute or relative path, or return early if there's no such branch.
|
||||
expectBranch0AtPath' :: Path' -> Cli (Branch0 IO)
|
||||
expectBranch0AtPath' =
|
||||
fmap Branch.head . expectBranchAtPath'
|
||||
|
||||
-- | Get the branch0 at a relative path, or return early if there's no such branch.
|
||||
expectBranch0AtPath :: Path -> Cli (Branch0 IO)
|
||||
expectBranch0AtPath =
|
||||
expectBranch0AtPath' . Path' . Right . Path.Relative
|
||||
|
||||
-- | Assert that there's "no branch" at an absolute or relative path, or return early if there is one, where "no branch"
|
||||
-- means either there's actually no branch, or there is a branch whose head is empty (i.e. it may have a history, but no
|
||||
-- current terms/types etc).
|
||||
|
@ -70,22 +70,15 @@ import Unison.Type (Type)
|
||||
import Unison.UnisonFile qualified as UF
|
||||
import Unison.UnisonFile.Names qualified as UF
|
||||
import Unison.UnisonFile.Type (TypecheckedUnisonFile, UnisonFile)
|
||||
import Unison.Util.Nametree (Defns (..))
|
||||
import Unison.Util.Pretty (Pretty)
|
||||
import Unison.Util.Pretty qualified as Pretty
|
||||
import Unison.Util.Relation qualified as Relation
|
||||
import Unison.Util.Set qualified as Set
|
||||
import Unison.Var (Var)
|
||||
|
||||
data Defns terms types = Defns
|
||||
{ terms :: !terms,
|
||||
types :: !types
|
||||
}
|
||||
deriving stock (Generic, Show)
|
||||
|
||||
handleUpdate2 :: Cli ()
|
||||
handleUpdate2 = do
|
||||
Cli.Env {codebase} <- ask
|
||||
-- - confirm all aliases updated together?
|
||||
tuf <- Cli.expectLatestTypecheckedFile
|
||||
|
||||
-- - get add/updates from TUF
|
||||
@ -97,10 +90,10 @@ handleUpdate2 = do
|
||||
|
||||
let ctorNames = forwardCtorNames namesExcludingLibdeps
|
||||
|
||||
(pped, bigUf) <- Cli.runTransactionWithRollback \_abort -> do
|
||||
(pped, bigUf) <- Cli.runTransaction do
|
||||
dependents <-
|
||||
Ops.dependentsWithinScope
|
||||
(namespaceReferences namesExcludingLibdeps)
|
||||
(Names.referenceIds namesExcludingLibdeps)
|
||||
(getExistingReferencesNamed termAndDeclNames namesExcludingLibdeps)
|
||||
-- - construct PPE for printing UF* for typechecking (whatever data structure we decide to print)
|
||||
pped <- Codebase.hashLength <&> (`PPE.fromNamesDecl` (NamesWithHistory.fromCurrentNames namesIncludingLibdeps))
|
||||
@ -241,7 +234,12 @@ getExistingReferencesNamed defns names = fromTerms <> fromTypes
|
||||
fromTerms = foldMap (\n -> Set.map Referent.toReference $ Relation.lookupDom n $ Names.terms names) (defns ^. #terms)
|
||||
fromTypes = foldMap (\n -> Relation.lookupDom n $ Names.types names) (defns ^. #types)
|
||||
|
||||
buildBigUnisonFile :: Codebase IO Symbol Ann -> TypecheckedUnisonFile Symbol Ann -> Map Reference.Id ReferenceType -> Names -> Transaction (UnisonFile Symbol Ann)
|
||||
buildBigUnisonFile ::
|
||||
Codebase IO Symbol Ann ->
|
||||
TypecheckedUnisonFile Symbol Ann ->
|
||||
Map Reference.Id ReferenceType ->
|
||||
Names ->
|
||||
Transaction (UnisonFile Symbol Ann)
|
||||
buildBigUnisonFile c tuf dependents names =
|
||||
-- for each dependent, add its definition with all its names to the UnisonFile
|
||||
foldM addComponent (UF.discardTypes tuf) (Map.toList dependents')
|
||||
@ -346,12 +344,6 @@ incrementLastSegmentChar (ForwardName segments) =
|
||||
else Text.init text `Text.append` Text.singleton (succ $ Text.last text)
|
||||
in NameSegment incrementedText
|
||||
|
||||
namespaceReferences :: Names -> Set Reference.Id
|
||||
namespaceReferences names = fromTerms <> fromTypes
|
||||
where
|
||||
fromTerms = Set.mapMaybe Referent.toReferenceId (Relation.ran $ Names.terms names)
|
||||
fromTypes = Set.mapMaybe Reference.toId (Relation.ran $ Names.types names)
|
||||
|
||||
getTermAndDeclNames :: Var v => TypecheckedUnisonFile v a -> Defns (Set Name) (Set Name)
|
||||
getTermAndDeclNames tuf = Defns (terms <> effectCtors <> dataCtors) (effects <> datas)
|
||||
where
|
||||
|
@ -3,14 +3,20 @@ module Unison.Codebase.Editor.HandleInput.Upgrade
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (over)
|
||||
import Data.Map.Strict qualified as Map
|
||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Branch.Names qualified as Branch
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl)
|
||||
@ -19,10 +25,18 @@ import Unison.UnisonFile (UnisonFile)
|
||||
|
||||
handleUpgrade :: NameSegment -> NameSegment -> Cli ()
|
||||
handleUpgrade oldDepName newDepName = do
|
||||
oldDepBranch <- Cli.expectBranchAtPath (Path.fromList [Name.libSegment, oldDepName])
|
||||
newDepBranch <- Cli.expectBranchAtPath (Path.fromList [Name.libSegment, newDepName])
|
||||
oldDepBranch <- Cli.expectBranch0AtPath (Path.fromList [Name.libSegment, oldDepName])
|
||||
newDepBranch <- Cli.expectBranch0AtPath (Path.fromList [Name.libSegment, newDepName])
|
||||
currentBranch <- Cli.getCurrentBranch0
|
||||
|
||||
let namesExcludingLibdeps = Branch.toNames (currentBranch & over Branch.children (Map.delete Name.libSegment))
|
||||
|
||||
dependents <-
|
||||
Cli.runTransaction do
|
||||
Operations.dependentsWithinScope
|
||||
(Names.referenceIds namesExcludingLibdeps)
|
||||
(Branch.deepTermReferences oldDepBranch <> Branch.deepTypeReferences newDepBranch)
|
||||
|
||||
let allNames = Branch.toNames currentBranch
|
||||
|
||||
-- Compute "fake names": these are all of things in `lib.old`, with the `old` segment swapped out for `new`
|
||||
|
@ -229,6 +229,7 @@ library
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util-base32hex
|
||||
, unison-util-nametree
|
||||
, unison-util-relation
|
||||
, unliftio
|
||||
, unordered-containers
|
||||
@ -367,6 +368,7 @@ executable cli-integration-tests
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util-base32hex
|
||||
, unison-util-nametree
|
||||
, unison-util-relation
|
||||
, unliftio
|
||||
, unordered-containers
|
||||
@ -500,6 +502,7 @@ executable transcripts
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util-base32hex
|
||||
, unison-util-nametree
|
||||
, unison-util-relation
|
||||
, unliftio
|
||||
, unordered-containers
|
||||
@ -639,6 +642,7 @@ executable unison
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util-base32hex
|
||||
, unison-util-nametree
|
||||
, unison-util-relation
|
||||
, unliftio
|
||||
, unordered-containers
|
||||
@ -781,6 +785,7 @@ test-suite cli-tests
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util-base32hex
|
||||
, unison-util-nametree
|
||||
, unison-util-relation
|
||||
, unliftio
|
||||
, unordered-containers
|
||||
|
@ -30,6 +30,7 @@ module Unison.Names
|
||||
restrictReferences,
|
||||
refTermsNamed,
|
||||
refTermsHQNamed,
|
||||
referenceIds,
|
||||
termReferences,
|
||||
termReferents,
|
||||
typeReferences,
|
||||
@ -150,6 +151,14 @@ fuzzyFind nameToText query names =
|
||||
query
|
||||
)
|
||||
|
||||
-- | Get all (untagged) term/type references ids in a @Names@.
|
||||
referenceIds :: Names -> Set Reference.Id
|
||||
referenceIds Names {terms, types} =
|
||||
fromTerms <> fromTypes
|
||||
where
|
||||
fromTerms = Set.mapMaybe Referent.toReferenceId (Relation.ran terms)
|
||||
fromTypes = Set.mapMaybe Reference.toId (Relation.ran types)
|
||||
|
||||
termReferences :: Names -> Set TermReference
|
||||
termReferences Names {..} = Set.map Referent.toReference $ R.ran terms
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user