From 9b65d9650404d8b7202fc63ba23554d734589f20 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 31 Mar 2014 10:36:45 -0400 Subject: monoid --- Propellor.hs | 3 ++- Propellor/Engine.hs | 3 ++- Propellor/Property.hs | 34 +++++++++++++++++----------------- Propellor/Types.hs | 16 ++++++++++------ 4 files changed, 31 insertions(+), 25 deletions(-) diff --git a/Propellor.hs b/Propellor.hs index bc26df58..3e7e88ad 100644 --- a/Propellor.hs +++ b/Propellor.hs @@ -17,7 +17,7 @@ -- > getProperties "example.com" = Just -- > [ Apt.installed ["mydaemon"] -- > , "/etc/mydaemon.conf" `File.containsLine` "secure=1" --- > `onChange` cmdProperty "service" ["mydaemon", "restart"]] +-- > `onChange` cmdProperty "service" ["mydaemon", "restart"] -- > ] -- > getProperties _ = Nothing -- @@ -57,3 +57,4 @@ import Data.Maybe as X import Data.Either as X import Control.Applicative as X import Control.Monad as X +import Data.Monoid as X diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs index 22091938..a220ec77 100644 --- a/Propellor/Engine.hs +++ b/Propellor/Engine.hs @@ -3,6 +3,7 @@ module Propellor.Engine where import System.Console.ANSI import System.Exit import System.IO +import Data.Monoid import Propellor.Types import Utility.Exception @@ -42,7 +43,7 @@ ensureProperties' ps = ensure ps NoChange putStrLn "done" setSGR [] hFlush stdout - ensure ls (combineResult r rs) + ensure ls (r <> rs) warningMessage :: String -> IO () warningMessage s = do diff --git a/Propellor/Property.hs b/Propellor/Property.hs index c2e2cbab..a1b871c2 100644 --- a/Propellor/Property.hs +++ b/Propellor/Property.hs @@ -2,6 +2,7 @@ module Propellor.Property where import System.Directory import Control.Monad +import Data.Monoid import Propellor.Types import Propellor.Engine @@ -13,16 +14,15 @@ makeChange a = a >> return MadeChange noChange :: IO Result noChange = return NoChange -{- | Combines a list of properties, resulting in a single property - - that when run will run each property in the list in turn, - - and print out the description of each as it's run. Does not stop - - on failure; does propigate overall success/failure. - -} +-- | Combines a list of properties, resulting in a single property +-- that when run will run each property in the list in turn, +-- and print out the description of each as it's run. Does not stop +-- on failure; does propigate overall success/failure. propertyList :: Desc -> [Property] -> Property propertyList desc ps = Property desc $ ensureProperties' ps -{- | Combines a list of properties, resulting in one property that - - ensures each in turn, stopping on failure. -} +-- | Combines a list of properties, resulting in one property that +-- ensures each in turn, stopping on failure. combineProperties :: [Property] -> Property combineProperties ps = Property desc $ go ps NoChange where @@ -31,14 +31,14 @@ combineProperties ps = Property desc $ go ps NoChange r <- ensureProperty l case r of FailedChange -> return FailedChange - _ -> go ls (combineResult r rs) + _ -> go ls (r <> rs) desc = case ps of (p:_) -> propertyDesc p _ -> "(empty)" -{- | Makes a perhaps non-idempotent Property be idempotent by using a flag - - file to indicate whether it has run before. - - Use with caution. -} +-- | Makes a perhaps non-idempotent Property be idempotent by using a flag +-- file to indicate whether it has run before. +-- Use with caution. flagFile :: Property -> FilePath -> Property flagFile property flagfile = Property (propertyDesc property) $ go =<< doesFileExist flagfile @@ -50,19 +50,19 @@ flagFile property flagfile = Property (propertyDesc property) $ writeFile flagfile "" return r -{- | Whenever a change has to be made for a Property, causes a hook - - Property to also be run, but not otherwise. -} +--- | Whenever a change has to be made for a Property, causes a hook +-- Property to also be run, but not otherwise. onChange :: Property -> Property -> Property property `onChange` hook = Property (propertyDesc property) $ do r <- ensureProperty property case r of MadeChange -> do r' <- ensureProperty hook - return $ combineResult r r' + return $ r <> r' _ -> return r -{- | Indicates that the first property can only be satisfied once - - the second is. -} +-- | Indicates that the first property can only be satisfied once +-- the second is. requires :: Property -> Property -> Property x `requires` y = combineProperties [y, x] `describe` propertyDesc x @@ -73,7 +73,7 @@ describe p d = p { propertyDesc = d } (==>) = flip describe infixl 1 ==> -{- | Makes a Property only be performed when a test succeeds. -} +-- | Makes a Property only be performed when a test succeeds. check :: IO Bool -> Property -> Property check c property = Property (propertyDesc property) $ ifM c ( ensureProperty property diff --git a/Propellor/Types.hs b/Propellor/Types.hs index 70ad8f9b..ec472ffe 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -1,5 +1,7 @@ module Propellor.Types where +import Data.Monoid + type HostName = String type UserName = String @@ -14,9 +16,11 @@ type Desc = String data Result = NoChange | MadeChange | FailedChange deriving (Show, Eq) -combineResult :: Result -> Result -> Result -combineResult FailedChange _ = FailedChange -combineResult _ FailedChange = FailedChange -combineResult MadeChange _ = MadeChange -combineResult _ MadeChange = MadeChange -combineResult NoChange NoChange = NoChange +instance Monoid Result where + mempty = NoChange + + mappend FailedChange _ = FailedChange + mappend _ FailedChange = FailedChange + mappend MadeChange _ = MadeChange + mappend _ MadeChange = MadeChange + mappend NoChange NoChange = NoChange -- cgit v1.2.3