rename BlobType and add submodule to it

This was badly named, it's a not a blob necessarily, but anything that a
tree can refer to.

Also removed the Show instance which was used for serialization to git
format, instead use fmtTreeItemType.

This commit was supported by the NSF-funded DataLad project.
This commit is contained in:
Joey Hess 2018-05-14 14:22:44 -04:00
parent a732004616
commit 0b7f6d24d3
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
12 changed files with 80 additions and 69 deletions

View file

@ -91,7 +91,7 @@ adjustTreeItem ShowMissingAdjustment = noAdjust
ifSymlink :: (TreeItem -> Annex a) -> (TreeItem -> Annex a) -> TreeItem -> Annex a
ifSymlink issymlink notsymlink ti@(TreeItem _f m _s)
| toBlobType m == Just SymlinkBlob = issymlink ti
| toTreeItemType m == Just TreeSymlink = issymlink ti
| otherwise = notsymlink ti
noAdjust :: TreeItem -> Annex (Maybe TreeItem)
@ -101,7 +101,7 @@ adjustToPointer :: TreeItem -> Annex (Maybe TreeItem)
adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case
Just k -> do
Database.Keys.addAssociatedFile k f
Just . TreeItem f (fromBlobType FileBlob)
Just . TreeItem f (fromTreeItemType TreeFile)
<$> hashPointerFile k
Nothing -> return (Just ti)
@ -114,7 +114,7 @@ adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case
absf <- inRepo $ \r -> absPath $
fromTopFilePath f r
linktarget <- calcRepo $ gitannexlink absf k
Just . TreeItem f (fromBlobType SymlinkBlob)
Just . TreeItem f (fromTreeItemType TreeSymlink)
<$> hashSymlink linktarget
Nothing -> return (Just ti)

View file

@ -23,7 +23,7 @@ import qualified Git.Merge
import qualified Git.Ref
import qualified Git
import qualified Git.Branch
import Git.Types (BlobType(..), fromBlobType)
import Git.Types (TreeItemType(..), fromTreeItemType)
import Git.FilePath
import Config
import Annex.ReplaceFile
@ -185,21 +185,23 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
Just sha -> catKey sha
Nothing -> return Nothing
islocked select = select (LsFiles.unmergedBlobType u) == Just SymlinkBlob
islocked select = select (LsFiles.unmergedTreeItemType u) == Just TreeSymlink
combinedmodes = case catMaybes [ourmode, theirmode] of
[] -> Nothing
l -> Just (combineModes l)
where
ourmode = fromBlobType <$> LsFiles.valUs (LsFiles.unmergedBlobType u)
theirmode = fromBlobType <$> LsFiles.valThem (LsFiles.unmergedBlobType u)
ourmode = fromTreeItemType
<$> LsFiles.valUs (LsFiles.unmergedTreeItemType u)
theirmode = fromTreeItemType
<$> LsFiles.valThem (LsFiles.unmergedTreeItemType u)
makeannexlink key select
| islocked select = makesymlink key dest
| otherwise = makepointer key dest destmode
where
dest = variantFile file key
destmode = fromBlobType <$> select (LsFiles.unmergedBlobType u)
destmode = fromTreeItemType <$> select (LsFiles.unmergedTreeItemType u)
stagefile :: FilePath -> Annex FilePath
stagefile f
@ -242,11 +244,11 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
=<< fromRepo (UpdateIndex.lsSubTree b item)
-- Update the work tree to reflect the graft.
unless inoverlay $ case (selectwant (LsFiles.unmergedBlobType u), selectunwant (LsFiles.unmergedBlobType u)) of
unless inoverlay $ case (selectwant (LsFiles.unmergedTreeItemType u), selectunwant (LsFiles.unmergedTreeItemType u)) of
-- Symlinks are never left in work tree when
-- there's a conflict with anything else.
-- So, when grafting in a symlink, we must create it:
(Just SymlinkBlob, _) -> do
(Just TreeSymlink, _) -> do
case selectwant' (LsFiles.unmergedSha u) of
Nothing -> noop
Just sha -> do
@ -254,7 +256,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
replacewithsymlink item link
-- And when grafting in anything else vs a symlink,
-- the work tree already contains what we want.
(_, Just SymlinkBlob) -> noop
(_, Just TreeSymlink) -> noop
_ -> ifM (withworktree item (liftIO . doesDirectoryExist))
-- a conflict between a file and a directory
-- leaves the directory, so since a directory

View file

@ -463,7 +463,7 @@ stageJournal jl = withIndex $ do
sha <- Git.HashObject.hashFile h path
hPutStrLn jlogh file
streamer $ Git.UpdateIndex.updateIndexLine
sha FileBlob (asTopFilePath $ fileJournal file)
sha TreeFile (asTopFilePath $ fileJournal file)
genstream dir h jh jlogh streamer
-- Clean up the staged files, as listed in the temp log file.
-- The temp file is used to avoid needing to buffer all the
@ -573,7 +573,7 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
ChangeFile content' -> do
sha <- hashBlob content'
Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $
Git.UpdateIndex.updateIndexLine sha FileBlob (asTopFilePath file)
Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file)
apply rest file content' trustmap
PreserveFile ->
apply rest file content trustmap

View file

@ -120,11 +120,11 @@ hashPointerFile key = hashBlob (formatPointer key)
stagePointerFile :: FilePath -> Maybe FileMode -> Sha -> Annex ()
stagePointerFile file mode sha =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageFile sha blobtype file)
inRepo (Git.UpdateIndex.stageFile sha treeitemtype file)
where
blobtype
| maybe False isExecutable mode = ExecutableBlob
| otherwise = FileBlob
treeitemtype
| maybe False isExecutable mode = TreeExecutable
| otherwise = TreeFile
writePointerFile :: FilePath -> Key -> Maybe FileMode -> IO ()
writePointerFile file k mode = do

View file

@ -71,9 +71,9 @@ scanUnlockedFiles = whenM (isJust <$> inRepo Git.Branch.current) $ do
=<< catKey (Git.LsTree.sha i)
liftIO $ void cleanup
where
isregfile i = case Git.Types.toBlobType (Git.LsTree.mode i) of
Just Git.Types.FileBlob -> True
Just Git.Types.ExecutableBlob -> True
isregfile i = case Git.Types.toTreeItemType (Git.LsTree.mode i) of
Just Git.Types.TreeFile -> True
Just Git.Types.TreeExecutable -> True
_ -> False
add i k = do
let tf = Git.LsTree.file i