From 1c8ee99b4687f44e11868e8cbff68fe61a93f545 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 30 May 2018 12:28:43 -0400 Subject: [PATCH] Fix build with ghc 8.4+, which broke due to the Semigroup Monoid change https://prime.haskell.org/wiki/Libraries/Proposals/SemigroupMonoid I am not happy with the fragile pile of CPP boilerplate required to support ghc back to 7.0, which git-annex still targets for both the android build and the standalone build targeting old linux kernels. It makes me unlikely to want to use Semigroup more in git-annex, because the benefit of the abstraction is swamped by the ugliness. I actually considered ripping out all the Semigroup instances, but some are needed to use optparse-applicative. The problem, I think, is they made this transaction on too fast a timeline. (Although ironically, work on it started in 2015 or earlier!) In particular, Debian oldstable is not out of security support, and it's not possible to follow the simpler workarounds documented on the wiki and have it build on oldstable (because the semigroups package in it is too old). I have only tested this build with ghc 8.2.2, not the newer and older versions that branches of the CPP support. So there could be typoes, we'll see. This commit was sponsored by Brock Spratlen on Patreon. --- CHANGELOG | 6 ++++ Command/Info.hs | 31 +++++++++++++---- Git/Fsck.hs | 34 ++++++++++++++----- Types/DesktopNotify.hs | 22 ++++++++++-- Types/Difference.hs | 32 +++++++++++++---- Types/Test.hs | 30 ++++++++++++---- ...ailure_in_Types__47__DesktopNotify.hs.mdwn | 3 ++ 7 files changed, 128 insertions(+), 30 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 5ad2191552..4d6b2b8d58 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +git-annex (6.20180530) UNRELEASED; urgency=medium + + * Fix build with ghc 8.4+, which broke due to the Semigroup Monoid change. + + -- Joey Hess Wed, 30 May 2018 11:49:08 -0400 + git-annex (6.20180529) upstream; urgency=medium * Prevent haskell http-client from decompressing gzip files, so downloads diff --git a/Command/Info.hs b/Command/Info.hs index c9a314056a..9e7e527296 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns, DeriveDataTypeable, CPP #-} module Command.Info where @@ -13,6 +13,10 @@ import "mtl" Control.Monad.State.Strict import qualified Data.Map.Strict as M import qualified Data.Vector as V import Data.Ord +#if MIN_VERSION_base(4,9,0) +import qualified Data.Semigroup as Sem +#endif +import Prelude import Command import qualified Git @@ -55,15 +59,28 @@ data KeyData = KeyData , unknownSizeKeys :: Integer , backendsKeys :: M.Map KeyVariety Integer } + +appendKeyData :: KeyData -> KeyData -> KeyData +appendKeyData a b = KeyData + { countKeys = countKeys a + countKeys b + , sizeKeys = sizeKeys a + sizeKeys b + , unknownSizeKeys = unknownSizeKeys a + unknownSizeKeys b + , backendsKeys = backendsKeys a <> backendsKeys b + } + +#if MIN_VERSION_base(4,9,0) +instance Sem.Semigroup KeyData where + (<>) = appendKeyData +#endif instance Monoid KeyData where mempty = KeyData 0 0 0 M.empty - mappend a b = KeyData - { countKeys = countKeys a + countKeys b - , sizeKeys = sizeKeys a + sizeKeys b - , unknownSizeKeys = unknownSizeKeys a + unknownSizeKeys b - , backendsKeys = backendsKeys a <> backendsKeys b - } +#if MIN_VERSION_base(4,11,0) +#elif MIN_VERSION_base(4,9,0) + mappend = (Sem.<>) +#else + mappend = appendKeyData +#endif data NumCopiesStats = NumCopiesStats { numCopiesVarianceMap :: M.Map Variance Integer diff --git a/Git/Fsck.hs b/Git/Fsck.hs index a716b56e3a..3092ff2c67 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP #-} module Git.Fsck ( FsckResults(..), @@ -26,6 +26,10 @@ import qualified Git.Version import qualified Data.Set as S import Control.Concurrent.Async +#if MIN_VERSION_base(4,9,0) +import qualified Data.Semigroup as Sem +#endif +import Prelude data FsckResults = FsckFoundMissing @@ -44,15 +48,29 @@ type MissingObjects = S.Set Sha type Truncated = Bool +appendFsckOutput :: FsckOutput -> FsckOutput -> FsckOutput +appendFsckOutput (FsckOutput s1 t1) (FsckOutput s2 t2) = + FsckOutput (S.union s1 s2) (t1 || t2) +appendFsckOutput (FsckOutput s t) _ = FsckOutput s t +appendFsckOutput _ (FsckOutput s t) = FsckOutput s t +appendFsckOutput NoFsckOutput NoFsckOutput = NoFsckOutput +appendFsckOutput AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning +appendFsckOutput AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning +appendFsckOutput NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning + +#if MIN_VERSION_base(4,9,0) +instance Sem.Semigroup FsckOutput where + (<>) = appendFsckOutput +#endif + 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 +#if MIN_VERSION_base(4,11,0) +#elif MIN_VERSION_base(4,9,0) + mappend = (Sem.<>) +#else + mappend = appendFsckOutput +#endif {- 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 e6df05ab1c..ce7e4c4a3e 100644 --- a/Types/DesktopNotify.hs +++ b/Types/DesktopNotify.hs @@ -5,9 +5,14 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Types.DesktopNotify where import Data.Monoid +#if MIN_VERSION_base(4,9,0) +import qualified Data.Semigroup as Sem +#endif import Prelude data DesktopNotify = DesktopNotify @@ -16,10 +21,23 @@ data DesktopNotify = DesktopNotify } deriving (Show) +appendDesktopNotify :: DesktopNotify -> DesktopNotify -> DesktopNotify +appendDesktopNotify (DesktopNotify s1 f1) (DesktopNotify s2 f2) = + DesktopNotify (s1 || s2) (f1 || f2) + +#if MIN_VERSION_base(4,9,0) +instance Sem.Semigroup DesktopNotify where + (<>) = appendDesktopNotify +#endif + instance Monoid DesktopNotify where mempty = DesktopNotify False False - mappend (DesktopNotify s1 f1) (DesktopNotify s2 f2) = - DesktopNotify (s1 || s2) (f1 || f2) +#if MIN_VERSION_base(4,11,0) +#elif MIN_VERSION_base(4,9,0) + mappend = (Sem.<>) +#else + mappend = appendDesktopNotify +#endif mkNotifyStart :: DesktopNotify mkNotifyStart = DesktopNotify True False diff --git a/Types/Difference.hs b/Types/Difference.hs index 4abc75c447..0f7100c0c0 100644 --- a/Types/Difference.hs +++ b/Types/Difference.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Types.Difference ( Difference(..), Differences(..), @@ -23,8 +25,11 @@ import qualified Git.Config import Data.Maybe import Data.Monoid -import Prelude import qualified Data.Set as S +#if MIN_VERSION_base(4,9,0) +import qualified Data.Semigroup as Sem +#endif +import Prelude -- Describes differences from the v5 repository format. -- @@ -67,14 +72,27 @@ instance Eq Differences where , oneLevelBranchHash ] +appendDifferences :: Differences -> Differences -> Differences +appendDifferences a@(Differences {}) b@(Differences {}) = a + { objectHashLower = objectHashLower a || objectHashLower b + , oneLevelObjectHash = oneLevelObjectHash a || oneLevelObjectHash b + , oneLevelBranchHash = oneLevelBranchHash a || oneLevelBranchHash b + } +appendDifferences _ _ = UnknownDifferences + +#if MIN_VERSION_base(4,9,0) +instance Sem.Semigroup Differences where + (<>) = appendDifferences +#endif + instance Monoid Differences where mempty = Differences False False False - mappend a@(Differences {}) b@(Differences {}) = a - { objectHashLower = objectHashLower a || objectHashLower b - , oneLevelObjectHash = oneLevelObjectHash a || oneLevelObjectHash b - , oneLevelBranchHash = oneLevelBranchHash a || oneLevelBranchHash b - } - mappend _ _ = UnknownDifferences +#if MIN_VERSION_base(4,11,0) +#elif MIN_VERSION_base(4,9,0) + mappend = (Sem.<>) +#else + mappend = appendDifferences +#endif readDifferences :: String -> Differences readDifferences = maybe UnknownDifferences mkDifferences . readish diff --git a/Types/Test.hs b/Types/Test.hs index 50c460f501..5a9a9e075c 100644 --- a/Types/Test.hs +++ b/Types/Test.hs @@ -5,11 +5,17 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Types.Test where import Test.Tasty.Options import Data.Monoid +#if MIN_VERSION_base(4,9,0) +import qualified Data.Semigroup as Sem +#endif import Prelude + import Types.Command data TestOptions = TestOptions @@ -19,13 +25,25 @@ data TestOptions = TestOptions , internalData :: CmdParams } +appendTestOptions :: TestOptions -> TestOptions -> TestOptions +appendTestOptions a b = TestOptions + (tastyOptionSet a <> tastyOptionSet b) + (keepFailuresOption a || keepFailuresOption b) + (fakeSsh a || fakeSsh b) + (internalData a <> internalData b) + +#if MIN_VERSION_base(4,9,0) +instance Sem.Semigroup TestOptions where + (<>) = appendTestOptions +#endif + instance Monoid TestOptions where mempty = TestOptions mempty False False mempty - mappend a b = TestOptions - (tastyOptionSet a <> tastyOptionSet b) - (keepFailuresOption a || keepFailuresOption b) - (fakeSsh a || fakeSsh b) - (internalData a <> internalData b) - +#if MIN_VERSION_base(4,11,0) +#elif MIN_VERSION_base(4,9,0) + mappend = (Sem.<>) +#else + mappend = appendTestOptions +#endif type TestRunner = TestOptions -> IO () diff --git a/doc/bugs/GHC_8.4.3_build_failure_in_Types__47__DesktopNotify.hs.mdwn b/doc/bugs/GHC_8.4.3_build_failure_in_Types__47__DesktopNotify.hs.mdwn index e9f0d113fd..61ac77f0ea 100644 --- a/doc/bugs/GHC_8.4.3_build_failure_in_Types__47__DesktopNotify.hs.mdwn +++ b/doc/bugs/GHC_8.4.3_build_failure_in_Types__47__DesktopNotify.hs.mdwn @@ -134,3 +134,6 @@ Full log https://gist.github.com/ilovezfs/e3af135ed0362e0253a786c71f2a914f ### Have you had any luck using git-annex before? (Sometimes we get tired of reading bug reports all day and a lil' positive end note does wonders) Yes! Thanks :) + +> Consequence of the Semigroup Monoid change. Fixed. [[done]] --[[Joey]] +