From e3384d4e6ea1be1a792db2531e744ef538821389 Mon Sep 17 00:00:00 2001
From: rhiannon morris <rhi@rhiannon.website>
Date: Mon, 2 May 2022 00:19:09 +0200
Subject: [PATCH] support TAP 13 for /usr/bin/prove's benefit

13 doesn't support test trees so we gotta flatten it >:(
---
 tests/Makefile    | 14 +++++++++++---
 tests/Options.idr | 40 ++++++++++++++++++++++++++++++++++++++++
 tests/TAP.idr     | 39 ++++++++++++++++++++++++++++++++++++---
 tests/Tests.idr   | 19 +++++++++++++------
 4 files changed, 100 insertions(+), 12 deletions(-)
 create mode 100644 tests/Options.idr

diff --git a/tests/Makefile b/tests/Makefile
index c0de71e..c757352 100644
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -8,10 +8,18 @@ depends/quox: lib
 	mkdir -p depends
 	ln -sf ../../build/ttc depends/quox
 
-.PHONY: test
-test: depends/quox
+.PHONY: build-tests
+build-tests: depends/quox
 	idris2 --build tests.ipkg
-	build/exec/quox-tests
+
+.PHONY: test
+test: build-tests
+	build/exec/quox-tests -V 14
+
+.PHONY: prove
+prove: build-tests
+	prove build/exec/quox-tests
+
 
 .PHONY: clean
 clean:
diff --git a/tests/Options.idr b/tests/Options.idr
new file mode 100644
index 0000000..5336560
--- /dev/null
+++ b/tests/Options.idr
@@ -0,0 +1,40 @@
+module Options
+
+import Data.String
+import System
+import System.Console.GetOpt
+
+
+public export
+record Options where
+  constructor Opts
+  tapVersion : String
+
+defaultOpts = Opts {tapVersion = "13"}
+
+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
+
+
+getArgs1 : IO (List String)
+getArgs1 =
+  case !getArgs of
+       _ :: args => pure args
+       []        => die "expecting getArgs to start with exe name"
+
+export
+getTestOpts : IO Options
+getTestOpts =
+  case getOpt Permute opts !getArgs1 of
+       MkResult opts [] [] [] => pure $ makeOpts opts
+       res => die $ unlines $ res.errors ++ [usageInfo "quox test suite" opts]
diff --git a/tests/TAP.idr b/tests/TAP.idr
index 17acddf..5316ce2 100644
--- a/tests/TAP.idr
+++ b/tests/TAP.idr
@@ -116,6 +116,31 @@ export %inline
 header : List a -> String
 header tests = "1..\{show $ length tests}"
 
+makePrefix : SnocList String -> String
+makePrefix [<]       = ""
+makePrefix (xs :< x) = foldr (\a, b => "\{a}/\{b}") x xs
+
+withPrefix : SnocList String -> TestBase -> Test
+withPrefix pfx b = One $ {label := "[\{makePrefix pfx}] \{b.label}"} b
+
+mutual
+  export
+  flattenWith : SnocList String -> List Test -> List Test
+  flattenWith pfx = concatMap (flatten1With pfx)
+
+  export
+  flatten1With : SnocList String -> Test -> List Test
+  flatten1With pfx (One   t)    = [withPrefix pfx t]
+  flatten1With pfx (Group x ts) = flattenWith (pfx :< x) ts
+
+export
+flatten : List Test -> List Test
+flatten = flattenWith [<]
+
+export
+flatten1 : Test -> List Test
+flatten1 = flatten1With [<]
+
 
 private
 Runner : Type -> Type
@@ -174,9 +199,17 @@ mutual
 
 
 export
-run : List Test -> IO ExitCode
-run tests = do
-  putStrLn "TAP version 14"
+run : (ver : Nat) -> List Test -> IO ExitCode
+run ver tests = do
+  putStrLn "TAP version \{show ver}"
   pure $ if !(runReaderT 0 $ runList tests)
             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 393c11a..783968a 100644
--- a/tests/Tests.idr
+++ b/tests/Tests.idr
@@ -1,11 +1,18 @@
 module Tests
 
-import Tests.Equal
-
+import Options
 import TAP
-
+import Tests.Lexer
+import Tests.Equal
 import System
 
-export main : IO Int
-main = exitWith =<< run
-  [Equal.tests]
+
+allTests = [Equal.tests]
+
+main = do
+  opts <- getTestOpts
+  go <- case opts.tapVersion of
+    "13" => pure TAP.mainFlat
+    "14" => pure TAP.main
+    _    => die "unrecognised TAP version; use 13 or 14"
+  go allTests