vty/test/VerifyOutput.hs

{- We setup the environment to envoke certain terminals of interest.
 - This assumes appropriate definitions exist in the current environment for the terminals of
 - interest.
 -}
module VerifyOutput where
import Verify

import Graphics.Vty

import Verify.Graphics.Vty.Image
import Verify.Graphics.Vty.Output

import Control.Monad

import qualified System.Console.Terminfo as Terminfo
import System.Posix.Env
import System.IO

tests :: IO [Test]
tests = concat <$> forM terminalsOfInterest (\termName -> do
    -- check if that terminfo exists
    -- putStrLn $ "testing end to end for terminal: " ++ termName
    mti <- try $ Terminfo.setupTerm termName
    case mti of
        Left (_ :: SomeException) -> return []
        Right _ -> return [ verify ("verify " ++ termName ++ " could output a picture")
                                   (smokeTestTermNonMac termName)
                          -- this is excessive.
                          , verify ("verify " ++ termName ++ " could output a picture on a Mac.")
                                   (smokeTestTermMac termName)
                          ]
    )

smokeTestTermNonMac :: String -> Image -> Property
smokeTestTermNonMac termName i = liftIOResult $ do
    -- unset the TERM_PROGRAM environment variable if set.
    -- Required to execute regression test for #42 on a mac
    unsetEnv "TERM_PROGRAM"
    smokeTestTerm termName i

smokeTestTermMac :: String -> Image -> Property
smokeTestTermMac termName i = liftIOResult $ do
    setEnv "TERM_PROGRAM" "Apple_Terminal" True
    smokeTestTerm termName i

smokeTestTerm :: String -> Image -> IO Result
smokeTestTerm termName i = do
    nullOut <- openFile "/dev/null" WriteMode
    t <- outputForNameAndIO termName nullOut
    -- putStrLn $ "context color count: " ++ show (contextColorCount t)
    reserveDisplay t
    dc <- displayContext t (100,100)
    -- always show the cursor to produce tests for terminals with no cursor support.
    let pic = (picForImage i) { picCursor = Cursor 0 0 }
    outputPicture dc pic
    setCursorPos t 0 0
    when (supportsCursorVisibility t) $ do
        hideCursor t
        showCursor t
    releaseDisplay t
    releaseTerminal t
    return succeeded