From: Apollon Oikonomopoulos <apoikos@debian.org>
Date: Thu, 1 Nov 2018 11:48:32 +0200
Subject: base-4.11 compatibility

With GHC 8.4/base-4.11, Semigroup has become a superclass of Monoid.
Adjust the code to implement Semigroup's (<>) and define mappend in
terms of (<>).

Additionally, we make sure that all TH-generated partial types are
instances of Semigroup in addition to Monoid.

Finally, base-4.11's Prelude now exports <>, which conflicts with
Text.PrettyPrint as used in PyRPC.hs, so we need to hide the former.
---
 src/Ganeti/ConstantUtils.hs  |  6 +++++-
 src/Ganeti/JSON.hs           |  6 +++++-
 src/Ganeti/Objects.hs        |  6 +++++-
 src/Ganeti/THH.hs            |  7 ++++++-
 src/Ganeti/THH/PyRPC.hs      |  1 +
 src/Ganeti/Utils/MultiMap.hs |  6 +++++-
 src/Ganeti/WConfd/Monad.hs   | 10 +++++++---
 src/Ganeti/WConfd/TempRes.hs |  6 +++++-
 8 files changed, 39 insertions(+), 9 deletions(-)

diff --git a/src/Ganeti/ConstantUtils.hs b/src/Ganeti/ConstantUtils.hs
index 6a61cf2..a3f8e72 100644
--- a/src/Ganeti/ConstantUtils.hs
+++ b/src/Ganeti/ConstantUtils.hs
@@ -41,6 +41,7 @@ import Data.Char (ord)
 import Data.Monoid (Monoid(..))
 import Data.Set (Set)
 import qualified Data.Set as Set (difference, fromList, toList, union)
+import qualified Data.Semigroup as Sem
 
 import Ganeti.PyValue
 
@@ -63,9 +64,12 @@ instance PyValue PythonNone where
 newtype FrozenSet a = FrozenSet { unFrozenSet :: Set a }
   deriving (Eq, Ord, Show)
 
+instance (Ord a) => Sem.Semigroup (FrozenSet a) where
+  (FrozenSet s) <> (FrozenSet t) = FrozenSet (mappend s t)
+
 instance (Ord a) => Monoid (FrozenSet a) where
   mempty = FrozenSet mempty
-  mappend (FrozenSet s) (FrozenSet t) = FrozenSet (mappend s t)
+  mappend = (<>)
 
 -- | Converts a Haskell 'Set' into a Python 'frozenset'
 --
diff --git a/src/Ganeti/JSON.hs b/src/Ganeti/JSON.hs
index 770da55..ba49dc0 100644
--- a/src/Ganeti/JSON.hs
+++ b/src/Ganeti/JSON.hs
@@ -95,6 +95,7 @@ import qualified Data.Traversable as F
 import Data.Maybe (fromMaybe, catMaybes)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import qualified Data.Semigroup as Sem
 import System.Time (ClockTime(..))
 import Text.Printf (printf)
 
@@ -396,9 +397,12 @@ instance (HasStringRepr a, Ord a, J.JSON b) =>
 
 newtype UsedKeys = UsedKeys (Maybe (Set.Set T.Text))
 
+instance Sem.Semigroup UsedKeys where
+  (UsedKeys xs) <> (UsedKeys ys) = UsedKeys $ liftA2 Set.union xs ys
+
 instance Monoid UsedKeys where
   mempty = UsedKeys (Just Set.empty)
-  mappend (UsedKeys xs) (UsedKeys ys) = UsedKeys $ liftA2 Set.union xs ys
+  mappend = (<>)
 
 mkUsedKeys :: Set.Set T.Text -> UsedKeys
 mkUsedKeys = UsedKeys . Just
diff --git a/src/Ganeti/Objects.hs b/src/Ganeti/Objects.hs
index 59abc5c..8fcc66d 100644
--- a/src/Ganeti/Objects.hs
+++ b/src/Ganeti/Objects.hs
@@ -115,6 +115,7 @@ import qualified Data.Map as Map
 import Data.Monoid
 import Data.Ord (comparing)
 import Data.Ratio (numerator, denominator)
+import qualified Data.Semigroup as Sem
 import Data.Tuple (swap)
 import Data.Word
 import Text.JSON (showJSON, readJSON, JSON, JSValue(..), fromJSString,
@@ -286,12 +287,15 @@ $(buildObject "DataCollectorConfig" "dataCollector" [
   ])
 
 -- | Central default values of the data collector config.
+instance Sem.Semigroup DataCollectorConfig where
+  _ <> a = a
+
 instance Monoid DataCollectorConfig where
   mempty = DataCollectorConfig
     { dataCollectorActive = True
     , dataCollectorInterval = 10^(6::Integer) * fromIntegral C.mondTimeInterval
     }
-  mappend _ a = a
+  mappend = (<>)
 
 -- * IPolicy definitions
 
diff --git a/src/Ganeti/THH.hs b/src/Ganeti/THH.hs
index 84941e7..faf81f3 100644
--- a/src/Ganeti/THH.hs
+++ b/src/Ganeti/THH.hs
@@ -1470,16 +1470,21 @@ fillParam sname field_pfx fields = do
   let altExp = zipWith (\l r -> AppE (AppE (VarE '(<|>)) (VarE r)) (VarE l))
       mappendExp = appCons name_p $ altExp pbinds pbinds2
       mappendClause = Clause [pConP, pConP2] (NormalB mappendExp) []
+      mappendAlias = Clause [] (NormalB $ VarE '(<>)) []
   let monoidType = AppT (ConT ''Monoid) (ConT name_p)
+  let semigroupType = AppT (ConT ''Semigroup) (ConT name_p)
   -- the instances combined
   return [ InstanceD Nothing [] instType
                      [ FunD 'fillParams [fclause]
                      , FunD 'toPartial [tpclause]
                      , FunD 'toFilled [tfclause]
                      ]
+         , InstanceD Nothing [] semigroupType
+                     [ FunD '(<>) [mappendClause]
+                     ]
          , InstanceD Nothing [] monoidType
                      [ FunD 'mempty [memptyClause]
-                     , FunD 'mappend [mappendClause]
+                     , FunD 'mappend [mappendAlias]
                      ]]
 
 -- * Template code for exceptions
diff --git a/src/Ganeti/THH/PyRPC.hs b/src/Ganeti/THH/PyRPC.hs
index d25c811..3db1780 100644
--- a/src/Ganeti/THH/PyRPC.hs
+++ b/src/Ganeti/THH/PyRPC.hs
@@ -40,6 +40,7 @@ module Ganeti.THH.PyRPC
   , genPyUDSRpcStubStr
   ) where
 
+import Prelude hiding ((<>))
 import Control.Monad
 import Data.Char (toLower, toUpper)
 import Data.Functor
diff --git a/src/Ganeti/Utils/MultiMap.hs b/src/Ganeti/Utils/MultiMap.hs
index 0f97e26..952d3e3 100644
--- a/src/Ganeti/Utils/MultiMap.hs
+++ b/src/Ganeti/Utils/MultiMap.hs
@@ -59,6 +59,7 @@ import Prelude hiding (lookup, null, elem)
 import Control.Monad
 import qualified Data.Foldable as F
 import qualified Data.Map as M
+import qualified Data.Semigroup as Sem
 import Data.Maybe (fromMaybe, isJust)
 import Data.Monoid
 import qualified Data.Set as S
@@ -72,9 +73,12 @@ import Ganeti.Lens
 newtype MultiMap k v = MultiMap { getMultiMap :: M.Map k (S.Set v) }
   deriving (Eq, Ord, Show)
 
+instance (Ord v, Ord k) => Sem.Semigroup (MultiMap k v) where
+  (MultiMap x) <> (MultiMap y) = MultiMap $ M.unionWith S.union x y
+
 instance (Ord v, Ord k) => Monoid (MultiMap k v) where
   mempty = MultiMap M.empty
-  mappend (MultiMap x) (MultiMap y) = MultiMap $ M.unionWith S.union x y
+  mappend = (<>)
 
 instance F.Foldable (MultiMap k) where
   foldMap f = F.foldMap (F.foldMap f) . getMultiMap
diff --git a/src/Ganeti/WConfd/Monad.hs b/src/Ganeti/WConfd/Monad.hs
index a761828..4ea8867 100644
--- a/src/Ganeti/WConfd/Monad.hs
+++ b/src/Ganeti/WConfd/Monad.hs
@@ -82,6 +82,7 @@ import Control.Monad.Trans.Control
 import Data.Functor.Identity
 import Data.IORef.Lifted
 import Data.Monoid (Any(..), Monoid(..))
+import qualified Data.Semigroup as Sem
 import qualified Data.Set as S
 import Data.Tuple (swap)
 import System.Posix.Process (getProcessID)
@@ -109,11 +110,14 @@ import Ganeti.WConfd.TempRes
 -- | Data type describing where the configuration has to be distributed to.
 data DistributionTarget = Everywhere | ToGroups (S.Set String) deriving Show
 
+instance Sem.Semigroup DistributionTarget where
+  Everywhere <> _ = Everywhere
+  _ <> Everywhere = Everywhere
+  (ToGroups a) <> (ToGroups b) = ToGroups (a `S.union` b)
+
 instance Monoid DistributionTarget where
   mempty = ToGroups S.empty
-  mappend Everywhere _ = Everywhere
-  mappend _ Everywhere = Everywhere
-  mappend (ToGroups a) (ToGroups b) = ToGroups (a `S.union` b)
+  mappend = (<>)
 
 -- * Pure data types used in the monad
 
diff --git a/src/Ganeti/WConfd/TempRes.hs b/src/Ganeti/WConfd/TempRes.hs
index 565fae2..64ec95a 100644
--- a/src/Ganeti/WConfd/TempRes.hs
+++ b/src/Ganeti/WConfd/TempRes.hs
@@ -85,6 +85,7 @@ import Data.Maybe
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Monoid
+import qualified Data.Semigroup as Sem
 import qualified Data.Set as S
 import System.Random
 import qualified Text.JSON as J
@@ -160,9 +161,12 @@ instance J.JSON IPv4Reservation where
 newtype TempRes j a = TempRes { getTempRes :: MM.MultiMap j a }
   deriving (Eq, Ord, Show)
 
+instance (Ord j, Ord a) => Sem.Semigroup (TempRes j a) where
+  (TempRes x) <> (TempRes y) = TempRes $ x <> y
+
 instance (Ord j, Ord a) => Monoid (TempRes j a) where
   mempty = TempRes mempty
-  mappend (TempRes x) (TempRes y) = TempRes $ x <> y
+  mappend = (<>)
 
 instance (J.JSON j, Ord j, J.JSON a, Ord a) => J.JSON (TempRes j a) where
   showJSON = J.showJSON . getTempRes