summaryrefslogtreecommitdiff
path: root/Git
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-12-13 00:29:06 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-12-13 00:29:06 -0400
commitde6406afce6de0cf8a48bc2ecf9be1e7de93e40e (patch)
tree08705fab60c11d4073734a8c2500a88b1aab7852 /Git
parent3e55a8f164d67d5bd1ef86ae2f38fb2c6c3a51b2 (diff)
parent94554782894ec6c26da3b46312d5d1d16d596458 (diff)
Merge branch 'master' into desymlink
Conflicts: Annex/CatFile.hs Annex/Content.hs Git/LsFiles.hs Git/LsTree.hs
Diffstat (limited to 'Git')
-rw-r--r--Git/AutoCorrect.hs50
-rw-r--r--Git/Branch.hs58
-rw-r--r--Git/CatFile.hs50
-rw-r--r--Git/CheckAttr.hs58
-rw-r--r--Git/Command.hs22
-rw-r--r--Git/Config.hs42
-rw-r--r--Git/Construct.hs236
-rw-r--r--Git/CurrentRepo.hs40
-rw-r--r--Git/HashObject.hs16
-rw-r--r--Git/Index.hs8
-rw-r--r--Git/LsFiles.hs6
-rw-r--r--Git/LsTree.hs16
-rw-r--r--Git/Queue.hs62
-rw-r--r--Git/Ref.hs70
-rw-r--r--Git/Sha.hs16
-rw-r--r--Git/UnionMerge.hs38
-rw-r--r--Git/UpdateIndex.hs16
-rw-r--r--Git/Url.hs22
-rw-r--r--Git/Version.hs20
19 files changed, 426 insertions, 420 deletions
diff --git a/Git/AutoCorrect.hs b/Git/AutoCorrect.hs
index a1ef14779..325632de9 100644
--- a/Git/AutoCorrect.hs
+++ b/Git/AutoCorrect.hs
@@ -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
diff --git a/Git/Branch.hs b/Git/Branch.hs
index 3407845d1..736c4c6e8 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -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
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index cd531e68f..704724211 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -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
diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs
index 13a7287b1..f9279d460 100644
--- a/Git/CheckAttr.hs
+++ b/Git/CheckAttr.hs
@@ -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 ++ ": "
diff --git a/Git/Command.hs b/Git/Command.hs
index 37df44713..88fed56e8 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -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]
diff --git a/Git/Config.hs b/Git/Config.hs
index 0d6d67fc0..52a9dafb5 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -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
diff --git a/Git/Construct.hs b/Git/Construct.hs
index e367c096b..4f6a63d86 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -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
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index 29bb28177..e309bf2f6 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -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 }
diff --git a/Git/HashObject.hs b/Git/HashObject.hs
index e048ce8e5..b4a32ef1c 100644
--- a/Git/HashObject.hs
+++ b/Git/HashObject.hs
@@ -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"]
diff --git a/Git/Index.hs b/Git/Index.hs
index d6fa4ee6c..80196ef78 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -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
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index 45c830cd6..45e105a3b 100644
--- a/Git/LsFiles.hs
+++ b/Git/LsFiles.hs
@@ -69,6 +69,12 @@ stagedDetails l repo = do
where
(metadata, file) = separate (== '\t') s
+{- 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
+
{- 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], IO Bool)
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
index 373bf0006..c61ae7fab 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -48,11 +48,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 shaSize $ 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 shaSize $ Prelude.tail past_t
+ f = Prelude.tail past_s
diff --git a/Git/Queue.hs b/Git/Queue.hs
index 9f7a44882..712d476cd 100644
--- a/Git/Queue.hs
+++ b/Git/Queue.hs
@@ -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
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 6fec46c22..02adf0547 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -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)]
diff --git a/Git/Sha.hs b/Git/Sha.hs
index 2a01ede83..e62b29dab 100644
--- a/Git/Sha.hs
+++ b/Git/Sha.hs
@@ -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
diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs
index 55eff0f1e..05d512df3 100644
--- a/Git/UnionMerge.hs
+++ b/Git/UnionMerge.hs
@@ -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
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index bc96570de..aa65b4429 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -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. -}
diff --git a/Git/Url.hs b/Git/Url.hs
index 21b69dc7c..7befc4669 100644
--- a/Git/Url.hs
+++ b/Git/Url.hs
@@ -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
diff --git a/Git/Version.hs b/Git/Version.hs
index c8bc121d6..44385d9b8 100644
--- a/Git/Version.hs
+++ b/Git/Version.hs
@@ -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