From c79473051a8e1647b14f351b72768b74301acc33 Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Wed, 19 Jan 2022 13:04:08 -0500 Subject: Deal with the MonadFail proposal MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit base-4.9 split MonadFail from Monad. Strengthen some type signatures to require MonadFail instead of just Monad, derive MonadFail in relevant places, and change a partial pattern match inside STM to one that explicitly calls error. (STM is not a MonadFail; the user must explicitly specify the desired semantics if a pattern match doesn’t work out. In this case, the failing branch of the pattern should never be reached, so crashing is fine.) --- Annex.hs | 1 + Assistant/Monad.hs | 2 ++ Assistant/TransferQueue.hs | 21 +++++++++++---------- COPYRIGHT | 18 ++++++++++++++++++ CmdLine/GitAnnex/Options.hs | 3 ++- Command/Expire.hs | 3 ++- Command/Init.hs | 3 ++- Utility/HumanTime.hs | 5 +++-- git-annex.cabal | 2 +- 9 files changed, 42 insertions(+), 16 deletions(-) diff --git a/Annex.hs b/Annex.hs index 54f71aee9..281531610 100644 --- a/Annex.hs +++ b/Annex.hs @@ -92,6 +92,7 @@ newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a } MonadCatch, MonadThrow, MonadMask, + MonadFail, Functor, Applicative ) diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 403ee16a8..f1b2dc78c 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -1,6 +1,7 @@ {- git-annex assistant monad - - Copyright 2012 Joey Hess + - Copyright 2022 Benjamin Barenblat - - Licensed under the GNU GPL version 3 or higher. -} @@ -49,6 +50,7 @@ newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a } Monad, MonadIO, MonadReader AssistantData, + MonadFail, Functor, Applicative ) diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index fbc589673..1679e0daf 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -192,16 +192,17 @@ getNextTransfer acceptable = do sz <- readTVar (queuesize q) if sz < 1 then retry -- blocks until queuesize changes - else do - (r@(t,info):rest) <- readTList (queuelist q) - void $ modifyTVar' (queuesize q) pred - setTList (queuelist q) rest - if acceptable info - then do - adjustTransfersSTM dstatus $ - M.insert t info - return $ Just r - else return Nothing + else readTList (queuelist q) >>= \case + (r@(t,info):rest) -> do + void $ modifyTVar' (queuesize q) pred + setTList (queuelist q) rest + if acceptable info + then do + adjustTransfersSTM dstatus $ + M.insert t info + return $ Just r + else return Nothing + _ -> error "empty queue claims to be nonempty" {- Moves transfers matching a condition from the queue, to the - currentTransfers map. -} diff --git a/COPYRIGHT b/COPYRIGHT index d3007b4ec..1c9f7ebce 100644 --- a/COPYRIGHT +++ b/COPYRIGHT @@ -11,6 +11,24 @@ Copyright: © 2011 Joey Hess © 2014 Robie Basak License: GPL-3+ +Files: Utility/HumanTime.hs +Copyright: 2012-2013 Joey Hess + 2022 Benjamin Barenblat +License: Apache-2.0 + Licensed under the Apache License, Version 2.0 (the "License"); you may not use + this file except in compliance with the License. You may obtain a copy of the + License at + . + https://www.apache.org/licenses/LICENSE-2.0 + . + Unless required by applicable law or agreed to in writing, software distributed + under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR + CONDITIONS OF ANY KIND, either express or implied. See the License for the + specific language governing permissions and limitations under the License. + . + On Debian systems, the complete text of the Apache License, Version 2.0, can be + found in "/usr/share/common-licenses/Apache-2.0". + Files: Utility/ThreadScheduler.hs Copyright: 2011 Bas van Dijk & Roel van Dijk 2012, 2013 Joey Hess diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 143bb6498..2a6dc0ef9 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -1,6 +1,7 @@ {- git-annex command-line option parsing - - Copyright 2010-2018 Joey Hess + - Copyright 2022 Benjamin Barenblat - - Licensed under the GNU GPL version 3 or higher. -} @@ -182,7 +183,7 @@ parseAllOption = flag' WantAllKeys <> help "operate on all versions of all files" ) -parseKey :: Monad m => String -> m Key +parseKey :: MonadFail m => String -> m Key parseKey = maybe (fail "invalid key") return . file2key -- Options to match properties of annexed files. diff --git a/Command/Expire.hs b/Command/Expire.hs index 28f90dfb5..bb65d5cfe 100644 --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -1,6 +1,7 @@ {- git-annex command - - Copyright 2015 Joey Hess + - Copyright 2022 Benjamin Barenblat - - Licensed under the GNU GPL version 3 or higher. -} @@ -108,7 +109,7 @@ parseExpire ps = do Nothing -> giveup $ "bad expire time: " ++ s Just d -> Just (now - durationToPOSIXTime d) -parseActivity :: Monad m => String -> m Activity +parseActivity :: MonadFail m => String -> m Activity parseActivity s = case readish s of Nothing -> fail $ "Unknown activity. Choose from: " ++ unwords (map show [minBound..maxBound :: Activity]) diff --git a/Command/Init.hs b/Command/Init.hs index 8ce82a75e..e12c6700c 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -1,6 +1,7 @@ {- git-annex command - - Copyright 2010 Joey Hess + - Copyright 2022 Benjamin Barenblat - - Licensed under the GNU GPL version 3 or higher. -} @@ -30,7 +31,7 @@ optParser desc = InitOptions <> help "Override default annex.version" )) -parseVersion :: Monad m => String -> m Version +parseVersion :: MonadFail m => String -> m Version parseVersion v | v `elem` supportedVersions = return v | otherwise = fail $ v ++ " is not a currently supported repository version" diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index fe7cf22a9..77d846d97 100644 --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -1,8 +1,9 @@ {- Time for humans. - - Copyright 2012-2013 Joey Hess + - Copyright 2022 Benjamin Barenblat - - - License: BSD-2-clause + - License: Apache-2.0 -} module Utility.HumanTime ( @@ -44,7 +45,7 @@ daysToDuration :: Integer -> Duration daysToDuration i = Duration $ i * dsecs {- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} -parseDuration :: Monad m => String -> m Duration +parseDuration :: MonadFail m => String -> m Duration parseDuration = maybe parsefail (return . Duration) . go 0 where go n [] = return n diff --git a/git-annex.cabal b/git-annex.cabal index d94b1469f..403fb65c2 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -202,7 +202,7 @@ custom-setup Executable git-annex Main-Is: git-annex.hs Build-Depends: - base (>= 4.6 && < 5.0), + base (>= 4.9 && < 5.0), optparse-applicative (>= 0.11.0), containers (>= 0.5.0.0), exceptions (>= 0.6), -- cgit v1.2.3