fix hacked up AutoMerge module to work again
This commit is contained in:
parent
d7833def66
commit
c756006374
1 changed files with 14 additions and 25 deletions
|
@ -43,8 +43,6 @@ import qualified Data.ByteString.Lazy as L
|
||||||
-}
|
-}
|
||||||
autoMergeFrom :: Git.Ref -> Maybe Git.Ref -> [Git.Merge.MergeConfig] -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool
|
autoMergeFrom :: Git.Ref -> Maybe Git.Ref -> [Git.Merge.MergeConfig] -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool
|
||||||
autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
|
autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
|
||||||
error "STUBBED FIXME"
|
|
||||||
{-
|
|
||||||
showOutput
|
showOutput
|
||||||
case currbranch of
|
case currbranch of
|
||||||
Nothing -> go Nothing
|
Nothing -> go Nothing
|
||||||
|
@ -64,7 +62,6 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
|
||||||
( resolveMerge old branch False
|
( resolveMerge old branch False
|
||||||
, return False
|
, return False
|
||||||
)
|
)
|
||||||
-}
|
|
||||||
|
|
||||||
{- Resolves a conflicted merge. It's important that any conflicts be
|
{- Resolves a conflicted merge. It's important that any conflicts be
|
||||||
- resolved in a way that itself avoids later merge conflicts, since
|
- resolved in a way that itself avoids later merge conflicts, since
|
||||||
|
@ -107,9 +104,7 @@ autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
|
||||||
-}
|
-}
|
||||||
resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool
|
resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool
|
||||||
resolveMerge us them inoverlay = do
|
resolveMerge us them inoverlay = do
|
||||||
error "STUBBED FIXME"
|
top <- toRawFilePath <$> if inoverlay
|
||||||
{-
|
|
||||||
top <- if inoverlay
|
|
||||||
then pure "."
|
then pure "."
|
||||||
else fromRepo Git.repoPath
|
else fromRepo Git.repoPath
|
||||||
(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
|
(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
|
||||||
|
@ -127,7 +122,7 @@ resolveMerge us them inoverlay = do
|
||||||
unless (null deleted) $
|
unless (null deleted) $
|
||||||
Annex.Queue.addCommand "rm"
|
Annex.Queue.addCommand "rm"
|
||||||
[Param "--quiet", Param "-f", Param "--"]
|
[Param "--quiet", Param "-f", Param "--"]
|
||||||
deleted
|
(map fromRawFilePath deleted)
|
||||||
void $ liftIO cleanup2
|
void $ liftIO cleanup2
|
||||||
|
|
||||||
when merged $ do
|
when merged $ do
|
||||||
|
@ -137,13 +132,10 @@ resolveMerge us them inoverlay = do
|
||||||
cleanConflictCruft mergedks' mergedfs' unstagedmap
|
cleanConflictCruft mergedks' mergedfs' unstagedmap
|
||||||
showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
|
showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
|
||||||
return merged
|
return merged
|
||||||
-}
|
|
||||||
|
|
||||||
resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe FilePath)
|
resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe FilePath)
|
||||||
resolveMerge' _ Nothing _ _ _ = return ([], Nothing)
|
resolveMerge' _ Nothing _ _ _ = return ([], Nothing)
|
||||||
resolveMerge' unstagedmap (Just us) them inoverlay u = do
|
resolveMerge' unstagedmap (Just us) them inoverlay u = do
|
||||||
error "STUBBED FIXME"
|
|
||||||
{-
|
|
||||||
kus <- getkey LsFiles.valUs
|
kus <- getkey LsFiles.valUs
|
||||||
kthem <- getkey LsFiles.valThem
|
kthem <- getkey LsFiles.valThem
|
||||||
case (kus, kthem) of
|
case (kus, kthem) of
|
||||||
|
@ -177,7 +169,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
|
||||||
-- Neither side is annexed file; cannot resolve.
|
-- Neither side is annexed file; cannot resolve.
|
||||||
(Nothing, Nothing) -> return ([], Nothing)
|
(Nothing, Nothing) -> return ([], Nothing)
|
||||||
where
|
where
|
||||||
file = LsFiles.unmergedFile u
|
file = fromRawFilePath $ LsFiles.unmergedFile u
|
||||||
|
|
||||||
getkey select =
|
getkey select =
|
||||||
case select (LsFiles.unmergedSha u) of
|
case select (LsFiles.unmergedSha u) of
|
||||||
|
@ -210,20 +202,20 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
|
||||||
makesymlink key dest = do
|
makesymlink key dest = do
|
||||||
l <- calcRepo $ gitAnnexLink dest key
|
l <- calcRepo $ gitAnnexLink dest key
|
||||||
unless inoverlay $ replacewithsymlink dest l
|
unless inoverlay $ replacewithsymlink dest l
|
||||||
dest' <- stagefile dest
|
dest' <- toRawFilePath <$> stagefile dest
|
||||||
stageSymlink dest' =<< hashSymlink l
|
stageSymlink dest' =<< hashSymlink l
|
||||||
|
|
||||||
replacewithsymlink dest link = withworktree dest $ \f ->
|
replacewithsymlink dest link = withworktree dest $ \f ->
|
||||||
replaceFile f $ makeGitLink link
|
replaceFile f $ makeGitLink link . toRawFilePath
|
||||||
|
|
||||||
makepointer key dest destmode = do
|
makepointer key dest destmode = do
|
||||||
unless inoverlay $
|
unless inoverlay $
|
||||||
unlessM (reuseOldFile unstagedmap key file dest) $
|
unlessM (reuseOldFile unstagedmap key file dest) $
|
||||||
linkFromAnnex key dest destmode >>= \case
|
linkFromAnnex key dest destmode >>= \case
|
||||||
LinkAnnexFailed -> liftIO $
|
LinkAnnexFailed -> liftIO $
|
||||||
writePointerFile dest key destmode
|
writePointerFile (toRawFilePath dest) key destmode
|
||||||
_ -> noop
|
_ -> noop
|
||||||
dest' <- stagefile dest
|
dest' <- toRawFilePath <$> stagefile dest
|
||||||
stagePointerFile dest' destmode =<< hashPointerFile key
|
stagePointerFile dest' destmode =<< hashPointerFile key
|
||||||
unless inoverlay $
|
unless inoverlay $
|
||||||
Database.Keys.addAssociatedFile key
|
Database.Keys.addAssociatedFile key
|
||||||
|
@ -247,7 +239,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
|
||||||
Nothing -> noop
|
Nothing -> noop
|
||||||
Just sha -> do
|
Just sha -> do
|
||||||
link <- catSymLinkTarget sha
|
link <- catSymLinkTarget sha
|
||||||
replacewithsymlink item link
|
replacewithsymlink item (fromRawFilePath link)
|
||||||
-- And when grafting in anything else vs a symlink,
|
-- And when grafting in anything else vs a symlink,
|
||||||
-- the work tree already contains what we want.
|
-- the work tree already contains what we want.
|
||||||
(_, Just TreeSymlink) -> noop
|
(_, Just TreeSymlink) -> noop
|
||||||
|
@ -273,7 +265,6 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
|
||||||
[Param "--quiet", Param "-f", Param "--cached", Param "--"] [file]
|
[Param "--quiet", Param "-f", Param "--cached", Param "--"] [file]
|
||||||
void a
|
void a
|
||||||
return (ks, Just file)
|
return (ks, Just file)
|
||||||
-}
|
|
||||||
|
|
||||||
{- git-merge moves conflicting files away to files
|
{- git-merge moves conflicting files away to files
|
||||||
- named something like f~HEAD or f~branch or just f, but the
|
- named something like f~HEAD or f~branch or just f, but the
|
||||||
|
@ -287,8 +278,6 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
|
||||||
-}
|
-}
|
||||||
cleanConflictCruft :: [Key] -> [FilePath] -> InodeMap -> Annex ()
|
cleanConflictCruft :: [Key] -> [FilePath] -> InodeMap -> Annex ()
|
||||||
cleanConflictCruft resolvedks resolvedfs unstagedmap = do
|
cleanConflictCruft resolvedks resolvedfs unstagedmap = do
|
||||||
error "STUBBED FIXME"
|
|
||||||
{-
|
|
||||||
is <- S.fromList . map (inodeCacheToKey Strongly) . concat
|
is <- S.fromList . map (inodeCacheToKey Strongly) . concat
|
||||||
<$> mapM Database.Keys.getInodeCaches resolvedks
|
<$> mapM Database.Keys.getInodeCaches resolvedks
|
||||||
forM_ (M.toList unstagedmap) $ \(i, f) ->
|
forM_ (M.toList unstagedmap) $ \(i, f) ->
|
||||||
|
@ -301,11 +290,10 @@ cleanConflictCruft resolvedks resolvedfs unstagedmap = do
|
||||||
matchesresolved is i f
|
matchesresolved is i f
|
||||||
| S.member f fs || S.member (conflictCruftBase f) fs = anyM id
|
| S.member f fs || S.member (conflictCruftBase f) fs = anyM id
|
||||||
[ pure (S.member i is)
|
[ pure (S.member i is)
|
||||||
, inks <$> isAnnexLink f
|
, inks <$> isAnnexLink (toRawFilePath f)
|
||||||
, inks <$> liftIO (isPointerFile f)
|
, inks <$> liftIO (isPointerFile (toRawFilePath f))
|
||||||
]
|
]
|
||||||
| otherwise = return False
|
| otherwise = return False
|
||||||
-}
|
|
||||||
|
|
||||||
conflictCruftBase :: FilePath -> FilePath
|
conflictCruftBase :: FilePath -> FilePath
|
||||||
conflictCruftBase f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f
|
conflictCruftBase f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f
|
||||||
|
@ -340,13 +328,14 @@ commitResolvedMerge commitmode = inRepo $ Git.Branch.commitCommand commitmode
|
||||||
|
|
||||||
type InodeMap = M.Map InodeCacheKey FilePath
|
type InodeMap = M.Map InodeCacheKey FilePath
|
||||||
|
|
||||||
inodeMap :: Annex ([FilePath], IO Bool) -> Annex InodeMap
|
inodeMap :: Annex ([RawFilePath], IO Bool) -> Annex InodeMap
|
||||||
inodeMap getfiles = do
|
inodeMap getfiles = do
|
||||||
(fs, cleanup) <- getfiles
|
(fs, cleanup) <- getfiles
|
||||||
fsis <- forM fs $ \f -> do
|
fsis <- forM fs $ \f -> do
|
||||||
mi <- withTSDelta (liftIO . genInodeCache f)
|
let f' = fromRawFilePath f
|
||||||
|
mi <- withTSDelta (liftIO . genInodeCache f')
|
||||||
return $ case mi of
|
return $ case mi of
|
||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
Just i -> Just (inodeCacheToKey Strongly i, f)
|
Just i -> Just (inodeCacheToKey Strongly i, f')
|
||||||
void $ liftIO cleanup
|
void $ liftIO cleanup
|
||||||
return $ M.fromList $ catMaybes fsis
|
return $ M.fromList $ catMaybes fsis
|
||||||
|
|
Loading…
Add table
Reference in a new issue