summaryrefslogtreecommitdiff
path: root/src/Propellor/EnsureProperty.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/EnsureProperty.hs')
-rw-r--r--src/Propellor/EnsureProperty.hs41
1 files changed, 32 insertions, 9 deletions
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
index ab624706..5ed0325f 100644
--- a/src/Propellor/EnsureProperty.hs
+++ b/src/Propellor/EnsureProperty.hs
@@ -8,7 +8,7 @@ module Propellor.EnsureProperty
( ensureProperty
, property'
, OuterMetaTypesWitness
- , Cannot_ensureProperty_WithInfo
+ , EnsurePropertyAllowed
) where
import Propellor.Types
@@ -16,6 +16,8 @@ import Propellor.Types.Core
import Propellor.Types.MetaTypes
import Propellor.Exception
+import GHC.TypeLits
+import Data.Type.Bool
import Data.Monoid
import Prelude
@@ -41,19 +43,40 @@ ensureProperty
-- -Wredundant-constraints is turned off because
-- this constraint appears redundant, but is actually
-- crucial.
- ( Cannot_ensureProperty_WithInfo inner ~ 'True
- , (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine
- )
+ ( EnsurePropertyAllowed inner outer ~ 'True)
=> OuterMetaTypesWitness outer
-> Property (MetaTypes inner)
-> Propellor Result
ensureProperty _ = maybe (return NoChange) catchPropellor . getSatisfy
--- The name of this was chosen to make type errors a bit more understandable.
-type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool where
- Cannot_ensureProperty_WithInfo '[] = 'True
- Cannot_ensureProperty_WithInfo (t ': ts) =
- Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts
+type family EnsurePropertyAllowed inner outer where
+ EnsurePropertyAllowed inner outer =
+ (EnsurePropertyNoInfo inner)
+ &&
+ (EnsurePropertyTargetOSMatches inner outer)
+
+type family EnsurePropertyNoInfo (l :: [a]) :: Bool where
+ EnsurePropertyNoInfo '[] = 'True
+ EnsurePropertyNoInfo (t ': ts) = If (Not (t `EqT` 'WithInfo))
+ (EnsurePropertyNoInfo ts)
+ (TypeError ('Text "Cannot use ensureProperty with a Property that HasInfo."))
+
+type family EnsurePropertyTargetOSMatches inner outer where
+ EnsurePropertyTargetOSMatches inner outer =
+ If (Targets outer `IsSubset` Targets inner)
+ 'True
+ (IfStuck (Targets outer)
+ (TypeError
+ ('Text "ensureProperty outer Property type is not able to be inferred here."
+ ':$$: 'Text "Consider adding a type annotation."
+ )
+ )
+ (TypeError
+ ('Text "ensureProperty inner Property is missing support for: "
+ ':$$: PrettyPrintMetaTypes (Difference (Targets outer) (Targets inner))
+ )
+ )
+ )
-- | Constructs a property, like `property`, but provides its
-- `OuterMetaTypesWitness`.