{-|
Module      : TestHS
Description : A lightweight testing framework for Haskell
Copyright   : Thodoris Papakonstantinou, 2026
License     : LGPL-3
Maintainer  : dev@tpapak.com
Stability   : experimental
Portability : POSIX

A minimal pure-functional test harness.  Build a list of 'Test' values
using 'testPassed' and 'testFailed', then report results with
'reportTests' (pure tests) or 'reportTestsIO' (IO tests).
Exits with failure if any test fails.
 -}
module TestHS
    ( Test
    , runTest
    , reportTests
    , reportTestsIO
    , testPassed
    , testFailed
    ) where

import Data.Tuple
import Control.Monad
import System.Console.ANSI
import System.Exit


-- | Test data type
data Test = Test
  { Test -> String
name :: String
  , Test -> Either (String, String) String
outcome :: Either (String, String) String
  } deriving (Int -> Test -> ShowS
[Test] -> ShowS
Test -> String
(Int -> Test -> ShowS)
-> (Test -> String) -> ([Test] -> ShowS) -> Show Test
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Test -> ShowS
showsPrec :: Int -> Test -> ShowS
$cshow :: Test -> String
show :: Test -> String
$cshowList :: [Test] -> ShowS
showList :: [Test] -> ShowS
Show, Test -> Test -> Bool
(Test -> Test -> Bool) -> (Test -> Test -> Bool) -> Eq Test
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Test -> Test -> Bool
== :: Test -> Test -> Bool
$c/= :: Test -> Test -> Bool
/= :: Test -> Test -> Bool
Eq)

-- | Create a passing test with a name and a result message.
testPassed :: String -> String -> Test
testPassed :: String -> String -> Test
testPassed String
t String
s = Test 
  { name :: String
name = String
t
  , outcome :: Either (String, String) String
outcome = String -> Either (String, String) String
forall a b. b -> Either a b
Right String
s
  }
  
-- | Create a failing test with a name and an @(expected, got)@ pair.
testFailed :: String -> (String,String) -> Test
testFailed :: String -> (String, String) -> Test
testFailed String
t (String, String)
f = Test 
  { name :: String
name = String
t
  , outcome :: Either (String, String) String
outcome = (String, String) -> Either (String, String) String
forall a b. a -> Either a b
Left (String, String)
f
  }
 
-- | run pure test
runTest :: Test -> IO Test
runTest :: Test -> IO Test
runTest Test
t = do
  case Test -> Either (String, String) String
outcome Test
t of
    Left (String, String)
err -> do
      String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Test -> String
name Test
t
      String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
err
      String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String, String) -> String
forall a b. (a, b) -> b
snd (String, String)
err
      [SGR] -> IO ()
setSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red]
      String -> IO ()
putStrLn  String
" ✗" 
      [SGR] -> IO ()
setSGR [SGR
Reset]
    Right String
succe -> do
      String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Test -> String
name Test
t
      String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
succe 
      [SGR] -> IO ()
setSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green]
      String -> IO ()
putStrLn String
" ✓"
      [SGR] -> IO ()
setSGR [SGR
Reset]
  Test -> IO Test
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Test
t

-- | Run a list of pure tests, print results, and exit with failure if any fail.
reportTests :: [Test] -> IO ()
reportTests :: [Test] -> IO ()
reportTests [Test]
ts = do
  [Test]
tests <- [IO Test] -> IO [Test]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([IO Test] -> IO [Test]) -> [IO Test] -> IO [Test]
forall a b. (a -> b) -> a -> b
$ (Test -> IO Test) -> [Test] -> [IO Test]
forall a b. (a -> b) -> [a] -> [b]
map Test -> IO Test
runTest [Test]
ts
  let lt :: Int
lt = [Test] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Test]
tests
  let passedtests :: [Test]
passedtests = (Test -> Bool) -> [Test] -> [Test]
forall a. (a -> Bool) -> [a] -> [a]
filter 
                    (\Test
test -> case Test -> Either (String, String) String
outcome Test
test of 
                      Left (String, String)
_ -> Bool
False
                      Right String
_ -> Bool
True)
                      [Test]
tests
  let failedTests :: Int
failedTests = Int
lt Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Test] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Test]
passedtests
  let passedAll :: Bool
passedAll = [Test] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Test]
passedtests Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lt
  case Bool
passedAll of
       Bool
True -> do
         String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Passed all " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
lt) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" tests!! 🎉"
       Bool
False -> do
         String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
failedTests) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" test(s) 😣"
         IO ()
forall a. IO a
exitFailure

-- | Run tests with IO
reportTestsIO :: [IO Test] -> IO ()
reportTestsIO :: [IO Test] -> IO ()
reportTestsIO [IO Test]
ts = do
  String -> IO ()
putStrLn String
"Running tests"
  [Test]
testsIO <- [IO Test] -> IO [Test]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [IO Test]
ts
  String -> IO ()
putStrLn String
"Reporting tests"
  [Test]
tests <- [IO Test] -> IO [Test]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([IO Test] -> IO [Test]) -> [IO Test] -> IO [Test]
forall a b. (a -> b) -> a -> b
$ (Test -> IO Test) -> [Test] -> [IO Test]
forall a b. (a -> b) -> [a] -> [b]
map Test -> IO Test
runTest [Test]
testsIO
  let lt :: Int
lt = [Test] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Test]
tests
  let passedtests :: [Test]
passedtests = (Test -> Bool) -> [Test] -> [Test]
forall a. (a -> Bool) -> [a] -> [a]
filter 
                    (\Test
test -> case Test -> Either (String, String) String
outcome Test
test of 
                      Left (String, String)
_ -> Bool
False
                      Right String
_ -> Bool
True)
                      [Test]
tests
  let failedTests :: Int
failedTests = Int
lt Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Test] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Test]
passedtests
  let passedAll :: Bool
passedAll = [Test] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Test]
passedtests Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lt
  case Bool
passedAll of
       Bool
True -> do
         String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Passed all " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
lt) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" tests!! 🎉"
       Bool
False -> do
         String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
failedTests) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" test(s) 😣"
         IO ()
forall a. IO a
exitFailure