0 | module Evince.Config
 1 |
 2 | import Data.SnocList
 3 | import Data.String
 4 | import System
 5 | import System.File
 6 | import Evince.Core
 7 |
 8 | parseNat : String -> Maybe Nat
 9 | parseNat s = do
10 |   n <- parseInteger {a = Integer} s
11 |   if n >= 0 then Just (cast n) else Nothing
12 |
13 | applyArg : RunConfig -> String -> (RunConfig, Maybe String)
14 | applyArg cfg "--fail-fast" = ({ failFast := True } cfg, Nothing)
15 | applyArg cfg "--randomize" = ({ randomize := True } cfg, Nothing)
16 | applyArg cfg "--times"     = ({ showTiming := True } cfg, Nothing)
17 | applyArg cfg "--rerun"     = ({ rerun := True } cfg, Nothing)
18 | applyArg cfg "--no-color"  = ({ color := False } cfg, Nothing)
19 | applyArg cfg "--help"      = (cfg, Nothing)
20 | applyArg cfg arg =
21 |   let (key, rest) = break (== '=') arg
22 |       val = substr 1 (length rest) rest
23 |       strArg : (String -> RunConfig) -> (RunConfig, Maybe String)
24 |       strArg f = if val == "" then (cfg, Just "missing value for \{key}")
25 |                  else (f val, Nothing)
26 |       natArg : (Nat -> RunConfig) -> (RunConfig, Maybe String)
27 |       natArg f = if val == "" then (cfg, Just "missing value for \{key}")
28 |                  else case parseNat val of
29 |                         Just n  => (f n, Nothing)
30 |                         Nothing => (cfg, Just "invalid value for \{key}: \{val}")
31 |   in case key of
32 |        "--match" => strArg (\v => { match := Just v } cfg)
33 |        "--skip"  => strArg (\v => { skip := Just v } cfg)
34 |        "--junit" => strArg (\v => { junitOutput := Just v } cfg)
35 |        "--seed"  => natArg (\n => { seed := Just n } cfg)
36 |        "--jobs"  => natArg (\n => { jobs := n } cfg)
37 |        _         => (cfg, Just "unknown argument: \{arg}")
38 |
39 | ||| Parse command-line arguments, also collecting a warning for every
40 | ||| argument that is unknown or has a missing/invalid value.
41 | export
42 | parseArgsWarn : List String -> (RunConfig, List String)
43 | parseArgsWarn args =
44 |   let (cfg, ws) = foldl step (defaultConfig, [<]) args
45 |   in (cfg, ws <>> [])
46 |   where
47 |     step : (RunConfig, SnocList String) -> String -> (RunConfig, SnocList String)
48 |     step (cfg, ws) arg =
49 |       let (cfg', w) = applyArg cfg arg
50 |       in (cfg', maybe ws (ws :<) w)
51 |
52 | ||| Parse command-line arguments into a RunConfig. Unknown or invalid
53 | ||| arguments are ignored; use `parseArgsWarn` to also collect warnings.
54 | export
55 | parseArgs : List String -> RunConfig
56 | parseArgs = fst . parseArgsWarn
57 |
58 | ||| Reference text for the CLI flags understood by the `*WithArgs` runners.
59 | export
60 | usage : String
61 | usage = """
62 | Usage: <test-binary> [OPTIONS]
63 |
64 |   --help         Show this help and exit
65 |   --fail-fast    Stop after the first failure
66 |   --times        Show per-test and total duration
67 |   --match=PAT    Run only tests whose label contains PAT
68 |   --skip=PAT     Skip tests and groups whose label contains PAT
69 |   --randomize    Shuffle top-level execution order
70 |   --seed=N       Deterministic seed for --randomize
71 |   --junit=FILE   Write a JUnit XML report to FILE
72 |   --rerun        Re-run only the tests that failed in the last run
73 |   --jobs=N       Run up to N top-level groups concurrently (async drivers)
74 |   --no-color     Disable colored output (NO_COLOR is also respected)
75 | """
76 |
77 | ||| Parse CLI arguments for a runner: `--help` prints the flag reference and
78 | ||| exits, and each unknown or invalid argument gets a warning on stderr.
79 | export
80 | handleArgs : List String -> IO RunConfig
81 | handleArgs args = do
82 |   when ("--help" `elem` args) $ do
83 |     putStrLn usage
84 |     exitSuccess
85 |   let (cfg, warnings) = parseArgsWarn args
86 |   for_ warnings $ \w => ignore $ fPutStrLn stderr "warning: \{w}"
87 |   pure cfg
88 |