From 380c1b0fd6c25dec3c924b82f1d721aa91a001da Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 30 Mar 2014 23:37:54 -0400 Subject: prepare for hackage --- Propellor/Property.hs | 123 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 123 insertions(+) create mode 100644 Propellor/Property.hs (limited to 'Propellor/Property.hs') diff --git a/Propellor/Property.hs b/Propellor/Property.hs new file mode 100644 index 00000000..727fe25e --- /dev/null +++ b/Propellor/Property.hs @@ -0,0 +1,123 @@ +module Propellor.Property where + +import System.Directory +import Control.Monad +import System.Console.ANSI +import System.Exit +import System.IO + +import Propellor.Types +import Utility.Monad +import Utility.Exception + +makeChange :: IO () -> IO Result +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. + -} +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. -} +combineProperties :: [Property] -> Property +combineProperties ps = Property desc $ go ps NoChange + where + go [] rs = return rs + go (l:ls) rs = do + r <- ensureProperty l + case r of + FailedChange -> return FailedChange + _ -> go ls (combineResult 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. -} +flagFile :: Property -> FilePath -> Property +flagFile property flagfile = Property (propertyDesc property) $ + go =<< doesFileExist flagfile + where + go True = return NoChange + go False = do + r <- ensureProperty property + when (r == MadeChange) $ + 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. -} +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 + +{- | 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 + +describe :: Property -> Desc -> Property +describe p d = p { propertyDesc = d } + +(==>) :: Desc -> Property -> Property +(==>) = flip describe +infixl 1 ==> + +{- | 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 + , return NoChange + ) + +ensureProperty :: Property -> IO Result +ensureProperty = catchDefaultIO FailedChange . propertySatisfy + +ensureProperties :: [Property] -> IO () +ensureProperties ps = do + r <- ensureProperties' [propertyList "overall" ps] + case r of + FailedChange -> exitWith (ExitFailure 1) + _ -> exitWith ExitSuccess + +ensureProperties' :: [Property] -> IO Result +ensureProperties' ps = ensure ps NoChange + where + ensure [] rs = return rs + ensure (l:ls) rs = do + r <- ensureProperty l + clearFromCursorToLineBeginning + setCursorColumn 0 + putStr $ propertyDesc l ++ "... " + case r of + FailedChange -> do + setSGR [SetColor Foreground Vivid Red] + putStrLn "failed" + NoChange -> do + setSGR [SetColor Foreground Dull Green] + putStrLn "unchanged" + MadeChange -> do + setSGR [SetColor Foreground Vivid Green] + putStrLn "done" + setSGR [] + ensure ls (combineResult r rs) + +warningMessage :: String -> IO () +warningMessage s = do + setSGR [SetColor Foreground Vivid Red] + putStrLn $ "** warning: " ++ s + setSGR [] + hFlush stdout -- cgit v1.2.3