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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
|
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
module Main ( main, run, defaultConfig, Config(..) ) where
import Darcs.Prelude
import qualified Darcs.Test.Email
import qualified Darcs.Test.HashedStorage
import qualified Darcs.Test.Misc
import qualified Darcs.Test.Patch
import qualified Darcs.Test.Repository.Inventory
import Darcs.Test.Shell
import qualified Darcs.Test.UI
import Darcs.Util.Exception ( die )
import Control.Monad ( filterM, unless, when )
import Data.List ( isPrefixOf, isSuffixOf, sort )
import GHC.IO.Encoding ( textEncodingName )
import System.Console.CmdArgs hiding ( args )
import System.Console.CmdArgs.Explicit ( process )
import System.Directory ( doesFileExist, doesPathExist, exeExtension, listDirectory )
import System.Environment.FindBin ( getProgPath )
import System.FilePath ( isAbsolute, takeBaseName, takeDirectory, (</>) )
import System.IO ( BufferMode(NoBuffering), hSetBuffering, localeEncoding, stdout )
import Test.Framework
( ColorMode(..)
, RunnerOptions'(..)
, Seed(..)
, TestOptions'(..)
, defaultMainWithOpts
)
data Config = Config { suites :: String
, formats :: String
, diffalgs :: String
, index :: String
, cache :: String
, full :: Bool
, darcs :: String
, tests :: [String]
, testDir :: Maybe FilePath
, ghcFlags :: String
, plain :: Bool
, hideSuccesses :: Bool
, threads :: Int
, qcCount :: Int
, replay :: Maybe Int
}
deriving (Data, Typeable, Eq, Show)
defaultConfigAnn :: Annotate Ann
defaultConfigAnn
= record Config{}
[ suites := "snu" += help "Select which test suites to run: (s=shell, n=network, u=unit, f=failing, h=hashed) [snu]" += typ "SET"
, formats := "123" += help "Select which darcs formats to test: (1=darcs-1, 2=darcs-2, 3=darcs-3) [123]" += name "f" += typ "SET"
, diffalgs := "p" += help "Select which diff alorithms to use (p=patience, m=myers) [p]" += name "a" += typ "SET"
, index := "y" += help "Select whether to use the index (n=no, y=yes) [y]" += typ "SET"
, cache := "y" += help "Select whether to use the cache (n=no, y=yes) [y]" += typ "SET"
, full := False += help "Shortcut for -s=snu -f=123 -a=mp -c=yn -i=yn"
, darcs := "" += help "Darcs binary path" += typ "PATH"
, tests := [] += help "Pattern to limit the tests to run" += typ "PATTERN" += name "t"
, testDir := Nothing += help "Directory to run tests in" += typ "PATH" += name "d"
, ghcFlags := "" += help "GHC flags to use when compiling tests" += typ "FLAGS" += name "g"
, plain := False += help "Use plain-text output [no]"
, hideSuccesses := False += help "Hide successes [no]"
, threads := 1 += help "Number of threads [1]" += name "j"
, qcCount := 100 += help "Number of QuickCheck iterations per test [100]" += name "q"
, replay := Nothing += help "Replay QC tests with given seed" += typ "SEED"
]
+= summary "Darcs test harness"
+= program "darcs-test"
defaultConfig :: Config
defaultConfig =
case process (cmdArgsMode_ defaultConfigAnn) [] of
Right r -> cmdArgsValue r
Left _ -> error "impossible"
-- | Find the darcs executable to test
findDarcs :: IO FilePath
findDarcs = do
path <- getProgPath
let darcsExe = "darcs" ++ exeExtension
candidates =
-- if darcs-test lives in foo/something, look for foo/darcs[.exe] for
-- example if we've done cabal install -ftest, there'll be a darcs-test
-- and darcs in the cabal installation folder
[path </> darcsExe] ++
-- if darcs-test lives in foo/darcs-test/something, look for
-- foo/darcs/darcs[.exe] for example after cabal build we can run
-- .../build/darcs-test/darcs-test and it'll find the darcs in
-- .../build/darcs/darcs
[ takeDirectory path </> "darcs" </> darcsExe
| takeBaseName path == "darcs-test"
] ++
-- some versions of cabal produce more complicated structures:
-- t/darcs-test/build/darcs-test/darcs-test and x/darcs/build/darcs/darcs
[ takeDirectory path </> ".." </> ".." </> ".." </> "x" </> "darcs" </>
"build" </> "darcs" </> darcsExe
| takeBaseName path == "darcs-test"
] ++
[ takeDirectory path </> ".." </> ".." </> ".." </> ".." </> "x" </>
"darcs" </> "noopt" </> "build" </> "darcs" </> darcsExe
| takeBaseName path == "darcs-test"
]
availableCandidates <- filterM doesFileExist candidates
case availableCandidates of
(result:_) -> do
putStrLn $ "Using darcs executable in " ++ takeDirectory result
return result
[] ->
die ("No darcs specified or found nearby. Tried:\n" ++ unlines candidates)
run :: Config -> IO ()
run conf = do
case testDir conf of
Nothing -> return ()
Just d -> do
e <- doesPathExist d
when e $ die ("Directory " ++ d ++ " already exists. Cowardly exiting")
let hashed = 'h' `elem` suites conf
failing = 'f' `elem` suites conf
shell = 's' `elem` suites conf
network = 'n' `elem` suites conf
unit = 'u' `elem` suites conf
darcs1 = '1' `elem` formats conf
darcs2 = '2' `elem` formats conf
darcs3 = '3' `elem` formats conf
myers = 'm' `elem` diffalgs conf
patience = 'p' `elem` diffalgs conf
noindex = 'n' `elem` index conf
withindex = 'y' `elem` index conf
nocache = 'n' `elem` cache conf
withcache = 'y' `elem` cache conf
darcsBin <-
case darcs conf of
"" -> findDarcs
v -> return v
when (shell || network || failing) $ do
unless (isAbsolute $ darcsBin) $
die ("Argument to --darcs should be an absolute path")
unless (exeExtension `isSuffixOf` darcsBin) $
putStrLn $
"Warning: --darcs flag does not end with " ++ exeExtension ++
" - some tests may fail (case does matter)"
putStrLn $ "Locale encoding is " ++ textEncodingName localeEncoding
let repoFormat = (if darcs1 then (Darcs1:) else id)
. (if darcs2 then (Darcs2:) else id)
. (if darcs3 then (Darcs3:) else id)
$ []
let diffAlgorithm = (if myers then (Myers:) else id)
. (if patience then (Patience:) else id)
$ []
let useIndex = (if noindex then (NoIndex:) else id)
. (if withindex then (WithIndex:) else id)
$ []
let useCache = (if nocache then (NoCache:) else id)
. (if withcache then (WithCache:) else id)
$ []
let findTestFiles dir = select . map (dir </>) <$> listDirectory dir
where
filter_failing =
if failing
then id
else filter $ not . ("failing-" `isPrefixOf`) . takeBaseName
select = sort . filter_failing . filter (".sh" `isSuffixOf`)
stests <-
if shell
then do
files <- findTestFiles "tests"
findShell darcsBin files (testDir conf) (ghcFlags conf) diffAlgorithm
repoFormat useIndex useCache
else return []
ntests <-
if network
then do
files <- findTestFiles "tests/network"
findShell darcsBin files (testDir conf) (ghcFlags conf) diffAlgorithm
repoFormat useIndex useCache
else return []
let utests =
if unit then
[ Darcs.Test.Email.testSuite
, Darcs.Test.Misc.testSuite
, Darcs.Test.Repository.Inventory.testSuite
, Darcs.Test.UI.testSuite
] ++
Darcs.Test.Patch.testSuite
else []
hstests = if hashed then Darcs.Test.HashedStorage.tests else []
let testRunnerOptions = RunnerOptions
{ ropt_threads = Just (threads conf)
, ropt_test_options = Just $ TestOptions
{ topt_seed = FixedSeed <$> replay conf
, topt_maximum_generated_tests = Just (qcCount conf)
, topt_maximum_unsuitable_generated_tests = Just (7 * qcCount conf)
, topt_maximum_test_size = Nothing
, topt_maximum_test_depth = Nothing
, topt_timeout = Nothing
}
, ropt_test_patterns =
if null (tests conf) then Nothing else Just (map read (tests conf))
, ropt_xml_output = Nothing
, ropt_xml_nested = Nothing
, ropt_color_mode = if plain conf then Just ColorNever else Nothing
, ropt_hide_successes = Just (hideSuccesses conf)
, ropt_list_only = Nothing
}
defaultMainWithOpts (stests ++ utests ++ ntests ++ hstests) testRunnerOptions
main :: IO ()
main = do hSetBuffering stdout NoBuffering
clp <- cmdArgs_ defaultConfigAnn
run $
if full clp then clp
{ formats = "123"
, diffalgs = "mp"
, index = "yn"
, cache = "yn"
}
else clp
|
