module TAP -- [todo] extract this and Quox.Error to their own packages import public Control.Monad.Either import Data.String import Data.List.Elem import Data.SnocList import Control.Monad.Reader import Control.Monad.State import System 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 %inline ToInfo () where toInfo () = [] export %inline Show a => ToInfo (List (String, a)) where toInfo = map (map show) export data Test = One TestBase | Group String (List Test) 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 : (ToInfo e, ToInfo a) => String -> EitherT e IO a -> Test testIO label act = One $ MakeTest label $ do case !(runEitherT act) of Right val => success val Left err => failure err export %inline test : (ToInfo e, ToInfo a) => String -> Lazy (Either e a) -> Test test label val = testIO label $ MkEitherT $ lazyToIO 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 "" private %inline makeSkip : String -> String -> Test makeSkip label reason = One $ MakeTest label $ pure $ Skip reason export %inline skipWith : Test -> String -> Test skipWith (One t) reason = makeSkip t.label reason skipWith (Group l _) reason = makeSkip l reason export %inline 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 success () else failure err Right val => failure [("success", val)] infix 1 :- export %inline (:-) : String -> List Test -> Test (:-) = Group export %inline bailOut : Test bailOut = One $ MakeTest "bail out" $ do putStrLn "Bail out!" exitFailure export %inline header : List a -> String header tests = "1..\{show $ length tests}" private makePrefix : SnocList String -> String makePrefix [<] = "" makePrefix (xs :< x) = foldr (\a, b => "\{a}/\{b}") x xs private %inline withPrefix : SnocList String -> TestBase -> Test withPrefix pfx b = One $ {label := "[\{makePrefix pfx}] \{b.label}"} b mutual export %inline 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 %inline flatten : List Test -> List Test flatten = flattenWith [<] export %inline flatten1 : Test -> List Test flatten1 = flatten1With [<] private Runner : Type -> Type Runner = ReaderT Nat IO private %inline putIndentLines : List String -> Runner () putIndentLines xs = traverse_ (putStrLn . indent !ask) xs private %inline isOk : Bool -> String isOk b = if b then "ok" else "not ok" 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 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}"] 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)