quox/tests/TAP.idr

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 0 :-
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)