From 9228bda32f0a3f6d52e7cc5eb444376e7b024d8c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 23 Apr 2018 13:20:13 -0400 Subject: semigroup monoid change fallout; drop ghc 7 support Fix build with ghc 8.4, which broke due to the Semigroup Monoid change. See https://prime.haskell.org/wiki/Libraries/Proposals/SemigroupMonoid Dropped support for building propellor with ghc 7 (as in debian oldstable), to avoid needing to depend on the semigroups transitional package, but also because it's just too old to be worth supporting. If we indeed drop ghc 7 support entirely, some code to support "jessie" can be removed; concurrent-output can be de-embedded, and the Singletons code can be simplified. This commit was sponsored by Jack Hill on Patreon. --- src/Propellor/Types/Chroot.hs | 21 ++++++++++++++------- src/Propellor/Types/Core.hs | 10 +++++++--- src/Propellor/Types/Dns.hs | 16 ++++++++++------ src/Propellor/Types/Docker.hs | 10 +++++++--- src/Propellor/Types/Info.hs | 10 +++++++--- src/Propellor/Types/Result.hs | 15 +++++++++------ 6 files changed, 54 insertions(+), 28 deletions(-) (limited to 'src/Propellor/Types') diff --git a/src/Propellor/Types/Chroot.hs b/src/Propellor/Types/Chroot.hs index da912120..b27203e5 100644 --- a/src/Propellor/Types/Chroot.hs +++ b/src/Propellor/Types/Chroot.hs @@ -7,6 +7,7 @@ import Propellor.Types.Empty import Propellor.Types.Info import Data.Monoid +import qualified Data.Semigroup as Sem import qualified Data.Map as M data ChrootInfo = ChrootInfo @@ -18,13 +19,16 @@ data ChrootInfo = ChrootInfo instance IsInfo ChrootInfo where propagateInfo _ = PropagateInfo False -instance Monoid ChrootInfo where - mempty = ChrootInfo mempty mempty - mappend old new = ChrootInfo +instance Sem.Semigroup ChrootInfo where + old <> new = ChrootInfo { _chroots = M.union (_chroots old) (_chroots new) , _chrootCfg = _chrootCfg old <> _chrootCfg new } +instance Monoid ChrootInfo where + mempty = ChrootInfo mempty mempty + mappend = (<>) + instance Empty ChrootInfo where isEmpty i = and [ isEmpty (_chroots i) @@ -36,12 +40,15 @@ data ChrootCfg | SystemdNspawnCfg [(String, Bool)] deriving (Show, Eq) +instance Sem.Semigroup ChrootCfg where + v <> NoChrootCfg = v + NoChrootCfg <> v = v + SystemdNspawnCfg l1 <> SystemdNspawnCfg l2 = + SystemdNspawnCfg (l1 <> l2) + instance Monoid ChrootCfg where mempty = NoChrootCfg - mappend v NoChrootCfg = v - mappend NoChrootCfg v = v - mappend (SystemdNspawnCfg l1) (SystemdNspawnCfg l2) = - SystemdNspawnCfg (l1 <> l2) + mappend = (<>) instance Empty ChrootCfg where isEmpty c= c == NoChrootCfg diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs index a805f561..cd3e09c5 100644 --- a/src/Propellor/Types/Core.hs +++ b/src/Propellor/Types/Core.hs @@ -10,6 +10,7 @@ import Propellor.Types.OS import Propellor.Types.Result import Data.Monoid +import qualified Data.Semigroup as Sem import "mtl" Control.Monad.RWS.Strict import Control.Monad.Catch import Control.Applicative @@ -50,15 +51,18 @@ instance LiftPropellor IO where -- | When two actions are appended together, the second action -- is only run if the first action does not fail. -instance Monoid (Propellor Result) where - mempty = return NoChange - mappend x y = do +instance Sem.Semigroup (Propellor Result) where + x <> y = do rx <- x case rx of FailedChange -> return FailedChange _ -> do ry <- y return (rx <> ry) + +instance Monoid (Propellor Result) where + mempty = return NoChange + mappend = (<>) -- | An action that Propellor runs at the end, after trying to satisfy all -- properties. It's passed the combined Result of the entire Propellor run. diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs index 513f162a..21a4860c 100644 --- a/src/Propellor/Types/Dns.hs +++ b/src/Propellor/Types/Dns.hs @@ -12,6 +12,7 @@ import Utility.Split import Data.Word import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.Semigroup as Sem import Data.List import Data.Monoid import Prelude @@ -26,7 +27,7 @@ instance ConfigurableValue IPAddr where val (IPv6 addr) = addr newtype AliasesInfo = AliasesInfo (S.Set HostName) - deriving (Show, Eq, Ord, Monoid, Typeable) + deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable) instance IsInfo AliasesInfo where propagateInfo _ = PropagateInfo False @@ -42,7 +43,7 @@ fromAliasesInfo (AliasesInfo s) = S.toList s -- of the containers in the host be reflected in the DNS. newtype DnsInfoPropagated = DnsInfoPropagated { fromDnsInfoPropagated :: S.Set Record } - deriving (Show, Eq, Ord, Monoid, Typeable) + deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable) toDnsInfoPropagated :: S.Set Record -> DnsInfoPropagated toDnsInfoPropagated = DnsInfoPropagated @@ -55,7 +56,7 @@ instance IsInfo DnsInfoPropagated where -- the host. newtype DnsInfoUnpropagated = DnsInfoUnpropagated { fromDnsInfoUnpropagated :: S.Set Record } - deriving (Show, Eq, Ord, Monoid, Typeable) + deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable) toDnsInfoUnpropagated :: S.Set Record -> DnsInfoUnpropagated toDnsInfoUnpropagated = DnsInfoUnpropagated @@ -183,15 +184,18 @@ instance IsInfo NamedConfMap where -- | Adding a Master NamedConf stanza for a particulr domain always -- overrides an existing Secondary stanza for that domain, while a -- Secondary stanza is only added when there is no existing Master stanza. -instance Monoid NamedConfMap where - mempty = NamedConfMap M.empty - mappend (NamedConfMap old) (NamedConfMap new) = NamedConfMap $ +instance Sem.Semigroup NamedConfMap where + NamedConfMap old <> NamedConfMap new = NamedConfMap $ M.unionWith combiner new old where combiner n o = case (confDnsServerType n, confDnsServerType o) of (Secondary, Master) -> o _ -> n +instance Monoid NamedConfMap where + mempty = NamedConfMap M.empty + mappend = (<>) + instance Empty NamedConfMap where isEmpty (NamedConfMap m) = isEmpty m diff --git a/src/Propellor/Types/Docker.hs b/src/Propellor/Types/Docker.hs index 6ff340e5..79577591 100644 --- a/src/Propellor/Types/Docker.hs +++ b/src/Propellor/Types/Docker.hs @@ -7,6 +7,7 @@ import Propellor.Types.Empty import Propellor.Types.Info import Data.Monoid +import qualified Data.Semigroup as Sem import qualified Data.Map as M data DockerInfo = DockerInfo @@ -18,13 +19,16 @@ data DockerInfo = DockerInfo instance IsInfo DockerInfo where propagateInfo _ = PropagateInfo False -instance Monoid DockerInfo where - mempty = DockerInfo mempty mempty - mappend old new = DockerInfo +instance Sem.Semigroup DockerInfo where + old <> new = DockerInfo { _dockerRunParams = _dockerRunParams old <> _dockerRunParams new , _dockerContainers = M.union (_dockerContainers old) (_dockerContainers new) } +instance Monoid DockerInfo where + mempty = DockerInfo mempty mempty + mappend = (<>) + instance Empty DockerInfo where isEmpty i = and [ isEmpty (_dockerRunParams i) diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index 06c45ed2..2ab6da7b 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -17,6 +17,7 @@ module Propellor.Types.Info ( import Data.Dynamic import Data.Maybe import Data.Monoid +import qualified Data.Semigroup as Sem import qualified Data.Typeable as T import Prelude @@ -25,7 +26,7 @@ import Prelude -- Many different types of data can be contained in the same Info value -- at the same time. See `toInfo` and `fromInfo`. newtype Info = Info [InfoEntry] - deriving (Monoid, Show) + deriving (Sem.Semigroup, Monoid, Show) data InfoEntry where InfoEntry :: (IsInfo v, Typeable v) => v -> InfoEntry @@ -80,10 +81,13 @@ mapInfo f (Info l) = Info (map go l) data InfoVal v = NoInfoVal | InfoVal v deriving (Typeable, Show) +instance Sem.Semigroup (InfoVal v) where + _ <> v@(InfoVal _) = v + v <> NoInfoVal = v + instance Monoid (InfoVal v) where mempty = NoInfoVal - mappend _ v@(InfoVal _) = v - mappend v NoInfoVal = v + mappend = (<>) instance (Typeable v, Show v) => IsInfo (InfoVal v) where propagateInfo _ = PropagateInfo False diff --git a/src/Propellor/Types/Result.hs b/src/Propellor/Types/Result.hs index 5209094b..f552b29b 100644 --- a/src/Propellor/Types/Result.hs +++ b/src/Propellor/Types/Result.hs @@ -1,6 +1,7 @@ module Propellor.Types.Result where import System.Console.ANSI +import qualified Data.Semigroup as Sem import Data.Monoid import Prelude @@ -8,14 +9,16 @@ import Prelude data Result = NoChange | MadeChange | FailedChange deriving (Read, Show, Eq) +instance Sem.Semigroup Result where + FailedChange <> _ = FailedChange + _ <> FailedChange = FailedChange + MadeChange <> _ = MadeChange + _ <> MadeChange = MadeChange + NoChange <> NoChange = NoChange + instance Monoid Result where mempty = NoChange - - mappend FailedChange _ = FailedChange - mappend _ FailedChange = FailedChange - mappend MadeChange _ = MadeChange - mappend _ MadeChange = MadeChange - mappend NoChange NoChange = NoChange + mappend = (<>) class ToResult t where toResult :: t -> Result -- cgit v1.2.3