summaryrefslogtreecommitdiff
path: root/src/Propellor/EnsureProperty.hs
diff options
context:
space:
mode:
authorJoey Hess2016-03-24 17:25:58 -0400
committerJoey Hess2016-03-24 17:28:20 -0400
commit83cd812ab5ac787769b34f59d1763f3c8648f06a (patch)
tree23b056fbe8616d34b623b58181e56225fcb939d6 /src/Propellor/EnsureProperty.hs
parent3d6a0d8663d32344a9f0761a144bfcacf9667378 (diff)
convert ensureProperty
Moved to its own module to keep everything related in one place.
Diffstat (limited to 'src/Propellor/EnsureProperty.hs')
-rw-r--r--src/Propellor/EnsureProperty.hs66
1 files changed, 66 insertions, 0 deletions
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
new file mode 100644
index 00000000..c72f7ecd
--- /dev/null
+++ b/src/Propellor/EnsureProperty.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Propellor.EnsureProperty
+ ( ensureProperty
+ , property'
+ , OuterMetaTypes
+ ) where
+
+import Propellor.Types
+import Propellor.Types.MetaTypes
+import Propellor.Exception
+
+-- | For when code running in the Propellor monad needs to ensure a
+-- Property.
+--
+-- Use `property'` to get the `OuterMetaTypes`. For example:
+--
+-- > foo = Property Debian
+-- > foo = property' $ \o -> do
+-- > ensureProperty o (aptInstall "foo")
+--
+-- The type checker will prevent using ensureProperty with a property
+-- that does not support the target OSes needed by the OuterMetaTypes.
+-- In the example above, aptInstall must support Debian, since foo
+-- is supposed to support Debian.
+--
+-- The type checker will also prevent using ensureProperty with a property
+-- with HasInfo in its MetaTypes. Doing so would cause the `Info` associated
+-- with the property to be lost.
+ensureProperty
+ ::
+ ( (Targets inner `NotSuperset` Targets outer) ~ 'CanCombineTargets
+ , CannotUseEnsurePropertyWithInfo inner ~ 'True
+ )
+ => OuterMetaTypes outer
+ -> Property (Sing inner)
+ -> Propellor Result
+ensureProperty _ = catchPropellor . propertySatisfy
+
+-- The name of this was chosen to make type errors a more understandable.
+type family CannotUseEnsurePropertyWithInfo (l :: [a]) :: Bool
+type instance CannotUseEnsurePropertyWithInfo '[] = 'True
+type instance CannotUseEnsurePropertyWithInfo (t ': ts) =
+ Not (t `EqT` 'WithInfo) && CannotUseEnsurePropertyWithInfo ts
+
+-- | Constructs a property, like `property`, but provides its
+-- `OuterMetaTypes`.
+property'
+ :: SingI metatypes
+ => Desc
+ -> (OuterMetaTypes metatypes -> Propellor Result)
+ -> Property (Sing metatypes)
+property' d a =
+ let p = Property sing d (a (outerMetaTypes p)) mempty mempty
+ in p
+
+-- | Used to provide the metatypes of a Property to calls to
+-- 'ensureProperty` within it.
+newtype OuterMetaTypes metatypes = OuterMetaTypes (Sing metatypes)
+
+outerMetaTypes :: Property (Sing l) -> OuterMetaTypes l
+outerMetaTypes (Property metatypes _ _ _ _) = OuterMetaTypes metatypes