summaryrefslogtreecommitdiff
path: root/src/Propellor/Types
diff options
context:
space:
mode:
authorJoey Hess2018-04-23 13:20:13 -0400
committerJoey Hess2018-04-23 13:20:13 -0400
commit9228bda32f0a3f6d52e7cc5eb444376e7b024d8c (patch)
treee3ada017b0f625db8b39a2212ab82c8e32a62b7c /src/Propellor/Types
parent5ecbec11127449fefe4812fd6b374801ce8499c1 (diff)
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.
Diffstat (limited to 'src/Propellor/Types')
-rw-r--r--src/Propellor/Types/Chroot.hs21
-rw-r--r--src/Propellor/Types/Core.hs10
-rw-r--r--src/Propellor/Types/Dns.hs16
-rw-r--r--src/Propellor/Types/Docker.hs10
-rw-r--r--src/Propellor/Types/Info.hs10
-rw-r--r--src/Propellor/Types/Result.hs15
6 files changed, 54 insertions, 28 deletions
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