fancier tests
This commit is contained in:
parent
25f9df34ab
commit
b0692c15b9
4 changed files with 200 additions and 89 deletions
2
Makefile
2
Makefile
|
|
@ -18,7 +18,7 @@ lib:
|
|||
|
||||
.PHONY: test
|
||||
test:
|
||||
nix run -- '.#quox-tests' -V 14
|
||||
nix run -- '.#quox-tests' -V 14 -c
|
||||
|
||||
.PHONY: prove
|
||||
prove:
|
||||
|
|
|
|||
|
|
@ -4,41 +4,110 @@ 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
|
||||
tapVersion : String
|
||||
version : TAPVersion
|
||||
pattern : Maybe String
|
||||
color : Bool
|
||||
|
||||
defaultOpts = Opts {tapVersion = "13"}
|
||||
export
|
||||
defaultOpts : Options
|
||||
defaultOpts = Opts {
|
||||
version = V13,
|
||||
pattern = Nothing,
|
||||
color = False
|
||||
}
|
||||
|
||||
OptMod = Options -> Options
|
||||
|
||||
opts : List (OptDescr OptMod)
|
||||
opts = [
|
||||
MkOpt ['V'] ["version"]
|
||||
(ReqArg (\v => the OptMod {tapVersion := v}) "VERSION")
|
||||
"TAP version to output (13 or 14, default 13)"
|
||||
]
|
||||
-- [todo] get rid of "the OptMod" when type inference is better, maybe
|
||||
|
||||
makeOpts : List OptMod -> Options
|
||||
makeOpts = foldl (flip ($)) defaultOpts
|
||||
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
|
||||
[] => do
|
||||
putStrLn "expecting getArgs to start with exe name"
|
||||
exitFailure
|
||||
[] => failureWith ["expected getArgs to start with exe name"]
|
||||
|
||||
export
|
||||
getTestOpts : IO Options
|
||||
getTestOpts =
|
||||
case getOpt Permute opts !getArgs1 of
|
||||
MkResult opts [] [] [] => pure $ makeOpts opts
|
||||
res => do
|
||||
traverse_ putStrLn $ res.errors ++ [usageInfo "quox test suite" opts]
|
||||
exitFailure
|
||||
MkResult opts [] [] [] => makeOpts opts
|
||||
res => failureWith $ res.errors ++ usage
|
||||
|
|
|
|||
166
tests/TAP.idr
166
tests/TAP.idr
|
|
@ -1,14 +1,20 @@
|
|||
module TAP
|
||||
-- [todo] extract this and Quox.Error to their own packages
|
||||
-- [todo] extract this to its own package?
|
||||
|
||||
import Options
|
||||
import public Control.Monad.Either
|
||||
import Data.String
|
||||
import Data.List
|
||||
import Data.List.Elem
|
||||
import Data.SnocList
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Control.ANSI
|
||||
import System
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
Info : Type
|
||||
Info = List (String, String)
|
||||
|
|
@ -39,24 +45,20 @@ toLines xs = "---" :: concatMap toLines1 xs <+> ["..."]
|
|||
|
||||
public export interface ToInfo e where toInfo : e -> Info
|
||||
|
||||
export %inline ToInfo () where toInfo () = []
|
||||
export ToInfo () where toInfo () = []
|
||||
|
||||
export %inline Show a => ToInfo (List (String, a)) where toInfo = map (map show)
|
||||
export Show a => ToInfo (List (String, a)) where toInfo = map (map show)
|
||||
|
||||
|
||||
export
|
||||
data Test = One TestBase | Group String (List Test)
|
||||
|
||||
|
||||
private %inline
|
||||
success : ToInfo a => a -> IO Result
|
||||
success = pure . Tried True . toInfo
|
||||
private
|
||||
result : ToInfo a => Bool -> a -> IO Result
|
||||
result ok = pure . Tried ok . toInfo
|
||||
|
||||
private %inline
|
||||
failure : ToInfo e => e -> IO Result
|
||||
failure = pure . Tried False . toInfo
|
||||
|
||||
private %inline
|
||||
private
|
||||
lazyToIO : Lazy a -> IO a
|
||||
lazyToIO val = primIO $ \w => MkIORes (force val) w
|
||||
|
||||
|
|
@ -64,32 +66,31 @@ export
|
|||
testIO : (ToInfo e, ToInfo a) => String -> EitherT e IO a -> Test
|
||||
testIO label act = One $ MakeTest label $ do
|
||||
case !(runEitherT act) of
|
||||
Right val => success val
|
||||
Left err => failure err
|
||||
Right val => result True val
|
||||
Left err => result False err
|
||||
|
||||
export %inline
|
||||
export
|
||||
test : (ToInfo e, ToInfo a) => String -> Lazy (Either e a) -> Test
|
||||
test label val =
|
||||
testIO label $ MkEitherT $ lazyToIO val
|
||||
test label val = testIO label $ MkEitherT $ lazyToIO val
|
||||
|
||||
export %inline
|
||||
export
|
||||
todoWith : String -> String -> Test
|
||||
todoWith label reason = One $ MakeTest label $ pure $ Todo reason
|
||||
|
||||
export %inline
|
||||
export
|
||||
todo : String -> Test
|
||||
todo label = todoWith label ""
|
||||
|
||||
private %inline
|
||||
private
|
||||
makeSkip : String -> String -> Test
|
||||
makeSkip label reason = One $ MakeTest label $ pure $ Skip reason
|
||||
|
||||
export %inline
|
||||
export
|
||||
skipWith : Test -> String -> Test
|
||||
skipWith (One t) reason = makeSkip t.label reason
|
||||
skipWith (Group l _) reason = makeSkip l reason
|
||||
|
||||
export %inline
|
||||
export
|
||||
skip : Test -> Test
|
||||
skip test = skipWith test ""
|
||||
|
||||
|
|
@ -98,15 +99,15 @@ testThrows : (ToInfo e, Show a) =>
|
|||
String -> (e -> Bool) -> Lazy (Either e a) -> Test
|
||||
testThrows label p act = One $ MakeTest label $ do
|
||||
case !(lazyToIO act) of
|
||||
Left err => if p err then success () else failure err
|
||||
Right val => failure [("success", val)]
|
||||
Left err => if p err then result True () else result False err
|
||||
Right val => result False [("success", val)]
|
||||
|
||||
infix 1 :-
|
||||
export %inline
|
||||
export
|
||||
(:-) : String -> List Test -> Test
|
||||
(:-) = Group
|
||||
|
||||
export %inline
|
||||
export
|
||||
bailOut : Test
|
||||
bailOut = One $ MakeTest "bail out" $ do
|
||||
putStrLn "Bail out!"
|
||||
|
|
@ -114,7 +115,7 @@ bailOut = One $ MakeTest "bail out" $ do
|
|||
|
||||
|
||||
|
||||
export %inline
|
||||
export
|
||||
header : List a -> String
|
||||
header tests = "1..\{show $ length tests}"
|
||||
|
||||
|
|
@ -123,42 +124,50 @@ makePrefix : SnocList String -> String
|
|||
makePrefix [<] = ""
|
||||
makePrefix (xs :< x) = foldr (\a, b => "\{a}/\{b}") x xs
|
||||
|
||||
private %inline
|
||||
private
|
||||
withPrefix : SnocList String -> TestBase -> Test
|
||||
withPrefix pfx b = One $ {label := "[\{makePrefix pfx}] \{b.label}"} b
|
||||
|
||||
mutual
|
||||
export %inline
|
||||
export
|
||||
flattenWith : SnocList String -> List Test -> List Test
|
||||
flattenWith pfx = concatMap (flatten1With pfx)
|
||||
flattenWith pfx tests =
|
||||
concatMap (\t => flatten1With pfx (assert_smaller tests t)) tests
|
||||
|
||||
export
|
||||
flatten1With : SnocList String -> Test -> List Test
|
||||
flatten1With pfx (One t) = [withPrefix pfx t]
|
||||
flatten1With pfx (Group x ts) = flattenWith (pfx :< x) ts
|
||||
|
||||
export %inline
|
||||
export
|
||||
flatten : List Test -> List Test
|
||||
flatten = flattenWith [<]
|
||||
|
||||
export %inline
|
||||
export
|
||||
flatten1 : Test -> List Test
|
||||
flatten1 = flatten1With [<]
|
||||
|
||||
|
||||
private
|
||||
record RunnerEnv where
|
||||
constructor RE
|
||||
indent : Nat
|
||||
color : Bool
|
||||
|
||||
|
||||
private
|
||||
Runner : Type -> Type
|
||||
Runner = ReaderT Nat IO
|
||||
Runner = ReaderT RunnerEnv IO
|
||||
|
||||
private %inline
|
||||
private
|
||||
putIndentLines : List String -> Runner ()
|
||||
putIndentLines xs = traverse_ (putStrLn . indent !ask) xs
|
||||
putIndentLines xs = traverse_ (putStrLn . indent (!ask).indent) xs
|
||||
|
||||
private %inline
|
||||
private
|
||||
isOk : Bool -> String
|
||||
isOk b = if b then "ok" else "not ok"
|
||||
|
||||
private %inline
|
||||
private
|
||||
toBool : Result -> Bool
|
||||
toBool (Tried ok _) = ok
|
||||
toBool _ = True
|
||||
|
|
@ -171,18 +180,45 @@ numbered = go 1 where
|
|||
go _ [] = []
|
||||
go i (x :: xs) = (i, x) :: go (S i) xs
|
||||
|
||||
|
||||
private
|
||||
col : Color -> String -> Runner String
|
||||
col c str = pure $ if (!ask).color then show $ colored c str else str
|
||||
|
||||
private
|
||||
putColor : Color -> String -> Runner ()
|
||||
putColor c str = putIndentLines [!(col c str)]
|
||||
|
||||
private
|
||||
okCol : Bool -> Color
|
||||
okCol True = Green
|
||||
okCol False = Red
|
||||
|
||||
private
|
||||
putOk' : Color -> Bool -> Nat -> String -> Runner ()
|
||||
putOk' c ok index label =
|
||||
putIndentLines [!(col c "\{isOk ok} \{show index}") ++ " - \{label}"]
|
||||
|
||||
private
|
||||
putOk : Bool -> Nat -> String -> Runner ()
|
||||
putOk ok = putOk' (okCol ok) ok
|
||||
|
||||
private
|
||||
putVersion : TAPVersion -> Runner ()
|
||||
putVersion ver = putColor Cyan "TAP version \{show ver}"
|
||||
|
||||
private
|
||||
run1' : (Nat, TestBase) -> Runner Bool
|
||||
run1' (index, test) = do
|
||||
res <- liftIO test.run
|
||||
case res of
|
||||
Tried ok info => do
|
||||
putIndentLines ["\{isOk ok} \{show index} - \{test.label}"]
|
||||
local (plus 2) $ putIndentLines $ toLines info
|
||||
Skip reason => putIndentLines
|
||||
["ok \{show index} - \{test.label} # skip \{reason}"]
|
||||
Todo reason => putIndentLines
|
||||
["ok \{show index} - \{test.label} # todo \{reason}"]
|
||||
putOk ok index test.label
|
||||
local {indent $= plus 2} $ putIndentLines $ toLines info
|
||||
Skip reason =>
|
||||
putOk' Yellow True index "test.label # skip \{reason}"
|
||||
Todo reason =>
|
||||
putOk' Yellow True index "test.label # todo \{reason}"
|
||||
pure $ toBool res
|
||||
|
||||
mutual
|
||||
|
|
@ -190,30 +226,42 @@ mutual
|
|||
run' : (Nat, Test) -> Runner Bool
|
||||
run' (index, One test) = run1' (index, test)
|
||||
run' (index, Group label tests) = do
|
||||
putIndentLines ["# Subtest: \{label}"]
|
||||
res <- local (plus 4) $ runList tests
|
||||
putIndentLines ["\{isOk res} \{show index} - \{label}"]
|
||||
putColor Magenta "# Subtest: \{label}"
|
||||
res <- local {indent $= plus 4} $ runList tests
|
||||
putOk res index label
|
||||
pure res
|
||||
|
||||
private
|
||||
runList : List Test -> Runner Bool
|
||||
runList tests = do
|
||||
putIndentLines [header tests]
|
||||
all id <$> traverse run' (numbered tests)
|
||||
putColor Cyan $ header tests
|
||||
all id <$> traverse (\t => run' (assert_smaller tests t)) (numbered tests)
|
||||
|
||||
|
||||
mutual
|
||||
export
|
||||
filterMatch : Maybe String -> List Test -> List Test
|
||||
filterMatch Nothing tests = tests
|
||||
filterMatch (Just pat) tests =
|
||||
mapMaybe (\t => filterMatch1 pat (assert_smaller tests t)) tests
|
||||
|
||||
export
|
||||
filterMatch1 : String -> Test -> Maybe Test
|
||||
filterMatch1 pat test@(One base) =
|
||||
guard (pat `isInfixOf` base.label) $> test
|
||||
filterMatch1 pat all@(Group label tests) =
|
||||
if pat `isInfixOf` label then Just all else
|
||||
case filterMatch (Just pat) tests of
|
||||
[] => Nothing
|
||||
res => Just $ Group label res
|
||||
|
||||
|
||||
export
|
||||
run : (ver : Nat) -> List Test -> IO ExitCode
|
||||
run ver tests = do
|
||||
putStrLn "TAP version \{show ver}"
|
||||
pure $ if !(runReaderT 0 $ runList tests)
|
||||
main : Options -> List Test -> IO ExitCode
|
||||
main opts tests = do
|
||||
let tests = filterMatch opts.pattern $
|
||||
case opts.version of V13 => flatten tests; V14 => tests
|
||||
let act = do putVersion opts.version; runList tests
|
||||
pure $ if !(runReaderT (RE 0 opts.color) act)
|
||||
then ExitSuccess
|
||||
else ExitFailure 70
|
||||
|
||||
export
|
||||
main : List Test -> IO ()
|
||||
main tests = exitWith !(run 14 tests)
|
||||
|
||||
export
|
||||
mainFlat : List Test -> IO ()
|
||||
mainFlat tests = exitWith !(run 13 $ flatten tests)
|
||||
|
|
|
|||
|
|
@ -16,10 +16,4 @@ allTests = [
|
|||
Equal.tests
|
||||
]
|
||||
|
||||
main = do
|
||||
opts <- getTestOpts
|
||||
go <- case opts.tapVersion of
|
||||
"13" => pure TAP.mainFlat
|
||||
"14" => pure TAP.main
|
||||
_ => do putStrLn "unrecognised TAP version; use 13 or 14"; exitFailure
|
||||
go allTests
|
||||
main = TAP.main !getTestOpts allTests
|
||||
|
|
|
|||
Loading…
Reference in a new issue