finished where indentation changes

This commit is contained in:
Joey Hess 2012-12-13 00:24:19 -04:00
parent b77290cecc
commit f87a781aa6
68 changed files with 1619 additions and 1628 deletions

View file

@ -33,11 +33,11 @@ similarityFloor = 7
fuzzymatches :: String -> (c -> String) -> [c] -> [c]
fuzzymatches input showchoice choices = fst $ unzip $
sortBy comparecost $ filter similarEnough $ zip choices costs
where
distance = restrictedDamerauLevenshteinDistance gitEditCosts input
costs = map (distance . showchoice) choices
comparecost a b = compare (snd a) (snd b)
similarEnough (_, cst) = cst < similarityFloor
where
distance = restrictedDamerauLevenshteinDistance gitEditCosts input
costs = map (distance . showchoice) choices
comparecost a b = compare (snd a) (snd b)
similarEnough (_, cst) = cst < similarityFloor
{- Takes action based on git's autocorrect configuration, in preparation for
- an autocorrected command being run. -}
@ -49,23 +49,23 @@ prepare input showmatch matches r =
| n < 0 -> warn
| otherwise -> sleep n
Nothing -> list
where
list = error $ unlines $
[ "Unknown command '" ++ input ++ "'"
, ""
, "Did you mean one of these?"
] ++ map (\m -> "\t" ++ showmatch m) matches
warn =
hPutStr stderr $ unlines
[ "WARNING: You called a command named '" ++
input ++ "', which does not exist."
, "Continuing under the assumption that you meant '" ++
showmatch (Prelude.head matches) ++ "'"
]
sleep n = do
warn
hPutStrLn stderr $ unwords
[ "in"
, show (fromIntegral n / 10 :: Float)
, "seconds automatically..."]
threadDelay (n * 100000) -- deciseconds to microseconds
where
list = error $ unlines $
[ "Unknown command '" ++ input ++ "'"
, ""
, "Did you mean one of these?"
] ++ map (\m -> "\t" ++ showmatch m) matches
warn =
hPutStr stderr $ unlines
[ "WARNING: You called a command named '" ++
input ++ "', which does not exist."
, "Continuing under the assumption that you meant '" ++
showmatch (Prelude.head matches) ++ "'"
]
sleep n = do
warn
hPutStrLn stderr $ unwords
[ "in"
, show (fromIntegral n / 10 :: Float)
, "seconds automatically..."]
threadDelay (n * 100000) -- deciseconds to microseconds

View file

@ -36,10 +36,10 @@ current r = do
currentUnsafe :: Repo -> IO (Maybe Git.Ref)
currentUnsafe r = parse . firstLine
<$> pipeReadStrict [Param "symbolic-ref", Param "HEAD"] r
where
parse l
| null l = Nothing
| otherwise = Just $ Git.Ref l
where
parse l
| null l = Nothing
| otherwise = Just $ Git.Ref l
{- Checks if the second branch has any commits not present on the first
- branch. -}
@ -47,12 +47,12 @@ changed :: Branch -> Branch -> Repo -> IO Bool
changed origbranch newbranch repo
| origbranch == newbranch = return False
| otherwise = not . null <$> diffs
where
diffs = pipeReadStrict
[ Param "log"
, Param (show origbranch ++ ".." ++ show newbranch)
, Params "--oneline -n1"
] repo
where
diffs = pipeReadStrict
[ Param "log"
, Param (show origbranch ++ ".." ++ show newbranch)
, Params "--oneline -n1"
] repo
{- Given a set of refs that are all known to have commits not
- on the branch, tries to update the branch by a fast-forward.
@ -70,23 +70,23 @@ fastForward branch (first:rest) repo =
( no_ff
, maybe no_ff do_ff =<< findbest first rest
)
where
no_ff = return False
do_ff to = do
run "update-ref"
[Param $ show branch, Param $ show to] repo
return True
findbest c [] = return $ Just c
findbest c (r:rs)
| c == r = findbest c rs
| otherwise = do
better <- changed c r repo
worse <- changed r c repo
case (better, worse) of
(True, True) -> return Nothing -- divergent fail
(True, False) -> findbest r rs -- better
(False, True) -> findbest c rs -- worse
(False, False) -> findbest c rs -- same
where
no_ff = return False
do_ff to = do
run "update-ref"
[Param $ show branch, Param $ show to] repo
return True
findbest c [] = return $ Just c
findbest c (r:rs)
| c == r = findbest c rs
| otherwise = do
better <- changed c r repo
worse <- changed r c repo
case (better, worse) of
(True, True) -> return Nothing -- divergent fail
(True, False) -> findbest r rs -- better
(False, True) -> findbest c rs -- worse
(False, False) -> findbest c rs -- same
{- Commits the index into the specified branch (or other ref),
- with the specified parent refs, and returns the committed sha -}
@ -99,5 +99,5 @@ commit message branch parentrefs repo = do
message repo
run "update-ref" [Param $ show branch, Param $ show sha] repo
return sha
where
ps = concatMap (\r -> ["-p", show r]) parentrefs
where
ps = concatMap (\r -> ["-p", show r]) parentrefs

View file

@ -48,28 +48,28 @@ catObject h object = maybe L.empty fst <$> catObjectDetails h object
{- Gets both the content of an object, and its Sha. -}
catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha))
catObjectDetails h object = CoProcess.query h send receive
where
send to = do
fileEncoding to
hPutStrLn to $ show object
receive from = do
fileEncoding from
header <- hGetLine from
case words header of
[sha, objtype, size]
| length sha == shaSize &&
isJust (readObjectType objtype) ->
case reads size of
[(bytes, "")] -> readcontent bytes from sha
_ -> dne
| otherwise -> dne
_
| header == show object ++ " missing" -> dne
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
readcontent bytes from sha = do
content <- S.hGet from bytes
c <- hGetChar from
when (c /= '\n') $
error "missing newline from git cat-file"
return $ Just (L.fromChunks [content], Ref sha)
dne = return Nothing
where
send to = do
fileEncoding to
hPutStrLn to $ show object
receive from = do
fileEncoding from
header <- hGetLine from
case words header of
[sha, objtype, size]
| length sha == shaSize &&
isJust (readObjectType objtype) ->
case reads size of
[(bytes, "")] -> readcontent bytes from sha
_ -> dne
| otherwise -> dne
_
| header == show object ++ " missing" -> dne
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
readcontent bytes from sha = do
content <- S.hGet from bytes
c <- hGetChar from
when (c /= '\n') $
error "missing newline from git cat-file"
return $ Just (L.fromChunks [content], Ref sha)
dne = return Nothing

View file

@ -24,12 +24,12 @@ checkAttrStart attrs repo = do
cwd <- getCurrentDirectory
h <- gitCoProcessStart params repo
return (h, attrs, cwd)
where
params =
[ Param "check-attr"
, Params "-z --stdin"
] ++ map Param attrs ++
[ Param "--" ]
where
params =
[ Param "check-attr"
, Params "-z --stdin"
] ++ map Param attrs ++
[ Param "--" ]
checkAttrStop :: CheckAttrHandle -> IO ()
checkAttrStop (h, _, _) = CoProcess.stop h
@ -42,26 +42,26 @@ checkAttr (h, attrs, cwd) want file = do
case vals of
[v] -> return v
_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
where
send to = do
fileEncoding to
hPutStr to $ file' ++ "\0"
receive from = forM attrs $ \attr -> do
fileEncoding from
l <- hGetLine from
return (attr, attrvalue attr l)
{- Before git 1.7.7, git check-attr worked best with
- absolute filenames; using them worked around some bugs
- with relative filenames.
-
- With newer git, git check-attr chokes on some absolute
- filenames, and the bugs that necessitated them were fixed,
- so use relative filenames. -}
oldgit = Git.Version.older "1.7.7"
file'
| oldgit = absPathFrom cwd file
| otherwise = relPathDirToFile cwd $ absPathFrom cwd file
attrvalue attr l = end bits !! 0
where
bits = split sep l
sep = ": " ++ attr ++ ": "
where
send to = do
fileEncoding to
hPutStr to $ file' ++ "\0"
receive from = forM attrs $ \attr -> do
fileEncoding from
l <- hGetLine from
return (attr, attrvalue attr l)
{- Before git 1.7.7, git check-attr worked best with
- absolute filenames; using them worked around some bugs
- with relative filenames.
-
- With newer git, git check-attr chokes on some absolute
- filenames, and the bugs that necessitated them were fixed,
- so use relative filenames. -}
oldgit = Git.Version.older "1.7.7"
file'
| oldgit = absPathFrom cwd file
| otherwise = relPathDirToFile cwd $ absPathFrom cwd file
attrvalue attr l = end bits !! 0
where
bits = split sep l
sep = ": " ++ attr ++ ": "

View file

@ -17,11 +17,11 @@ import qualified Utility.CoProcess as CoProcess
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params
where
setdir = Param $ "--git-dir=" ++ gitdir l
settree = case worktree l of
Nothing -> []
Just t -> [Param $ "--work-tree=" ++ t]
where
setdir = Param $ "--git-dir=" ++ gitdir l
settree = case worktree l of
Nothing -> []
Just t -> [Param $ "--work-tree=" ++ t]
gitCommandLine _ repo = assertLocal repo $ error "internal"
{- Runs git in the specified repo. -}
@ -49,8 +49,8 @@ pipeReadLazy params repo = assertLocal repo $ do
fileEncoding h
c <- hGetContents h
return (c, checkSuccessProcess pid)
where
p = gitCreateProcess params repo
where
p = gitCreateProcess params repo
{- Runs a git subcommand, and returns its output, strictly.
-
@ -63,8 +63,8 @@ pipeReadStrict params repo = assertLocal repo $
output <- hGetContentsStrict h
hClose h
return output
where
p = gitCreateProcess params repo
where
p = gitCreateProcess params repo
{- Runs a git subcommand, feeding it input, and returning its output,
- which is expected to be fairly small, since it's all read into memory
@ -85,8 +85,8 @@ pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool)
pipeNullSplit params repo = do
(s, cleanup) <- pipeReadLazy params repo
return (filter (not . null) $ split sep s, cleanup)
where
sep = "\0"
where
sep = "\0"
pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]

View file

@ -48,18 +48,18 @@ reRead r = read' $ r
-}
read' :: Repo -> IO Repo
read' repo = go repo
where
go Repo { location = Local { gitdir = d } } = git_config d
go Repo { location = LocalUnknown d } = git_config d
go _ = assertLocal repo $ error "internal"
git_config d = withHandle StdoutHandle createProcessSuccess p $
hRead repo
where
params = ["config", "--null", "--list"]
p = (proc "git" params)
{ cwd = Just d
, env = gitEnv repo
}
where
go Repo { location = Local { gitdir = d } } = git_config d
go Repo { location = LocalUnknown d } = git_config d
go _ = assertLocal repo $ error "internal"
git_config d = withHandle StdoutHandle createProcessSuccess p $
hRead repo
where
params = ["config", "--null", "--list"]
p = (proc "git" params)
{ cwd = Just d
, env = gitEnv repo
}
{- Gets the global git config, returning a dummy Repo containing it. -}
global :: IO (Maybe Repo)
@ -73,9 +73,9 @@ global = do
return $ Just repo'
, return Nothing
)
where
params = ["config", "--null", "--list", "--global"]
p = (proc "git" params)
where
params = ["config", "--null", "--list", "--global"]
p = (proc "git" params)
{- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> Handle -> IO Repo
@ -133,10 +133,10 @@ parse s
| all ('=' `elem`) (take 1 ls) = sep '=' ls
-- --null --list output separates keys from values with newlines
| otherwise = sep '\n' $ split "\0" s
where
ls = lines s
sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
map (separate (== c))
where
ls = lines s
sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
map (separate (== c))
{- Checks if a string from git config is a true value. -}
isTrue :: String -> Maybe Bool
@ -144,8 +144,8 @@ isTrue s
| s' == "true" = Just True
| s' == "false" = Just False
| otherwise = Nothing
where
s' = map toLower s
where
s' = map toLower s
isBare :: Repo -> Bool
isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r

View file

@ -33,15 +33,15 @@ import Utility.UserInfo
- directory. -}
fromCwd :: IO Repo
fromCwd = getCurrentDirectory >>= seekUp checkForRepo
where
norepo = error "Not in a git repository."
seekUp check dir = do
r <- check dir
case r of
Nothing -> case parentDir dir of
"" -> norepo
d -> seekUp check d
Just loc -> newFrom loc
where
norepo = error "Not in a git repository."
seekUp check dir = do
r <- check dir
case r of
Nothing -> case parentDir dir of
"" -> norepo
d -> seekUp check d
Just loc -> newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -}
fromPath :: FilePath -> IO Repo
@ -55,21 +55,21 @@ fromAbsPath dir
ifM (doesDirectoryExist dir') ( ret dir' , hunt )
| otherwise =
error $ "internal error, " ++ dir ++ " is not absolute"
where
ret = newFrom . LocalUnknown
{- Git always looks for "dir.git" in preference to
- to "dir", even if dir ends in a "/". -}
canondir = dropTrailingPathSeparator dir
dir' = canondir ++ ".git"
{- When dir == "foo/.git", git looks for "foo/.git/.git",
- and failing that, uses "foo" as the repository. -}
hunt
| "/.git" `isSuffixOf` canondir =
ifM (doesDirectoryExist $ dir </> ".git")
( ret dir
, ret $ takeDirectory canondir
)
| otherwise = ret dir
where
ret = newFrom . LocalUnknown
{- Git always looks for "dir.git" in preference to
- to "dir", even if dir ends in a "/". -}
canondir = dropTrailingPathSeparator dir
dir' = canondir ++ ".git"
{- When dir == "foo/.git", git looks for "foo/.git/.git",
- and failing that, uses "foo" as the repository. -}
hunt
| "/.git" `isSuffixOf` canondir =
ifM (doesDirectoryExist $ dir </> ".git")
( ret dir
, ret $ takeDirectory canondir
)
| otherwise = ret dir
{- Remote Repo constructor. Throws exception on invalid url.
-
@ -85,9 +85,9 @@ fromUrlStrict :: String -> IO Repo
fromUrlStrict url
| startswith "file://" url = fromAbsPath $ uriPath u
| otherwise = newFrom $ Url u
where
u = fromMaybe bad $ parseURI url
bad = error $ "bad url " ++ url
where
u = fromMaybe bad $ parseURI url
bad = error $ "bad url " ++ url
{- Creates a repo that has an unknown location. -}
fromUnknown :: IO Repo
@ -100,21 +100,23 @@ localToUrl reference r
| not $ repoIsUrl reference = error "internal error; reference repo not url"
| repoIsUrl r = r
| otherwise = r { location = Url $ fromJust $ parseURI absurl }
where
absurl =
Url.scheme reference ++ "//" ++
Url.authority reference ++
repoPath r
where
absurl = concat
[ Url.scheme reference
, "//"
, Url.authority reference
, repoPath r
]
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
fromRemotes :: Repo -> IO [Repo]
fromRemotes repo = mapM construct remotepairs
where
filterconfig f = filter f $ M.toList $ config repo
filterkeys f = filterconfig (\(k,_) -> f k)
remotepairs = filterkeys isremote
isremote k = startswith "remote." k && endswith ".url" k
construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
where
filterconfig f = filter f $ M.toList $ config repo
filterkeys f = filterconfig (\(k,_) -> f k)
remotepairs = filterkeys isremote
isremote k = startswith "remote." k && endswith ".url" k
construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
{- Sets the name of a remote when constructing the Repo to represent it. -}
remoteNamed :: String -> IO Repo -> IO Repo
@ -126,50 +128,48 @@ remoteNamed n constructor = do
"remote.foo.url". -}
remoteNamedFromKey :: String -> IO Repo -> IO Repo
remoteNamedFromKey k = remoteNamed basename
where
basename = join "." $ reverse $ drop 1 $
reverse $ drop 1 $ split "." k
where
basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k
{- Constructs a new Repo for one of a Repo's remotes using a given
- location (ie, an url). -}
fromRemoteLocation :: String -> Repo -> IO Repo
fromRemoteLocation s repo = gen $ calcloc s
where
gen v
| scpstyle v = fromUrl $ scptourl v
| urlstyle v = fromUrl v
| otherwise = fromRemotePath v repo
-- insteadof config can rewrite remote location
calcloc l
| null insteadofs = l
| otherwise = replacement ++ drop (length bestvalue) l
where
replacement = drop (length prefix) $
take (length bestkey - length suffix) bestkey
(bestkey, bestvalue) = maximumBy longestvalue insteadofs
longestvalue (_, a) (_, b) = compare b a
insteadofs = filterconfig $ \(k, v) ->
startswith prefix k &&
endswith suffix k &&
startswith v l
filterconfig f = filter f $
concatMap splitconfigs $
M.toList $ fullconfig repo
splitconfigs (k, vs) = map (\v -> (k, v)) vs
(prefix, suffix) = ("url." , ".insteadof")
urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
-- git remotes can be written scp style -- [user@]host:dir
-- but foo::bar is a git-remote-helper location instead
scpstyle v = ":" `isInfixOf` v
&& not ("//" `isInfixOf` v)
&& not ("::" `isInfixOf` v)
scptourl v = "ssh://" ++ host ++ slash dir
where
(host, dir) = separate (== ':') v
slash d | d == "" = "/~/" ++ d
| "/" `isPrefixOf` d = d
| "~" `isPrefixOf` d = '/':d
| otherwise = "/~/" ++ d
where
gen v
| scpstyle v = fromUrl $ scptourl v
| urlstyle v = fromUrl v
| otherwise = fromRemotePath v repo
-- insteadof config can rewrite remote location
calcloc l
| null insteadofs = l
| otherwise = replacement ++ drop (length bestvalue) l
where
replacement = drop (length prefix) $
take (length bestkey - length suffix) bestkey
(bestkey, bestvalue) = maximumBy longestvalue insteadofs
longestvalue (_, a) (_, b) = compare b a
insteadofs = filterconfig $ \(k, v) ->
startswith prefix k &&
endswith suffix k &&
startswith v l
filterconfig f = filter f $
concatMap splitconfigs $ M.toList $ fullconfig repo
splitconfigs (k, vs) = map (\v -> (k, v)) vs
(prefix, suffix) = ("url." , ".insteadof")
urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
-- git remotes can be written scp style -- [user@]host:dir
-- but foo::bar is a git-remote-helper location instead
scpstyle v = ":" `isInfixOf` v
&& not ("//" `isInfixOf` v)
&& not ("::" `isInfixOf` v)
scptourl v = "ssh://" ++ host ++ slash dir
where
(host, dir) = separate (== ':') v
slash d | d == "" = "/~/" ++ d
| "/" `isPrefixOf` d = d
| "~" `isPrefixOf` d = '/':d
| otherwise = "/~/" ++ d
{- Constructs a Repo from the path specified in the git remotes of
- another Repo. -}
@ -191,25 +191,25 @@ repoAbsPath d = do
expandTilde :: FilePath -> IO FilePath
expandTilde = expandt True
where
expandt _ [] = return ""
expandt _ ('/':cs) = do
v <- expandt True cs
return ('/':v)
expandt True ('~':'/':cs) = do
h <- myHomeDir
return $ h </> cs
expandt True ('~':cs) = do
let (name, rest) = findname "" cs
u <- getUserEntryForName name
return $ homeDirectory u </> rest
expandt _ (c:cs) = do
v <- expandt False cs
return (c:v)
findname n [] = (n, "")
findname n (c:cs)
| c == '/' = (n, cs)
| otherwise = findname (n++[c]) cs
where
expandt _ [] = return ""
expandt _ ('/':cs) = do
v <- expandt True cs
return ('/':v)
expandt True ('~':'/':cs) = do
h <- myHomeDir
return $ h </> cs
expandt True ('~':cs) = do
let (name, rest) = findname "" cs
u <- getUserEntryForName name
return $ homeDirectory u </> rest
expandt _ (c:cs) = do
v <- expandt False cs
return (c:v)
findname n [] = (n, "")
findname n (c:cs)
| c == '/' = (n, cs)
| otherwise = findname (n++[c]) cs
checkForRepo :: FilePath -> IO (Maybe RepoLocation)
checkForRepo dir =
@ -217,28 +217,28 @@ checkForRepo dir =
check gitDirFile $
check isBareRepo $
return Nothing
where
check test cont = maybe cont (return . Just) =<< test
checkdir c = ifM c
( return $ Just $ LocalUnknown dir
, return Nothing
)
isRepo = checkdir $ gitSignature $ ".git" </> "config"
isBareRepo = checkdir $ gitSignature "config"
<&&> doesDirectoryExist (dir </> "objects")
gitDirFile = do
c <- firstLine <$>
catchDefaultIO "" (readFile $ dir </> ".git")
return $ if gitdirprefix `isPrefixOf` c
then Just $ Local
{ gitdir = absPathFrom dir $
drop (length gitdirprefix) c
, worktree = Just dir
}
else Nothing
where
gitdirprefix = "gitdir: "
gitSignature file = doesFileExist $ dir </> file
where
check test cont = maybe cont (return . Just) =<< test
checkdir c = ifM c
( return $ Just $ LocalUnknown dir
, return Nothing
)
isRepo = checkdir $ gitSignature $ ".git" </> "config"
isBareRepo = checkdir $ gitSignature "config"
<&&> doesDirectoryExist (dir </> "objects")
gitDirFile = do
c <- firstLine <$>
catchDefaultIO "" (readFile $ dir </> ".git")
return $ if gitdirprefix `isPrefixOf` c
then Just $ Local
{ gitdir = absPathFrom dir $
drop (length gitdirprefix) c
, worktree = Just dir
}
else Nothing
where
gitdirprefix = "gitdir: "
gitSignature file = doesFileExist $ dir </> file
newFrom :: RepoLocation -> IO Repo
newFrom l = return Repo

View file

@ -39,23 +39,23 @@ get = do
unless (d `dirContains` cwd) $
changeWorkingDirectory d
return $ addworktree wt r
where
pathenv s = do
v <- getEnv s
case v of
Just d -> do
unsetEnv s
Just <$> absPath d
Nothing -> return Nothing
configure Nothing r = Git.Config.read r
configure (Just d) r = do
r' <- Git.Config.read r
-- Let GIT_DIR override the default gitdir.
absd <- absPath d
return $ changelocation r' $ Local
{ gitdir = absd
, worktree = worktree (location r')
}
addworktree w r = changelocation r $
Local { gitdir = gitdir (location r), worktree = w }
changelocation r l = r { location = l }
where
pathenv s = do
v <- getEnv s
case v of
Just d -> do
unsetEnv s
Just <$> absPath d
Nothing -> return Nothing
configure Nothing r = Git.Config.read r
configure (Just d) r = do
r' <- Git.Config.read r
-- Let GIT_DIR override the default gitdir.
absd <- absPath d
return $ changelocation r' $ Local
{ gitdir = absd
, worktree = worktree (location r')
}
addworktree w r = changelocation r $
Local { gitdir = gitdir (location r), worktree = w }
changelocation r l = r { location = l }

View file

@ -29,17 +29,17 @@ hashObjectStop = CoProcess.stop
{- Injects a file into git, returning the Sha of the object. -}
hashFile :: HashObjectHandle -> FilePath -> IO Sha
hashFile h file = CoProcess.query h send receive
where
send to = do
fileEncoding to
hPutStrLn to file
receive from = getSha "hash-object" $ hGetLine from
where
send to = do
fileEncoding to
hPutStrLn to file
receive from = getSha "hash-object" $ hGetLine from
{- Injects some content into git, returning its Sha. -}
hashObject :: ObjectType -> String -> Repo -> IO Sha
hashObject objtype content repo = getSha subcmd $ do
s <- pipeWriteRead (map Param params) content repo
return s
where
subcmd = "hash-object"
params = [subcmd, "-t", show objtype, "-w", "--stdin"]
where
subcmd = "hash-object"
params = [subcmd, "-t", show objtype, "-w", "--stdin"]

View file

@ -21,7 +21,7 @@ override index = do
res <- getEnv var
setEnv var index True
return $ reset res
where
var = "GIT_INDEX_FILE"
reset (Just v) = setEnv var v True
reset _ = unsetEnv var
where
var = "GIT_INDEX_FILE"
reset (Just v) = setEnv var v True
reset _ = unsetEnv var

View file

@ -31,12 +31,12 @@ inRepo l = pipeNullSplit $ 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], IO Bool)
notInRepo include_ignored l repo = pipeNullSplit params repo
where
params = [Params "ls-files --others"] ++ exclude ++
[Params "-z --"] ++ map File l
exclude
| include_ignored = []
| otherwise = [Param "--exclude-standard"]
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], IO Bool)
@ -49,15 +49,15 @@ stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix
where
prefix = [Params "diff --cached --name-only -z"]
suffix = Param "--" : map File l
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], IO Bool)
changedUnstaged l = pipeNullSplit params
where
params = Params "diff --name-only -z --" : map File l
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. -}
@ -77,9 +77,9 @@ typeChanged' ps l repo = do
let top = repoPath repo
cwd <- getCurrentDirectory
return (map (\f -> relPathDirToFile cwd $ top </> f) fs, cleanup)
where
prefix = [Params "diff --name-only --diff-filter=T -z"]
suffix = Param "--" : map File l
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. -}
@ -108,8 +108,8 @@ unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool)
unmerged l repo = do
(fs, cleanup) <- pipeNullSplit params repo
return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup)
where
params = Params "ls-files --unmerged -z --" : map File l
where
params = Params "ls-files --unmerged -z --" : map File l
data InternalUnmerged = InternalUnmerged
{ isus :: Bool
@ -131,28 +131,28 @@ parseUnmerged s
return $ InternalUnmerged (stage == 2) file
(Just blobtype) (Just sha)
_ -> Nothing
where
(metadata, file) = separate (== '\t') s
where
(metadata, file) = separate (== '\t') s
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
}
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
}

View file

@ -47,11 +47,11 @@ parseLsTree l = TreeItem
, sha = s
, file = Git.Filename.decode f
}
where
-- l = <mode> SP <type> SP <sha> TAB <file>
-- All fields are fixed, so we can pull them out of
-- specific positions in the line.
(m, past_m) = splitAt 7 l
(t, past_t) = splitAt 4 past_m
(s, past_s) = splitAt 40 $ Prelude.tail past_t
f = Prelude.tail past_s
where
-- l = <mode> SP <type> SP <sha> TAB <file>
-- All fields are fixed, so we can pull them out of
-- specific positions in the line.
(m, past_m) = splitAt 7 l
(t, past_t) = splitAt 4 past_m
(s, past_s) = splitAt 40 $ Prelude.tail past_t
f = Prelude.tail past_s

View file

@ -86,30 +86,30 @@ new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue
addCommand subcommand params files q repo =
updateQueue action different (length newfiles) q repo
where
key = actionKey action
action = CommandAction
{ getSubcommand = subcommand
, getParams = params
, getFiles = newfiles
}
newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)
where
key = actionKey action
action = CommandAction
{ getSubcommand = subcommand
, getParams = params
, getFiles = newfiles
}
newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)
different (CommandAction { getSubcommand = s }) = s /= subcommand
different _ = True
different (CommandAction { getSubcommand = s }) = s /= subcommand
different _ = True
{- Adds an update-index streamer to the queue. -}
addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue
addUpdateIndex streamer q repo =
updateQueue action different 1 q repo
where
key = actionKey action
-- the list is built in reverse order
action = UpdateIndexAction $ streamer : streamers
streamers = maybe [] getStreamers $ M.lookup key $ items q
where
key = actionKey action
-- the list is built in reverse order
action = UpdateIndexAction $ streamer : streamers
streamers = maybe [] getStreamers $ M.lookup key $ items q
different (UpdateIndexAction _) = False
different _ = True
different (UpdateIndexAction _) = False
different _ = True
{- Updates or adds an action in the queue. If the queue already contains a
- different action, it will be flushed; this is to ensure that conflicting
@ -118,15 +118,15 @@ updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue
updateQueue !action different sizeincrease q repo
| null (filter different (M.elems (items q))) = return $ go q
| otherwise = go <$> flush q repo
where
go q' = newq
where
!newq = q'
{ size = newsize
, items = newitems
}
!newsize = size q' + sizeincrease
!newitems = M.insertWith' const (actionKey action) action (items q')
where
go q' = newq
where
!newq = q'
{ size = newsize
, items = newitems
}
!newsize = size q' + sizeincrease
!newitems = M.insertWith' const (actionKey action) action (items q')
{- Is a queue large enough that it should be flushed? -}
full :: Queue -> Bool
@ -153,8 +153,8 @@ runAction repo action@(CommandAction {}) =
fileEncoding h
hPutStr h $ join "\0" $ getFiles action
hClose h
where
p = (proc "xargs" params) { env = gitEnv repo }
params = "-0":"git":baseparams
baseparams = toCommand $ gitCommandLine
(Param (getSubcommand action):getParams action) repo
where
p = (proc "xargs" params) { env = gitEnv repo }
params = "-0":"git":baseparams
baseparams = toCommand $ gitCommandLine
(Param (getSubcommand action):getParams action) repo

View file

@ -21,10 +21,10 @@ describe = show . base
- Converts such a fully qualified ref into a base ref (eg: master). -}
base :: Ref -> Ref
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
where
remove prefix s
| prefix `isPrefixOf` s = drop (length prefix) s
| otherwise = s
where
remove prefix s
| prefix `isPrefixOf` s = drop (length prefix) s
| otherwise = s
{- Given a directory such as "refs/remotes/origin", and a ref such as
- refs/heads/master, yields a version of that ref under the directory,
@ -40,51 +40,51 @@ exists ref = runBool "show-ref"
{- Get the sha of a fully qualified git ref, if it exists. -}
sha :: Branch -> Repo -> IO (Maybe Sha)
sha branch repo = process <$> showref repo
where
showref = pipeReadStrict [Param "show-ref",
Param "--hash", -- get the hash
Param $ show branch]
process [] = Nothing
process s = Just $ Ref $ firstLine s
where
showref = pipeReadStrict [Param "show-ref",
Param "--hash", -- get the hash
Param $ show branch]
process [] = Nothing
process s = Just $ Ref $ firstLine s
{- List of (refs, branches) matching a given ref spec. -}
matching :: Ref -> Repo -> IO [(Ref, Branch)]
matching ref repo = map gen . lines <$>
pipeReadStrict [Param "show-ref", Param $ show ref] repo
where
gen l = let (r, b) = separate (== ' ') l in
(Ref r, Ref b)
where
gen l = let (r, b) = separate (== ' ') l
in (Ref r, Ref b)
{- List of (refs, branches) matching a given ref spec.
- Duplicate refs are filtered out. -}
matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)]
matchingUniq ref repo = nubBy uniqref <$> matching ref repo
where
uniqref (a, _) (b, _) = a == b
where
uniqref (a, _) (b, _) = a == b
{- Checks if a String is a legal git ref name.
-
- The rules for this are complex; see git-check-ref-format(1) -}
legal :: Bool -> String -> Bool
legal allowonelevel s = all (== False) illegal
where
illegal =
[ any ("." `isPrefixOf`) pathbits
, any (".lock" `isSuffixOf`) pathbits
, not allowonelevel && length pathbits < 2
, contains ".."
, any (\c -> contains [c]) illegalchars
, begins "/"
, ends "/"
, contains "//"
, ends "."
, contains "@{"
, null s
]
contains v = v `isInfixOf` s
ends v = v `isSuffixOf` s
begins v = v `isPrefixOf` s
where
illegal =
[ any ("." `isPrefixOf`) pathbits
, any (".lock" `isSuffixOf`) pathbits
, not allowonelevel && length pathbits < 2
, contains ".."
, any (\c -> contains [c]) illegalchars
, begins "/"
, ends "/"
, contains "//"
, ends "."
, contains "@{"
, null s
]
contains v = v `isInfixOf` s
ends v = v `isSuffixOf` s
begins v = v `isPrefixOf` s
pathbits = split "/" s
illegalchars = " ~^:?*[\\" ++ controlchars
controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]
pathbits = split "/" s
illegalchars = " ~^:?*[\\" ++ controlchars
controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]

View file

@ -14,8 +14,8 @@ import Git.Types
any trailing newline, returning the sha. -}
getSha :: String -> IO String -> IO Sha
getSha subcommand a = maybe bad return =<< extractSha <$> a
where
bad = error $ "failed to read sha from git " ++ subcommand
where
bad = error $ "failed to read sha from git " ++ subcommand
{- Extracts the Sha from a string. There can be a trailing newline after
- it, but nothing else. -}
@ -24,12 +24,12 @@ extractSha s
| len == shaSize = val s
| len == shaSize + 1 && length s' == shaSize = val s'
| otherwise = Nothing
where
len = length s
s' = firstLine s
val v
| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
| otherwise = Nothing
where
len = length s
s' = firstLine s
val v
| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
| otherwise = Nothing
{- Size of a git sha. -}
shaSize :: Int

View file

@ -62,11 +62,11 @@ doMerge ch differ repo streamer = do
(diff, cleanup) <- pipeNullSplit (map Param differ) repo
go diff
void $ cleanup
where
go [] = noop
go (info:file:rest) = mergeFile info file ch repo >>=
maybe (go rest) (\l -> streamer l >> go rest)
go (_:[]) = error $ "parse error " ++ show differ
where
go [] = noop
go (info:file:rest) = mergeFile info file ch repo >>=
maybe (go rest) (\l -> streamer l >> go rest)
go (_:[]) = error $ "parse error " ++ show differ
{- Given an info line from a git raw diff, and the filename, generates
- a line suitable for update-index that union merges the two sides of the
@ -78,16 +78,16 @@ mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of
shas -> use
=<< either return (\s -> hashObject BlobObject (unlines s) repo)
=<< calcMerge . zip shas <$> mapM getcontents shas
where
[_colonmode, _bmode, asha, bsha, _status] = words info
use sha = return $ Just $
updateIndexLine sha FileBlob $ asTopFilePath file
-- We don't know how the file is encoded, but need to
-- split it into lines to union merge. Using the
-- FileSystemEncoding for this is a hack, but ensures there
-- are no decoding errors. Note that this works because
-- hashObject sets fileEncoding on its write handle.
getcontents s = lines . encodeW8 . L.unpack <$> catObject h s
where
[_colonmode, _bmode, asha, bsha, _status] = words info
use sha = return $ Just $
updateIndexLine sha FileBlob $ asTopFilePath file
-- We don't know how the file is encoded, but need to
-- split it into lines to union merge. Using the
-- FileSystemEncoding for this is a hack, but ensures there
-- are no decoding errors. Note that this works because
-- hashObject sets fileEncoding on its write handle.
getcontents s = lines . encodeW8 . L.unpack <$> catObject h s
{- Calculates a union merge between a list of refs, with contents.
-
@ -98,7 +98,7 @@ calcMerge :: [(Ref, [String])] -> Either Ref [String]
calcMerge shacontents
| null reuseable = Right $ new
| otherwise = Left $ fst $ Prelude.head reuseable
where
reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents
new = sorteduniq $ concat $ map snd shacontents
sorteduniq = S.toList . S.fromList
where
reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents
new = sorteduniq $ concat $ map snd shacontents
sorteduniq = S.toList . S.fromList

View file

@ -38,12 +38,12 @@ streamUpdateIndex repo as = pipeWrite params repo $ \h -> do
fileEncoding h
forM_ as (stream h)
hClose h
where
params = map Param ["update-index", "-z", "--index-info"]
stream h a = a (streamer h)
streamer h s = do
hPutStr h s
hPutStr h "\0"
where
params = map Param ["update-index", "-z", "--index-info"]
stream h a = a (streamer h)
streamer h s = do
hPutStr h s
hPutStr h "\0"
{- A streamer that adds the current tree for a ref. Useful for eg, copying
- and modifying branches. -}
@ -52,8 +52,8 @@ lsTree (Ref x) repo streamer = do
(s, cleanup) <- pipeNullSplit params repo
mapM_ streamer s
void $ cleanup
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
{- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -}

View file

@ -28,13 +28,13 @@ scheme repo = notUrl repo
- <http://trac.haskell.org/network/ticket/40> -}
uriRegName' :: URIAuth -> String
uriRegName' a = fixup $ uriRegName a
where
fixup x@('[':rest)
| rest !! len == ']' = take len rest
| otherwise = x
where
len = length rest - 1
fixup x = x
where
fixup x@('[':rest)
| rest !! len == ']' = take len rest
| otherwise = x
where
len = length rest - 1
fixup x = x
{- Hostname of an URL repo. -}
host :: Repo -> String
@ -55,14 +55,14 @@ hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r
{- The full authority portion an URL repo. (ie, "user@host:port") -}
authority :: Repo -> String
authority = authpart assemble
where
assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
where
assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
{- Applies a function to extract part of the uriAuthority of an URL repo. -}
authpart :: (URIAuth -> a) -> Repo -> a
authpart a Repo { location = Url u } = a auth
where
auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
where
auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
authpart _ repo = notUrl repo
notUrl :: Repo -> a

View file

@ -26,13 +26,13 @@ normalize :: String -> Integer
normalize = sum . mult 1 . reverse .
extend precision . take precision .
map readi . split "."
where
extend n l = l ++ replicate (n - length l) 0
mult _ [] = []
mult n (x:xs) = (n*x) : mult (n*10^width) xs
readi :: String -> Integer
readi s = case reads s of
((x,_):_) -> x
_ -> 0
precision = 10 -- number of segments of the version to compare
width = length "yyyymmddhhmmss" -- maximum width of a segment
where
extend n l = l ++ replicate (n - length l) 0
mult _ [] = []
mult n (x:xs) = (n*x) : mult (n*10^width) xs
readi :: String -> Integer
readi s = case reads s of
((x,_):_) -> x
_ -> 0
precision = 10 -- number of segments of the version to compare
width = length "yyyymmddhhmmss" -- maximum width of a segment