blob: 95a225c9a3fb71dcd04ea1b8e2c249ed7886733c (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
module Property where
import System.Directory
import Control.Monad
import System.Console.ANSI
import System.Exit
import System.IO
import Utility.Monad
import Utility.Exception
data Property = Property
{ propertyDesc :: Desc
-- must be idempotent; may run repeatedly
, propertySatisfy :: IO Result
}
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
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)
|
