mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

improve type signatures with a Ref newtype

Browse source 
In git, a Ref can be a Sha, or a Branch, or a Tag. I added type aliases for
those. Note that this does not prevent mixing up of eg, refs and branches
at the type level. Since git really doesn't care, except rare cases like
git update-ref, or git tag -d, that seems ok for now.

There's also a tree-ish, but let's just use Ref for it. A given Sha or Ref
may or may not be a tree-ish, depending on the object type, so there seems
no point in trying to represent it at the type level.
This commit is contained in:
Joey Hess 2011-11-16 02:23:34 -04:00
parent 272a67921c
commit 9290095fc2
10 changed files with 86 additions and 71 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

47
Annex/Branch.hs
View file

@ -31,19 +31,17 @@ import qualified Git.UnionMerge
import qualified Annex
import Annex.CatFile
type GitRef = String
{- Name of the branch that is used to store git-annex's information. -}
name :: GitRef
name = "git-annex"
name :: Git.Ref
name = Git.Ref "git-annex"
{- Fully qualified name of the branch. -}
fullname :: GitRef
fullname = "refs/heads/" ++ name
fullname :: Git.Ref
fullname = Git.Ref $ "refs/heads/" ++ show name
{- Branch's name in origin. -}
originname :: GitRef
originname = "origin/" ++ name
originname :: Git.Ref
originname = Git.Ref $ "origin/" ++ show name
{- A separate index file for the branch. -}
index :: Git.Repo -> FilePath
@ -104,7 +102,8 @@ create :: Annex ()
create = unlessM hasBranch $ do
e <- hasOrigin
if e
then inRepo $ Git.run "branch" [Param name, Param originname]
then inRepo $ Git.run "branch"
[Param $ show name, Param $ show originname]
else withIndex' True $
inRepo $ Git.commit "branch created" fullname []
@ -140,8 +139,8 @@ update = onceonly $ do
let merge_desc = if null branches
then "update"
else "merging " ++
(unwords $ map Git.refDescribe branches) ++
" into " ++ name
(unwords $ map (show . Git.refDescribe) branches) ++
" into " ++ show name
unless (null branches) $ do
showSideAction merge_desc
{- Note: This merges the branches into the index.
@ -164,12 +163,12 @@ update = onceonly $ do
{- Checks if the second branch has any commits not present on the first
- branch. -}
changedBranch :: String -> String -> Annex Bool
changedBranch :: Git.Branch -> Git.Branch -> Annex Bool
changedBranch origbranch newbranch = not . L.null <$> diffs
where
diffs = inRepo $ Git.pipeRead
[ Param "log"
, Param (origbranch ++ ".." ++ newbranch)
, Param (show origbranch ++ ".." ++ show newbranch)
, Params "--oneline -n1"
]
@ -181,7 +180,7 @@ changedBranch origbranch newbranch = not . L.null <$> diffs
- every commit present in all the other refs, as well as in the
- git-annex branch.
-}
tryFastForwardTo :: [String] -> Annex Bool
tryFastForwardTo :: [Git.Ref] -> Annex Bool
tryFastForwardTo [] = return True
tryFastForwardTo (first:rest) = do
-- First, check that the git-annex branch does not contain any
@ -194,7 +193,7 @@ tryFastForwardTo (first:rest) = do
where
no_ff = return False
do_ff branch = do
inRepo $ Git.run "update-ref" [Param fullname, Param branch]
inRepo $ Git.run "update-ref" [Param $ show fullname, Param $ show branch]
return True
findbest c [] = return $ Just c
findbest c (r:rs)
@ -220,9 +219,9 @@ disableUpdate = Annex.changeState setupdated
old = Annex.branchstate s
{- Checks if a git ref exists. -}
refExists :: GitRef -> Annex Bool
refExists :: Git.Ref -> Annex Bool
refExists ref = inRepo $ Git.runBool "show-ref"
[Param "--verify", Param "-q", Param ref]
[Param "--verify", Param "-q", Param $ show ref]
{- Does the main git-annex branch exist? -}
hasBranch :: Annex Bool
@ -238,12 +237,12 @@ hasSomeBranch = not . null <$> siblingBranches
{- List of git-annex (refs, branches), including the main one and any
- from remotes. Duplicate refs are filtered out. -}
siblingBranches :: Annex [(String, String)]
siblingBranches :: Annex [(Git.Ref, Git.Branch)]
siblingBranches = do
r <- inRepo $ Git.pipeRead [Param "show-ref", Param name]
return $ nubBy uref $ map (pair . words . L.unpack) (L.lines r)
r <- inRepo $ Git.pipeRead [Param "show-ref", Param $ show name]
return $ nubBy uref $ map (gen . words . L.unpack) (L.lines r)
where
pair l = (head l, last l)
gen l = (Git.Ref $ head l, Git.Ref $ last l)
uref (a, _) (b, _) = a == b
{- Applies a function to modifiy the content of a file.
@ -291,7 +290,7 @@ get' staleok file = fromcache =<< getCache file
files :: Annex [FilePath]
files = withIndexUpdate $ do
bfiles <- inRepo $ Git.pipeNullSplit
[Params "ls-tree --name-only -r -z", Param fullname]
[Params "ls-tree --name-only -r -z", Param $ show fullname]
jfiles <- getJournalledFiles
return $ jfiles ++ bfiles
@ -346,10 +345,10 @@ stageJournalFiles = do
hClose toh
exitSuccess
hClose toh
s <- hGetContents fromh
shas <- map Git.Ref . lines <$> hGetContents fromh
-- update the index, also in just one command
Git.UnionMerge.update_index g $
index_lines (lines s) $ map fileJournal fs
index_lines shas (map fileJournal fs)
hClose fromh
forceSuccess pid
mapM_ removeFile paths

3
Annex/CatFile.hs
View file

@ -13,10 +13,11 @@ module Annex.CatFile (
import qualified Data.ByteString.Lazy.Char8 as L
import Common.Annex
import qualified Git
import qualified Git.CatFile
import qualified Annex
catFile :: String -> FilePath -> Annex L.ByteString
catFile :: Git.Branch -> FilePath -> Annex L.ByteString
catFile branch file = do
h <- catFileHandle
liftIO $ Git.CatFile.catFile h branch file

6
Command/Uninit.hs
View file

@ -26,9 +26,9 @@ check :: Annex ()
check = do
b <- current_branch
when (b == Annex.Branch.name) $ error $
"cannot uninit when the " ++ b ++ " branch is checked out"
"cannot uninit when the " ++ show b ++ " branch is checked out"
where
current_branch = head . lines . B.unpack <$> revhead
current_branch = Git.Ref . head . lines . B.unpack <$> revhead
revhead = inRepo $ Git.pipeRead
[Params "rev-parse --abbrev-ref HEAD"]
@ -57,5 +57,5 @@ cleanup = do
liftIO $ removeDirectoryRecursive annexdir
-- avoid normal shutdown
saveState
inRepo $ Git.run "branch" [Param "-D", Param Annex.Branch.name]
inRepo $ Git.run "branch" [Param "-D", Param $ show Annex.Branch.name]
liftIO exitSuccess

7
Command/Unused.hs
View file

@ -152,12 +152,13 @@ excludeReferenced l = do
(S.fromList l)
where
-- Skip the git-annex branches, and get all other unique refs.
refs = map last .
refs = map Git.Ref .
last .
nubBy cmpheads .
filter ourbranches .
map words . lines . L.unpack
cmpheads a b = head a == head b
ourbranchend = '/' : Annex.Branch.name
ourbranchend = '/' : show (Annex.Branch.name)
ourbranches ws = not $ ourbranchend `isSuffixOf` last ws
removewith [] s = return $ S.toList s
removewith (a:as) s
@ -188,7 +189,7 @@ getKeysReferenced = do
return $ map fst $ catMaybes keypairs
{- List of keys referenced by symlinks in a git ref. -}
getKeysReferencedInGit :: String -> Annex [Key]
getKeysReferencedInGit :: Git.Ref -> Annex [Key]
getKeysReferencedInGit ref = do
showAction $ "checking " ++ Git.refDescribe ref
findkeys [] =<< inRepo (LsTree.lsTree ref)

36
Git.hs
View file

@ -10,6 +10,10 @@
module Git (
Repo,
Ref(..),
Branch,
Sha,
Tag,
repoFromCwd,
repoFromAbsPath,
repoFromUnknown,
@ -94,6 +98,18 @@ data Repo = Repo {
remoteName :: Maybe String
} deriving (Show, Eq)
{- A git ref. Can be a sha1, or a branch or tag name. -}
newtype Ref = Ref String
deriving (Eq)
instance Show Ref where
show (Ref v) = v
{- Aliases for Ref. -}
type Branch = Ref
type Sha = Ref
type Tag = Ref
newFrom :: RepoLocation -> Repo
newFrom l =
Repo {
@ -162,9 +178,9 @@ repoDescribe Repo { location = Url url } = show url
repoDescribe Repo { location = Dir dir } = dir
repoDescribe Repo { location = Unknown } = "UNKNOWN"
{- Converts a fully qualified git ref into a user-visible version -}
refDescribe :: String -> String
refDescribe = remove "refs/heads/" . remove "refs/remotes/"
{- Converts a fully qualified git ref into a user-visible version. -}
refDescribe :: Ref -> String
refDescribe = remove "refs/heads/" . remove "refs/remotes/" . show
where
remove prefix s
| prefix `isPrefixOf` s = drop (length prefix) s
@ -432,7 +448,7 @@ useIndex index = do
{- Runs an action that causes a git subcommand to emit a sha, and strips
any trailing newline, returning the sha. -}
getSha :: String -> IO String -> IO String
getSha :: String -> IO String -> IO Sha
getSha subcommand a = do
t <- a
let t' = if last t == '\n'
@ -440,27 +456,27 @@ getSha subcommand a = do
else t
when (length t' /= shaSize) $
error $ "failed to read sha from git " ++ subcommand ++ " (" ++ t' ++ ")"
return t'
return $ Ref t'
{- Size of a git sha. -}
shaSize :: Int
shaSize = 40
{- Commits the index into the specified branch,
{- Commits the index into the specified branch (or other ref),
- with the specified parent refs. -}
commit :: String -> String -> [String] -> Repo -> IO ()
commit :: String -> Ref -> [Ref] -> Repo -> IO ()
commit message newref parentrefs repo = do
tree <- getSha "write-tree" $ asString $
pipeRead [Param "write-tree"] repo
sha <- getSha "commit-tree" $ asString $
ignorehandle $ pipeWriteRead
(map Param $ ["commit-tree", tree] ++ ps)
(map Param $ ["commit-tree", show tree] ++ ps)
(L.pack message) repo
run "update-ref" [Param newref, Param sha] repo
run "update-ref" [Param $ show newref, Param $ show sha] repo
where
ignorehandle a = snd <$> a
asString a = L.unpack <$> a
ps = concatMap (\r -> ["-p", r]) parentrefs
ps = concatMap (\r -> ["-p", show r]) parentrefs
{- Runs git config and populates a repo with its config. -}
configRead :: Repo -> IO Repo

10
Git/CatFile.hs
View file

@ -37,14 +37,14 @@ catFileStop (pid, from, to) = do
forceSuccess pid
{- Reads a file from a specified branch. -}
catFile :: CatFileHandle -> String -> FilePath -> IO L.ByteString
catFile h branch file = catObject h (branch ++ ":" ++ file)
catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
catFile h branch file = catObject h $ Ref $ show branch ++ ":" ++ file
{- Uses a running git cat-file read the content of an object.
- Objects that do not exist will have "" returned. -}
catObject :: CatFileHandle -> String -> IO L.ByteString
catObject :: CatFileHandle -> Ref -> IO L.ByteString
catObject (_, from, to) object = do
hPutStrLn to object
hPutStrLn to $ show object
hFlush to
header <- hGetLine from
case words header of
@ -53,7 +53,7 @@ catObject (_, from, to) object = do
validobjtype objtype -> handle size
| otherwise -> empty
_
| header == object ++ " missing" -> empty
| header == show object ++ " missing" -> empty
| otherwise -> error $ "unknown response from git cat-file " ++ header
where
handle size = case reads size of

8
Git/LsTree.hs
View file

@ -19,8 +19,6 @@ import qualified Data.ByteString.Lazy.Char8 as L
import Git
import Utility.SafeCommand
type Treeish = String
data TreeItem = TreeItem
{ mode :: FileMode
, typeobj :: String
@ -28,10 +26,10 @@ data TreeItem = TreeItem
, file :: FilePath
} deriving Show
{- Lists the contents of a Treeish -}
lsTree :: Treeish -> Repo -> IO [TreeItem]
{- Lists the contents of a Ref -}
lsTree :: Ref -> Repo -> IO [TreeItem]
lsTree t repo = map parseLsTree <$>
pipeNullSplitB [Params "ls-tree --full-tree -z -r --", File t] repo
pipeNullSplitB [Params "ls-tree --full-tree -z -r --", File $ show t] repo
{- Parses a line of ls-tree output.
- (The --long format is not currently supported.) -}

34
Git/UnionMerge.hs
View file

@ -22,12 +22,14 @@ import Common
import Git
import Git.CatFile
type Streamer = (String -> IO ()) -> IO ()
{- Performs a union merge between two branches, staging it in the index.
- Any previously staged changes in the index will be lost.
-
- Should be run with a temporary index file configured by Git.useIndex.
-}
merge :: String -> String -> Repo -> IO ()
merge :: Ref -> Ref -> Repo -> IO ()
merge x y repo = do
h <- catFileStart repo
stream_update_index repo
@ -38,7 +40,7 @@ merge x y repo = do
{- Merges a list of branches into the index. Previously staged changed in
- the index are preserved (and participate in the merge). -}
merge_index :: CatFileHandle -> Repo -> [String] -> IO ()
merge_index :: CatFileHandle -> Repo -> [Ref] -> IO ()
merge_index h repo bs =
stream_update_index repo $ map (\b -> merge_tree_index b h repo) bs
@ -48,8 +50,6 @@ merge_index h repo bs =
update_index :: Repo -> [String] -> IO ()
update_index repo ls = stream_update_index repo [\s -> mapM_ s ls]
type Streamer = (String -> IO ()) -> IO ()
{- Streams content into update-index. -}
stream_update_index :: Repo -> [Streamer] -> IO ()
stream_update_index repo as = do
@ -66,22 +66,22 @@ stream_update_index repo as = do
{- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -}
update_index_line :: String -> FilePath -> String
update_index_line sha file = "100644 blob " ++ sha ++ "\t" ++ file
update_index_line :: Sha -> FilePath -> String
update_index_line sha file = "100644 blob " ++ show sha ++ "\t" ++ file
{- Gets the contents of a tree. -}
ls_tree :: String -> Repo -> Streamer
ls_tree x repo streamer = mapM_ streamer =<< pipeNullSplit params repo
{- Gets the current tree for a ref. -}
ls_tree :: Ref -> Repo -> Streamer
ls_tree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
{- For merging two trees. -}
merge_trees :: String -> String -> CatFileHandle -> Repo -> Streamer
merge_trees x y h = calc_merge h $ "diff-tree":diff_opts ++ [x, y]
merge_trees :: Ref -> Ref -> CatFileHandle -> Repo -> Streamer
merge_trees (Ref x) (Ref y) h = calc_merge h $ "diff-tree":diff_opts ++ [x, y]
{- For merging a single tree into the index. -}
merge_tree_index :: String -> CatFileHandle -> Repo -> Streamer
merge_tree_index x h = calc_merge h $ "diff-index":diff_opts ++ ["--cached", x]
merge_tree_index :: Ref -> CatFileHandle -> Repo -> Streamer
merge_tree_index (Ref x) h = calc_merge h $ "diff-index":diff_opts ++ ["--cached", x]
diff_opts :: [String]
diff_opts = ["--raw", "-z", "-r", "--no-renames", "-l0"]
@ -101,7 +101,7 @@ calc_merge ch differ repo streamer = gendiff >>= go
- a line suitable for update_index that union merges the two sides of the
- diff. -}
mergeFile :: String -> FilePath -> CatFileHandle -> Repo -> IO (Maybe String)
mergeFile info file h repo = case filter (/= nullsha) [asha, bsha] of
mergeFile info file h repo = case filter (/= nullsha) [Ref asha, Ref bsha] of
[] -> return Nothing
(sha:[]) -> return $ Just $ update_index_line sha file
shas -> do
@ -110,11 +110,11 @@ mergeFile info file h repo = case filter (/= nullsha) [asha, bsha] of
return $ Just $ update_index_line sha file
where
[_colonamode, _bmode, asha, bsha, _status] = words info
nullsha = replicate shaSize '0'
nullsha = Ref $ replicate shaSize '0'
unionmerge = L.unlines . nub . L.lines
{- Injects some content into git, returning its hash. -}
hashObject :: L.ByteString -> Repo -> IO String
{- Injects some content into git, returning its Sha. -}
hashObject :: L.ByteString -> Repo -> IO Sha
hashObject content repo = getSha subcmd $ do
(h, s) <- pipeWriteRead (map Param params) content repo
L.length s `seq` do

4
Upgrade/V2.hs
View file

@ -86,7 +86,7 @@ logFiles dir = return . filter (".log" `isSuffixOf`)
push :: Annex ()
push = do
origin_master <- Annex.Branch.refExists "origin/master"
origin_master <- Annex.Branch.refExists $ Git.Ref "origin/master"
origin_gitannex <- Annex.Branch.hasOrigin
case (origin_master, origin_gitannex) of
(_, True) -> do
@ -103,7 +103,7 @@ push = do
Annex.Branch.update -- just in case
showAction "pushing new git-annex branch to origin"
showOutput
inRepo $ Git.run "push" [Param "origin", Param Annex.Branch.name]
inRepo $ Git.run "push" [Param "origin", Param $ show Annex.Branch.name]
_ -> do
-- no origin exists, so just let the user
-- know about the new branch

2
git-union-merge.hs
View file

@ -37,7 +37,7 @@ parseArgs = do
main :: IO ()
main = do
[aref, bref, newref] <- parseArgs
[aref, bref, newref] <- map Git.Ref <$> parseArgs
g <- Git.configRead =<< Git.repoFromCwd
_ <- Git.useIndex (tmpIndex g)
setup g