summaryrefslogtreecommitdiff
path: root/src/Propellor/Types.hs
diff options
context:
space:
mode:
authorJoey Hess2019-07-01 15:49:20 -0400
committerJoey Hess2019-07-01 16:20:51 -0400
commit14f6ae30809d8bbdb10b91cc59757e865a365df8 (patch)
treebe688e4685f05d6426cf30b0e0eff5a25cf003ee /src/Propellor/Types.hs
parent70e71629b370349914e9fc89956a6756783296b0 (diff)
custom type error messages
* Avoid displaying an excessive amount of type error messages when many properties have been combined in a props list. * Added custom type error messages when Properties don't combine due to conflicting metatypes. * Added custom type error messages for ensureProperty and tightenTargets. * ensureProperty: The constraints have been simplified to EnsurePropertyAllowed. (API change) * ensureProperty: The contraints have been simplified to TightenTargetsAllowed. (API change) * CheckCombinable generates a Bool. (API change) This commit was sponsored by Jake Vosloo on Patreon.
Diffstat (limited to 'src/Propellor/Types.hs')
-rw-r--r--src/Propellor/Types.hs29
1 files changed, 21 insertions, 8 deletions
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 7052bf92..e8e92332 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -31,6 +31,7 @@ module Propellor.Types (
, HasInfo
, type (+)
, TightenTargets(..)
+ , TightenTargetsAllowed
-- * Combining and modifying properties
, Combines(..)
, CombinedType
@@ -44,6 +45,8 @@ module Propellor.Types (
, module Propellor.Types.ZFS
) where
+import GHC.TypeLits hiding (type (+))
+import Data.Type.Bool
import qualified Data.Semigroup as Sem
import Data.Monoid
import Control.Applicative
@@ -59,7 +62,7 @@ import Propellor.Types.MetaTypes
import Propellor.Types.ZFS
-- | The core data type of Propellor, this represents a property
--- that the system should have, with a descrition, and an action to ensure
+-- that the system should have, with a description, and an action to ensure
-- it has the property.
--
-- There are different types of properties that target different OS's,
@@ -185,17 +188,17 @@ class Combines x y where
-> y
-> CombinedType x y
-instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes y)) where
+instance (CheckCombinable x y ~ 'True, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes y)) where
combineWith f _ (Property _ d1 a1 i1 c1) (Property _ d2 a2 i2 c2) =
Property sing d1 (f a1 a2) i1 (ChildProperty d2 a2 i2 c2 : c1)
-instance (CheckCombinable x y ~ 'CanCombine, CheckCombinable x' y' ~ 'CanCombine, SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
+instance (CheckCombinable x y ~ 'True, CheckCombinable x' y' ~ 'True, SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) =
RevertableProperty
(combineWith sf tf s1 s2)
(combineWith tf sf t1 t2)
-instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) where
+instance (CheckCombinable x y ~ 'True, SingI (Combine x y)) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) where
combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
-instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
+instance (CheckCombinable x y ~ 'True, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y
class TightenTargets p where
@@ -209,14 +212,24 @@ class TightenTargets p where
-- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"]
tightenTargets
::
- -- Note that this uses PolyKinds
- ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine
- , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine
+ ( TightenTargetsAllowed untightened tightened ~ 'True
, SingI tightened
)
=> p (MetaTypes untightened)
-> p (MetaTypes tightened)
+-- Note that this uses PolyKinds
+type family TightenTargetsAllowed untightened tightened where
+ TightenTargetsAllowed untightened tightened =
+ If (Targets tightened `IsSubset` Targets untightened
+ && NonTargets untightened `IsSubset` NonTargets tightened)
+ 'True
+ ( TypeError
+ ( 'Text "This use of tightenTargets would widen, not narrow, adding: "
+ ':$$: PrettyPrintMetaTypes (Difference (Targets tightened) (Targets untightened))
+ )
+ )
+
instance TightenTargets Property where
tightenTargets (Property _ d a i c) = Property sing d a i c