quox/tests/Options.idr
2022-05-25 14:22:30 +02:00

113 lines
2.6 KiB
Idris

module Options
import Data.String
import System
import System.Console.GetOpt
%default total
public export
data TAPVersion = V13 | V14
export
readVersion : String -> Maybe TAPVersion
readVersion "13" = Just V13
readVersion "14" = Just V14
readVersion _ = Nothing
export Show TAPVersion where show V13 = "13"; show V14 = "14"
public export
record Options where
constructor Opts
version : TAPVersion
pattern : Maybe String
color : Bool
export
defaultOpts : Options
defaultOpts = Opts {
version = V13,
pattern = Nothing,
color = False
}
public export
Mod : Type
Mod = Options -> IO Options
export
failureWith : List String -> IO a
failureWith msgs = do
traverse_ (\s => putStrLn "# \{s}") msgs
putStrLn "\nBail out!"
exitFailure
private
setTapVer : String -> Mod
setTapVer ver opts =
case readVersion ver of
Just v => pure $ {version := v} opts
Nothing => failureWith ["unrecognised TAP version '\{ver}'"]
private
setPat : String -> Mod
setPat str opts = pure $ {pattern := Just str} opts
mutual
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"],
argDescr = ReqArg setPat "STR"
},
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}
}
]
export
usage : List String
usage = assert_total $ "quox test suite" :: lines (usageInfo "" opts)
export
makeOpts : List Mod -> IO Options
makeOpts = foldlM (\x, f => f x) defaultOpts
export
getArgs1 : IO (List String)
getArgs1 =
case !getArgs of
_ :: args => pure args
[] => failureWith ["expected getArgs to start with exe name"]
export
getTestOpts : IO Options
getTestOpts =
case getOpt Permute opts !getArgs1 of
MkResult opts [] [] [] => makeOpts opts
res => failureWith $ res.errors ++ usage