summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-03-14 17:43:34 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-03-14 17:43:34 -0400
commit60ab3d84e188b8dd3a284d962df25bbee41ff1cb (patch)
tree768d4f632bab0152dbc1ca72f81fc3b9c7915c0a
parenta4f72c9625486786a4549cf4db1b542ea89da7c7 (diff)
added ifM and nuked 11 lines of code
no behavior changes
-rw-r--r--Annex/Content.hs35
-rw-r--r--Annex/Ssh.hs20
-rw-r--r--Annex/UUID.hs6
-rw-r--r--Command.hs4
-rw-r--r--Command/Add.hs9
-rw-r--r--Command/AddUrl.hs14
-rw-r--r--Command/Fsck.hs70
-rw-r--r--Command/Get.hs38
-rw-r--r--Command/Map.hs10
-rw-r--r--Command/Move.hs8
-rw-r--r--Command/PreCommit.hs8
-rw-r--r--Command/Sync.hs30
-rw-r--r--Command/Unannex.hs8
-rw-r--r--Command/Unused.hs8
-rw-r--r--Init.hs17
-rw-r--r--Remote.hs14
-rw-r--r--Utility/Monad.hs14
17 files changed, 151 insertions, 162 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs
index ccaff5c56..fad5f5134 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -150,16 +150,16 @@ prepTmp key = do
getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmpUnchecked key action = do
tmp <- prepTmp key
- success <- action tmp
- if success
- then do
+ ifM (action tmp)
+ ( do
moveAnnex key tmp
logStatus key InfoPresent
return True
- else do
+ , do
-- the tmp file is left behind, in case caller wants
-- to resume its transfer
return False
+ )
{- Creates a temp file, runs an action on it, and cleans up the temp file. -}
withTmp :: Key -> (FilePath -> Annex a) -> Annex a
@@ -230,15 +230,15 @@ moveAnnex :: Key -> FilePath -> Annex ()
moveAnnex key src = do
dest <- inRepo $ gitAnnexLocation key
let dir = parentDir dest
- e <- liftIO $ doesFileExist dest
- if e
- then liftIO $ removeFile src
- else liftIO $ do
+ liftIO $ ifM (doesFileExist dest)
+ ( removeFile src
+ , do
createDirectoryIfMissing True dir
allowWrite dir -- in case the directory already exists
moveFile src dest
preventWrite dest
preventWrite dir
+ )
withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a
withObjectLoc key a = do
@@ -314,12 +314,12 @@ getKeysPresent = liftIO . traverse (2 :: Int) =<< fromRepo gitAnnexObjectDir
saveState :: Bool -> Annex ()
saveState oneshot = do
Annex.Queue.flush False
- unless oneshot $ do
- alwayscommit <- fromMaybe True . Git.configTrue
+ unless oneshot $
+ ifM alwayscommit
+ ( Annex.Branch.commit "update" , Annex.Branch.stage)
+ where
+ alwayscommit = fromMaybe True . Git.configTrue
<$> fromRepo (Git.Config.get "annex.alwayscommit" "")
- if alwayscommit
- then Annex.Branch.commit "update"
- else Annex.Branch.stage
{- Downloads content from any of a list of urls. -}
downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
@@ -338,10 +338,9 @@ preseedTmp key file = go =<< inAnnex key
ok <- copy
when ok $ liftIO $ allowWrite file
return ok
- copy = do
- present <- liftIO $ doesFileExist file
- if present
- then return True
- else do
+ copy = ifM (liftIO $ doesFileExist file)
+ ( return True
+ , do
s <- inRepo $ gitAnnexLocation key
liftIO $ copyFileExternal s file
+ )
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index 39983ab25..79cfbe908 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -37,15 +37,17 @@ sshParams (host, port) opts = go =<< sshInfo (host, port)
sshCleanup
sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
-sshInfo (host, port) = do
- caching <- fromMaybe SysConfig.sshconnectioncaching . Git.configTrue
- <$> fromRepo (Git.Config.get "annex.sshcaching" "")
- if caching
- then do
- dir <- fromRepo gitAnnexSshDir
- let socketfile = dir </> hostport2socket host port
- return (Just socketfile, cacheParams socketfile)
- else return (Nothing, [])
+sshInfo (host, port) = ifM caching
+ ( do
+ dir <- fromRepo gitAnnexSshDir
+ let socketfile = dir </> hostport2socket host port
+ return (Just socketfile, cacheParams socketfile)
+ , return (Nothing, [])
+ )
+ where
+ caching = fromMaybe SysConfig.sshconnectioncaching
+ . Git.configTrue
+ <$> fromRepo (Git.Config.get "annex.sshcaching" "")
cacheParams :: FilePath -> [CommandParam]
cacheParams socketfile =
diff --git a/Annex/UUID.hs b/Annex/UUID.hs
index 48bf71f10..0ab2e7e52 100644
--- a/Annex/UUID.hs
+++ b/Annex/UUID.hs
@@ -34,11 +34,11 @@ genUUID :: IO UUID
genUUID = pOpen ReadFromPipe command params $ liftM toUUID . hGetLine
where
command = SysConfig.uuid
- params = if command == "uuid"
+ params
-- request a random uuid be generated
- then ["-m"]
+ | command == "uuid" = ["-m"]
-- uuidgen generates random uuid by default
- else []
+ | otherwise = []
{- Get current repository's UUID. -}
getUUID :: Annex UUID
diff --git a/Command.hs b/Command.hs
index 13ea167bb..0dff0c862 100644
--- a/Command.hs
+++ b/Command.hs
@@ -65,9 +65,7 @@ stop = return Nothing
{- Stops unless a condition is met. -}
stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a)
-stopUnless c a = do
- ok <- c
- if ok then a else stop
+stopUnless c a = ifM c ( a , stop )
{- Prepares to run a command via the check and seek stages, returning a
- list of actions to perform to run the command. -}
diff --git a/Command/Add.hs b/Command/Add.hs
index b6b5753af..ef839b2a3 100644
--- a/Command/Add.hs
+++ b/Command/Add.hs
@@ -85,8 +85,9 @@ cleanup file key hascontent = do
mtime <- modificationTime <$> getFileStatus file
touch file (TimeSpec mtime) False
- force <- Annex.getState Annex.force
- if force
- then Annex.Queue.add "add" [Param "-f", Param "--"] [file]
- else Annex.Queue.add "add" [Param "--"] [file]
+ params <- ifM (Annex.getState Annex.force)
+ ( return [Param "-f"]
+ , return []
+ )
+ Annex.Queue.add "add" (params++[Param "--"]) [file]
return True
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index 6c945baf9..c87399f5d 100644
--- a/Command/AddUrl.hs
+++ b/Command/AddUrl.hs
@@ -51,17 +51,17 @@ perform url file = ifAnnexed file addurl geturl
where
geturl = do
liftIO $ createDirectoryIfMissing True (parentDir file)
- fast <- Annex.getState Annex.fast
- if fast then nodownload url file else download url file
- addurl (key, _backend) = do
- ok <- liftIO $ Url.check url (keySize key)
- if ok
- then do
+ ifM (Annex.getState Annex.fast)
+ ( nodownload url file , download url file )
+ addurl (key, _backend) =
+ ifM (liftIO $ Url.check url $ keySize key)
+ ( do
setUrlPresent key url
next $ return True
- else do
+ , do
warning $ "failed to verify url: " ++ url
stop
+ )
download :: String -> FilePath -> CommandPerform
download url file = do
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index d8d0db23b..dac3bfac9 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -62,17 +62,18 @@ perform key file backend numcopies = check
{- To fsck a remote, the content is retrieved to a tmp file,
- and checked locally. -}
performRemote :: Key -> FilePath -> Backend -> Maybe Int -> Remote -> CommandPerform
-performRemote key file backend numcopies remote = do
- v <- Remote.hasKey remote key
- case v of
- Left err -> do
+performRemote key file backend numcopies remote =
+ dispatch =<< Remote.hasKey remote key
+ where
+ dispatch (Left err) = do
showNote err
stop
- Right True -> withtmp $ \tmpfile -> do
- copied <- getfile tmpfile
- if copied then go True (Just tmpfile) else go True Nothing
- Right False -> go False Nothing
- where
+ dispatch (Right True) = withtmp $ \tmpfile ->
+ ifM (getfile tmpfile)
+ ( go True (Just tmpfile)
+ , go True Nothing
+ )
+ dispatch (Right False) = go False Nothing
go present localcopy = check
[ verifyLocationLogRemote key file remote present
, checkKeySizeRemote key remote localcopy
@@ -87,15 +88,14 @@ performRemote key file backend numcopies remote = do
let cleanup = liftIO $ catchIO (removeFile tmp) (const $ return ())
cleanup
cleanup `after` a tmp
- getfile tmp = do
- ok <- Remote.retrieveKeyFileCheap remote key tmp
- if ok
- then return ok
- else do
- fast <- Annex.getState Annex.fast
- if fast
- then return False
- else Remote.retrieveKeyFile remote key tmp
+ getfile tmp =
+ ifM (Remote.retrieveKeyFileCheap remote key tmp)
+ ( return True
+ , ifM (Annex.getState Annex.fast)
+ ( return False
+ , Remote.retrieveKeyFile remote key tmp
+ )
+ )
{- To fsck a bare repository, fsck each key in the location log. -}
withBarePresentKeys :: (Key -> CommandStart) -> CommandSeek
@@ -205,10 +205,10 @@ verifyLocationLog' key desc present u bad = do
checkKeySize :: Key -> Annex Bool
checkKeySize key = do
file <- inRepo $ gitAnnexLocation key
- present <- liftIO $ doesFileExist file
- if present
- then checkKeySize' key file badContent
- else return True
+ ifM (liftIO $ doesFileExist file)
+ ( checkKeySize' key file badContent
+ , return True
+ )
checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool
checkKeySizeRemote _ _ Nothing = return True
@@ -219,16 +219,22 @@ checkKeySize' :: Key -> FilePath -> (Key -> Annex String) -> Annex Bool
checkKeySize' key file bad = case Types.Key.keySize key of
Nothing -> return True
Just size -> do
- stat <- liftIO $ getFileStatus file
- let size' = fromIntegral (fileSize stat)
- if size == size'
- then return True
- else do
- msg <- bad key
- warning $ "Bad file size (" ++
- compareSizes storageUnits True size size' ++
- "); " ++ msg
- return False
+ size' <- fromIntegral . fileSize
+ <$> (liftIO $ getFileStatus file)
+ comparesizes size size'
+ where
+ comparesizes a b = do
+ let same = a == b
+ unless same $ badsize a b
+ return same
+ badsize a b = do
+ msg <- bad key
+ warning $ concat
+ [ "Bad file size ("
+ , compareSizes storageUnits True a b
+ , "); "
+ , msg
+ ]
checkBackend :: Backend -> Key -> Annex Bool
checkBackend backend key = do
diff --git a/Command/Get.hs b/Command/Get.hs
index 9b12b9599..772fbd90c 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -42,37 +42,29 @@ perform key = stopUnless (getViaTmp key $ getKeyFile key) $
{- Try to find a copy of the file in one of the remotes,
- and copy it to here. -}
getKeyFile :: Key -> FilePath -> Annex Bool
-getKeyFile key file = do
- remotes <- Remote.keyPossibilities key
- if null remotes
- then do
+getKeyFile key file = dispatch =<< Remote.keyPossibilities key
+ where
+ dispatch [] = do
showNote "not available"
Remote.showLocations key []
return False
- else trycopy remotes remotes
- where
+ dispatch remotes = trycopy remotes remotes
trycopy full [] = do
Remote.showTriedRemotes full
Remote.showLocations key []
return False
- trycopy full (r:rs) = do
- probablythere <- probablyPresent r
- if probablythere
- then docopy r (trycopy full rs)
- else trycopy full rs
+ trycopy full (r:rs) =
+ ifM (probablyPresent r)
+ ( docopy r (trycopy full rs)
+ , trycopy full rs
+ )
-- This check is to avoid an ugly message if a remote is a
-- drive that is not mounted.
- probablyPresent r =
- if Remote.hasKeyCheap r
- then do
- res <- Remote.hasKey r key
- case res of
- Right b -> return b
- Left _ -> return False
- else return True
+ probablyPresent r
+ | Remote.hasKeyCheap r =
+ either (const False) id <$> Remote.hasKey r key
+ | otherwise = return True
docopy r continue = do
showAction $ "from " ++ Remote.name r
- copied <- Remote.retrieveKeyFile r key file
- if copied
- then return True
- else continue
+ ifM (Remote.retrieveKeyFile r key file)
+ ( return True , continue)
diff --git a/Command/Map.hs b/Command/Map.hs
index da7a048a4..bdb86f95a 100644
--- a/Command/Map.hs
+++ b/Command/Map.hs
@@ -41,14 +41,14 @@ start = do
trusted <- trustGet Trusted
liftIO $ writeFile file (drawMap rs umap trusted)
- next $ next $ do
- fast <- Annex.getState Annex.fast
- if fast
- then return True
- else do
+ next $ next $
+ ifM (Annex.getState Annex.fast)
+ ( return True
+ , do
showLongNote $ "running: dot -Tx11 " ++ file
showOutput
liftIO $ boolSystem "dot" [Param "-Tx11", File file]
+ )
where
file = "map.dot"
diff --git a/Command/Move.hs b/Command/Move.hs
index 6b58f711a..8612c9f2d 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -131,13 +131,13 @@ fromOk src key
return $ u /= Remote.uuid src && any (== src) remotes
fromPerform :: Remote -> Bool -> Key -> CommandPerform
fromPerform src move key = moveLock move key $ do
- ishere <- inAnnex key
- if ishere
- then handle move True
- else do
+ ifM (inAnnex key)
+ ( handle move True
+ , do
showAction $ "from " ++ Remote.name src
ok <- getViaTmp key $ Remote.retrieveKeyFile src key
handle move ok
+ )
where
handle _ False = stop -- failed
handle False True = next $ return True -- copy complete
diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs
index b0328ca19..06140fa52 100644
--- a/Command/PreCommit.hs
+++ b/Command/PreCommit.hs
@@ -7,6 +7,7 @@
module Command.PreCommit where
+import Common.Annex
import Command
import qualified Command.Add
import qualified Command.Fix
@@ -26,7 +27,6 @@ start file = next $ perform file
perform :: FilePath -> CommandPerform
perform file = do
- ok <- doCommand $ Command.Add.start file
- if ok
- then next $ return True
- else error $ "failed to add " ++ file ++ "; canceling commit"
+ unlessM (doCommand $ Command.Add.start file) $
+ error $ "failed to add " ++ file ++ "; canceling commit"
+ next $ return True
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 51b6d6f63..b9ef0bc97 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -51,11 +51,7 @@ remoteBranch :: Remote -> Git.Ref -> Git.Ref
remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote
syncRemotes :: [String] -> Annex [Remote]
-syncRemotes rs = do
- fast <- Annex.getState Annex.fast
- if fast
- then nub <$> pickfast
- else wanted
+syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
where
pickfast = (++) <$> listed <*> (good =<< fastest <$> available)
wanted
@@ -113,11 +109,11 @@ pullRemote remote branch = do
showStart "pull" (Remote.name remote)
next $ do
showOutput
- fetched <- inRepo $ Git.Command.runBool "fetch"
+ stopUnless fetch $
+ next $ mergeRemote remote branch
+ where
+ fetch = inRepo $ Git.Command.runBool "fetch"
[Param $ Remote.name remote]
- if fetched
- then next $ mergeRemote remote branch
- else stop
{- The remote probably has both a master and a synced/master branch.
- Which to merge from? Well, the master has whatever latest changes
@@ -159,15 +155,15 @@ mergeFrom branch = do
changed :: Remote -> Git.Ref -> Annex Bool
changed remote b = do
let r = remoteBranch remote b
- e <- inRepo $ Git.Ref.exists r
- if e
- then inRepo $ Git.Branch.changed b r
- else return False
+ ifM (inRepo $ Git.Ref.exists r)
+ ( inRepo $ Git.Branch.changed b r
+ , return False
+ )
newer :: Remote -> Git.Ref -> Annex Bool
newer remote b = do
let r = remoteBranch remote b
- e <- inRepo $ Git.Ref.exists r
- if e
- then inRepo $ Git.Branch.changed r b
- else return True
+ ifM (inRepo $ Git.Ref.exists r)
+ ( inRepo $ Git.Branch.changed r b
+ , return True
+ )
diff --git a/Command/Unannex.hs b/Command/Unannex.hs
index fee67429d..1e7313711 100644
--- a/Command/Unannex.hs
+++ b/Command/Unannex.hs
@@ -47,16 +47,16 @@ cleanup file key = do
Params "-m", Param "content removed from git annex",
Param "--", File file]
- fast <- Annex.getState Annex.fast
- if fast
- then do
+ ifM (Annex.getState Annex.fast)
+ ( do
-- fast mode: hard link to content in annex
src <- inRepo $ gitAnnexLocation key
liftIO $ do
createLink src file
allowWrite file
- else do
+ , do
fromAnnex key file
logStatus key InfoMissing
+ )
return True
diff --git a/Command/Unused.hs b/Command/Unused.hs
index b878ab265..246929f71 100644
--- a/Command/Unused.hs
+++ b/Command/Unused.hs
@@ -299,11 +299,11 @@ staleKeysPrune dirspec = do
staleKeys :: (Git.Repo -> FilePath) -> Annex [Key]
staleKeys dirspec = do
dir <- fromRepo dirspec
- exists <- liftIO $ doesDirectoryExist dir
- if not exists
- then return []
- else do
+ ifM (liftIO $ doesDirectoryExist dir)
+ ( do
contents <- liftIO $ getDirectoryContents dir
files <- liftIO $ filterM doesFileExist $
map (dir </>) contents
return $ mapMaybe (fileKey . takeFileName) files
+ , return []
+ )
diff --git a/Init.hs b/Init.hs
index c9d5bb909..f3d8bd017 100644
--- a/Init.hs
+++ b/Init.hs
@@ -38,23 +38,22 @@ uninitialize = gitPreCommitHookUnWrite
ensureInitialized :: Annex ()
ensureInitialized = getVersion >>= maybe needsinit checkVersion
where
- needsinit = do
- annexed <- Annex.Branch.hasSibling
- if annexed
- then initialize Nothing
- else error "First run: git-annex init"
+ needsinit = ifM Annex.Branch.hasSibling
+ ( initialize Nothing
+ , error "First run: git-annex init"
+ )
{- set up a git pre-commit hook, if one is not already present -}
gitPreCommitHookWrite :: Annex ()
gitPreCommitHookWrite = unlessBare $ do
hook <- preCommitHook
- exists <- liftIO $ doesFileExist hook
- if exists
- then warning $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
- else liftIO $ do
+ ifM (liftIO $ doesFileExist hook)
+ ( warning $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
+ , liftIO $ do
viaTmp writeFile hook preCommitScript
p <- getPermissions hook
setPermissions hook $ p {executable = True}
+ )
gitPreCommitHookUnWrite :: Annex ()
gitPreCommitHookUnWrite = unlessBare $ do
diff --git a/Remote.hs b/Remote.hs
index b3f464f5c..aac45fae9 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -70,19 +70,13 @@ addName desc n
- (Or it can be a UUID.) Only finds currently configured git remotes. -}
byName :: Maybe String -> Annex (Maybe Remote)
byName Nothing = return Nothing
-byName (Just n) = do
- res <- byName' n
- case res of
- Left e -> error e
- Right r -> return $ Just r
+byName (Just n) = either error Just <$> byName' n
byName' :: String -> Annex (Either String Remote)
byName' "" = return $ Left "no remote specified"
-byName' n = do
- match <- filter matching <$> remoteList
- if null match
- then return $ Left $ "there is no git remote named \"" ++ n ++ "\""
- else return $ Right $ Prelude.head match
+byName' n = handle . filter matching <$> remoteList
where
+ handle [] = Left $ "there is no git remote named \"" ++ n ++ "\""
+ handle match = Right $ Prelude.head match
matching r = n == name r || toUUID n == uuid r
{- Looks up a remote by name (or by UUID, or even by description),
diff --git a/Utility/Monad.hs b/Utility/Monad.hs
index 28aa33ee8..23c0c4c19 100644
--- a/Utility/Monad.hs
+++ b/Utility/Monad.hs
@@ -1,6 +1,6 @@
{- monadic stuff
-
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -14,11 +14,7 @@ import Control.Monad (liftM)
- predicate -}
firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
firstM _ [] = return Nothing
-firstM p (x:xs) = do
- q <- p x
- if q
- then return (Just x)
- else firstM p xs
+firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs)
{- Returns true if any value in the list satisfies the predicate,
- stopping once one is found. -}
@@ -29,6 +25,12 @@ anyM p = liftM isJust . firstM p
untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool
untilTrue = flip anyM
+{- if with a monadic conditional. -}
+ifM :: Monad m => m Bool -> (m a, m a) -> m a
+ifM cond (thenclause, elseclause) = do
+ c <- cond
+ if c then thenclause else elseclause
+
{- Runs an action, passing its value to an observer before returning it. -}
observe :: Monad m => (a -> m b) -> m a -> m a
observe observer a = do