diff --git a/Command/Drop.hs b/Command/Drop.hs index 05c956fddf..07cec1a677 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -7,8 +7,6 @@ module Command.Drop where -import Control.Monad (when) - import Command import qualified Backend import LocationLog @@ -46,7 +44,6 @@ perform key backend numcopies = do cleanup :: Key -> CommandCleanup cleanup key = do - inannex <- inAnnex key - when inannex $ removeAnnex key + whenM (inAnnex key) $ removeAnnex key logStatus key ValueMissing return True diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 965a99ed56..1bb3b7f970 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -7,7 +7,6 @@ module Command.DropUnused where -import Control.Monad (when) import Control.Monad.State (liftIO) import qualified Data.Map as M import System.Directory @@ -24,6 +23,7 @@ import qualified Remote import qualified GitRepo as Git import Backend import Key +import Utility type UnusedMap = M.Map String Key @@ -72,8 +72,7 @@ performOther :: (Git.Repo -> Key -> FilePath) -> Key -> CommandPerform performOther filespec key = do g <- Annex.gitRepo let f = filespec g key - e <- liftIO $ doesFileExist f - when e $ liftIO $ removeFile f + liftIO $ whenM (doesFileExist f) $ removeFile f next $ return True readUnusedLog :: FilePath -> Annex UnusedMap diff --git a/Command/Find.hs b/Command/Find.hs index eecf3cd7da..9d760ff5a8 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -7,11 +7,11 @@ module Command.Find where -import Control.Monad (when) import Control.Monad.State (liftIO) import Command import Content +import Utility command :: [Command] command = [repoCommand "find" (paramOptional $ paramRepeating paramPath) seek @@ -23,6 +23,5 @@ seek = [withFilesInGit start] {- Output a list of files. -} start :: CommandStartString start file = isAnnexed file $ \(key, _) -> do - exists <- inAnnex key - when exists $ liftIO $ putStrLn file + whenM (inAnnex key) $ liftIO $ putStrLn file stop diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 790d5d365b..09ff6df7da 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -8,7 +8,6 @@ module Command.Migrate where import Control.Monad.State (liftIO) -import Control.Monad (unless, when) import System.Posix.Files import System.Directory import System.FilePath @@ -20,6 +19,7 @@ import Locations import Types import Content import Messages +import Utility import qualified Command.Add command :: [Command] @@ -63,9 +63,7 @@ perform file oldkey newbackend = do ok <- getViaTmpUnchecked newkey $ \t -> do -- Make a hard link to the old backend's -- cached key, to avoid wasting disk space. - liftIO $ do - exists <- doesFileExist t - unless exists $ createLink src t + liftIO $ unlessM (doesFileExist t) $ createLink src t return True if ok then do @@ -74,6 +72,4 @@ perform file oldkey newbackend = do next $ Command.Add.cleanup file newkey else stop where - cleantmp t = do - exists <- doesFileExist t - when exists $ removeFile t + cleantmp t = whenM (doesFileExist t) $ removeFile t diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index 126608f614..b49116de45 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -7,13 +7,13 @@ module Command.RecvKey where -import Control.Monad (when) import Control.Monad.State (liftIO) import System.Exit import Command import CmdLine import Content +import Utility import RsyncFile command :: [Command] @@ -25,9 +25,7 @@ seek = [withKeys start] start :: CommandStartKey start key = do - present <- inAnnex key - when present $ - error "key is already present in annex" + whenM (inAnnex key) $ error "key is already present in annex" ok <- getViaTmp key (liftIO . rsyncServerReceive) if ok diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 871a530af7..7497ce3bfe 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -7,7 +7,6 @@ module Command.SendKey where -import Control.Monad (when) import Control.Monad.State (liftIO) import System.Exit @@ -15,6 +14,7 @@ import Locations import qualified Annex import Command import Content +import Utility import RsyncFile command :: [Command] @@ -26,9 +26,8 @@ seek = [withKeys start] start :: CommandStartKey start key = do - present <- inAnnex key g <- Annex.gitRepo let file = gitAnnexLocation g key - when present $ - liftIO $ rsyncServerSend file + whenM (inAnnex key) $ + liftIO $ rsyncServerSend file -- does not return liftIO exitFailure diff --git a/Command/Uninit.hs b/Command/Uninit.hs index d3d7ac3398..1e96e1e6f7 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -8,7 +8,6 @@ module Command.Uninit where import Control.Monad.State (liftIO) -import Control.Monad (when) import System.Directory import Command @@ -44,8 +43,7 @@ perform = do gitPreCommitHookUnWrite :: Git.Repo -> Annex () gitPreCommitHookUnWrite repo = do let hook = Command.Init.preCommitHook repo - hookexists <- liftIO $ doesFileExist hook - when hookexists $ do + whenM (liftIO $ doesFileExist hook) $ do c <- liftIO $ readFile hook if c == Command.Init.preCommitScript then liftIO $ removeFile hook @@ -56,8 +54,7 @@ gitPreCommitHookUnWrite repo = do gitAttributesUnWrite :: Git.Repo -> IO () gitAttributesUnWrite repo = do let attributes = Git.attributes repo - attrexists <- doesFileExist attributes - when attrexists $ do + whenM (doesFileExist attributes) $ do c <- readFileStrict attributes safeWriteFile attributes $ unlines $ filter (\l -> not $ l `elem` Command.Init.attrLines) $ lines c diff --git a/Command/Unlock.hs b/Command/Unlock.hs index d65579ec73..161df2ddf9 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -7,7 +7,6 @@ module Command.Unlock where -import Control.Monad (when) import Control.Monad.State (liftIO) import System.Directory hiding (copyFile) @@ -19,6 +18,7 @@ import Messages import Locations import Content import CopyFile +import Utility command :: [Command] command = @@ -38,9 +38,7 @@ start file = isAnnexed file $ \(key, _) -> do perform :: FilePath -> Key -> CommandPerform perform dest key = do - inbackend <- Backend.hasKey key - when (not inbackend) $ - error "content not present" + unlessM (Backend.hasKey key) $ error "content not present" checkDiskSpace key diff --git a/Content.hs b/Content.hs index 0758fcdb13..ec7a3776bf 100644 --- a/Content.hs +++ b/Content.hs @@ -134,8 +134,7 @@ withTmp key action = do let tmp = gitAnnexTmpLocation g key liftIO $ createDirectoryIfMissing True (parentDir tmp) res <- action tmp - tmp_exists <- liftIO $ doesFileExist tmp - when tmp_exists $ liftIO $ removeFile tmp + liftIO $ whenM (doesFileExist tmp) $ liftIO $ removeFile tmp return res {- Checks that there is disk space available to store a given key, @@ -160,8 +159,7 @@ checkDiskSpace' adjustment key = do megabyte :: Integer megabyte = 1000000 needmorespace n = do - force <- Annex.getState Annex.force - unless force $ + unlessM (Annex.getState Annex.force) $ error $ "not enough free space, need " ++ roughSize storageUnits True n ++ " more (use --force to override this check or adjust annex.diskreserve)" diff --git a/CopyFile.hs b/CopyFile.hs index 4575fb08ad..b08ede3c88 100644 --- a/CopyFile.hs +++ b/CopyFile.hs @@ -7,7 +7,6 @@ module CopyFile (copyFile) where -import Control.Monad (when) import System.Directory (doesFileExist, removeFile) import Utility @@ -17,8 +16,7 @@ import qualified SysConfig - and because this allows easy access to features like cp --reflink. -} copyFile :: FilePath -> FilePath -> IO Bool copyFile src dest = do - e <- doesFileExist dest - when e $ + whenM (doesFileExist dest) $ removeFile dest boolSystem "cp" [params, File src, File dest] where diff --git a/GitRepo.hs b/GitRepo.hs index 87cceece41..d070bc89ef 100644 --- a/GitRepo.hs +++ b/GitRepo.hs @@ -329,9 +329,9 @@ gitCommandLine repo _ = assertLocal repo $ error "internal" {- Runs git in the specified repo, throwing an error if it fails. -} run :: Repo -> String -> [CommandParam] -> IO () -run repo subcommand params = assertLocal repo $ do - ok <- boolSystem "git" (gitCommandLine repo ((Param subcommand):params)) - unless ok $ error $ "git " ++ show params ++ " failed" +run repo subcommand params = assertLocal repo $ + boolSystem "git" (gitCommandLine repo ((Param subcommand):params)) + <|> error $ "git " ++ show params ++ " failed" {- Runs a git subcommand and returns it output, lazily. - diff --git a/Remote/Bup.hs b/Remote/Bup.hs index d2b771bf77..51a5d05d17 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -11,7 +11,7 @@ import qualified Data.ByteString.Lazy.Char8 as L import IO import Control.Exception.Extensible (IOException) import qualified Data.Map as M -import Control.Monad (unless, when) +import Control.Monad (when) import Control.Monad.State (liftIO) import System.Process import System.Exit @@ -75,8 +75,7 @@ bupSetup u c = do -- bup init will create the repository. -- (If the repository already exists, bup init again appears safe.) showNote "bup init" - ok <- bup "init" buprepo [] - unless ok $ error "bup init failed" + bup "init" buprepo [] <|> error "bup init failed" storeBupUUID u buprepo @@ -172,9 +171,9 @@ storeBupUUID u buprepo = do if Git.repoIsUrl r then do showNote "storing uuid" - ok <- onBupRemote r boolSystem "git" + onBupRemote r boolSystem "git" [Params $ "config annex.uuid " ++ u] - unless ok $ do error "ssh failed" + <|> error "ssh failed" else liftIO $ do r' <- Git.configRead r let olduuid = Git.configGet r' "annex.uuid" "" diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 0cd3760d63..f69aa1256b 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -62,8 +62,8 @@ directorySetup u c = do -- verify configuration is sane let dir = maybe (error "Specify directory=") id $ M.lookup "directory" c - e <- liftIO $ doesDirectoryExist dir - when (not e) $ error $ "Directory does not exist: " ++ dir + liftIO $ doesDirectoryExist dir + <|> error $ "Directory does not exist: " ++ dir c' <- encryptionSetup c -- The directory is stored in git config, not in this remote's diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index c15ab37a75..53418a9ef8 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -10,7 +10,7 @@ module Remote.Rsync (remote) where import qualified Data.ByteString.Lazy.Char8 as L import Control.Exception.Extensible (IOException) import qualified Data.Map as M -import Control.Monad.State (liftIO, when) +import Control.Monad.State (liftIO) import System.FilePath import System.Directory import System.Posix.Files @@ -168,9 +168,8 @@ withRsyncScratchDir a = do nuke tmp return res where - nuke d = liftIO $ do - e <- doesDirectoryExist d - when e $ liftIO $ removeDirectoryRecursive d + nuke d = liftIO $ + doesDirectoryExist d <&> removeDirectoryRecursive d rsyncRemote :: RsyncOpts -> [CommandParam] -> Annex Bool rsyncRemote o params = do diff --git a/Utility.hs b/Utility.hs index 6dd7d329c8..5aa0afea7d 100644 --- a/Utility.hs +++ b/Utility.hs @@ -1,4 +1,4 @@ -{- git-annex utility functions +{- general purpose utility functions - - Copyright 2010-2011 Joey Hess - @@ -26,6 +26,10 @@ module Utility ( dirContents, myHomeDir, catchBool, + whenM, + (<&>), + unlessM, + (<|>), prop_idempotent_shellEscape, prop_idempotent_shellEscape_multiword, @@ -46,7 +50,8 @@ import System.FilePath import System.Directory import Foreign (complement) import Data.List -import Control.Monad (liftM2) +import Data.Maybe +import Control.Monad (liftM2, when, unless) {- A type for parameters passed to a shell command. A command can - be passed either some Params (multiple parameters can be included, @@ -110,7 +115,7 @@ shellEscape f = "'" ++ escaped ++ "'" {- Unescapes a set of shellEscaped words or filenames. -} shellUnEscape :: String -> [String] shellUnEscape [] = [] -shellUnEscape s = word:(shellUnEscape rest) +shellUnEscape s = word : shellUnEscape rest where (word, rest) = findword "" s findword w [] = (w, "") @@ -165,7 +170,7 @@ prop_parentDir_basics dir dirContains :: FilePath -> FilePath -> Bool dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b' where - norm p = maybe "" id $ absNormPath p "." + norm p = fromMaybe "" $ absNormPath p "." a' = norm a b' = norm b @@ -178,7 +183,7 @@ absPath file = do {- Converts a filename into a normalized, absolute path - from the specified cwd. -} absPathFrom :: FilePath -> FilePath -> FilePath -absPathFrom cwd file = maybe bad id $ absNormPath cwd file +absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file where bad = error $ "unable to normalize " ++ file @@ -258,3 +263,20 @@ myHomeDir = do {- Catches IO errors and returns a Bool -} catchBool :: IO Bool -> IO Bool catchBool = flip catch (const $ return False) + +{- when with a monadic conditional -} +whenM :: Monad m => m Bool -> m () -> m () +whenM c a = c >>= flip when a + +unlessM :: Monad m => m Bool -> m () -> m () +unlessM c a = c >>= flip unless a + +(<&>) :: Monad m => m Bool -> m () -> m () +(<&>) = whenM + +(<|>) :: Monad m => m Bool -> m () -> m () +(<|>) = unlessM + +-- low fixity allows eg, foo bar <|> error $ "failed " ++ meep +infixr 0 <&> +infixr 0 <|> diff --git a/git-annex-shell.hs b/git-annex-shell.hs index e8a744748b..1487a61616 100644 --- a/git-annex-shell.hs +++ b/git-annex-shell.hs @@ -6,7 +6,6 @@ -} import System.Environment -import Control.Monad (when) import Data.List import qualified GitRepo as Git @@ -66,8 +65,7 @@ builtin cmd dir params = do external :: [String] -> IO () external params = do - ret <- boolSystem "git-shell" $ map Param $ ("-c":filterparams params) - when (not ret) $ + unlessM (boolSystem "git-shell" $ map Param $ "-c":filterparams params) $ error "git-shell failed" -- Drop all args after "--".