From a9b9e5d0d72c2348580dbac5533b89a45abd8938 Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Wed, 19 Jan 2022 13:11:40 -0500 Subject: Deal with the Semigroup/Monoid proposal base-4.11 made Semigroup a superclass of Monoid. Provide Semigroup implementations for Monoids. --- Git/Fsck.hs | 17 ++++++++++------- Types/DesktopNotify.hs | 7 +++++-- Types/Difference.hs | 11 +++++++---- Types/Test.hs | 9 ++++++--- git-annex.cabal | 2 +- 5 files changed, 29 insertions(+), 17 deletions(-) diff --git a/Git/Fsck.hs b/Git/Fsck.hs index a716b56e3..a1b42a953 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -1,6 +1,7 @@ {- git fsck interface - - Copyright 2013 Joey Hess + - Copyright 2022 Benjamin Barenblat - - Licensed under the GNU GPL version 3 or higher. -} @@ -44,15 +45,17 @@ type MissingObjects = S.Set Sha type Truncated = Bool +instance Semigroup FsckOutput where + FsckOutput s1 t1 <> FsckOutput s2 t2 = FsckOutput (S.union s1 s2) (t1 || t2) + FsckOutput s t <> _ = FsckOutput s t + _ <> FsckOutput s t = FsckOutput s t + NoFsckOutput <> NoFsckOutput = NoFsckOutput + AllDuplicateEntriesWarning <> AllDuplicateEntriesWarning = AllDuplicateEntriesWarning + AllDuplicateEntriesWarning <> NoFsckOutput = AllDuplicateEntriesWarning + NoFsckOutput <> AllDuplicateEntriesWarning = AllDuplicateEntriesWarning + instance Monoid FsckOutput where mempty = NoFsckOutput - mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2) - mappend (FsckOutput s t) _ = FsckOutput s t - mappend _ (FsckOutput s t) = FsckOutput s t - mappend NoFsckOutput NoFsckOutput = NoFsckOutput - mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning - mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning - mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning {- Runs fsck to find some of the broken objects in the repository. - May not find all broken objects, if fsck fails on bad data in some of diff --git a/Types/DesktopNotify.hs b/Types/DesktopNotify.hs index e6df05ab1..0b2da9377 100644 --- a/Types/DesktopNotify.hs +++ b/Types/DesktopNotify.hs @@ -1,6 +1,7 @@ {- git-annex DesktopNotify type - - Copyright 2014 Joey Hess + - Copyright 2022 Benjamin Barenblat - - Licensed under the GNU GPL version 3 or higher. -} @@ -16,10 +17,12 @@ data DesktopNotify = DesktopNotify } deriving (Show) +instance Semigroup DesktopNotify where + DesktopNotify s1 f1 <> DesktopNotify s2 f2 = + DesktopNotify (s1 || s2) (f1 || f2) + instance Monoid DesktopNotify where mempty = DesktopNotify False False - mappend (DesktopNotify s1 f1) (DesktopNotify s2 f2) = - DesktopNotify (s1 || s2) (f1 || f2) mkNotifyStart :: DesktopNotify mkNotifyStart = DesktopNotify True False diff --git a/Types/Difference.hs b/Types/Difference.hs index 4abc75c44..8516a3df7 100644 --- a/Types/Difference.hs +++ b/Types/Difference.hs @@ -1,6 +1,7 @@ {- git-annex repository differences - - Copyright 2015 Joey Hess + - Copyright 2022 Benjamin Barenblat - - Licensed under the GNU GPL version 3 or higher. -} @@ -67,14 +68,16 @@ instance Eq Differences where , oneLevelBranchHash ] -instance Monoid Differences where - mempty = Differences False False False - mappend a@(Differences {}) b@(Differences {}) = a +instance Semigroup Differences where + a@(Differences {}) <> b@(Differences {}) = a { objectHashLower = objectHashLower a || objectHashLower b , oneLevelObjectHash = oneLevelObjectHash a || oneLevelObjectHash b , oneLevelBranchHash = oneLevelBranchHash a || oneLevelBranchHash b } - mappend _ _ = UnknownDifferences + _ <> _ = UnknownDifferences + +instance Monoid Differences where + mempty = Differences False False False readDifferences :: String -> Differences readDifferences = maybe UnknownDifferences mkDifferences . readish diff --git a/Types/Test.hs b/Types/Test.hs index 50c460f50..0179474b4 100644 --- a/Types/Test.hs +++ b/Types/Test.hs @@ -1,6 +1,7 @@ {- git-annex test data types. - - Copyright 2011-2017 Joey Hess + - Copyright 2022 Benjamin Barenblat - - Licensed under the GNU GPL version 3 or higher. -} @@ -19,13 +20,15 @@ data TestOptions = TestOptions , internalData :: CmdParams } -instance Monoid TestOptions where - mempty = TestOptions mempty False False mempty - mappend a b = TestOptions +instance Semigroup TestOptions where + a <> b = TestOptions (tastyOptionSet a <> tastyOptionSet b) (keepFailuresOption a || keepFailuresOption b) (fakeSsh a || fakeSsh b) (internalData a <> internalData b) +instance Monoid TestOptions where + mempty = TestOptions mempty False False mempty + type TestRunner = TestOptions -> IO () diff --git a/git-annex.cabal b/git-annex.cabal index 403fb65c2..d51c73003 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.9 && < 5.0), + base (>= 4.11 && < 5.0), optparse-applicative (>= 0.11.0), containers (>= 0.5.0.0), exceptions (>= 0.6), -- cgit v1.2.3