monadic-bang-0.2.1.0: test/MonadicBang/Test.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LexicalNegation #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE ViewPatterns #-}

module Main (main) where

import Prelude hiding ((<>))
#if MIN_VERSION_ghc(9,6,0)
#else
import Control.Applicative (liftA2)
#endif
import Data.Foldable
import Data.Traversable
import System.IO

import MonadicBang.Test.Utils
import MonadicBang.Test.ShouldPass
import MonadicBang.Test.ShouldFail

import GHC.Utils.Outputable
import GHC.Utils.Ppr (Mode(PageMode))
import System.Exit (exitFailure)

main :: IO ()
main = do
  (numFailures, numFailedSuites) <- liftA2 (,) sum (length . filter (> 0)) <$> for suites \suite -> do
    failures <- runSuite suite
    for_ failures \failure -> putSDoc stderr $ vcat [space, prettyFail failure]
    pure $ length failures
  if numFailures == 0
    then putStrLn "All tests passed!"
    else do
      putSDoc stdout $
        space $+$ plural' numFailures "test" <+> text "in" <+> int numFailedSuites <> char '/' <> plural' (length suites) "suite" <+> text "failed."
      exitFailure
  where
    plural' :: Int -> String -> SDoc
    plural' n (text -> s) = int n <+> case n of
      1 -> s
      _ -> s <> char 's'

putSDoc :: Handle -> SDoc -> IO ()
putSDoc = printSDocLn defaultSDocContext (PageMode True)

suites :: [TestType]
suites =
  [ shouldPass
  , shouldFail
  ]