first

TAP/Options.idr

@@ -0,0 +1,113 @@
+module TAP.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