avoid unncessary IO

This commit is contained in:
Joey Hess 2015-02-12 15:33:05 -04:00
parent ecf7ef3ff2
commit 52e40970c8
6 changed files with 15 additions and 17 deletions

View file

@ -66,10 +66,9 @@ global = do
home <- myHomeDir home <- myHomeDir
ifM (doesFileExist $ home </> ".gitconfig") ifM (doesFileExist $ home </> ".gitconfig")
( do ( do
repo <- Git.Construct.fromUnknown repo <- withHandle StdoutHandle createProcessSuccess p $
repo' <- withHandle StdoutHandle createProcessSuccess p $ hRead (Git.Construct.fromUnknown)
hRead repo return $ Just repo
return $ Just repo'
, return Nothing , return Nothing
) )
where where

View file

@ -19,8 +19,8 @@ module Git.Construct (
fromRemotes, fromRemotes,
fromRemoteLocation, fromRemoteLocation,
repoAbsPath, repoAbsPath,
newFrom,
checkForRepo, checkForRepo,
newFrom,
) where ) where
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
@ -48,7 +48,7 @@ fromCwd = getCurrentDirectory >>= seekUp
Nothing -> case upFrom dir of Nothing -> case upFrom dir of
Nothing -> return Nothing Nothing -> return Nothing
Just d -> seekUp d Just d -> seekUp d
Just loc -> Just <$> newFrom loc Just loc -> pure $ Just $ newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -} {- Local Repo constructor, accepts a relative or absolute path. -}
fromPath :: FilePath -> IO Repo fromPath :: FilePath -> IO Repo
@ -62,7 +62,7 @@ fromAbsPath dir
| otherwise = | otherwise =
error $ "internal error, " ++ dir ++ " is not absolute" error $ "internal error, " ++ dir ++ " is not absolute"
where where
ret = newFrom . LocalUnknown ret = pure . newFrom . LocalUnknown
{- Git always looks for "dir.git" in preference to {- Git always looks for "dir.git" in preference to
- to "dir", even if dir ends in a "/". -} - to "dir", even if dir ends in a "/". -}
canondir = dropTrailingPathSeparator dir canondir = dropTrailingPathSeparator dir
@ -90,13 +90,13 @@ fromUrl url
fromUrlStrict :: String -> IO Repo fromUrlStrict :: String -> IO Repo
fromUrlStrict url fromUrlStrict url
| startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u
| otherwise = newFrom $ Url u | otherwise = pure $ newFrom $ Url u
where where
u = fromMaybe bad $ parseURI url u = fromMaybe bad $ parseURI url
bad = error $ "bad url " ++ url bad = error $ "bad url " ++ url
{- Creates a repo that has an unknown location. -} {- Creates a repo that has an unknown location. -}
fromUnknown :: IO Repo fromUnknown :: Repo
fromUnknown = newFrom Unknown fromUnknown = newFrom Unknown
{- Converts a local Repo into a remote repo, using the reference repo {- Converts a local Repo into a remote repo, using the reference repo
@ -223,8 +223,8 @@ checkForRepo dir =
gitdirprefix = "gitdir: " gitdirprefix = "gitdir: "
gitSignature file = doesFileExist $ dir </> file gitSignature file = doesFileExist $ dir </> file
newFrom :: RepoLocation -> IO Repo newFrom :: RepoLocation -> Repo
newFrom l = return Repo newFrom l = Repo
{ location = l { location = l
, config = M.empty , config = M.empty
, fullconfig = M.empty , fullconfig = M.empty
@ -234,4 +234,3 @@ newFrom l = return Repo
, gitGlobalOpts = [] , gitGlobalOpts = []
} }

View file

@ -50,8 +50,8 @@ get = do
configure (Just d) _ = do configure (Just d) _ = do
absd <- absPath d absd <- absPath d
curr <- getCurrentDirectory curr <- getCurrentDirectory
r <- newFrom $ Local { gitdir = absd, worktree = Just curr } Git.Config.read $ newFrom $
Git.Config.read r Local { gitdir = absd, worktree = Just curr }
configure Nothing Nothing = error "Not in a git repository." configure Nothing Nothing = error "Not in a git repository."
addworktree w r = changelocation r $ addworktree w r = changelocation r $

View file

@ -44,7 +44,7 @@ remote = RemoteType {
-- There is only one bittorrent remote, and it always exists. -- There is only one bittorrent remote, and it always exists.
list :: Annex [Git.Repo] list :: Annex [Git.Repo]
list = do list = do
r <- liftIO $ Git.Construct.remoteNamed "bittorrent" Git.Construct.fromUnknown r <- liftIO $ Git.Construct.remoteNamed "bittorrent" (pure Git.Construct.fromUnknown)
return [r] return [r]
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)

View file

@ -59,7 +59,7 @@ findSpecialRemotes s = do
liftIO $ mapM construct $ remotepairs m liftIO $ mapM construct $ remotepairs m
where where
remotepairs = M.toList . M.filterWithKey match remotepairs = M.toList . M.filterWithKey match
construct (k,_) = Git.Construct.remoteNamedFromKey k Git.Construct.fromUnknown construct (k,_) = Git.Construct.remoteNamedFromKey k (pure Git.Construct.fromUnknown)
match k _ = startswith "remote." k && endswith (".annex-"++s) k match k _ = startswith "remote." k && endswith (".annex-"++s) k
{- Sets up configuration for a special remote in .git/config. -} {- Sets up configuration for a special remote in .git/config. -}

View file

@ -38,7 +38,7 @@ remote = RemoteType {
-- a new release to the survivors by carrier pigeon.) -- a new release to the survivors by carrier pigeon.)
list :: Annex [Git.Repo] list :: Annex [Git.Repo]
list = do list = do
r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown)
return [r] return [r]
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)