{-# LANGUAGE DeriveDataTypeable #-}

-- | This module provides a function that tests whether a program can
-- be run successfully. For example if you have 'foo.hs' source file:
--
-- > module Foo where
-- >
-- > foo :: Int
-- > foo = 5
--
-- you can test whether GHC can compile it:
--
-- > module Main (
-- >   main
-- >  ) where
-- >
-- > import Test.Tasty
-- > import Test.Tasty.Program
-- >
-- > main :: IO ()
-- > main = defaultMain $ testGroup "Compilation with GHC" $ [
-- >     testProgram "Foo" "ghc" ["-fforce-recomp", "foo.hs"] Nothing
-- >   ]
--
-- Program's output and error streams are ignored.

module Test.Tasty.Program (
   testProgram
 , CatchStderr(..)
 ) where

import Control.DeepSeq      ( deepseq                                  )
import Data.List            ( intercalate                              )
import Data.Typeable        ( Typeable                                 )
import Data.Proxy           ( Proxy (..)                               )
import System.Directory     ( findExecutable                           )
import System.Exit          ( ExitCode(..)                             )
import System.Process       ( runInteractiveProcess, waitForProcess    )
import System.IO            ( hGetContents                             )
import Test.Tasty.Providers ( IsTest (..), Result, TestName, TestTree,
                              singleTest, testPassed, testFailed       )
import Test.Tasty.Options   ( IsOption (..), OptionDescription(..),
                              safeRead, lookupOption, flagCLParser     )

data TestProgram = TestProgram String [String] (Maybe FilePath)
     deriving (Typeable)

-- | Create test that runs a program with given options. Test succeeds
-- if program terminates successfully.
testProgram :: TestName        -- ^ Test name
            -> String          -- ^ Program name
            -> [String]        -- ^ Program options
            -> Maybe FilePath  -- ^ Optional working directory
            -> TestTree
testProgram :: String -> String -> [String] -> Maybe String -> TestTree
testProgram String
testName String
program [String]
opts Maybe String
workingDir =
    forall t. IsTest t => String -> t -> TestTree
singleTest String
testName (String -> [String] -> Maybe String -> TestProgram
TestProgram String
program [String]
opts Maybe String
workingDir)

instance IsTest TestProgram where
  run :: OptionSet -> TestProgram -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (TestProgram String
program [String]
args Maybe String
workingDir) Progress -> IO ()
_ = do
    Maybe String
execFound <- String -> IO (Maybe String)
findExecutable String
program

    let CatchStderr Bool
catchStderr = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts

    case Maybe String
execFound of
      Maybe String
Nothing       -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Result
execNotFoundFailure String
program
      Just String
progPath -> String -> [String] -> Maybe String -> Bool -> IO Result
runProgram String
progPath [String]
args Maybe String
workingDir Bool
catchStderr

  testOptions :: Tagged TestProgram [OptionDescription]
testOptions = forall (m :: * -> *) a. Monad m => a -> m a
return [forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy CatchStderr)]

newtype CatchStderr = CatchStderr Bool deriving (Int -> CatchStderr -> ShowS
[CatchStderr] -> ShowS
CatchStderr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CatchStderr] -> ShowS
$cshowList :: [CatchStderr] -> ShowS
show :: CatchStderr -> String
$cshow :: CatchStderr -> String
showsPrec :: Int -> CatchStderr -> ShowS
$cshowsPrec :: Int -> CatchStderr -> ShowS
Show, Typeable)

instance IsOption CatchStderr where
  defaultValue :: CatchStderr
defaultValue = Bool -> CatchStderr
CatchStderr Bool
False
  parseValue :: String -> Maybe CatchStderr
parseValue   = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> CatchStderr
CatchStderr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
safeRead
  optionName :: Tagged CatchStderr String
optionName   = forall (m :: * -> *) a. Monad m => a -> m a
return String
"catch-stderr"
  optionHelp :: Tagged CatchStderr String
optionHelp   = forall (m :: * -> *) a. Monad m => a -> m a
return String
"Catch standart error of programs"
  optionCLParser :: Parser CatchStderr
optionCLParser = forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser (forall a. a -> Maybe a
Just Char
'e') (Bool -> CatchStderr
CatchStderr Bool
True)

-- | Run a program with given options and optional working directory.
-- Return success if program exits with success code.
runProgram :: String          -- ^ Program name
           -> [String]        -- ^ Program options
           -> Maybe FilePath  -- ^ Optional working directory
           -> Bool            -- ^ Whether to print stderr on error
           -> IO Result
runProgram :: String -> [String] -> Maybe String -> Bool -> IO Result
runProgram String
program [String]
args Maybe String
workingDir Bool
catchStderr = do
  (Handle
_, Handle
_, Handle
stderrH, ProcessHandle
pid) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
program [String]
args Maybe String
workingDir forall a. Maybe a
Nothing

  Maybe String
stderr <- if Bool
catchStderr then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (Handle -> IO String
hGetContents Handle
stderrH) else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  ExitCode
ecode  <- Maybe String
stderr forall a b. NFData a => a -> b -> b
`deepseq` ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid

  case ExitCode
ecode of
    ExitCode
ExitSuccess      -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
success
    ExitFailure Int
code -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> [String] -> Int -> Maybe String -> Result
exitFailure String
program [String]
args Int
code Maybe String
stderr

-- | Indicates successful test
success :: Result
success :: Result
success = String -> Result
testPassed String
""

-- | Indicates that program does not exist in the path
execNotFoundFailure :: String -> Result
execNotFoundFailure :: String -> Result
execNotFoundFailure String
file =
  String -> Result
testFailed forall a b. (a -> b) -> a -> b
$ String
"Cannot locate program " forall a. [a] -> [a] -> [a]
++ String
file forall a. [a] -> [a] -> [a]
++ String
" in the PATH"

-- | Indicates that program failed with an error code
exitFailure :: String -> [String] -> Int -> Maybe String -> Result
exitFailure :: String -> [String] -> Int -> Maybe String -> Result
exitFailure String
file [String]
args Int
code Maybe String
stderr =
  let indent :: ShowS
indent String
s = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ (String
"  " forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
lines String
s in
  String -> Result
testFailed forall a b. (a -> b) -> a -> b
$ String
"Program " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
" " (String
fileforall a. a -> [a] -> [a]
:[String]
args) forall a. [a] -> [a] -> [a]
++
               String
" failed with code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
code
               forall a. [a] -> [a] -> [a]
++ case Maybe String
stderr of
                    Maybe String
Nothing -> String
""
                    Just String
s  -> String
"\n Stderr was: \n" forall a. [a] -> [a] -> [a]
++ ShowS
indent String
s