idris2-tap/TAP/Options.idr

156 lines
4.1 KiB
Idris
Raw Normal View History

2022-05-26 09:41:48 -04:00
||| command line options
2022-05-26 08:23:50 -04:00
module TAP.Options
import Data.String
import System
import System.Console.GetOpt
%default total
2022-05-26 09:41:48 -04:00
||| which TAP version to use for output.
||| - `V14` supports subtests
||| - `V13` flattens the tree before running it
2022-05-26 08:23:50 -04:00
public export
data TAPVersion = V13 | V14
2022-05-26 09:41:48 -04:00
||| try to read a numeric TAP version number
2022-05-26 08:23:50 -04:00
export
readVersion : String -> Maybe TAPVersion
readVersion "13" = Just V13
readVersion "14" = Just V14
readVersion _ = Nothing
2022-05-26 09:41:48 -04:00
||| prints as just the number
2022-05-26 08:23:50 -04:00
export Show TAPVersion where show V13 = "13"; show V14 = "14"
2022-05-26 09:41:48 -04:00
||| command line options
|||
||| apart from these there is also a usage message with
||| `-?`, `-h`, `--help`
2022-05-26 08:23:50 -04:00
public export
record Options where
constructor Opts
2022-05-26 09:41:48 -04:00
||| `-V`, `--version`:
||| which TAP version to output
2022-05-26 08:23:50 -04:00
version : TAPVersion
2022-05-26 09:41:48 -04:00
||| `-F`, `--filter`:
||| search for a substring in test or group names.
||| if it is present in a group name then all subtests are run
||| regardless of their own names
2022-05-26 08:23:50 -04:00
pattern : Maybe String
2022-05-26 09:41:48 -04:00
||| `-c`, `--color`, `--colour`:
||| colour code test results and a few other things.
||| this is not TAP compliant so it is off by default.
2022-05-26 08:23:50 -04:00
color : Bool
2022-05-26 09:41:48 -04:00
||| default options
||| (version 13 (because of `prove`), no filter, no colour)
2022-05-26 08:23:50 -04:00
export
defaultOpts : Options
defaultOpts = Opts {
version = V13,
pattern = Nothing,
color = False
}
2022-05-26 09:41:48 -04:00
||| value for each option.
||| i'm using the old idiom where each option is a function that updates
||| an accumulated record. with IO because of the error messages being printed
2022-05-26 08:23:50 -04:00
public export
Mod : Type
Mod = Options -> IO Options
2022-05-26 09:41:48 -04:00
||| print the given messages as TAP comments and then say `Bail out!`.
||| so the error is a valid TAP transcript too :3
2022-05-26 08:23:50 -04:00
export
failureWith : List String -> IO a
failureWith msgs = do
traverse_ (\s => putStrLn "# \{s}") msgs
putStrLn "\nBail out!"
exitFailure
2022-05-26 09:41:48 -04:00
2022-05-26 08:23:50 -04:00
private
setTapVer : String -> Mod
setTapVer ver opts =
case readVersion ver of
Just v => pure $ {version := v} opts
Nothing => failureWith ["unrecognised TAP version '\{ver}'"]
private
2022-05-26 09:41:48 -04:00
setFilter : String -> Mod
setFilter str opts = pure $ {pattern := Just str} opts
2022-05-26 08:23:50 -04:00
mutual
2022-05-26 09:41:48 -04:00
||| option descriptions
2022-05-26 08:23:50 -04:00
export
opts : List (OptDescr Mod)
opts =
[ MkOpt {
description = "show this help",
shortNames = ['h', '?'], longNames = ["help"],
argDescr = NoArg $ const $ failureWith usage
},
MkOpt {
description = "TAP version to output (13 or 14, default 13)",
shortNames = ['V'], longNames = ["version"],
argDescr = ReqArg setTapVer "VERSION"
},
MkOpt {
description = "only run tests containing STR in their group or label",
shortNames = ['F'], longNames = ["filter"],
2022-05-26 09:41:48 -04:00
argDescr = ReqArg setFilter "STR"
2022-05-26 08:23:50 -04:00
},
MkOpt {
description = "don't colour-code results (default)",
shortNames = ['C'], longNames = ["no-color", "no-colour"],
argDescr = NoArg $ pure . {color := False}
},
MkOpt {
description = "colour-code results (not TAP compliant)",
shortNames = ['c'], longNames = ["color", "colour"],
argDescr = NoArg $ pure . {color := True}
}
]
2022-05-26 09:41:48 -04:00
||| usage message
2022-05-26 08:23:50 -04:00
export
usage : List String
usage = assert_total $ "quox test suite" :: lines (usageInfo "" opts)
2022-05-26 09:41:48 -04:00
||| interpret the result of `getOpt`
2022-05-26 08:23:50 -04:00
export
makeOpts : List Mod -> IO Options
makeOpts = foldlM (\x, f => f x) defaultOpts
2022-05-26 09:41:48 -04:00
||| like `getArgs` but skip the first one, which is the executable name
2022-05-26 08:23:50 -04:00
export
getArgs1 : IO (List String)
getArgs1 =
case !getArgs of
_ :: args => pure args
[] => failureWith ["expected getArgs to start with exe name"]
2022-05-26 09:41:48 -04:00
||| read & interpret the command line arguments
|||
||| [todo] allow unrecognised things and pass them back out
2022-05-26 08:23:50 -04:00
export
2022-05-26 09:41:48 -04:00
getTestOpts' : List String -> IO Options
getTestOpts' args =
case getOpt Permute opts args of
2022-05-26 08:23:50 -04:00
MkResult opts [] [] [] => makeOpts opts
res => failureWith $ res.errors ++ usage
2022-05-26 09:41:48 -04:00
||| interpret some command line arguments passed in
|||
||| [todo] allow unrecognised things and pass them back out
export
getTestOpts : IO Options
getTestOpts = getTestOpts' !getArgs1