propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

EnsureProperty.hs (3237B)


      1 {-# LANGUAGE DataKinds #-}
      2 {-# LANGUAGE KindSignatures #-}
      3 {-# LANGUAGE PolyKinds #-}
      4 {-# LANGUAGE ConstraintKinds #-}
      5 {-# LANGUAGE TypeFamilies #-}
      6 {-# LANGUAGE UndecidableInstances #-}
      7 
      8 module Propellor.EnsureProperty
      9 	( ensureProperty
     10 	, property'
     11 	, OuterMetaTypesWitness
     12 	, EnsurePropertyAllowed
     13 	) where
     14 
     15 import Propellor.Types
     16 import Propellor.Types.Core
     17 import Propellor.Types.MetaTypes
     18 import Propellor.Exception
     19 
     20 import GHC.TypeLits
     21 import GHC.Exts (Constraint)
     22 import Data.Type.Bool
     23 import Data.Monoid
     24 import Prelude
     25 
     26 -- | For when code running in the Propellor monad needs to ensure a
     27 -- Property.
     28 --
     29 -- Use `property'` to get the `OuterMetaTypesWithness`. For example:
     30 --
     31 -- > foo = Property Debian
     32 -- > foo = property' "my property" $ \w -> do
     33 -- > 	ensureProperty w (aptInstall "foo")
     34 --
     35 -- The type checker will prevent using ensureProperty with a property
     36 -- that does not support the target OSes needed by the OuterMetaTypesWitness.
     37 -- In the example above, aptInstall must support Debian, since foo
     38 -- is supposed to support Debian.
     39 --
     40 -- The type checker will also prevent using ensureProperty with a property
     41 -- with HasInfo in its MetaTypes. Doing so would cause the `Info` associated
     42 -- with the property to be lost.
     43 ensureProperty
     44 	::
     45 		-- -Wredundant-constraints is turned off because
     46 		-- this constraint appears redundant, but is actually
     47 		-- crucial.
     48 		( EnsurePropertyAllowed inner outer)
     49 	=> OuterMetaTypesWitness outer
     50 	-> Property (MetaTypes inner)
     51 	-> Propellor Result
     52 ensureProperty _ = maybe (return NoChange) catchPropellor . getSatisfy
     53 
     54 type family EnsurePropertyAllowed inner outer :: Constraint where
     55 	EnsurePropertyAllowed inner outer = 'True ~
     56 		((EnsurePropertyNoInfo inner)
     57 			&&
     58 		(EnsurePropertyTargetOSMatches inner outer))
     59 
     60 type family EnsurePropertyNoInfo (l :: [a]) :: Bool where
     61 	EnsurePropertyNoInfo '[] = 'True
     62 	EnsurePropertyNoInfo (t ': ts) = If (Not (t `EqT` 'WithInfo))
     63 		(EnsurePropertyNoInfo ts)
     64 		(TypeError ('Text "Cannot use ensureProperty with a Property that HasInfo."))
     65 
     66 type family EnsurePropertyTargetOSMatches inner outer where
     67 	EnsurePropertyTargetOSMatches inner outer = 
     68 		If (Targets outer `IsSubset` Targets inner)
     69 			'True
     70 			(IfStuck (Targets outer)
     71 				(DelayError
     72 					('Text "ensureProperty outer Property type is not able to be inferred here."
     73 					 ':$$: 'Text "Consider adding a type annotation."
     74 					)
     75 				)
     76 				(DelayErrorFcf
     77 					('Text "ensureProperty inner Property is missing support for: "
     78 					 ':$$: PrettyPrintMetaTypes (Difference (Targets outer) (Targets inner))
     79 					)
     80 				)
     81 			)
     82 
     83 -- | Constructs a property, like `property`, but provides its
     84 -- `OuterMetaTypesWitness`.
     85 property'
     86 	:: SingI metatypes
     87 	=> Desc
     88 	-> (OuterMetaTypesWitness metatypes -> Propellor Result)
     89 	-> Property (MetaTypes metatypes)
     90 property' d a =
     91 	let p = Property sing d (Just (a (outerMetaTypesWitness p))) mempty mempty
     92 	in p
     93 
     94 -- | Used to provide the metatypes of a Property to calls to 
     95 -- 'ensureProperty` within it.
     96 newtype OuterMetaTypesWitness metatypes = OuterMetaTypesWitness (MetaTypes metatypes)
     97 
     98 outerMetaTypesWitness :: Property (MetaTypes l) -> OuterMetaTypesWitness l
     99 outerMetaTypesWitness (Property metatypes _ _ _ _) = OuterMetaTypesWitness metatypes