Output.hs

{-# LANGUAGE CPP #-}

module Test.Chell.Output
  ( Output,
    outputStart,
    outputResult,
    ColorMode (..),
    plainOutput,
    colorOutput,
  )
where

import Control.Monad (forM_, unless, when)

#ifdef MIN_VERSION_ansi_terminal
import qualified System.Console.ANSI as AnsiTerminal
#endif

import Test.Chell.Types

data Output = Output
  { outputStart :: Test -> IO (),
    outputResult :: Test -> TestResult -> IO ()
  }

plainOutput :: Bool -> Output
plainOutput v =
  Output
    { outputStart = plainOutputStart v,
      outputResult = plainOutputResult v
    }

plainOutputStart :: Bool -> Test -> IO ()
plainOutputStart v t =
  when v $
    do
      putStr "[ RUN   ] "
      putStrLn (testName t)

plainOutputResult :: Bool -> Test -> TestResult -> IO ()
plainOutputResult v t (TestPassed _) =
  when v $
    do
      putStr "[ PASS  ] "
      putStrLn (testName t)
      putStrLn ""
plainOutputResult v t TestSkipped =
  when v $
    do
      putStr "[ SKIP  ] "
      putStrLn (testName t)
      putStrLn ""
plainOutputResult _ t (TestFailed notes fs) =
  do
    putStr "[ FAIL  ] "
    putStrLn (testName t)
    printNotes notes
    printFailures fs
plainOutputResult _ t (TestAborted notes msg) =
  do
    putStr "[ ABORT ] "
    putStrLn (testName t)
    printNotes notes
    putStr "  "
    putStr msg
    putStrLn "\n"
plainOutputResult _ _ _ = return ()

data ColorMode
  = ColorModeAuto
  | ColorModeAlways
  | ColorModeNever
  deriving (Enum)

colorOutput :: Bool -> Output
#ifndef MIN_VERSION_ansi_terminal
colorOutput = plainOutput
#else
colorOutput v =
  Output
    { outputStart = colorOutputStart v
    , outputResult = colorOutputResult v
    }

colorOutputStart :: Bool -> Test -> IO ()
colorOutputStart v t = when v $
  do
    putStr "[ RUN   ] "
    putStrLn (testName t)

colorOutputResult :: Bool -> Test -> TestResult -> IO ()
colorOutputResult v t (TestPassed _) =
    when v $
      do
        putStr "[ "
        AnsiTerminal.setSGR
            [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Green
            ]
        putStr "PASS"
        AnsiTerminal.setSGR
            [ AnsiTerminal.Reset
            ]
        putStr "  ] "
        putStrLn (testName t)
        putStrLn ""
colorOutputResult v t TestSkipped =
    when v $
      do
        putStr "[ "
        AnsiTerminal.setSGR
            [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Yellow
            ]
        putStr "SKIP"
        AnsiTerminal.setSGR
            [ AnsiTerminal.Reset
            ]
        putStr "  ] "
        putStrLn (testName t)
        putStrLn ""
colorOutputResult _ t (TestFailed notes fs) =
  do
    putStr "[ "
    AnsiTerminal.setSGR
        [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Red
        ]
    putStr "FAIL"
    AnsiTerminal.setSGR
        [ AnsiTerminal.Reset
        ]
    putStr "  ] "
    putStrLn (testName t)
    printNotes notes
    printFailures fs
colorOutputResult _ t (TestAborted notes msg) =
  do
    putStr "[ "
    AnsiTerminal.setSGR
        [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Red
        ]
    putStr "ABORT"
    AnsiTerminal.setSGR
        [ AnsiTerminal.Reset
        ]
    putStr " ] "
    putStrLn (testName t)
    printNotes notes
    putStr "  "
    putStr msg
    putStrLn "\n"
colorOutputResult _ _ _ = return ()
#endif

printNotes :: [(String, String)] -> IO ()
printNotes notes =
  unless (null notes) $
    do
      forM_ notes $ \(key, value) ->
        do
          putStr "  note: "
          putStr key
          putStr "="
          putStrLn value
      putStrLn ""

printFailures :: [Failure] -> IO ()
printFailures fs =
  forM_ fs $ \f ->
    do
      putStr "  "
      case failureLocation f of
        Just loc ->
          do
            putStr (locationFile loc)
            putStr ":"
            case locationLine loc of
              Just line -> putStrLn (show line)
              Nothing -> putStrLn ""
        Nothing -> return ()
      putStr "  "
      putStr (failureMessage f)
      putStrLn "\n"