From 030f13f2d0501c9fb42c8f1efa0a15fa63c94d67 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Dec 2015 14:24:44 -0400 Subject: allow using `check` on a UncheckedProperty, which yields a Property --- src/Propellor/Types/ResultCheck.hs | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) (limited to 'src/Propellor/Types/ResultCheck.hs') diff --git a/src/Propellor/Types/ResultCheck.hs b/src/Propellor/Types/ResultCheck.hs index 09fbf73b..4c6524ee 100644 --- a/src/Propellor/Types/ResultCheck.hs +++ b/src/Propellor/Types/ResultCheck.hs @@ -4,15 +4,16 @@ module Propellor.Types.ResultCheck ( UncheckedProperty, unchecked, checkResult, + check, Checkable, assume, ) where import Propellor.Types import Propellor.Exception +import Utility.Monad import Data.Monoid -import Control.Monad.IO.Class (liftIO) -- | This is a `Property` but its `Result` is not accurate; in particular -- it may return `NoChange` despite having made a change. @@ -29,30 +30,44 @@ unchecked = UncheckedProperty -- `UncheckedProperty` to a `Property`, but can also be used to further -- check a `Property`. checkResult - :: Checkable p i - => IO a + :: (Checkable p i, LiftPropellor m) + => m a -- ^ Run before ensuring the property. - -> (a -> IO Result) + -> (a -> m Result) -- ^ Run after ensuring the property. Return `MadeChange` if a -- change was detected, or `NoChange` if no change was detected. -> p i -> Property i checkResult precheck postcheck p = adjustPropertySatisfy (checkedProp p) $ \satisfy -> do - a <- liftIO precheck + a <- liftPropellor precheck r <- catchPropellor satisfy -- Always run postcheck, even if the result is already MadeChange, -- as it may need to clean up after precheck. - r' <- liftIO $ postcheck a + r' <- liftPropellor $ postcheck a return (r <> r') - + +-- | Makes a `Property` or an `UncheckedProperty` only run +-- when a test succeeds. +check :: (Checkable p i, LiftPropellor m) => m Bool -> p i -> Property i +check test p = adjustPropertySatisfy (preCheckedProp p) $ \satisfy -> + ifM (liftPropellor test) + ( satisfy + , return NoChange + ) + class Checkable p i where checkedProp :: p i -> Property i + preCheckedProp :: p i -> Property i instance Checkable Property i where checkedProp = id + preCheckedProp = id instance Checkable UncheckedProperty i where checkedProp (UncheckedProperty p) = p + -- Since it was pre-checked that the property needed to be run, + -- if the property succeeded, we can assume it made a change. + preCheckedProp (UncheckedProperty p) = p `assume` MadeChange -- | Sometimes it's not practical to test if a property made a change. -- In such a case, it's often fine to say: -- cgit v1.2.3