diff options
| author | Joey Hess <joey@kitenet.net> | 2014-03-30 23:37:54 -0400 |
|---|---|---|
| committer | Joey Hess <joey@kitenet.net> | 2014-03-30 23:37:54 -0400 |
| commit | 380c1b0fd6c25dec3c924b82f1d721aa91a001da (patch) | |
| tree | 7d5b73309b73f13ac2be3f911318fe6a126264ff /Property.hs | |
| parent | 02a7bf5f0e2de1d0dea71781ed0c1ae3a50e6425 (diff) | |
prepare for hackage
Diffstat (limited to 'Property.hs')
| -rw-r--r-- | Property.hs | 123 |
1 files changed, 0 insertions, 123 deletions
diff --git a/Property.hs b/Property.hs deleted file mode 100644 index c37af3dc..00000000 --- a/Property.hs +++ /dev/null @@ -1,123 +0,0 @@ -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 - 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 |
