From b4ac58f866d6acc824302e0f99fd89dd0cf9510f Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 26 May 2022 16:25:56 +0200 Subject: [PATCH] move TAP to its own package https://git.rhiannon.website/rhi/idris2-tap --- flake.lock | 31 ++++- flake.nix | 15 ++- tests/Options.idr | 113 ----------------- tests/TAP.idr | 289 ------------------------------------------ tests/Tests.idr | 1 - tests/quox-tests.ipkg | 2 +- 6 files changed, 44 insertions(+), 407 deletions(-) delete mode 100644 tests/Options.idr delete mode 100644 tests/TAP.idr diff --git a/flake.lock b/flake.lock index d2fb8af..27db544 100644 --- a/flake.lock +++ b/flake.lock @@ -502,7 +502,8 @@ "nixpkgs": [ "idris2-pkgs", "nixpkgs" - ] + ], + "tap": "tap" } }, "snocvect": { @@ -553,6 +554,34 @@ "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": { "flake": false, "locked": { diff --git a/flake.nix b/flake.nix index d5606f4..21cf707 100644 --- a/flake.nix +++ b/flake.nix @@ -4,9 +4,16 @@ flake-utils.url = "github:numtide/flake-utils"; idris2-pkgs.url = "github:claymager/idris2-pkgs"; 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; # [ x86_64-darwin x86_64-linux i686-linux ]; # FIXME [ x86_64-linux ]; @@ -19,10 +26,14 @@ }; builders = pkgs.idris2-pkgs._builders; + testDeps = tap.packages.${system}; + packages = rec { quox-lib = builders.idrisPackage ./lib { }; quox = builders.idrisPackage ./exe { extraPkgs = packages; }; - quox-tests = builders.idrisPackage ./tests { extraPkgs = packages; }; + quox-tests = builders.idrisPackage ./tests { + extraPkgs = packages // testDeps; + }; }; devShells = diff --git a/tests/Options.idr b/tests/Options.idr deleted file mode 100644 index 9744c00..0000000 --- a/tests/Options.idr +++ /dev/null @@ -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 diff --git a/tests/TAP.idr b/tests/TAP.idr deleted file mode 100644 index 5640e4c..0000000 --- a/tests/TAP.idr +++ /dev/null @@ -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 diff --git a/tests/Tests.idr b/tests/Tests.idr index 1313813..6d01899 100644 --- a/tests/Tests.idr +++ b/tests/Tests.idr @@ -1,6 +1,5 @@ module Tests -import Options import TAP import Tests.Unicode import Tests.Lexer diff --git a/tests/quox-tests.ipkg b/tests/quox-tests.ipkg index f00bdd9..b0af397 100644 --- a/tests/quox-tests.ipkg +++ b/tests/quox-tests.ipkg @@ -1,6 +1,6 @@ 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 main = Tests