propellor/Property.hs

119 lines
3.3 KiB
Haskell

module Property where
import System.Directory
import Control.Monad
import System.Console.ANSI
import System.Exit
import System.IO
import 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
putStr $ propertyDesc l ++ "... "
hFlush stdout
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)