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

@@ -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 <id@joeyh.name>  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

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
@@ -56,15 +60,28 @@ data KeyData = KeyData
 	, backendsKeys :: M.Map KeyVariety Integer
 	}
 	
-instance Monoid KeyData where
-	mempty = KeyData 0 0 0 M.empty
-	mappend a b = KeyData
+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
+#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
 	}

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

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

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
 		]
 
-instance Monoid Differences where
-	mempty = Differences False False False
-	mappend a@(Differences {}) b@(Differences {}) = a
+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
 	}
-	mappend _ _ = UnknownDifferences
+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
+#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

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
 	}
 
-instance Monoid TestOptions where
-	mempty = TestOptions mempty False False mempty
-	mappend a b = TestOptions
+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
+#if MIN_VERSION_base(4,11,0)
+#elif MIN_VERSION_base(4,9,0)
+	mappend = (Sem.<>)
+#else
+	mappend = appendTestOptions
+#endif
 
 type TestRunner = TestOptions -> IO ()

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]]
+