{-|
Module      : TLT
Description : Calling TLT tests from Tasty
Copyright   : (c) John Maraist, 2022
License     : GPL3
Maintainer  : haskell-tlt@maraist.org
Stability   : experimental
Portability : POSIX

This module allows TLT tests to be named and called from within Tasty.

TLT is a small unit test system oriented towards examining
intermediate results of computations in monad transformers.  It is
intended to be lightweight for the programmer, and does not require
tests to be specified in some sort of formal list of tests.  Rather,
tests are simply commands in a monad stack which includes the
transformer layer @Test.TLT@.

-}

{-# LANGUAGE FlexibleInstances #-}

module Test.Tasty.TLT (tltTest) where

import Control.Monad.IO.Class
import Data.Typeable
import Data.Tagged
import Test.TLT.Results (formatFail, totalFailCount)
import Test.TLT.Class
import qualified Test.Tasty.Providers as TTP

-- * TLT integration

class MonadIO m => TastyTLT m where runOuter :: m a -> IO a
instance TastyTLT IO where runOuter :: IO a -> IO a
runOuter = IO a -> IO a
forall a. a -> a
id

instance (Typeable m, TastyTLT m) => TTP.IsTest (TLT m ()) where
  -- options :: Test.Tasty.Options.OptionSet, https://tinyurl.com/y5x2nenr
  run :: OptionSet -> TLT m () -> (Progress -> IO ()) -> IO Result
run OptionSet
options TLT m ()
tlt Progress -> IO ()
_ = do
    (TLTopts
optsOut, [TestResult]
results) <- m (TLTopts, [TestResult]) -> IO (TLTopts, [TestResult])
forall (m :: * -> *) a. TastyTLT m => m a -> IO a
runOuter (m (TLTopts, [TestResult]) -> IO (TLTopts, [TestResult]))
-> m (TLTopts, [TestResult]) -> IO (TLTopts, [TestResult])
forall a b. (a -> b) -> a -> b
$ TLT m () -> m (TLTopts, [TestResult])
forall (m :: * -> *) r.
Monad m =>
TLT m r -> m (TLTopts, [TestResult])
runTLT TLT m ()
tlt
    Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ case [TestResult] -> Int
totalFailCount [TestResult]
results of
      Int
0 -> String -> Result
TTP.testPassed String
""
      Int
_ -> String -> Result
TTP.testFailed
             (Int -> String
forall a. Show a => a -> String
show ([TestResult] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestResult]
results) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" errors found in TLT invocation")

  testOptions :: Tagged (TLT m ()) [OptionDescription]
testOptions = [OptionDescription] -> Tagged (TLT m ()) [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return []

tltTest :: String -> TLT IO () -> TTP.TestTree
tltTest :: String -> TLT IO () -> TestTree
tltTest = String -> TLT IO () -> TestTree
forall t. IsTest t => String -> t -> TestTree
TTP.singleTest