add whenM and unlessM

Just more golfing.. I am pretty sure something in a library somewhere can
do this, but I have been unable to find it.

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

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

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

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

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

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

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

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
 

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)"

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

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. 
  -

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" ""

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

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

Utility.hs

@@ -1,4 +1,4 @@
-{- git-annex utility functions
+{- general purpose utility functions
  -
  - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
  -
@@ -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 <|>

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 "--".