mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-05 06:07:21 +03:00
Merge pull request #3693 from unisonweb/22-12-12-diff-namespace-v2
Make `diff.namespace.to-patch` use "v2" branch diffs
This commit is contained in:
Mitchell Rosen
GitHub
commit
af5d1f2f50
@ -54,6 +54,11 @@ toReference = \case
|
||||
Ref termRef -> termRef
|
||||
Con typeRef _ -> typeRef
|
||||
|
||||
toTermReference :: Referent' termRef typeRef -> Maybe termRef
|
||||
toTermReference = \case
|
||||
Ref termRef -> Just termRef
|
||||
Con _ _ -> Nothing
|
||||
|
||||
type Id = Id' Hash Hash
|
||||
|
||||
data Id' hTm hTp
|
||||
|
||||
@ -3,8 +3,10 @@ module U.Codebase.Branch.Diff
|
||||
NameChanges (..),
|
||||
DefinitionDiffs (..),
|
||||
Diff (..),
|
||||
NameBasedDiff (..),
|
||||
diffBranches,
|
||||
nameChanges,
|
||||
nameBasedDiff,
|
||||
)
|
||||
where
|
||||
|
||||
@ -20,10 +22,13 @@ import qualified U.Codebase.Branch.Type as Branch
|
||||
import qualified U.Codebase.Causal as Causal
|
||||
import U.Codebase.Reference (Reference)
|
||||
import U.Codebase.Referent (Referent)
|
||||
import qualified U.Codebase.Referent as Referent
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
import Unison.Util.Relation (Relation)
|
||||
import qualified Unison.Util.Relation as Relation
|
||||
|
||||
data Diff a = Diff
|
||||
{ adds :: Set a,
|
||||
@ -83,56 +88,70 @@ data NameChanges = NameChanges
|
||||
}
|
||||
|
||||
instance Semigroup NameChanges where
|
||||
(NameChanges a b c d) <> (NameChanges a2 b2 c2 d2) =
|
||||
NameChanges a b c d <> NameChanges a2 b2 c2 d2 =
|
||||
NameChanges (a <> a2) (b <> b2) (c <> c2) (d <> d2)
|
||||
|
||||
instance Monoid NameChanges where
|
||||
mempty = NameChanges mempty mempty mempty mempty
|
||||
|
||||
-- | A name-based diff for namespaces `N1` and `N2` is (for both terms and types) a relation between references, where
|
||||
-- `a R b` if:
|
||||
--
|
||||
-- 1. `a` has name `n` in `N1`, and `b` has the same name `n` in `N2`
|
||||
-- 2. `a` != `b`
|
||||
data NameBasedDiff = NameBasedDiff
|
||||
{ terms :: Relation Reference Reference,
|
||||
types :: Relation Reference Reference
|
||||
}
|
||||
deriving stock (Generic, Show)
|
||||
|
||||
instance Monoid NameBasedDiff where
|
||||
mempty = NameBasedDiff mempty mempty
|
||||
|
||||
instance Semigroup NameBasedDiff where
|
||||
NameBasedDiff terms0 types0 <> NameBasedDiff terms1 types1 =
|
||||
NameBasedDiff (terms0 <> terms1) (types0 <> types1)
|
||||
|
||||
-- | Diff two Branches, returning a tree containing all of the changes
|
||||
diffBranches :: forall m. Monad m => Branch m -> Branch m -> m TreeDiff
|
||||
diffBranches from to = do
|
||||
let termDiffs = diffMap (terms from) (terms to)
|
||||
let typeDiffs = diffMap (types from) (types to)
|
||||
let termDiffs = diffMap (Branch.terms from) (Branch.terms to)
|
||||
let typeDiffs = diffMap (Branch.types from) (Branch.types to)
|
||||
let defDiff = DefinitionDiffs {termDiffs, typeDiffs}
|
||||
childDiff <- do
|
||||
Align.align (children from) (children to)
|
||||
& wither
|
||||
( \case
|
||||
This ca -> do
|
||||
-- TODO: For the names index we really don't need to know which exact
|
||||
-- names were removed, we just need to delete from the index using a
|
||||
-- prefix query, this would be faster than crawling to get all the deletes.
|
||||
removedChildBranch <- Causal.value ca
|
||||
Just . unTreeDiff <$> diffBranches removedChildBranch Branch.empty
|
||||
That ca -> do
|
||||
newChildBranch <- Causal.value ca
|
||||
Just . unTreeDiff <$> diffBranches Branch.empty newChildBranch
|
||||
These fromC toC
|
||||
| Causal.valueHash fromC == Causal.valueHash toC -> do
|
||||
-- This child didn't change.
|
||||
pure Nothing
|
||||
| otherwise -> do
|
||||
fromChildBranch <- Causal.value fromC
|
||||
toChildBranch <- Causal.value toC
|
||||
diffBranches fromChildBranch toChildBranch >>= \case
|
||||
Lens.Empty -> pure Nothing
|
||||
TreeDiff cfr -> pure . Just $ cfr
|
||||
)
|
||||
& wither \case
|
||||
This ca -> do
|
||||
-- TODO: For the names index we really don't need to know which exact
|
||||
-- names were removed, we just need to delete from the index using a
|
||||
-- prefix query, this would be faster than crawling to get all the deletes.
|
||||
removedChildBranch <- Causal.value ca
|
||||
Just . unTreeDiff <$> diffBranches removedChildBranch Branch.empty
|
||||
That ca -> do
|
||||
newChildBranch <- Causal.value ca
|
||||
Just . unTreeDiff <$> diffBranches Branch.empty newChildBranch
|
||||
These fromC toC
|
||||
| Causal.valueHash fromC == Causal.valueHash toC -> do
|
||||
-- This child didn't change.
|
||||
pure Nothing
|
||||
| otherwise -> do
|
||||
fromChildBranch <- Causal.value fromC
|
||||
toChildBranch <- Causal.value toC
|
||||
diffBranches fromChildBranch toChildBranch >>= \case
|
||||
Lens.Empty -> pure Nothing
|
||||
TreeDiff cfr -> pure . Just $ cfr
|
||||
pure $ TreeDiff (defDiff :< childDiff)
|
||||
where
|
||||
diffMap :: forall ref. Ord ref => Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Diff ref)
|
||||
diffMap l r =
|
||||
Align.align l r
|
||||
& fmap
|
||||
( \case
|
||||
(This refs) -> (Diff {removals = Map.keysSet refs, adds = mempty})
|
||||
(That refs) -> (Diff {removals = mempty, adds = Map.keysSet refs})
|
||||
(These l' r') ->
|
||||
let lRefs = Map.keysSet l'
|
||||
rRefs = Map.keysSet r'
|
||||
in (Diff {removals = lRefs `Set.difference` rRefs, adds = rRefs `Set.difference` lRefs})
|
||||
)
|
||||
& fmap \case
|
||||
This refs -> Diff {removals = Map.keysSet refs, adds = mempty}
|
||||
That refs -> Diff {removals = mempty, adds = Map.keysSet refs}
|
||||
These l' r' ->
|
||||
let lRefs = Map.keysSet l'
|
||||
rRefs = Map.keysSet r'
|
||||
in Diff {removals = lRefs `Set.difference` rRefs, adds = rRefs `Set.difference` lRefs}
|
||||
|
||||
-- | Get a summary of all of the name adds and removals from a tree diff.
|
||||
--
|
||||
@ -144,22 +163,19 @@ nameChanges ::
|
||||
NameChanges
|
||||
nameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< children)) =
|
||||
let (termNameAdds, termNameRemovals) =
|
||||
( termDiffs
|
||||
& ifoldMap \ns diff ->
|
||||
let name = appendName ns
|
||||
in (listifyNames name $ adds diff, listifyNames name $ removals diff)
|
||||
)
|
||||
termDiffs
|
||||
& ifoldMap \ns diff ->
|
||||
let name = appendName ns
|
||||
in (listifyNames name $ adds diff, listifyNames name $ removals diff)
|
||||
(typeNameAdds, typeNameRemovals) =
|
||||
( typeDiffs
|
||||
& ifoldMap \ns diff ->
|
||||
let name = appendName ns
|
||||
in (listifyNames name $ adds diff, listifyNames name $ removals diff)
|
||||
)
|
||||
typeDiffs
|
||||
& ifoldMap \ns diff ->
|
||||
let name = appendName ns
|
||||
in (listifyNames name $ adds diff, listifyNames name $ removals diff)
|
||||
childNameChanges =
|
||||
( children
|
||||
& ifoldMap \ns childTree ->
|
||||
nameChanges (Just $ appendName ns) (TreeDiff childTree)
|
||||
)
|
||||
children
|
||||
& ifoldMap \ns childTree ->
|
||||
nameChanges (Just $ appendName ns) (TreeDiff childTree)
|
||||
in NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} <> childNameChanges
|
||||
where
|
||||
appendName :: NameSegment -> Name
|
||||
@ -172,3 +188,26 @@ nameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< chil
|
||||
xs
|
||||
& Set.toList
|
||||
& fmap (name,)
|
||||
|
||||
-- | Get a 'NameBasedDiff' from a 'TreeDiff'.
|
||||
nameBasedDiff :: TreeDiff -> NameBasedDiff
|
||||
nameBasedDiff (TreeDiff defnDiffs) =
|
||||
defnDiffs & foldMap \DefinitionDiffs {termDiffs, typeDiffs} ->
|
||||
NameBasedDiff
|
||||
{ terms = foldMap nameBasedTermDiff termDiffs,
|
||||
types = foldMap nameBasedTypeDiff typeDiffs
|
||||
}
|
||||
where
|
||||
nameBasedTermDiff :: Diff Referent -> Relation Reference Reference
|
||||
nameBasedTermDiff Diff {adds, removals} =
|
||||
let termAdds = mapMaybe Referent.toTermReference (Set.toList adds)
|
||||
termRemovals = mapMaybe Referent.toTermReference (Set.toList removals)
|
||||
in ((,) <$> termRemovals <*> termAdds)
|
||||
& filter (\(r0, r1) -> r0 /= r1)
|
||||
& Relation.fromList
|
||||
|
||||
nameBasedTypeDiff :: Diff Reference -> Relation Reference Reference
|
||||
nameBasedTypeDiff Diff {adds, removals} =
|
||||
((,) <$> Set.toList removals <*> Set.toList adds)
|
||||
& filter (\(r0, r1) -> r0 /= r1)
|
||||
& Relation.fromList
|
||||
|
||||
@ -38,6 +38,7 @@ module Unison.Cli.Monad
|
||||
|
||||
-- * Running transactions
|
||||
runTransaction,
|
||||
runEitherTransaction,
|
||||
|
||||
-- * Misc types
|
||||
LoadSourceResult (..),
|
||||
@ -381,3 +382,8 @@ runTransaction :: Sqlite.Transaction a -> Cli a
|
||||
runTransaction action = do
|
||||
Env {codebase} <- ask
|
||||
liftIO (Codebase.runTransaction codebase action)
|
||||
|
||||
-- | Return early if a transaction returns Left.
|
||||
runEitherTransaction :: Sqlite.Transaction (Either Output a) -> Cli a
|
||||
runEitherTransaction action =
|
||||
runTransaction action & onLeftM returnEarly
|
||||
|
||||
@ -13,7 +13,9 @@ module Unison.Cli.MonadUtils
|
||||
|
||||
-- ** Resolving branch identifiers
|
||||
resolveAbsBranchId,
|
||||
resolveAbsBranchIdV2,
|
||||
resolveBranchId,
|
||||
resolveBranchIdToAbsBranchId,
|
||||
resolveShortCausalHash,
|
||||
|
||||
-- ** Getting/setting branches
|
||||
@ -78,6 +80,7 @@ import Control.Monad.State
|
||||
import qualified Data.Configurator as Configurator
|
||||
import qualified Data.Configurator.Types as Configurator
|
||||
import qualified Data.Set as Set
|
||||
import qualified U.Codebase.Branch as V2 (Branch)
|
||||
import qualified U.Codebase.Branch as V2Branch
|
||||
import qualified U.Codebase.Causal as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
@ -101,6 +104,7 @@ import Unison.Parser.Ann (Ann (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (TypeReference)
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Sqlite as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.UnisonFile (TypecheckedUnisonFile)
|
||||
import qualified Unison.Util.Set as Set
|
||||
@ -144,32 +148,54 @@ resolveAbsBranchId = \case
|
||||
Left hash -> resolveShortCausalHash hash
|
||||
Right path -> getBranchAt path
|
||||
|
||||
-- | V2 version of 'resolveAbsBranchId2'.
|
||||
resolveAbsBranchIdV2 :: Input.AbsBranchId -> Sqlite.Transaction (Either Output.Output (V2.Branch Sqlite.Transaction))
|
||||
resolveAbsBranchIdV2 = \case
|
||||
Left shortHash -> do
|
||||
resolveShortCausalHashToCausalHash shortHash >>= \case
|
||||
Left output -> pure (Left output)
|
||||
Right hash -> succeed (Codebase.expectCausalBranchByCausalHash hash)
|
||||
Right path -> succeed (Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path))
|
||||
where
|
||||
succeed getCausal = do
|
||||
causal <- getCausal
|
||||
branch <- V2Causal.value causal
|
||||
pure (Right branch)
|
||||
|
||||
-- | Resolve a @BranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent
|
||||
-- branches by path are OK - the empty branch will be returned).
|
||||
resolveBranchId :: Input.BranchId -> Cli (Branch IO)
|
||||
resolveBranchId branchId = do
|
||||
absBranchId <- traverseOf _Right resolvePath' branchId
|
||||
absBranchId <- resolveBranchIdToAbsBranchId branchId
|
||||
resolveAbsBranchId absBranchId
|
||||
|
||||
-- | Resolve a @BranchId@ to an @AbsBranchId@.
|
||||
resolveBranchIdToAbsBranchId :: Input.BranchId -> Cli Input.AbsBranchId
|
||||
resolveBranchIdToAbsBranchId =
|
||||
traverseOf _Right resolvePath'
|
||||
|
||||
-- | Resolve a @ShortCausalHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found.
|
||||
resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO)
|
||||
resolveShortCausalHash hash = do
|
||||
resolveShortCausalHash shortHash = do
|
||||
Cli.time "resolveShortCausalHash" do
|
||||
Cli.Env {codebase} <- ask
|
||||
(hashSet, len) <-
|
||||
Cli.runTransaction do
|
||||
hashSet <- Codebase.causalHashesByPrefix hash
|
||||
len <- Codebase.branchHashLength
|
||||
pure (hashSet, len)
|
||||
h <-
|
||||
Set.asSingleton hashSet & onNothing do
|
||||
Cli.returnEarly
|
||||
if Set.null hashSet
|
||||
then Output.NoBranchWithHash hash
|
||||
else Output.BranchHashAmbiguous hash (Set.map (SCH.fromHash len) hashSet)
|
||||
branch <- liftIO (Codebase.getBranchForHash codebase h)
|
||||
hash <- Cli.runEitherTransaction (resolveShortCausalHashToCausalHash shortHash)
|
||||
branch <- liftIO (Codebase.getBranchForHash codebase hash)
|
||||
pure (fromMaybe Branch.empty branch)
|
||||
|
||||
resolveShortCausalHashToCausalHash :: ShortCausalHash -> Sqlite.Transaction (Either Output.Output CausalHash)
|
||||
resolveShortCausalHashToCausalHash shortHash = do
|
||||
hashes <- Codebase.causalHashesByPrefix shortHash
|
||||
case Set.asSingleton hashes of
|
||||
Nothing ->
|
||||
fmap Left do
|
||||
if Set.null hashes
|
||||
then pure (Output.NoBranchWithHash shortHash)
|
||||
else do
|
||||
len <- Codebase.branchHashLength
|
||||
pure (Output.BranchHashAmbiguous shortHash (Set.map (SCH.fromHash len) hashes))
|
||||
Just hash -> pure (Right hash)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Getting/Setting branches
|
||||
|
||||
|
||||
@ -12,6 +12,7 @@ import Control.Lens
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.State (StateT)
|
||||
import qualified Control.Monad.State as State
|
||||
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
|
||||
import Control.Monad.Writer (WriterT (..))
|
||||
import Data.Bifunctor (first, second)
|
||||
import qualified Data.Foldable as Foldable
|
||||
@ -41,6 +42,7 @@ import qualified Text.Megaparsec as P
|
||||
import qualified U.Codebase.Branch.Diff as V2Branch
|
||||
import qualified U.Codebase.Causal as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
import qualified U.Codebase.Reference as V2 (Reference)
|
||||
import qualified U.Codebase.Reflog as Reflog
|
||||
import qualified U.Codebase.Sqlite.Operations as Ops
|
||||
import qualified U.Codebase.Sqlite.Queries as Queries
|
||||
@ -64,7 +66,6 @@ import Unison.Codebase.Branch (Branch (..), Branch0 (..))
|
||||
import qualified Unison.Codebase.Branch as Branch
|
||||
import qualified Unison.Codebase.Branch.Merge as Branch
|
||||
import qualified Unison.Codebase.Branch.Names as Branch
|
||||
import qualified Unison.Codebase.BranchDiff as BranchDiff (diff0)
|
||||
import qualified Unison.Codebase.BranchUtil as BranchUtil
|
||||
import qualified Unison.Codebase.Causal as Causal
|
||||
import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..))
|
||||
@ -118,6 +119,7 @@ import Unison.Codebase.PushBehavior (PushBehavior)
|
||||
import qualified Unison.Codebase.PushBehavior as PushBehavior
|
||||
import qualified Unison.Codebase.Runtime as Runtime
|
||||
import qualified Unison.Codebase.ShortCausalHash as SCH
|
||||
import qualified Unison.Codebase.SqliteCodebase.Conversions as Conversions
|
||||
import qualified Unison.Codebase.SyncMode as SyncMode
|
||||
import Unison.Codebase.TermEdit (TermEdit (..))
|
||||
import qualified Unison.Codebase.TermEdit as TermEdit
|
||||
@ -1410,8 +1412,8 @@ loop e = do
|
||||
([fromCH], [toCH]) -> pure (fromCH, toCH)
|
||||
output <-
|
||||
Cli.runTransaction do
|
||||
fromBranch <- (Codebase.expectCausalBranchByCausalHash fromCH) >>= V2Causal.value
|
||||
toBranch <- (Codebase.expectCausalBranchByCausalHash toCH) >>= V2Causal.value
|
||||
fromBranch <- Codebase.expectCausalBranchByCausalHash fromCH >>= V2Causal.value
|
||||
toBranch <- Codebase.expectCausalBranchByCausalHash toCH >>= V2Causal.value
|
||||
treeDiff <- V2Branch.diffBranches fromBranch toBranch
|
||||
let nameChanges = V2Branch.nameChanges Nothing treeDiff
|
||||
pure (DisplayDebugNameDiff nameChanges)
|
||||
@ -1804,58 +1806,34 @@ handleDiffNamespaceToPatch :: Text -> DiffNamespaceToPatchInput -> Cli ()
|
||||
handleDiffNamespaceToPatch description input = do
|
||||
Cli.Env {codebase} <- ask
|
||||
|
||||
branch1 <- Branch.head <$> Cli.resolveBranchId (input ^. #branchId1)
|
||||
branch2 <- Branch.head <$> Cli.resolveBranchId (input ^. #branchId2)
|
||||
branchDiff <- liftIO (BranchDiff.diff0 branch1 branch2)
|
||||
absBranchId1 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId1)
|
||||
absBranchId2 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId2)
|
||||
|
||||
-- Given {old referents} and {new referents}, create term edit patch entries as follows:
|
||||
--
|
||||
-- * If the {new referents} is a singleton set {new referent}, proceed. (Otherwise, the patch we might create would
|
||||
-- not be a function, which is a bogus/conflicted patch).
|
||||
-- * If the new referent is a term reference, not a data constructor, proceed. (Patches currently can't track
|
||||
-- updates to data constructors).
|
||||
-- * For each old term reference (again, throwing constructors away) in {old referents}, create a patch entry that
|
||||
-- maps the old reference to the new. The patch entry includes the typing relationship between the terms, so we
|
||||
-- look the references' types up in the codebase, too.
|
||||
let termNamespaceUpdateToTermEdits :: (Set Referent, Set Referent) -> Sqlite.Transaction (Set (Reference, TermEdit))
|
||||
termNamespaceUpdateToTermEdits (refs0, refs1) =
|
||||
case Set.asSingleton refs1 of
|
||||
Just (Referent.Ref ref1) ->
|
||||
Codebase.getTypeOfTerm codebase ref1 >>= \case
|
||||
Nothing -> pure Set.empty
|
||||
Just ty1 ->
|
||||
Monoid.foldMapM
|
||||
( \ref0 ->
|
||||
Codebase.getTypeOfTerm codebase ref0 <&> \case
|
||||
Nothing -> Set.empty
|
||||
Just ty0 -> Set.singleton (ref0, TermEdit.Replace ref1 (TermEdit.typing ty0 ty1))
|
||||
)
|
||||
(mapMaybe Referent.toTermReference (Set.toList refs0))
|
||||
_ -> pure Set.empty
|
||||
|
||||
-- The same idea as above, but for types: if there's one new reference in {new references}, then map each of the old
|
||||
-- references to it.
|
||||
let typeNamespaceUpdateToTypeEdits :: (Set Reference, Set Reference) -> Set (Reference, TypeEdit)
|
||||
typeNamespaceUpdateToTypeEdits (refs0, refs1) =
|
||||
case Set.asSingleton refs1 of
|
||||
Just ref1 -> Set.map (\ref0 -> (ref0, TypeEdit.Replace ref1)) refs0
|
||||
_ -> Set.empty
|
||||
|
||||
termUpdates <-
|
||||
Cli.runTransaction do
|
||||
(branchDiff ^. #termsDiff . #tallnamespaceUpdates)
|
||||
& Map.elems
|
||||
& Monoid.foldMapM termNamespaceUpdateToTermEdits
|
||||
let typeUpdates =
|
||||
(branchDiff ^. #typesDiff . #tallnamespaceUpdates)
|
||||
& Map.elems
|
||||
& foldMap typeNamespaceUpdateToTypeEdits
|
||||
|
||||
let patch =
|
||||
Patch
|
||||
{ _termEdits = Relation.fromSet termUpdates,
|
||||
_typeEdits = Relation.fromSet typeUpdates
|
||||
}
|
||||
patch <- do
|
||||
Cli.runEitherTransaction do
|
||||
runExceptT do
|
||||
branch1 <- ExceptT (Cli.resolveAbsBranchIdV2 absBranchId1)
|
||||
branch2 <- ExceptT (Cli.resolveAbsBranchIdV2 absBranchId2)
|
||||
lift do
|
||||
branchDiff <- V2Branch.nameBasedDiff <$> V2Branch.diffBranches branch1 branch2
|
||||
termEdits <-
|
||||
(branchDiff ^. #terms)
|
||||
& Relation.domain
|
||||
& Map.toList
|
||||
& traverse \(oldRef, newRefs) -> makeTermEdit codebase oldRef newRefs
|
||||
pure
|
||||
Patch
|
||||
{ _termEdits =
|
||||
termEdits
|
||||
& catMaybes
|
||||
& Relation.fromList,
|
||||
_typeEdits =
|
||||
(branchDiff ^. #types)
|
||||
& Relation.domain
|
||||
& Map.toList
|
||||
& mapMaybe (\(oldRef, newRefs) -> makeTypeEdit oldRef newRefs)
|
||||
& Relation.fromList
|
||||
}
|
||||
|
||||
-- Display the patch that we are about to create.
|
||||
ppe <- suffixifiedPPE =<< makePrintNamesFromLabeled' (Patch.labeledDependencies patch)
|
||||
@ -1868,6 +1846,30 @@ handleDiffNamespaceToPatch description input = do
|
||||
Cli.stepAtM
|
||||
description
|
||||
(Path.unabsolute patchPath, Branch.modifyPatches patchName (const patch))
|
||||
where
|
||||
-- Given {old reference} and {new references}, create term edit patch entries as follows:
|
||||
--
|
||||
-- * If the {new references} is a singleton set {new reference}, proceed. (Otherwise, the patch we might create
|
||||
-- would not be a function, which is a bogus/conflicted patch).
|
||||
-- * Look up {old reference} and {new reference} types in the codebase (which can technically fail, due to
|
||||
-- non-transactionality of this command, though we don't typically delete anything from SQLite), and create a
|
||||
-- patch entry that maps {old reference} to {new reference} with the typing relationship.
|
||||
makeTermEdit ::
|
||||
Codebase m Symbol Ann ->
|
||||
V2.Reference ->
|
||||
Set V2.Reference ->
|
||||
Sqlite.Transaction (Maybe (Reference, TermEdit))
|
||||
makeTermEdit codebase (Conversions.reference2to1 -> oldRef) newRefs =
|
||||
runMaybeT do
|
||||
newRef <- Conversions.reference2to1 <$> MaybeT (pure (Set.asSingleton newRefs))
|
||||
oldRefType <- MaybeT (Codebase.getTypeOfTerm codebase oldRef)
|
||||
newRefType <- MaybeT (Codebase.getTypeOfTerm codebase newRef)
|
||||
pure (oldRef, TermEdit.Replace newRef (TermEdit.typing oldRefType newRefType))
|
||||
|
||||
-- Same idea as 'makeTermEdit', but simpler, because there's nothing to look up in the database.
|
||||
makeTypeEdit :: V2.Reference -> Set V2.Reference -> Maybe (Reference, TypeEdit)
|
||||
makeTypeEdit (Conversions.reference2to1 -> oldRef) newRefs =
|
||||
Set.asSingleton newRefs <&> \newRef -> (oldRef, TypeEdit.Replace (Conversions.reference2to1 newRef))
|
||||
|
||||
-- | Handle a @push@ command.
|
||||
handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
|
||||
|
||||
@ -39,6 +39,5 @@ A summary of the diff:
|
||||
* `one.a` -> `two.a` is a normal update.
|
||||
* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`.
|
||||
* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch.
|
||||
* Oops, a similar case slipped by - `one.d` and `one.e` map to `two.d` and `two.e` respectively, but because `one.d` and
|
||||
`one.e` were aliases, we end up with a busted patch that isn't a function. This is a bug.
|
||||
* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch.
|
||||
* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g` are not common to both namespaces.
|
||||
|
||||
@ -39,11 +39,9 @@ two.e = 6
|
||||
.> diff.namespace.to-patch one two thepatch
|
||||
|
||||
Edited Terms:
|
||||
1. one.b#cp6ri8mtg0 -> 6. two.b
|
||||
2. one.b#dcgdua2lj6 -> 7. two.b
|
||||
3. one.a -> 8. two.a
|
||||
4. one.d -> 9. two.d
|
||||
5. one.d -> 10. two.e
|
||||
1. one.b#cp6ri8mtg0 -> 4. two.b
|
||||
2. one.b#dcgdua2lj6 -> 5. two.b
|
||||
3. one.a -> 6. two.a
|
||||
|
||||
Tip: To remove entries from a patch, use
|
||||
delete.term-replacement or delete.type-replacement, as
|
||||
@ -55,6 +53,5 @@ A summary of the diff:
|
||||
* `one.a` -> `two.a` is a normal update.
|
||||
* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`.
|
||||
* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch.
|
||||
* Oops, a similar case slipped by - `one.d` and `one.e` map to `two.d` and `two.e` respectively, but because `one.d` and
|
||||
`one.e` were aliases, we end up with a busted patch that isn't a function. This is a bug.
|
||||
* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch.
|
||||
* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g are not common to both namespaces.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user