aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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
-rw-r--r--git-annex.cabal4
13 files changed, 119 insertions, 166 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)
diff --git a/git-annex.cabal b/git-annex.cabal
index 0d3681aa5..6347b58a4 100644
--- a/git-annex.cabal
+++ b/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
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-11 08:38:45 +0000