
I'm down to 9 places in the code that can produce unwaited for zombies. Most of these are pretty innocuous, at least for now, are only used in short-running commands, or commands that run a set of actions and explicitly reap zombies after each one. The one from Annex.Branch.files could be trouble later, since both Command.Fsck and Command.Unused can trigger it, and the assistant will be doing those eventally. Ditto the one in Git.LsTree.lsTree, which Command.Unused uses. The only ones currently affecting the assistant though, are in Git.LsFiles. Several threads use several of those. (And yeah, using pipes or ResourceT would be a less ad-hoc approach, but I don't really feel like ripping my entire code base apart right now to change a foundation monad. Maybe one of these days..)
156 lines
4.9 KiB
Haskell
156 lines
4.9 KiB
Haskell
{- git ls-files interface
|
|
-
|
|
- Copyright 2010,2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Git.LsFiles (
|
|
inRepo,
|
|
notInRepo,
|
|
staged,
|
|
stagedNotDeleted,
|
|
changedUnstaged,
|
|
typeChanged,
|
|
typeChangedStaged,
|
|
Conflicting(..),
|
|
Unmerged(..),
|
|
unmerged,
|
|
) where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Command
|
|
import Git.Types
|
|
import Git.Sha
|
|
|
|
{- Scans for files that are checked into git at the specified locations. -}
|
|
inRepo :: [FilePath] -> Repo -> IO [FilePath]
|
|
inRepo l = pipeNullSplitZombie $ Params "ls-files --cached -z --" : map File l
|
|
|
|
{- Scans for files at the specified locations that are not checked into git. -}
|
|
notInRepo :: Bool -> [FilePath] -> Repo -> IO [FilePath]
|
|
notInRepo include_ignored l repo = pipeNullSplitZombie params repo
|
|
where
|
|
params = [Params "ls-files --others"] ++ exclude ++
|
|
[Params "-z --"] ++ map File l
|
|
exclude
|
|
| include_ignored = []
|
|
| otherwise = [Param "--exclude-standard"]
|
|
|
|
{- Returns a list of all files that are staged for commit. -}
|
|
staged :: [FilePath] -> Repo -> IO [FilePath]
|
|
staged = staged' []
|
|
|
|
{- Returns a list of the files, staged for commit, that are being added,
|
|
- moved, or changed (but not deleted), from the specified locations. -}
|
|
stagedNotDeleted :: [FilePath] -> Repo -> IO [FilePath]
|
|
stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
|
|
|
|
staged' :: [CommandParam] -> [FilePath] -> Repo -> IO [FilePath]
|
|
staged' ps l = pipeNullSplitZombie $ prefix ++ ps ++ suffix
|
|
where
|
|
prefix = [Params "diff --cached --name-only -z"]
|
|
suffix = Param "--" : map File l
|
|
|
|
{- Returns a list of files that have unstaged changes. -}
|
|
changedUnstaged :: [FilePath] -> Repo -> IO [FilePath]
|
|
changedUnstaged l = pipeNullSplitZombie params
|
|
where
|
|
params = Params "diff --name-only -z --" : map File l
|
|
|
|
{- Returns a list of the files in the specified locations that are staged
|
|
- for commit, and whose type has changed. -}
|
|
typeChangedStaged :: [FilePath] -> Repo -> IO [FilePath]
|
|
typeChangedStaged = typeChanged' [Param "--cached"]
|
|
|
|
{- Returns a list of the files in the specified locations whose type has
|
|
- changed. Files only staged for commit will not be included. -}
|
|
typeChanged :: [FilePath] -> Repo -> IO [FilePath]
|
|
typeChanged = typeChanged' []
|
|
|
|
typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO [FilePath]
|
|
typeChanged' ps l repo = do
|
|
fs <- pipeNullSplitZombie (prefix ++ ps ++ suffix) repo
|
|
-- git diff returns filenames relative to the top of the git repo;
|
|
-- convert to filenames relative to the cwd, like git ls-files.
|
|
let top = repoPath repo
|
|
cwd <- getCurrentDirectory
|
|
return $ map (\f -> relPathDirToFile cwd $ top </> f) fs
|
|
where
|
|
prefix = [Params "diff --name-only --diff-filter=T -z"]
|
|
suffix = Param "--" : map File l
|
|
|
|
{- A item in conflict has two possible values.
|
|
- Either can be Nothing, when that side deleted the file. -}
|
|
data Conflicting v = Conflicting
|
|
{ valUs :: Maybe v
|
|
, valThem :: Maybe v
|
|
} deriving (Show)
|
|
|
|
data Unmerged = Unmerged
|
|
{ unmergedFile :: FilePath
|
|
, unmergedBlobType :: Conflicting BlobType
|
|
, unmergedSha :: Conflicting Sha
|
|
} deriving (Show)
|
|
|
|
{- Returns a list of the files in the specified locations that have
|
|
- unresolved merge conflicts.
|
|
-
|
|
- ls-files outputs multiple lines per conflicting file, each with its own
|
|
- stage number:
|
|
- 1 = old version, can be ignored
|
|
- 2 = us
|
|
- 3 = them
|
|
- If a line is omitted, that side deleted the file.
|
|
-}
|
|
unmerged :: [FilePath] -> Repo -> IO [Unmerged]
|
|
unmerged l repo = reduceUnmerged [] . catMaybes . map parseUnmerged <$> list repo
|
|
where
|
|
files = map File l
|
|
list = pipeNullSplitZombie $
|
|
Params "ls-files --unmerged -z --" : files
|
|
|
|
data InternalUnmerged = InternalUnmerged
|
|
{ isus :: Bool
|
|
, ifile :: FilePath
|
|
, iblobtype :: Maybe BlobType
|
|
, isha :: Maybe Sha
|
|
} deriving (Show)
|
|
|
|
parseUnmerged :: String -> Maybe InternalUnmerged
|
|
parseUnmerged s
|
|
| null file || length ws < 3 = Nothing
|
|
| otherwise = do
|
|
stage <- readish (ws !! 2) :: Maybe Int
|
|
unless (stage == 2 || stage == 3) $
|
|
fail undefined -- skip stage 1
|
|
blobtype <- readBlobType (ws !! 0)
|
|
sha <- extractSha (ws !! 1)
|
|
return $ InternalUnmerged (stage == 2) file (Just blobtype) (Just sha)
|
|
where
|
|
(metadata, file) = separate (== '\t') s
|
|
ws = words metadata
|
|
|
|
reduceUnmerged :: [Unmerged] -> [InternalUnmerged] -> [Unmerged]
|
|
reduceUnmerged c [] = c
|
|
reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
|
|
where
|
|
(rest, sibi) = findsib i is
|
|
(blobtypeA, blobtypeB, shaA, shaB)
|
|
| isus i = (iblobtype i, iblobtype sibi, isha i, isha sibi)
|
|
| otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i)
|
|
new = Unmerged
|
|
{ unmergedFile = ifile i
|
|
, unmergedBlobType = Conflicting blobtypeA blobtypeB
|
|
, unmergedSha = Conflicting shaA shaB
|
|
}
|
|
findsib templatei [] = ([], deleted templatei)
|
|
findsib templatei (l:ls)
|
|
| ifile l == ifile templatei = (ls, l)
|
|
| otherwise = (l:ls, deleted templatei)
|
|
deleted templatei = templatei
|
|
{ isus = not (isus templatei)
|
|
, iblobtype = Nothing
|
|
, isha = Nothing
|
|
}
|