enable LambdaCase and convert around 10% of places that could use it

Needs ghc 7.6.1, so minimum base version increased slightly. All builds
are well above this version of ghc, and debian oldstable is as well.

Code that could use lambdacase can be found by running:
git grep -B 1 'case ' | less
and searching in less for "<-"

This commit was sponsored by andrea rota.

Annex/AdjustedBranch.hs

@@ -80,9 +80,8 @@ adjustTreeItem UnlockAdjustment = ifSymlink adjustToPointer noAdjust
 adjustTreeItem LockAdjustment = ifSymlink noAdjust adjustToSymlink
 adjustTreeItem FixAdjustment = ifSymlink adjustToSymlink noAdjust
 adjustTreeItem UnFixAdjustment = ifSymlink (adjustToSymlink' gitAnnexLinkCanonical) noAdjust
-adjustTreeItem HideMissingAdjustment = \ti@(TreeItem _ _ s) -> do
+adjustTreeItem HideMissingAdjustment = \ti@(TreeItem _ _ s) ->
-	mk <- catKey s
+	catKey s >>= \case
-	case mk of
 		Just k -> ifM (inAnnex k)
 			( return (Just ti)
 			, return Nothing
@@ -99,29 +98,25 @@ noAdjust :: TreeItem -> Annex (Maybe TreeItem)
 noAdjust = return . Just
 
 adjustToPointer :: TreeItem -> Annex (Maybe TreeItem)
-adjustToPointer ti@(TreeItem f _m s) = do
+adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case
-	mk <- catKey s
+	Just k -> do
-	case mk of
+		Database.Keys.addAssociatedFile k f
-		Just k -> do
+		Just . TreeItem f (fromBlobType FileBlob)
-			Database.Keys.addAssociatedFile k f
+			<$> hashPointerFile k
-			Just . TreeItem f (fromBlobType FileBlob)
+	Nothing -> return (Just ti)
-				<$> hashPointerFile k
-		Nothing -> return (Just ti)
 
 adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem)
 adjustToSymlink = adjustToSymlink' gitAnnexLink
 
 adjustToSymlink' :: (FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath) -> TreeItem -> Annex (Maybe TreeItem)
-adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = do
+adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case
-	mk <- catKey s
+	Just k -> do
-	case mk of
+		absf <- inRepo $ \r -> absPath $
-		Just k -> do
+			fromTopFilePath f r
-			absf <- inRepo $ \r -> absPath $
+		linktarget <- calcRepo $ gitannexlink absf k
-				fromTopFilePath f r
+		Just . TreeItem f (fromBlobType SymlinkBlob)
-			linktarget <- calcRepo $ gitannexlink absf k
+			<$> hashSymlink linktarget
-			Just . TreeItem f (fromBlobType SymlinkBlob)
+	Nothing -> return (Just ti)
-				<$> hashSymlink linktarget
-		Nothing -> return (Just ti)
 
 type OrigBranch = Branch
 newtype AdjBranch = AdjBranch { adjBranch :: Branch }
@@ -438,11 +433,9 @@ updateAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge commi
 		return True
 	reparent _ _ Nothing = return False
 
-	getcurrentcommit = do
+	getcurrentcommit = inRepo Git.Branch.currentUnsafe >>= \case
-		v <- inRepo Git.Branch.currentUnsafe
+		Nothing -> return Nothing
-		case v of
+		Just c -> catCommit c
-			Nothing -> return Nothing
-			Just c -> catCommit c
 
 {- Check for any commits present on the adjusted branch that have not yet
  - been propigated to the basis branch, and propigate them to the basis
@@ -463,23 +456,19 @@ propigateAdjustedCommits'
 	-> Adjustment
 	-> CommitsPrevented
 	-> Annex (Maybe Sha, Annex ())
-propigateAdjustedCommits' origbranch adj _commitsprevented = do
+propigateAdjustedCommits' origbranch adj _commitsprevented =
-	ov <- inRepo $ Git.Ref.sha basis
+	inRepo (Git.Ref.sha basis) >>= \case
-	case ov of
+		Just origsha -> catCommit currbranch >>= \case
-		Just origsha -> do
+			Just currcommit ->
-			cv <- catCommit currbranch
+				newcommits >>= go origsha False >>= \case
-			case cv of
+					Left e -> do
-				Just currcommit -> do
+						warning e
-					v <- newcommits >>= go origsha False
+						return (Nothing, return ())
-					case v of
+					Right newparent -> return
-						Left e -> do
+						( Just newparent
-							warning e
+						, rebase currcommit newparent
-							return (Nothing, return ())
+						)
-						Right newparent -> return
+			Nothing -> return (Nothing, return ())
-							( Just newparent
-							, rebase currcommit newparent
-							)
-				Nothing -> return (Nothing, return ())
 		Nothing -> return (Nothing, return ())
   where
 	(BasisBranch basis) = basisBranch adjbranch
@@ -492,18 +481,16 @@ propigateAdjustedCommits' origbranch adj _commitsprevented = do
 		setBasisBranch (BasisBranch basis) parent
 		inRepo $ Git.Branch.update' origbranch parent
 		return (Right parent)
-	go parent pastadjcommit (sha:l) = do
+	go parent pastadjcommit (sha:l) = catCommit sha >>= \case
-		mc <- catCommit sha
+		Just c
-		case mc of
+			| commitMessage c == adjustedBranchCommitMessage ->
-			Just c
+				go parent True l
-				| commitMessage c == adjustedBranchCommitMessage ->
+			| pastadjcommit ->
-					go parent True l
+				reverseAdjustedCommit parent adj (sha, c) origbranch
-				| pastadjcommit -> do
+					>>= \case
-					v <- reverseAdjustedCommit parent adj (sha, c) origbranch
-					case v of
 						Left e -> return (Left e)
 						Right commit -> go commit pastadjcommit l
-			_ -> go parent pastadjcommit l
+		_ -> go parent pastadjcommit l
 	rebase currcommit newparent = do
 		-- Reuse the current adjusted tree, and reparent it
 		-- on top of the newparent.

Annex/AutoMerge.hs

@@ -217,9 +217,8 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
 
 	makepointer key dest destmode = do
 		unless inoverlay $ 
-			unlessM (reuseOldFile unstagedmap key file dest) $ do
+			unlessM (reuseOldFile unstagedmap key file dest) $
-				r <- linkFromAnnex key dest destmode
+				linkFromAnnex key dest destmode >>= \case
-				case r of
 					LinkAnnexFailed -> liftIO $
 						writePointerFile dest key destmode
 					_ -> noop

Annex/Branch.hs

@@ -446,18 +446,16 @@ stageJournal jl = withIndex $ do
 			[genstream dir h jh jlogh]
 	return $ cleanup dir jlogh jlogf
   where
-	genstream dir h jh jlogh streamer = do
+	genstream dir h jh jlogh streamer = readDirectory jh >>= \case
-		v <- readDirectory jh
+		Nothing -> return ()
-		case v of
+		Just file -> do
-			Nothing -> return ()
+			unless (dirCruft file) $ do
-			Just file -> do
+				let path = dir </> file
-				unless (dirCruft file) $ do
+				sha <- Git.HashObject.hashFile h path
-					let path = dir </> file
+				hPutStrLn jlogh file
-					sha <- Git.HashObject.hashFile h path
+				streamer $ Git.UpdateIndex.updateIndexLine
-					hPutStrLn jlogh file
+					sha FileBlob (asTopFilePath $ fileJournal file)
-					streamer $ Git.UpdateIndex.updateIndexLine
+			genstream dir h jh jlogh streamer
-						sha FileBlob (asTopFilePath $ fileJournal file)
-				genstream dir h jh jlogh streamer
 	-- Clean up the staged files, as listed in the temp log file.
 	-- The temp file is used to avoid needing to buffer all the
 	-- filenames in memory.

Annex/ChangedRefs.hs

@@ -39,31 +39,26 @@ data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha)
 -- When possible, coalesce ref writes that occur closely together
 -- in time. Delay up to 0.05 seconds to get more ref writes.
 waitChangedRefs :: ChangedRefsHandle -> IO ChangedRefs
-waitChangedRefs (ChangedRefsHandle _ chan) = do
+waitChangedRefs (ChangedRefsHandle _ chan) =
-	v <- atomically $ readTBMChan chan
+	atomically (readTBMChan chan) >>= \case
-	case v of
 		Nothing -> return $ ChangedRefs []
 		Just r -> do
 			threadDelay 50000
 			rs <- atomically $ loop []
 			return $ ChangedRefs (r:rs)
   where
-	loop rs = do
+	loop rs = tryReadTBMChan chan >>= \case
-		v <- tryReadTBMChan chan
+		Just (Just r) -> loop (r:rs)
-		case v of
+		_ -> return rs
-			Just (Just r) -> loop (r:rs)
-			_ -> return rs
 
 -- | Remove any changes that might be buffered in the channel,
 -- without waiting for any new changes.
 drainChangedRefs :: ChangedRefsHandle -> IO ()
 drainChangedRefs (ChangedRefsHandle _ chan) = atomically go
   where
-	go = do
+	go = tryReadTBMChan chan >>= \case
-		v <- tryReadTBMChan chan
+		Just (Just _) -> go
-		case v of
+		_ -> return ()
-			Just (Just _) -> go
-			_ -> return ()
 
 stopWatchingChangedRefs :: ChangedRefsHandle -> IO ()
 stopWatchingChangedRefs h@(ChangedRefsHandle wh chan) = do

Annex/Content.hs

@@ -149,30 +149,25 @@ inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key
 			( checkOr is_unlocked lockfile
 			, return is_missing
 			)
-	checkOr d lockfile = do
+	checkOr d lockfile = checkLocked lockfile >>= return . \case
-		v <- checkLocked lockfile
+		Nothing -> d
-		return $ case v of
+		Just True -> is_locked
-			Nothing -> d
+		Just False -> is_unlocked
-			Just True -> is_locked
-			Just False -> is_unlocked
 #else
 	checkindirect f = liftIO $ ifM (doesFileExist f)
-		( do
+		( lockShared f >>= \case
-			v <- lockShared f
+			Nothing -> return is_locked
-			case v of
+			Just lockhandle -> do
-				Nothing -> return is_locked
+				dropLock lockhandle
-				Just lockhandle -> do
+				return is_unlocked
-					dropLock lockhandle
-					return is_unlocked
 		, return is_missing
 		)
 	{- In Windows, see if we can take a shared lock. If so, 
 	 - remove the lock file to clean up after ourselves. -}
 	checkdirect contentfile lockfile =
 		ifM (liftIO $ doesFileExist contentfile)
-			( modifyContent lockfile $ liftIO $ do
+			( modifyContent lockfile $ liftIO $
-				v <- lockShared lockfile
+				lockShared >>= \case
-				case v of
 					Nothing -> return is_locked
 					Just lockhandle -> do
 						dropLock lockhandle
@@ -428,8 +423,7 @@ checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getSta
 		inprogress <- if samefilesystem
 			then sizeOfDownloadsInProgress (/= key)
 			else pure 0
-		free <- liftIO . getDiskFree =<< dir
+		dir >>= liftIO . getDiskFree >>= \case
-		case free of
 			Just have -> do
 				reserve <- annexDiskReserve <$> Annex.getGitConfig
 				let delta = need + reserve - have - alreadythere + inprogress
@@ -581,9 +575,8 @@ data FromTo = From | To
  -}
 linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult
 linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed
-linkAnnex fromto key src (Just srcic) dest destmode = do
+linkAnnex fromto key src (Just srcic) dest destmode =
-	mdestic <- withTSDelta (liftIO . genInodeCache dest)
+	withTSDelta (liftIO . genInodeCache dest) >>= \case
-	case mdestic of
 		Just destic -> do
 			cs <- Database.Keys.getInodeCaches key
 			if null cs
@@ -602,17 +595,15 @@ linkAnnex fromto key src (Just srcic) dest destmode = do
 	failed = do
 		Database.Keys.addInodeCaches key [srcic]
 		return LinkAnnexFailed
-	checksrcunchanged = do
+	checksrcunchanged = withTSDelta (liftIO . genInodeCache src) >>= \case
-		mcache <- withTSDelta (liftIO . genInodeCache src)
+		Just srcic' | compareStrong srcic srcic' -> do
-		case mcache of
+			destic <- withTSDelta (liftIO . genInodeCache dest)
-			Just srcic' | compareStrong srcic srcic' -> do
+			Database.Keys.addInodeCaches key $
-				destic <- withTSDelta (liftIO . genInodeCache dest)
+				catMaybes [destic, Just srcic]
-				Database.Keys.addInodeCaches key $
+			return LinkAnnexOk
-					catMaybes [destic, Just srcic]
+		_ -> do
-				return LinkAnnexOk
+			liftIO $ nukeFile dest
-			_ -> do
+			failed
-				liftIO $ nukeFile dest
-				failed
 
 {- Hard links or copies src to dest, which must not already exists.
  -

Annex/Direct.hs

@@ -111,9 +111,8 @@ preCommitDirect = do
 		withkey (DiffTree.srcsha diff) (DiffTree.srcmode diff) removeAssociatedFile
 		withkey (DiffTree.dstsha diff) (DiffTree.dstmode diff) addAssociatedFile
 	  where
-		withkey sha _mode a = when (sha /= nullSha) $ do
+		withkey sha _mode a = when (sha /= nullSha) $
-			k <- catKey sha
+			catKey sha >>= \case
-			case k of
 				Nothing -> noop
 				Just key -> void $ a key $
 					makeabs $ DiffTree.file diff
@@ -427,14 +426,12 @@ setDirect wantdirect = do
 			then moveconfig coreworktree indirectworktree
 			else moveconfig indirectworktree coreworktree
 		setConfig (ConfigKey Git.Config.coreBare) val
-	moveconfig src dest = do
+	moveconfig src dest = getConfigMaybe src >>= \case
-		v <- getConfigMaybe src
+		Nothing -> noop
-		case v of
+		Just wt -> do
-			Nothing -> noop
+			unsetConfig src
-			Just wt -> do
+			setConfig dest wt
-				unsetConfig src
+			reloadConfig
-				setConfig dest wt
-				reloadConfig
 
 {- Since direct mode sets core.bare=true, incoming pushes could change
  - the currently checked out branch. To avoid this problem, HEAD
@@ -474,8 +471,7 @@ switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
   where
 	switch currhead = do
 		let orighead = fromDirectBranch currhead
-		v <- inRepo $ Git.Ref.sha currhead
+		inRepo (Git.Ref.sha currhead) >>= \case
-		case v of
 			Just headsha
 				| orighead /= currhead -> do
 					inRepo $ Git.Branch.update "leaving direct mode" orighead headsha

Annex/FileMatcher.hs

@@ -133,12 +133,10 @@ mkLargeFilesParser = do
 #ifdef WITH_MAGICMIME
 	magicmime <- liftIO $ catchMaybeIO $ do
 		m <- magicOpen [MagicMimeType]
-		liftIO $ do
+		liftIO $ getEnv "GIT_ANNEX_DIR" >>= \case
-			md <- getEnv "GIT_ANNEX_DIR"
+			Nothing -> magicLoadDefault m
-			case md of
+			Just d -> magicLoad m
-				Nothing -> magicLoadDefault m
+				(d </> "magic" </> "magic.mgc")
-				Just d -> magicLoad m
-					(d </> "magic" </> "magic.mgc")
 		return m
 #endif
 	let parse = parseToken $ commonTokens

Annex/Ingest.hs

@@ -169,9 +169,8 @@ ingest' preferredbackend (Just (LockedDown cfg source)) mk = withTSDelta $ \delt
 			)
 	go _ _ _ = failure "failed to generate a key"
 
-	golocked key mcache s = do
+	golocked key mcache s =
-		v <- tryNonAsync (moveAnnex key $ contentLocation source)
+		tryNonAsync (moveAnnex key $ contentLocation source) >>= \case
-		case v of
 			Right True -> do
 				populateAssociatedFiles key source
 				success key mcache s		
@@ -184,8 +183,7 @@ ingest' preferredbackend (Just (LockedDown cfg source)) mk = withTSDelta $ \delt
 		-- already has a hard link.
 		cleanCruft source
 		cleanOldKeys (keyFilename source) key
-		r <- linkToAnnex key (keyFilename source) (Just cache)
+		linkToAnnex key (keyFilename source) (Just cache) >>= \case
-		case r of
 			LinkAnnexFailed -> failure "failed to link to annex"
 			_ -> do
 				finishIngestUnlocked' key source
@@ -259,8 +257,7 @@ cleanOldKeys file newkey = do
 			fs <- filter (/= ingestedf)
 				. map (`fromTopFilePath` g)
 				<$> Database.Keys.getAssociatedFiles key
-			fs' <- filterM (`sameInodeCache` caches) fs
+			filterM (`sameInodeCache` caches) fs >>= \case
-			case fs' of
 				-- If linkToAnnex fails, the associated 
 				-- file with the content is still present,
 				-- so no need for any recovery.
@@ -342,14 +339,12 @@ cachedCurrentBranch = maybe cache (return . Just)
 	=<< Annex.getState Annex.cachedcurrentbranch
   where
 	cache :: Annex (Maybe Git.Branch)
-	cache = do
+	cache = inRepo Git.Branch.currentUnsafe >>= \case
-		mb <- inRepo Git.Branch.currentUnsafe
+		Nothing -> return Nothing
-		case mb of
+		Just b -> do
-			Nothing -> return Nothing
+			Annex.changeState $ \s ->
-			Just b -> do
+				s { Annex.cachedcurrentbranch = Just b }
-				Annex.changeState $ \s ->
+			return (Just b)
-					s { Annex.cachedcurrentbranch = Just b }
-				return (Just b)
 
 {- Adds a file to the work tree for the key, and stages it in the index.
  - The content of the key may be provided in a temp file, which will be
@@ -389,10 +384,8 @@ addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect)
 			Nothing -> return True
 	)
   where
-	linkunlocked mode = do
+	linkunlocked mode = linkFromAnnex key file mode >>= \case
-		r <- linkFromAnnex key file mode
+		LinkAnnexFailed -> liftIO $
-		case r of
+			writePointerFile file key mode
-			LinkAnnexFailed -> liftIO $
+		_ -> return ()
-				writePointerFile file key mode
-			_ -> return ()
 	writepointer mode = liftIO $ writePointerFile file key mode

Annex/Init.hs

@@ -93,8 +93,7 @@ initialize' mversion = do
 	whenM versionSupportsUnlockedPointers $ do
 		configureSmudgeFilter
 		scanUnlockedFiles
-	v <- checkAdjustedClone
+	checkAdjustedClone >>= \case
-	case v of
 		NeedUpgradeForAdjustedClone -> 
 			void $ upgrade True  versionForAdjustedClone
 		InAdjustedClone -> return ()

Annex/LockPool/PosixOrPid.hs

@@ -49,12 +49,10 @@ tryLockExclusive m f = tryPidLock m f $ Posix.tryLockExclusive m f
 checkLocked :: LockFile -> Annex (Maybe Bool)
 checkLocked f = Posix.checkLocked f `pidLockCheck` checkpid
   where
-	checkpid pidlock = do
+	checkpid pidlock = Pid.checkLocked pidlock >>= \case
-		v <- Pid.checkLocked pidlock
+		-- Only return true when the posix lock file exists.
-		case v of
+		Just _ -> Posix.checkLocked f
-			-- Only return true when the posix lock file exists.
+		Nothing -> return Nothing
-			Just _ -> Posix.checkLocked f
-			Nothing -> return Nothing
 
 getLockStatus :: LockFile -> Annex LockStatus
 getLockStatus f = Posix.getLockStatus f

Annex/MetaData.hs

@@ -39,8 +39,7 @@ import Data.Time.Clock.POSIX
  -}
 genMetaData :: Key -> FilePath -> FileStatus -> Annex ()
 genMetaData key file status = do
-	v <- catKeyFileHEAD file
+	catKeyFileHEAD file >>= \case
-	case v of
 		Nothing -> noop
 		Just oldkey -> 
 			whenM (copyMetaData oldkey key)

Annex/Perms.hs

@@ -112,7 +112,7 @@ isContentWritePermOk file = ifM crippledFileSystem
 	go AllShared = want writeModes
 	go _ = return True
 	want wantmode = do
-		mmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
+		liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
 		return $ case mmode of
 			Nothing -> True
 			Just havemode -> havemode == combineModes (havemode:wantmode)

git-annex.cabal

@@ -306,7 +306,7 @@ source-repository head
 Executable git-annex
   Main-Is: git-annex.hs
   Build-Depends:
-   base (>= 4.5 && < 5.0),
+   base (>= 4.6 && < 5.0),
    optparse-applicative (>= 0.11.0), 
    containers (>= 0.5.0.0),
    exceptions (>= 0.6),
@@ -360,7 +360,7 @@ Executable git-annex
    split
   CC-Options: -Wall
   GHC-Options: -Wall -fno-warn-tabs
-  Extensions: PackageImports
+  Extensions: PackageImports, LambdaCase
   -- Some things don't work with the non-threaded RTS.
   GHC-Options: -threaded
   Other-Extensions: TemplateHaskell