summaryrefslogtreecommitdiff
path: root/Annex
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2017-11-15 16:55:38 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2017-11-15 16:59:32 -0400
commit4888bd597e34dce996fd581bb417ce017099171b (patch)
tree8b97f6807b5528be6b00c8d21038057ca097ec29 /Annex
parent01c524779136a688abf312e721abce41d2dd109c (diff)
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.
Diffstat (limited to 'Annex')
-rw-r--r--Annex/AdjustedBranch.hs93
-rw-r--r--Annex/AutoMerge.hs5
-rw-r--r--Annex/Branch.hs22
-rw-r--r--Annex/ChangedRefs.hs21
-rw-r--r--Annex/Content.hs55
-rw-r--r--Annex/Direct.hs22
-rw-r--r--Annex/FileMatcher.hs10
-rw-r--r--Annex/Ingest.hs35
-rw-r--r--Annex/Init.hs3
-rw-r--r--Annex/LockPool/PosixOrPid.hs10
-rw-r--r--Annex/MetaData.hs3
-rw-r--r--Annex/Perms.hs2
12 files changed, 117 insertions, 164 deletions
diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs
index 9eedf06f5..1ffc54f66 100644
--- a/Annex/AdjustedBranch.hs
+++ b/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
- mk <- catKey s
- case mk of
+adjustTreeItem HideMissingAdjustment = \ti@(TreeItem _ _ s) ->
+ catKey s >>= \case
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
- mk <- catKey s
- case mk of
- Just k -> do
- Database.Keys.addAssociatedFile k f
- Just . TreeItem f (fromBlobType FileBlob)
- <$> hashPointerFile k
- Nothing -> return (Just ti)
+adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case
+ Just k -> do
+ Database.Keys.addAssociatedFile k f
+ Just . TreeItem f (fromBlobType FileBlob)
+ <$> 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
- mk <- catKey s
- case mk of
- Just k -> do
- absf <- inRepo $ \r -> absPath $
- fromTopFilePath f r
- linktarget <- calcRepo $ gitannexlink absf k
- Just . TreeItem f (fromBlobType SymlinkBlob)
- <$> hashSymlink linktarget
- Nothing -> return (Just ti)
+adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case
+ Just k -> do
+ absf <- inRepo $ \r -> absPath $
+ fromTopFilePath f r
+ linktarget <- calcRepo $ gitannexlink absf k
+ Just . TreeItem f (fromBlobType SymlinkBlob)
+ <$> 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
- v <- inRepo Git.Branch.currentUnsafe
- case v of
- Nothing -> return Nothing
- Just c -> catCommit c
+ getcurrentcommit = inRepo Git.Branch.currentUnsafe >>= \case
+ 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
- ov <- inRepo $ Git.Ref.sha basis
- case ov of
- Just origsha -> do
- cv <- catCommit currbranch
- case cv of
- Just currcommit -> do
- v <- newcommits >>= go origsha False
- case v of
- Left e -> do
- warning e
- return (Nothing, return ())
- Right newparent -> return
- ( Just newparent
- , rebase currcommit newparent
- )
- Nothing -> return (Nothing, return ())
+propigateAdjustedCommits' origbranch adj _commitsprevented =
+ inRepo (Git.Ref.sha basis) >>= \case
+ Just origsha -> catCommit currbranch >>= \case
+ Just currcommit ->
+ newcommits >>= go origsha False >>= \case
+ Left e -> do
+ warning e
+ return (Nothing, return ())
+ Right newparent -> 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
- mc <- catCommit sha
- case mc of
- Just c
- | commitMessage c == adjustedBranchCommitMessage ->
- go parent True l
- | pastadjcommit -> do
- v <- reverseAdjustedCommit parent adj (sha, c) origbranch
- case v of
+ go parent pastadjcommit (sha:l) = catCommit sha >>= \case
+ Just c
+ | commitMessage c == adjustedBranchCommitMessage ->
+ go parent True l
+ | pastadjcommit ->
+ reverseAdjustedCommit parent adj (sha, c) origbranch
+ >>= \case
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.
diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs
index 91f8fc99e..078e69eec 100644
--- a/Annex/AutoMerge.hs
+++ b/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
- r <- linkFromAnnex key dest destmode
- case r of
+ unlessM (reuseOldFile unstagedmap key file dest) $
+ linkFromAnnex key dest destmode >>= \case
LinkAnnexFailed -> liftIO $
writePointerFile dest key destmode
_ -> noop
diff --git a/Annex/Branch.hs b/Annex/Branch.hs
index 5f3c71b1a..0dc360c54 100644
--- a/Annex/Branch.hs
+++ b/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
- v <- readDirectory jh
- case v of
- Nothing -> return ()
- Just file -> do
- unless (dirCruft file) $ do
- let path = dir </> file
- sha <- Git.HashObject.hashFile h path
- hPutStrLn jlogh file
- streamer $ Git.UpdateIndex.updateIndexLine
- sha FileBlob (asTopFilePath $ fileJournal file)
- genstream dir h jh jlogh streamer
+ genstream dir h jh jlogh streamer = readDirectory jh >>= \case
+ Nothing -> return ()
+ Just file -> do
+ unless (dirCruft file) $ do
+ let path = dir </> file
+ sha <- Git.HashObject.hashFile h path
+ hPutStrLn jlogh file
+ streamer $ Git.UpdateIndex.updateIndexLine
+ 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.
diff --git a/Annex/ChangedRefs.hs b/Annex/ChangedRefs.hs
index 1f2372c04..edef1c06c 100644
--- a/Annex/ChangedRefs.hs
+++ b/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
- v <- atomically $ readTBMChan chan
- case v of
+waitChangedRefs (ChangedRefsHandle _ chan) =
+ atomically (readTBMChan chan) >>= \case
Nothing -> return $ ChangedRefs []
Just r -> do
threadDelay 50000
rs <- atomically $ loop []
return $ ChangedRefs (r:rs)
where
- loop rs = do
- v <- tryReadTBMChan chan
- case v of
- Just (Just r) -> loop (r:rs)
- _ -> return rs
+ loop rs = tryReadTBMChan chan >>= \case
+ 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
- v <- tryReadTBMChan chan
- case v of
- Just (Just _) -> go
- _ -> return ()
+ go = tryReadTBMChan chan >>= \case
+ Just (Just _) -> go
+ _ -> return ()
stopWatchingChangedRefs :: ChangedRefsHandle -> IO ()
stopWatchingChangedRefs h@(ChangedRefsHandle wh chan) = do
diff --git a/Annex/Content.hs b/Annex/Content.hs
index 2ba387105..9661f068a 100644
--- a/Annex/Content.hs
+++ b/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
- v <- checkLocked lockfile
- return $ case v of
- Nothing -> d
- Just True -> is_locked
- Just False -> is_unlocked
+ checkOr d lockfile = checkLocked lockfile >>= return . \case
+ Nothing -> d
+ Just True -> is_locked
+ Just False -> is_unlocked
#else
checkindirect f = liftIO $ ifM (doesFileExist f)
- ( do
- v <- lockShared f
- case v of
- Nothing -> return is_locked
- Just lockhandle -> do
- dropLock lockhandle
- return is_unlocked
+ ( lockShared f >>= \case
+ Nothing -> return is_locked
+ Just lockhandle -> do
+ 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
- v <- lockShared lockfile
- case v of
+ ( modifyContent lockfile $ liftIO $
+ lockShared >>= \case
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
- case free of
+ dir >>= liftIO . getDiskFree >>= \case
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
- mdestic <- withTSDelta (liftIO . genInodeCache dest)
- case mdestic of
+linkAnnex fromto key src (Just srcic) dest destmode =
+ withTSDelta (liftIO . genInodeCache dest) >>= \case
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
- mcache <- withTSDelta (liftIO . genInodeCache src)
- case mcache of
- Just srcic' | compareStrong srcic srcic' -> do
- destic <- withTSDelta (liftIO . genInodeCache dest)
- Database.Keys.addInodeCaches key $
- catMaybes [destic, Just srcic]
- return LinkAnnexOk
- _ -> do
- liftIO $ nukeFile dest
- failed
+ checksrcunchanged = withTSDelta (liftIO . genInodeCache src) >>= \case
+ Just srcic' | compareStrong srcic srcic' -> do
+ destic <- withTSDelta (liftIO . genInodeCache dest)
+ Database.Keys.addInodeCaches key $
+ catMaybes [destic, Just srcic]
+ return LinkAnnexOk
+ _ -> do
+ liftIO $ nukeFile dest
+ failed
{- Hard links or copies src to dest, which must not already exists.
-
diff --git a/Annex/Direct.hs b/Annex/Direct.hs
index 7a88a8755..57e363a86 100644
--- a/Annex/Direct.hs
+++ b/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
- k <- catKey sha
- case k of
+ withkey sha _mode a = when (sha /= nullSha) $
+ catKey sha >>= \case
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
- v <- getConfigMaybe src
- case v of
- Nothing -> noop
- Just wt -> do
- unsetConfig src
- setConfig dest wt
- reloadConfig
+ moveconfig src dest = getConfigMaybe src >>= \case
+ Nothing -> noop
+ Just wt -> do
+ unsetConfig src
+ 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
- case v of
+ inRepo (Git.Ref.sha currhead) >>= \case
Just headsha
| orighead /= currhead -> do
inRepo $ Git.Branch.update "leaving direct mode" orighead headsha
diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs
index 1e07a9da2..722f2b33a 100644
--- a/Annex/FileMatcher.hs
+++ b/Annex/FileMatcher.hs
@@ -133,12 +133,10 @@ mkLargeFilesParser = do
#ifdef WITH_MAGICMIME
magicmime <- liftIO $ catchMaybeIO $ do
m <- magicOpen [MagicMimeType]
- liftIO $ do
- md <- getEnv "GIT_ANNEX_DIR"
- case md of
- Nothing -> magicLoadDefault m
- Just d -> magicLoad m
- (d </> "magic" </> "magic.mgc")
+ liftIO $ getEnv "GIT_ANNEX_DIR" >>= \case
+ Nothing -> magicLoadDefault m
+ Just d -> magicLoad m
+ (d </> "magic" </> "magic.mgc")
return m
#endif
let parse = parseToken $ commonTokens
diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs
index 5fdcd042c..1bc081560 100644
--- a/Annex/Ingest.hs
+++ b/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
- v <- tryNonAsync (moveAnnex key $ contentLocation source)
- case v of
+ golocked key mcache s =
+ tryNonAsync (moveAnnex key $ contentLocation source) >>= \case
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)
- case r of
+ linkToAnnex key (keyFilename source) (Just cache) >>= \case
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
- case fs' of
+ filterM (`sameInodeCache` caches) fs >>= \case
-- 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
- mb <- inRepo Git.Branch.currentUnsafe
- case mb of
- Nothing -> return Nothing
- Just b -> do
- Annex.changeState $ \s ->
- s { Annex.cachedcurrentbranch = Just b }
- return (Just b)
+ cache = inRepo Git.Branch.currentUnsafe >>= \case
+ Nothing -> return Nothing
+ Just b -> do
+ Annex.changeState $ \s ->
+ 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
- r <- linkFromAnnex key file mode
- case r of
- LinkAnnexFailed -> liftIO $
- writePointerFile file key mode
- _ -> return ()
+ linkunlocked mode = linkFromAnnex key file mode >>= \case
+ LinkAnnexFailed -> liftIO $
+ writePointerFile file key mode
+ _ -> return ()
writepointer mode = liftIO $ writePointerFile file key mode
diff --git a/Annex/Init.hs b/Annex/Init.hs
index 63f27493b..0754d1f96 100644
--- a/Annex/Init.hs
+++ b/Annex/Init.hs
@@ -93,8 +93,7 @@ initialize' mversion = do
whenM versionSupportsUnlockedPointers $ do
configureSmudgeFilter
scanUnlockedFiles
- v <- checkAdjustedClone
- case v of
+ checkAdjustedClone >>= \case
NeedUpgradeForAdjustedClone ->
void $ upgrade True versionForAdjustedClone
InAdjustedClone -> return ()
diff --git a/Annex/LockPool/PosixOrPid.hs b/Annex/LockPool/PosixOrPid.hs
index c788f6fa0..47d2e5144 100644
--- a/Annex/LockPool/PosixOrPid.hs
+++ b/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
- v <- Pid.checkLocked pidlock
- case v of
- -- Only return true when the posix lock file exists.
- Just _ -> Posix.checkLocked f
- Nothing -> return Nothing
+ checkpid pidlock = Pid.checkLocked pidlock >>= \case
+ -- Only return true when the posix lock file exists.
+ Just _ -> Posix.checkLocked f
+ Nothing -> return Nothing
getLockStatus :: LockFile -> Annex LockStatus
getLockStatus f = Posix.getLockStatus f
diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs
index 355c5124a..f14db0a3e 100644
--- a/Annex/MetaData.hs
+++ b/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
- case v of
+ catKeyFileHEAD file >>= \case
Nothing -> noop
Just oldkey ->
whenM (copyMetaData oldkey key)
diff --git a/Annex/Perms.hs b/Annex/Perms.hs
index 1ce342911..cfd25a5ee 100644
--- a/Annex/Perms.hs
+++ b/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)