mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-20 06:47:15 +03:00
work on upgrade sad path
This commit is contained in:
parent
974725a492
commit
0cf9727132
@ -33,6 +33,7 @@ module Unison.Codebase.Branch
|
||||
-- * properties
|
||||
history,
|
||||
head,
|
||||
head_,
|
||||
headHash,
|
||||
children,
|
||||
nonEmptyChildren,
|
||||
|
@ -138,11 +138,12 @@ isRoot :: Absolute -> Bool
|
||||
isRoot = Seq.null . toSeq . unabsolute
|
||||
|
||||
absoluteToPath' :: Absolute -> Path'
|
||||
absoluteToPath' abs = Path' (Left abs)
|
||||
absoluteToPath' = AbsolutePath'
|
||||
|
||||
instance Show Path' where
|
||||
show (Path' (Left abs)) = show abs
|
||||
show (Path' (Right rel)) = show rel
|
||||
show = \case
|
||||
AbsolutePath' abs -> show abs
|
||||
RelativePath' rel -> show rel
|
||||
|
||||
instance Show Absolute where
|
||||
show s = "." ++ show (unabsolute s)
|
||||
@ -151,8 +152,9 @@ instance Show Relative where
|
||||
show = show . unrelative
|
||||
|
||||
unsplit' :: Split' -> Path'
|
||||
unsplit' (Path' (Left (Absolute p)), seg) = Path' (Left (Absolute (unsplit (p, seg))))
|
||||
unsplit' (Path' (Right (Relative p)), seg) = Path' (Right (Relative (unsplit (p, seg))))
|
||||
unsplit' = \case
|
||||
(AbsolutePath' (Absolute p), seg) -> AbsolutePath' (Absolute (unsplit (p, seg)))
|
||||
(RelativePath' (Relative p), seg) -> RelativePath' (Relative (unsplit (p, seg)))
|
||||
|
||||
unsplit :: Split -> Path
|
||||
unsplit (Path p, a) = Path (p :|> a)
|
||||
@ -182,15 +184,15 @@ type HQSplitAbsolute = (Absolute, HQ'.HQSegment)
|
||||
-- unprefix .foo.bar id == id (relative paths starting w/ nonmatching prefix left alone)
|
||||
-- unprefix .foo.bar foo.bar.baz == baz (relative paths w/ common prefix get stripped)
|
||||
unprefix :: Absolute -> Path' -> Path
|
||||
unprefix (Absolute prefix) (Path' p) = case p of
|
||||
Left abs -> unabsolute abs
|
||||
Right (unrelative -> rel) -> fromList $ dropPrefix (toList prefix) (toList rel)
|
||||
unprefix (Absolute prefix) = \case
|
||||
AbsolutePath' abs -> unabsolute abs
|
||||
RelativePath' rel -> fromList $ dropPrefix (toList prefix) (toList (unrelative rel))
|
||||
|
||||
-- too many types
|
||||
prefix :: Absolute -> Path' -> Path
|
||||
prefix (Absolute (Path prefix)) (Path' p) = case p of
|
||||
Left (unabsolute -> abs) -> abs
|
||||
Right (unrelative -> rel) -> Path $ prefix <> toSeq rel
|
||||
prefix (Absolute (Path prefix)) = \case
|
||||
AbsolutePath' abs -> unabsolute abs
|
||||
RelativePath' rel -> Path $ prefix <> toSeq (unrelative rel)
|
||||
|
||||
-- | Finds the longest shared path prefix of two paths.
|
||||
-- Returns (shared prefix, path to first location from shared prefix, path to second location from shared prefix)
|
||||
@ -218,22 +220,22 @@ relativeEmpty :: Relative
|
||||
relativeEmpty = Relative empty
|
||||
|
||||
relativeEmpty' :: Path'
|
||||
relativeEmpty' = Path' (Right (Relative empty))
|
||||
relativeEmpty' = RelativePath' (Relative empty)
|
||||
|
||||
absoluteEmpty' :: Path'
|
||||
absoluteEmpty' = Path' (Left (Absolute empty))
|
||||
absoluteEmpty' = AbsolutePath' (Absolute empty)
|
||||
|
||||
-- | Mitchell: this function is bogus, because an empty name segment is bogus
|
||||
toPath' :: Path -> Path'
|
||||
toPath' = \case
|
||||
Path (NameSegment "" :<| tail) -> Path' . Left . Absolute . Path $ tail
|
||||
Path (NameSegment "" :<| tail) -> AbsolutePath' . Absolute . Path $ tail
|
||||
p -> Path' . Right . Relative $ p
|
||||
|
||||
-- Forget whether the path is absolute or relative
|
||||
fromPath' :: Path' -> Path
|
||||
fromPath' (Path' e) = case e of
|
||||
Left (Absolute p) -> p
|
||||
Right (Relative p) -> p
|
||||
fromPath' = \case
|
||||
AbsolutePath' (Absolute p) -> p
|
||||
RelativePath' (Relative p) -> p
|
||||
|
||||
toList :: Path -> [NameSegment]
|
||||
toList = Foldable.toList . toSeq
|
||||
@ -301,8 +303,8 @@ fromName = fromList . List.NonEmpty.toList . Name.segments
|
||||
|
||||
fromName' :: Name -> Path'
|
||||
fromName' n = case take 1 (Name.toString n) of
|
||||
"." -> Path' . Left . Absolute $ Path seq
|
||||
_ -> Path' . Right $ Relative path
|
||||
"." -> AbsolutePath' . Absolute $ Path seq
|
||||
_ -> RelativePath' $ Relative path
|
||||
where
|
||||
path = fromName n
|
||||
seq = toSeq path
|
||||
@ -366,15 +368,13 @@ fromText' :: Text -> Path'
|
||||
fromText' txt =
|
||||
case Text.uncons txt of
|
||||
Nothing -> relativeEmpty'
|
||||
Just ('.', p) ->
|
||||
Path' (Left . Absolute $ fromText p)
|
||||
Just _ ->
|
||||
Path' (Right . Relative $ fromText txt)
|
||||
Just ('.', p) -> AbsolutePath' . Absolute $ fromText p
|
||||
Just _ -> RelativePath' . Relative $ fromText txt
|
||||
|
||||
toText' :: Path' -> Text
|
||||
toText' = \case
|
||||
Path' (Left (Absolute path)) -> Text.cons '.' (toText path)
|
||||
Path' (Right (Relative path)) -> toText path
|
||||
AbsolutePath' (Absolute path) -> Text.cons '.' (toText path)
|
||||
RelativePath' (Relative path) -> toText path
|
||||
|
||||
{-# COMPLETE Empty, (:<) #-}
|
||||
|
||||
@ -451,18 +451,18 @@ instance Snoc Path Path NameSegment NameSegment where
|
||||
snoc (Path p) ns = Path (p <> pure ns)
|
||||
|
||||
instance Snoc Path' Path' NameSegment NameSegment where
|
||||
_Snoc = prism (uncurry snoc') $ \case
|
||||
Path' (Left (Lens.unsnoc -> Just (s, a))) -> Right (Path' (Left s), a)
|
||||
Path' (Right (Lens.unsnoc -> Just (s, a))) -> Right (Path' (Right s), a)
|
||||
_Snoc = prism (uncurry snoc') \case
|
||||
AbsolutePath' (Lens.unsnoc -> Just (s, a)) -> Right (AbsolutePath' s, a)
|
||||
RelativePath' (Lens.unsnoc -> Just (s, a)) -> Right (RelativePath' s, a)
|
||||
e -> Left e
|
||||
where
|
||||
snoc' :: Path' -> NameSegment -> Path'
|
||||
snoc' (Path' e) n = case e of
|
||||
Left abs -> Path' (Left . Absolute $ Lens.snoc (unabsolute abs) n)
|
||||
Right rel -> Path' (Right . Relative $ Lens.snoc (unrelative rel) n)
|
||||
snoc' = \case
|
||||
AbsolutePath' abs -> AbsolutePath' . Absolute . Lens.snoc (unabsolute abs)
|
||||
RelativePath' rel -> RelativePath' . Relative . Lens.snoc (unrelative rel)
|
||||
|
||||
instance Snoc Split' Split' NameSegment NameSegment where
|
||||
_Snoc = prism (uncurry snoc') $ \case
|
||||
_Snoc = prism (uncurry snoc') \case
|
||||
-- unsnoc
|
||||
(Lens.unsnoc -> Just (s, a), ns) -> Right ((s, a), ns)
|
||||
e -> Left e
|
||||
@ -482,10 +482,13 @@ instance Resolve Relative Relative Relative where
|
||||
instance Resolve Absolute Relative Absolute where
|
||||
resolve (Absolute l) (Relative r) = Absolute (resolve l r)
|
||||
|
||||
instance Resolve Absolute Relative Path' where
|
||||
resolve l r = AbsolutePath' (resolve l r)
|
||||
|
||||
instance Resolve Path' Path' Path' where
|
||||
resolve _ a@(Path' Left {}) = a
|
||||
resolve (Path' (Left a)) (Path' (Right r)) = Path' (Left (resolve a r))
|
||||
resolve (Path' (Right r1)) (Path' (Right r2)) = Path' (Right (resolve r1 r2))
|
||||
resolve _ a@(AbsolutePath' {}) = a
|
||||
resolve (AbsolutePath' a) (RelativePath' r) = AbsolutePath' (resolve a r)
|
||||
resolve (RelativePath' r1) (RelativePath' r2) = RelativePath' (resolve r1 r2)
|
||||
|
||||
instance Resolve Path' Split' Path' where
|
||||
resolve l r = resolve l (unsplit' r)
|
||||
@ -497,8 +500,8 @@ instance Resolve Absolute HQSplit HQSplitAbsolute where
|
||||
resolve l (r, hq) = (resolve l (Relative r), hq)
|
||||
|
||||
instance Resolve Absolute Path' Absolute where
|
||||
resolve _ (Path' (Left a)) = a
|
||||
resolve a (Path' (Right r)) = resolve a r
|
||||
resolve _ (AbsolutePath' a) = a
|
||||
resolve a (RelativePath' r) = resolve a r
|
||||
|
||||
instance Convert Absolute Path where convert = unabsolute
|
||||
|
||||
|
@ -1,6 +1,6 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.1.
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
|
@ -84,7 +84,7 @@ handleBranch sourceI projectAndBranchNames0 = do
|
||||
-- We can't make the *first* branch of a project with `branch`; the project has to already exist.
|
||||
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
|
||||
|
||||
doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames)
|
||||
_ <- doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames)
|
||||
|
||||
Cli.respond $
|
||||
Output.CreatedProjectBranch
|
||||
@ -106,7 +106,9 @@ handleBranch sourceI projectAndBranchNames0 = do
|
||||
--
|
||||
-- This bit of functionality is factored out from the main 'handleBranch' handler because it is also called by the
|
||||
-- @release.draft@ command, which essentially just creates a branch, but with some different output for the user.
|
||||
doCreateBranch :: CreateFrom -> Sqlite.Project -> ProjectBranchName -> Text -> Cli ()
|
||||
--
|
||||
-- Returns the branch id of the newly-created branch.
|
||||
doCreateBranch :: CreateFrom -> Sqlite.Project -> ProjectBranchName -> Text -> Cli ProjectBranchId
|
||||
doCreateBranch createFrom project newBranchName description = do
|
||||
let projectId = project ^. #projectId
|
||||
newBranchId <-
|
||||
@ -143,3 +145,4 @@ doCreateBranch createFrom project newBranchName description = do
|
||||
CreateFrom'Nothingness -> pure Branch.empty
|
||||
_ <- Cli.updateAt description newBranchPath (const sourceNamespaceObject)
|
||||
Cli.cd newBranchPath
|
||||
pure newBranchId
|
||||
|
@ -3,39 +3,55 @@ module Unison.Codebase.Editor.HandleInput.Upgrade
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (over)
|
||||
import Control.Lens (ix, over, (^.))
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.List qualified as List
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as Cli
|
||||
import Unison.Codebase.Branch (Branch0)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Branch.Names qualified as Branch
|
||||
import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch
|
||||
import Unison.Codebase.Editor.HandleInput.Update2 (addDefinitionsToUnisonFile)
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl)
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName)
|
||||
import Unison.UnisonFile (UnisonFile)
|
||||
import Unison.UnisonFile qualified as UnisonFile
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
handleUpgrade :: NameSegment -> NameSegment -> Cli ()
|
||||
handleUpgrade oldDepName newDepName = do
|
||||
Cli.Env {codebase} <- ask
|
||||
|
||||
oldDepBranch <- Cli.expectBranch0AtPath (Path.fromList [Name.libSegment, oldDepName])
|
||||
newDepBranch <- Cli.expectBranch0AtPath (Path.fromList [Name.libSegment, newDepName])
|
||||
currentBranch <- Cli.getCurrentBranch0
|
||||
(projectAndBranch, _path) <- Cli.expectCurrentProjectBranch
|
||||
let projectId = projectAndBranch ^. #project . #projectId
|
||||
let projectPath = Cli.projectBranchPath (ProjectAndBranch projectId (projectAndBranch ^. #branch . #branchId))
|
||||
let oldDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [Name.libSegment, oldDepName]))
|
||||
let newDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [Name.libSegment, newDepName]))
|
||||
|
||||
let namesIncludingLibdeps = Branch.toNames currentBranch
|
||||
let namesExcludingLibdeps = Branch.toNames (currentBranch & over Branch.children (Map.delete Name.libSegment))
|
||||
currentV1Branch <- Cli.getBranch0At projectPath
|
||||
oldDepV1Branch <- Cli.expectBranch0AtPath' oldDepPath
|
||||
newDepV1Branch <- Cli.expectBranch0AtPath' newDepPath
|
||||
|
||||
let namesIncludingLibdeps = Branch.toNames currentV1Branch
|
||||
let namesExcludingLibdeps = Branch.toNames (currentV1Branch & over Branch.children (Map.delete Name.libSegment))
|
||||
let namesExcludingOldDep = wundefined
|
||||
|
||||
-- Compute "fake names": these are all of things in `lib.old`, with the `old` segment swapped out for `new`
|
||||
@ -51,7 +67,7 @@ handleUpgrade oldDepName newDepName = do
|
||||
dependents <-
|
||||
Operations.dependentsWithinScope
|
||||
(Names.referenceIds namesExcludingLibdeps)
|
||||
(Branch.deepTermReferences oldDepBranch <> Branch.deepTypeReferences newDepBranch)
|
||||
(Branch.deepTermReferences oldDepV1Branch <> Branch.deepTypeReferences newDepV1Branch)
|
||||
unisonFile <- addDefinitionsToUnisonFile codebase namesExcludingLibdeps dependents UnisonFile.emptyUnisonFile
|
||||
-- Construct a PPE to use for rendering the Unison file full of dependents.
|
||||
printPPE :: PrettyPrintEnvDecl <- wundefined (namesExcludingOldDep <> fakeNames)
|
||||
@ -69,9 +85,56 @@ handleUpgrade oldDepName newDepName = do
|
||||
wundefined
|
||||
|
||||
-- Sad path:
|
||||
-- 1. Make a new project branch, stepped forward one causal (tossing `lib.old`).
|
||||
-- 2. Put the busted dependents into scratch.u
|
||||
-- 3. Output message or something.
|
||||
wundefined
|
||||
-- [x] Make a new project branch, stepped forward one causal (tossing `lib.old`).
|
||||
-- [ ] Put the busted dependents into scratch.u
|
||||
-- [ ] Output message or something.
|
||||
let sadPath = False
|
||||
when sadPath do
|
||||
temporaryBranchName <- do
|
||||
-- Small race condition: since picking a branch name and creating the branch happen in different
|
||||
-- transactions, creating could fail.
|
||||
allBranchNames <-
|
||||
fmap (Set.fromList . map snd) do
|
||||
Cli.runTransaction (Queries.loadAllProjectBranchesBeginningWith projectId Nothing)
|
||||
|
||||
pure ()
|
||||
let -- all branch name candidates in order of preference:
|
||||
-- upgrade-<old>-to-<new>
|
||||
-- upgrade-<old>-to-<new>-2
|
||||
-- upgrade-<old>-to-<new>-3
|
||||
-- ...
|
||||
allCandidates :: [ProjectBranchName]
|
||||
allCandidates =
|
||||
preferred : do
|
||||
n <- [(2 :: Int) ..]
|
||||
pure (unsafeFrom @Text (into @Text preferred <> "-" <> tShow n))
|
||||
where
|
||||
preferred :: ProjectBranchName
|
||||
preferred =
|
||||
unsafeFrom @Text $
|
||||
"upgrade-"
|
||||
<> NameSegment.toText oldDepName
|
||||
<> "-to-"
|
||||
<> NameSegment.toText newDepName
|
||||
|
||||
pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates))
|
||||
|
||||
temporaryBranchId <-
|
||||
HandleInput.Branch.doCreateBranch
|
||||
(HandleInput.Branch.CreateFrom'Branch projectAndBranch)
|
||||
(projectAndBranch ^. #project)
|
||||
temporaryBranchName
|
||||
textualDescriptionOfUpgrade
|
||||
|
||||
let temporaryBranchPath :: Path
|
||||
temporaryBranchPath =
|
||||
Path.unabsolute (Cli.projectBranchPath (ProjectAndBranch projectId temporaryBranchId))
|
||||
|
||||
Cli.stepAt textualDescriptionOfUpgrade (temporaryBranchPath, deleteLibdep oldDepName)
|
||||
where
|
||||
textualDescriptionOfUpgrade :: Text
|
||||
textualDescriptionOfUpgrade =
|
||||
Text.unwords ["upgrade", NameSegment.toText oldDepName, NameSegment.toText newDepName]
|
||||
|
||||
deleteLibdep :: NameSegment -> Branch0 m -> Branch0 m
|
||||
deleteLibdep dep =
|
||||
over (Branch.children . ix Name.libSegment . Branch.head_ . Branch.children) (Map.delete dep)
|
||||
|
Loading…
Reference in New Issue
Block a user