move TAP to its own package
https://git.rhiannon.website/rhi/idris2-tap
This commit is contained in:
parent
4befbbeb42
commit
b4ac58f866
6 changed files with 44 additions and 407 deletions
31
flake.lock
31
flake.lock
|
|
@ -502,7 +502,8 @@
|
||||||
"nixpkgs": [
|
"nixpkgs": [
|
||||||
"idris2-pkgs",
|
"idris2-pkgs",
|
||||||
"nixpkgs"
|
"nixpkgs"
|
||||||
]
|
],
|
||||||
|
"tap": "tap"
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
"snocvect": {
|
"snocvect": {
|
||||||
|
|
@ -553,6 +554,34 @@
|
||||||
"type": "github"
|
"type": "github"
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
|
"tap": {
|
||||||
|
"inputs": {
|
||||||
|
"flake-utils": [
|
||||||
|
"flake-utils"
|
||||||
|
],
|
||||||
|
"idris2-pkgs": [
|
||||||
|
"idris2-pkgs"
|
||||||
|
],
|
||||||
|
"nixpkgs": [
|
||||||
|
"idris2-pkgs",
|
||||||
|
"nixpkgs"
|
||||||
|
]
|
||||||
|
},
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1653572671,
|
||||||
|
"narHash": "sha256-ev1z+LW5f6AAWegLQjGpsH6qGccJ5kelzTx4pQddT7k=",
|
||||||
|
"ref": "main",
|
||||||
|
"rev": "4c0ab9ca9b669869b341851f3fd2fa591d5aa4b2",
|
||||||
|
"revCount": 4,
|
||||||
|
"type": "git",
|
||||||
|
"url": "https://git.rhiannon.website/rhi/idris2-tap"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"ref": "main",
|
||||||
|
"type": "git",
|
||||||
|
"url": "https://git.rhiannon.website/rhi/idris2-tap"
|
||||||
|
}
|
||||||
|
},
|
||||||
"xml": {
|
"xml": {
|
||||||
"flake": false,
|
"flake": false,
|
||||||
"locked": {
|
"locked": {
|
||||||
|
|
|
||||||
15
flake.nix
15
flake.nix
|
|
@ -4,9 +4,16 @@
|
||||||
flake-utils.url = "github:numtide/flake-utils";
|
flake-utils.url = "github:numtide/flake-utils";
|
||||||
idris2-pkgs.url = "github:claymager/idris2-pkgs";
|
idris2-pkgs.url = "github:claymager/idris2-pkgs";
|
||||||
nixpkgs.follows = "idris2-pkgs/nixpkgs";
|
nixpkgs.follows = "idris2-pkgs/nixpkgs";
|
||||||
|
|
||||||
|
tap.url = "git+https://git.rhiannon.website/rhi/idris2-tap?ref=main";
|
||||||
|
tap.inputs = {
|
||||||
|
flake-utils.follows = "flake-utils";
|
||||||
|
idris2-pkgs.follows = "idris2-pkgs";
|
||||||
|
nixpkgs.follows = "idris2-pkgs/nixpkgs";
|
||||||
|
};
|
||||||
};
|
};
|
||||||
|
|
||||||
outputs = { self, nixpkgs, idris2-pkgs, flake-utils }:
|
outputs = { self, nixpkgs, idris2-pkgs, flake-utils, tap }:
|
||||||
let systems = with flake-utils.lib.system;
|
let systems = with flake-utils.lib.system;
|
||||||
# [ x86_64-darwin x86_64-linux i686-linux ]; # FIXME
|
# [ x86_64-darwin x86_64-linux i686-linux ]; # FIXME
|
||||||
[ x86_64-linux ];
|
[ x86_64-linux ];
|
||||||
|
|
@ -19,10 +26,14 @@
|
||||||
};
|
};
|
||||||
builders = pkgs.idris2-pkgs._builders;
|
builders = pkgs.idris2-pkgs._builders;
|
||||||
|
|
||||||
|
testDeps = tap.packages.${system};
|
||||||
|
|
||||||
packages = rec {
|
packages = rec {
|
||||||
quox-lib = builders.idrisPackage ./lib { };
|
quox-lib = builders.idrisPackage ./lib { };
|
||||||
quox = builders.idrisPackage ./exe { extraPkgs = packages; };
|
quox = builders.idrisPackage ./exe { extraPkgs = packages; };
|
||||||
quox-tests = builders.idrisPackage ./tests { extraPkgs = packages; };
|
quox-tests = builders.idrisPackage ./tests {
|
||||||
|
extraPkgs = packages // testDeps;
|
||||||
|
};
|
||||||
};
|
};
|
||||||
|
|
||||||
devShells =
|
devShells =
|
||||||
|
|
|
||||||
|
|
@ -1,113 +0,0 @@
|
||||||
module 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
|
|
||||||
289
tests/TAP.idr
289
tests/TAP.idr
|
|
@ -1,289 +0,0 @@
|
||||||
module TAP
|
|
||||||
-- [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)
|
|
||||||
|
|
||||||
private
|
|
||||||
data Result = Tried Bool Info | Skip String | Todo String
|
|
||||||
|
|
||||||
private
|
|
||||||
record TestBase where
|
|
||||||
constructor MakeTest
|
|
||||||
label : String
|
|
||||||
run : IO Result
|
|
||||||
|
|
||||||
|
|
||||||
private
|
|
||||||
toLines1 : (String, String) -> List String
|
|
||||||
toLines1 (k, v) =
|
|
||||||
let vs = lines v in
|
|
||||||
if length vs == 1
|
|
||||||
then ["\{k}: \{v}"]
|
|
||||||
else "\{k}: |" :: map (indent 2) vs
|
|
||||||
|
|
||||||
private
|
|
||||||
toLines : Info -> List String
|
|
||||||
toLines [] = []
|
|
||||||
toLines xs = "---" :: concatMap toLines1 xs <+> ["..."]
|
|
||||||
|
|
||||||
|
|
||||||
public export interface ToInfo e where toInfo : e -> Info
|
|
||||||
|
|
||||||
export ToInfo () where toInfo () = []
|
|
||||||
|
|
||||||
export Show a => ToInfo (List (String, a)) where toInfo = map (map show)
|
|
||||||
|
|
||||||
|
|
||||||
export
|
|
||||||
data Test
|
|
||||||
= One TestBase
|
|
||||||
| Group String (List Test)
|
|
||||||
| Note String
|
|
||||||
|
|
||||||
|
|
||||||
export
|
|
||||||
isRealTest : Test -> Bool
|
|
||||||
isRealTest (One _) = True
|
|
||||||
isRealTest (Group _ _) = True
|
|
||||||
isRealTest (Note _) = False
|
|
||||||
|
|
||||||
|
|
||||||
private
|
|
||||||
result : ToInfo a => Bool -> a -> IO Result
|
|
||||||
result ok = pure . Tried ok . toInfo
|
|
||||||
|
|
||||||
private
|
|
||||||
lazyToIO : Lazy a -> IO a
|
|
||||||
lazyToIO val = primIO $ \w => MkIORes (force val) w
|
|
||||||
|
|
||||||
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 => result True val
|
|
||||||
Left err => result False err
|
|
||||||
|
|
||||||
export
|
|
||||||
test : (ToInfo e, ToInfo a) => String -> Lazy (Either e a) -> Test
|
|
||||||
test label val = testIO label $ MkEitherT $ lazyToIO val
|
|
||||||
|
|
||||||
export
|
|
||||||
todoWith : String -> String -> Test
|
|
||||||
todoWith label reason = One $ MakeTest label $ pure $ Todo reason
|
|
||||||
|
|
||||||
export
|
|
||||||
todo : String -> Test
|
|
||||||
todo label = todoWith label ""
|
|
||||||
|
|
||||||
private
|
|
||||||
makeSkip : String -> String -> Test
|
|
||||||
makeSkip label reason = One $ MakeTest label $ pure $ Skip reason
|
|
||||||
|
|
||||||
export
|
|
||||||
skipWith : Test -> String -> Test
|
|
||||||
skipWith (One t) reason = makeSkip t.label reason
|
|
||||||
skipWith (Group l _) reason = makeSkip l reason
|
|
||||||
skipWith (Note n) _ = Note n
|
|
||||||
|
|
||||||
export
|
|
||||||
skip : Test -> Test
|
|
||||||
skip test = skipWith test ""
|
|
||||||
|
|
||||||
export
|
|
||||||
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 result True () else result False err
|
|
||||||
Right val => result False [("success", val)]
|
|
||||||
|
|
||||||
infix 1 :-
|
|
||||||
export
|
|
||||||
(:-) : String -> List Test -> Test
|
|
||||||
(:-) = Group
|
|
||||||
|
|
||||||
export
|
|
||||||
bailOut : Test
|
|
||||||
bailOut = One $ MakeTest "bail out" $ do
|
|
||||||
putStrLn "Bail out!"
|
|
||||||
exitFailure
|
|
||||||
|
|
||||||
export
|
|
||||||
note : String -> Test
|
|
||||||
note = Note
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
export
|
|
||||||
header : List Test -> String
|
|
||||||
header tests =
|
|
||||||
let count = length $ filter isRealTest tests in
|
|
||||||
"1..\{show count}"
|
|
||||||
|
|
||||||
|
|
||||||
private
|
|
||||||
withPrefix : SnocList String -> TestBase -> Test
|
|
||||||
withPrefix pfx = One . {label $= (makePrefix pfx ++)}
|
|
||||||
where makePrefix = concatMap $ \s => "\{s} ⟫ "
|
|
||||||
|
|
||||||
mutual
|
|
||||||
export
|
|
||||||
flattenWith : SnocList String -> List Test -> List Test
|
|
||||||
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
|
|
||||||
flatten1With pfx (Note n) = [Note n]
|
|
||||||
|
|
||||||
export
|
|
||||||
flatten : List Test -> List Test
|
|
||||||
flatten = flattenWith [<]
|
|
||||||
|
|
||||||
export
|
|
||||||
flatten1 : Test -> List Test
|
|
||||||
flatten1 = flatten1With [<]
|
|
||||||
|
|
||||||
|
|
||||||
private
|
|
||||||
record RunnerEnv where
|
|
||||||
constructor RE
|
|
||||||
indent : Nat
|
|
||||||
color : Bool
|
|
||||||
|
|
||||||
|
|
||||||
private
|
|
||||||
Runner : Type -> Type
|
|
||||||
Runner = ReaderT RunnerEnv IO
|
|
||||||
|
|
||||||
private
|
|
||||||
putIndentLines : List String -> Runner ()
|
|
||||||
putIndentLines xs = traverse_ (putStrLn . indent (!ask).indent) xs
|
|
||||||
|
|
||||||
private
|
|
||||||
isOk : Bool -> String
|
|
||||||
isOk b = if b then "ok" else "not ok"
|
|
||||||
|
|
||||||
private
|
|
||||||
toBool : Result -> Bool
|
|
||||||
toBool (Tried ok _) = ok
|
|
||||||
toBool _ = True
|
|
||||||
|
|
||||||
|
|
||||||
private
|
|
||||||
numbered : (a -> Bool) -> List a -> List (Nat, a)
|
|
||||||
numbered p = go 1 where
|
|
||||||
go : Nat -> List a -> List (Nat, a)
|
|
||||||
go _ [] = []
|
|
||||||
go i (x :: xs) =
|
|
||||||
if p x then (i, x) :: go (S i) xs
|
|
||||||
else (0, x) :: go 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
|
|
||||||
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
|
|
||||||
private
|
|
||||||
run' : (Nat, Test) -> Runner Bool
|
|
||||||
run' (index, One test) = run1' (index, test)
|
|
||||||
run' (index, Group label tests) = do
|
|
||||||
putIndentLines [!(col Magenta "# Subtest: ") ++ label]
|
|
||||||
res <- local {indent $= plus 4} $ runList tests
|
|
||||||
putOk res index label
|
|
||||||
pure res
|
|
||||||
run' (_, Note note) = do
|
|
||||||
putIndentLines [!(col Magenta "# ") ++ note]
|
|
||||||
pure True
|
|
||||||
|
|
||||||
private
|
|
||||||
runList : List Test -> Runner Bool
|
|
||||||
runList tests = do
|
|
||||||
putColor Cyan $ header tests
|
|
||||||
let tests' = numbered isRealTest tests
|
|
||||||
all id <$> traverse (\t => run' (assert_smaller tests t)) 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
|
|
||||||
filterMatch1 pat note@(Note _) = Just note
|
|
||||||
|
|
||||||
|
|
||||||
export
|
|
||||||
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
|
|
||||||
|
|
@ -1,6 +1,5 @@
|
||||||
module Tests
|
module Tests
|
||||||
|
|
||||||
import Options
|
|
||||||
import TAP
|
import TAP
|
||||||
import Tests.Unicode
|
import Tests.Unicode
|
||||||
import Tests.Lexer
|
import Tests.Lexer
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
package quox-tests
|
package quox-tests
|
||||||
|
|
||||||
depends = base, contrib, elab-util, sop, snocvect, quox-lib
|
depends = base, contrib, elab-util, sop, snocvect, quox-lib, tap
|
||||||
|
|
||||||
executable = quox-tests
|
executable = quox-tests
|
||||||
main = Tests
|
main = Tests
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue