-- 
-- Copyright (c) 2005   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
-- 
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

module Test.Framework.FileBasedTest ( 
  
  Diff, FBTConfig(..), 

  defaultFBTConfig, defaultDiff,

  fileBasedTests

) where

import Prelude hiding ( catch )

import System.IO
import System.Exit
import Control.Exception
import System.Directory 
import Data.List ( mapAccumL )
import qualified Data.Map as Map
import Control.Monad

import Test.Framework.Process
import Test.Framework.HUnitWrapper as HU
import Test.Framework.Utils

type Diff = Maybe FilePath      -- Name of the file that contains the expected output.
                                -- If the parameter is Nothing, then no output
                                -- is expected.
          -> String             -- Actual output
          -> IO (Maybe String)  -- A Nothing value means ok, otherwise the
                                -- Just value wraps the error message

data FileBasedTest = FileBasedTest
                   { fbt_shouldFail  :: Bool
                   , fbt_cmd         :: String
                   , fbt_stdinFile   :: Maybe FilePath
                   , fbt_stdoutFile  :: Maybe FilePath
                   , fbt_stderrFile  :: Maybe FilePath
                     -- functions for comparing output on stdout and stderr.
                   , fbt_stdoutCmp   :: Diff
                   , fbt_stderrCmp   :: Diff
                   }

runFileBasedTest :: FileBasedTest -> HU.Assertion
runFileBasedTest fbt = 
    do inp <- case fbt_stdinFile fbt of
                Nothing -> return Nothing
                Just f -> do s <- readFile f
                             return $ Just s
       (out,err,exit) <- popenShell (fbt_cmd fbt) inp
       case exit of
         ExitSuccess | fbt_shouldFail fbt 
           -> HU.assertFailure ("test is supposed to fail but succeeded")
         ExitFailure i | not $ fbt_shouldFail fbt
           -> do hPutStrLn stderr $ "stderr for " ++ show (fbt_cmd fbt) ++ ":"
                 hPutStr stderr err
                 putStrLn $ "stdout for " ++ show (fbt_cmd fbt) ++ ":"
                 putStr out
                 HU.assertFailure ("test is supposed to succeed but failed with " ++
                                "exit code " ++ show i)
         _ -> do cmpOut <- cmp (fbt_stdoutFile fbt) (fbt_stdoutCmp fbt)
                             out "Mismatch on stdout:\n"
                 cmpErr <- cmp (fbt_stderrFile fbt) (fbt_stderrCmp fbt)
                             err "Mismatch on stderr:\n"
                 case (cmpOut, cmpErr) of
                  (Nothing, Nothing) -> return ()
                  (x1, x2) -> HU.assertFailure (x1 `concatMaybes` x2)
    where cmp expectFile cmpAction real label = 
              do res <- cmpAction expectFile real
                 case res of
                   Nothing -> return Nothing
                   Just s -> return $ Just (label ++ s)
          concatMaybes Nothing Nothing = ""
          concatMaybes (Just s) Nothing = s
          concatMaybes (Nothing) (Just s) = s
          concatMaybes (Just s1) (Just s2) = s1 ++ "\n" ++ s2


data FBTConfig = FBTConfig { fbt_stdinSuffix    :: String
                           , fbt_stdoutSuffix   :: String
                           , fbt_stderrSuffix   :: String
                           , fbt_dynConfigName  :: String
                           , fbt_stdoutDiff     :: Diff
                           , fbt_stderrDiff     :: Diff }

defaultDiff :: Diff
defaultDiff expectFile real = 
    do mexe <- findExecutable "diff"
       let exe = case mexe of
                   Just p -> p
                   Nothing -> error ("diff command not in path")
       case expectFile of
         Nothing | null real -> return Nothing
                 | otherwise -> return $ Just ("no output expected, but given:\n" 
                                               ++ real)
         Just expect ->
             do (out, err, exitCode) <- popen exe ["-u", expect, "-"] (Just real)
                case exitCode of
                  ExitSuccess -> return Nothing       -- no difference
                  ExitFailure 1 -> return $ Just out  -- files differ
                  ExitFailure i -> error ("diff command failed with exit code " ++ 
                                          show i ++ ": " ++ err)

defaultFBTConfig = FBTConfig { fbt_stdinSuffix    = ".in"
                             , fbt_stdoutSuffix   = ".out"
                             , fbt_stderrSuffix   = ".err"
                             , fbt_dynConfigName  = "FBTConfig"
                             , fbt_stdoutDiff     = defaultDiff
                             , fbt_stderrDiff     = defaultDiff }

fileBasedTests :: String    -- id for the tests
               -> FilePath  -- root directory of the test hierarchy
               -> String    -- name of executable
               -> String    -- filename suffix for input file
               -> FBTConfig -- configuration
               -> IO HU.Test
fileBasedTests id root exe suf cfg = 
    do let prune root _ = do dynCfg <- readDynCfg Map.empty
                                                  (root </> fbt_dynConfigName cfg)
                             return $ dyn_skip dynCfg
       inputFiles <- collectFiles root suf prune
       (_, tests) <- mapAccumLM genTest Map.empty inputFiles
       return $ HU.TestLabel id $ HU.TestList tests
    where genTest :: DynamicConfigMap -> FilePath -> IO (DynamicConfigMap, HU.Test)
          genTest map fname =
            do stdinf <- maybeFile $ replaceSuffix fname (fbt_stdinSuffix cfg)
               stdoutf <- maybeFile $  replaceSuffix fname (fbt_stdoutSuffix cfg)
               stderrf <- maybeFile $ replaceSuffix fname (fbt_stderrSuffix cfg)
               let configFile = dirname fname </> fbt_dynConfigName cfg
               dynCfg <- readDynCfg map configFile
               let cmd = exe ++ " " ++ dropSpace (dyn_flags dynCfg) ++ " " ++ fname
                   shouldFail = dyn_shouldFail dynCfg
               let fbt = FileBasedTest
                         { fbt_shouldFail  = shouldFail
                         , fbt_cmd         = cmd
                         , fbt_stdinFile   = stdinf
                         , fbt_stdoutFile  = stdoutf
                         , fbt_stderrFile  = stderrf
                         , fbt_stdoutCmp   = fbt_stdoutDiff cfg
                         , fbt_stderrCmp   = fbt_stderrDiff cfg
                         }
               return (Map.insert configFile dynCfg map,
                       HU.TestLabel fname $ HU.TestCase $ runFileBasedTest fbt)

data DynamicConfig = DynamicConfig { dyn_skip        :: Bool
                                   , dyn_flags       :: String
                                   , dyn_shouldFail  :: Bool }

type DynamicConfigMap = Map.Map FilePath DynamicConfig

defaultDynCfg = DynamicConfig False "" False

readDynCfg :: DynamicConfigMap -> FilePath -> IO DynamicConfig
readDynCfg m f = 
    do case Map.lookup f m of
         Just dynCfg -> return dynCfg
         Nothing ->
             do b <- doesFileExist f
                if not b then return $ defaultDynCfg
                   else do s <- readFile f
                           return $ foldl (parse f) defaultDynCfg $ 
                                 filter (not . isUseless) (map dropSpace (lines s))
    where isUseless :: String -> Bool
          isUseless []      = True
          isUseless ('#':_) = True
          isUseless _       = False
          parse :: FilePath -> DynamicConfig -> String -> DynamicConfig
          parse _ cfg "Skip" = cfg { dyn_skip = True }
          parse _ cfg "Fail" = cfg { dyn_shouldFail = True }
          parse _ cfg ('F':'l':'a':'g':'s':':':flags) = cfg { dyn_flags = flags }
          parse f _ l = error ("invalid line in dynamic configuration file `" ++
                               f ++ "': " ++ show l)