From b0692c15b9e44f1adee21141f2182e230ccdb8ea Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Tue, 24 May 2022 12:09:17 +0200 Subject: [PATCH] fancier tests --- Makefile | 2 +- tests/Options.idr | 111 ++++++++++++++++++++++++------ tests/TAP.idr | 168 +++++++++++++++++++++++++++++----------------- tests/Tests.idr | 8 +-- 4 files changed, 200 insertions(+), 89 deletions(-) diff --git a/Makefile b/Makefile index f5135dd..f4aa5c5 100644 --- a/Makefile +++ b/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: diff --git a/tests/Options.idr b/tests/Options.idr index 969d6bf..9744c00 100644 --- a/tests/Options.idr +++ b/tests/Options.idr @@ -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 diff --git a/tests/TAP.idr b/tests/TAP.idr index d4b06bf..647f229 100644 --- a/tests/TAP.idr +++ b/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,45 +124,53 @@ 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 +toBool _ = True private @@ -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) diff --git a/tests/Tests.idr b/tests/Tests.idr index 2053dbd..f89ba9a 100644 --- a/tests/Tests.idr +++ b/tests/Tests.idr @@ -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