quox/tests/src/TAP.idr

221 lines
5.1 KiB
Idris
Raw Normal View History

module TAP
import public Quox.Error
import Data.String
import Data.List.Elem
import Control.Monad.Reader
import Control.Monad.State
import System
2022-04-27 09:07:32 -04:00
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
2022-04-27 08:57:41 -04:00
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 [] = []
2022-04-27 08:57:41 -04:00
toLines xs = "---" :: concatMap toLines1 xs <+> ["..."]
public export interface ToInfo e where toInfo : e -> Info
export
All ToInfo es => ToInfo (OneOf es) where
toInfo (One Here value) = toInfo value
toInfo (One (There x) value) = toInfo (One x value)
2022-04-27 09:07:32 -04:00
export %inline ToInfo () where toInfo () = []
2022-04-27 14:06:39 -04:00
export Show a => ToInfo (List (String, a)) where toInfo = map (map show)
export
data Test = One TestBase | Group String (List Test)
2022-04-27 14:06:39 -04:00
private %inline
success : ToInfo a => a -> IO Result
success = pure . Tried True . toInfo
private %inline
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
export
testIO : (All ToInfo es, ToInfo a) => String -> ErrorT es IO a -> Test
testIO label act = One $ MakeTest label $ do
case !(runErrorT act) of
2022-04-27 14:06:39 -04:00
Right val => success val
Left err => failure err
export %inline
test : (All ToInfo es, ToInfo a) => String -> Lazy (Error es a) -> Test
test label val =
2022-04-27 14:06:39 -04:00
testIO label $ MkErrorT $ lazyToIO $ runError val
export %inline
todoWith : String -> String -> Test
todoWith label reason = One $ MakeTest label $ pure $ Todo reason
export %inline
todo : String -> Test
todo label = todoWith label ""
2022-05-01 20:27:03 -04:00
private %inline
makeSkip : String -> String -> Test
makeSkip label reason = One $ MakeTest label $ pure $ Skip reason
export %inline
2022-05-01 20:27:03 -04:00
skipWith : Test -> String -> Test
skipWith (One t) reason = makeSkip t.label reason
skipWith (Group l _) reason = makeSkip l reason
export %inline
2022-05-01 20:27:03 -04:00
skip : Test -> Test
skip test = skipWith test ""
2022-04-27 14:06:39 -04:00
export
testThrows : Show a => String -> Lazy (Error es a) -> Test
testThrows label act = One $ MakeTest label $ do
case runError !(lazyToIO act) of
Left err => success ()
Right val => failure [("success", val)]
infix 0 :-
export %inline
(:-) : String -> List Test -> Test
(:-) = Group
2022-04-27 14:06:39 -04:00
export %inline
bailOut : Test
bailOut = One $ MakeTest "bail out" $ do
putStrLn "Bail out!"
exitFailure
2022-04-27 09:07:32 -04:00
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
Runner = ReaderT Nat IO
2022-04-27 09:07:32 -04:00
private %inline
putIndentLines : List String -> Runner ()
putIndentLines xs = traverse_ (putStrLn . indent !ask) xs
2022-04-27 09:07:32 -04:00
private %inline
isOk : Bool -> String
isOk b = if b then "ok" else "not ok"
2022-04-27 09:07:32 -04:00
private %inline
toBool : Result -> Bool
toBool (Tried ok _) = ok
toBool _ = True
private
numbered : List a -> List (Nat, a)
numbered = go 1 where
go : Nat -> List a -> List (Nat, a)
go _ [] = []
go i (x :: xs) = (i, x) :: go (S i) xs
private
run1' : (Nat, TestBase) -> Runner Bool
run1' (index, test) = do
res <- liftIO test.run
case res of
2022-04-27 09:03:29 -04:00
Tried ok info => do
putIndentLines ["\{isOk ok} \{show index} - \{test.label}"]
local (plus 2) $ putIndentLines $ toLines info
Skip reason => putIndentLines
["ok \{show index} - \{test.label} # skip \{reason}"]
2022-04-27 09:03:29 -04:00
Todo reason => putIndentLines
["ok \{show 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 ["# Subtest: \{label}"]
res <- local (plus 4) $ runList tests
putIndentLines ["\{isOk res} \{show index} - \{label}"]
pure res
private
runList : List Test -> Runner Bool
runList tests = do
putIndentLines [header tests]
all id <$> traverse run' (numbered tests)
export
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)