fancier tests

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:

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
+public export
+Mod : Type
+Mod = Options -> IO Options
 
-opts : List (OptDescr OptMod)
+
-opts = [
+export
-  MkOpt ['V'] ["version"]
+failureWith : List String -> IO a
-    (ReqArg (\v => the OptMod {tapVersion := v}) "VERSION")
+failureWith msgs = do
-    "TAP version to output (13 or 14, default 13)"
+  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}
+      }
     ]
--- [todo] get rid of "the OptMod" when type inference is better, maybe
 
-makeOpts : List OptMod -> Options
+  export
-makeOpts = foldl (flip ($)) defaultOpts
+  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
+       []        => failureWith ["expected getArgs to start with exe name"]
-         putStrLn "expecting getArgs to start with exe name"
-         exitFailure
 
 export
 getTestOpts : IO Options
 getTestOpts =
   case getOpt Permute opts !getArgs1 of
-       MkResult opts [] [] [] => pure $ makeOpts opts
+       MkResult opts [] [] [] => makeOpts opts
-       res => do
+       res                    => failureWith $ res.errors ++ usage
-         traverse_ putStrLn $ res.errors ++ [usageInfo "quox test suite" opts]
-         exitFailure

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
+private
-success : ToInfo a => a -> IO Result
+result : ToInfo a => Bool -> a -> IO Result
-success = pure . Tried True . toInfo
+result ok = pure . Tried ok . toInfo
 
-private %inline
+private
-failure : ToInfo e => e -> IO Result
-failure = pure . Tried False . toInfo
-
-private %inline
 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
+       Right val => result True  val
-       Left  err => failure err
+       Left  err => result False err
 
-export %inline
+export
 test : (ToInfo e, ToInfo a) => String -> Lazy (Either e a) -> Test
-test label val =
+test label val = testIO label $ MkEitherT $ lazyToIO 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
+       Left  err => if p err then result True () else result False err
-       Right val => failure [("success", val)]
+       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}"]
+         putOk ok index test.label
-         local (plus 2) $ putIndentLines $ toLines info
+         local {indent $= plus 2} $ putIndentLines $ toLines info
-       Skip reason => putIndentLines
+       Skip reason =>
-         ["ok \{show index} - \{test.label}  # skip \{reason}"]
+         putOk' Yellow True index "test.label  # skip \{reason}"
-       Todo reason => putIndentLines
+       Todo reason =>
-         ["ok \{show index} - \{test.label}  # 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}"]
+    putColor Magenta "# Subtest: \{label}"
-    res <- local (plus 4) $ runList tests
+    res <- local {indent $= plus 4} $ runList tests
-    putIndentLines ["\{isOk res} \{show index} - \{label}"]
+    putOk res index label
     pure res
 
   private
   runList : List Test -> Runner Bool
   runList tests = do
-    putIndentLines [header tests]
+    putColor Cyan $ header tests
-    all id <$> traverse run' (numbered 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
+main : Options -> List Test -> IO ExitCode
-run ver tests = do
+main opts tests = do
-  putStrLn "TAP version \{show ver}"
+  let tests = filterMatch opts.pattern $
-  pure $ if !(runReaderT 0 $ runList tests)
+              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)

tests/Tests.idr

@@ -16,10 +16,4 @@ allTests = [
   Equal.tests
 ]
 
-main = do
+main = TAP.main !getTestOpts allTests
-  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