summaryrefslogtreecommitdiff
path: root/src/Propellor/EnsureProperty.hs
diff options
context:
space:
mode:
authorJoey Hess2019-07-02 00:46:21 -0400
committerJoey Hess2019-07-02 00:46:21 -0400
commit2ba2cda972f484771b763603bf09d555003861b7 (patch)
tree13c79ae8e9f46cf6c9ec5353ca366555da0e0ab1 /src/Propellor/EnsureProperty.hs
parent7ac0fbfa247ca153a6187c47dde9fc3a94c9cdb5 (diff)
Revert "Revert "custom type error messages""
This reverts commit 665ea0d3d9e1b0e90278fd659dee0ef8642030da.
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`.