{-# LANGUAGE Rank2Types, GADTs #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  TestFramework
-- Copyright   :  Copyright 2004 by  by Aetion Technologies LLC
--
-- Maintainer  :  Isaac Jones <isaac.jones@aetion.com>
-- Stability   :  alpha
-- Portability :  Hugs, GHC (Uses existential types)
--
-- Explanation: Provide basic functions for conviniently running a
-- collection of HUnit and QuickCheck tests.

{- =============================================================================
Copyright 2004 by Aetion Technologies LLC.
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

* Redistributions of source code must retain the above copyright notice, this
  list of conditions and the following disclaimer.

* Redistributions in binary form must reproduce the above copyright notice,
  this list of conditions and the following disclaimer in the documentation
  and/or other materials provided with the distribution.

* Neither the name of the Aetion Technologies LLC nor the names of its
  contributors may be used to endorse or promote products derived from this
  software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
============================================================================= -}

module Halfs.TestFramework (UnitTests, QC(..), runTest,
                      combineCounts, runAllTests,
                      hunitToUnitTest, listsToUnitTests,
                      qcToUnitTest, testMain, assertCmd,
                      module Test.QuickCheck,
                      module Test.HUnit
--                      ,(~:), (~=?)
                     ) where

-- Base:
import Control.Monad(liftM)
import Data.Maybe(catMaybes)
import Test.QuickCheck (quickCheck, Testable, (==>))
import System.Cmd(system)
import System.Exit (ExitCode(ExitSuccess))

-- Misc:
 -- FIX: should eventually be Debug.HUnit or Test.HUnit.
import Test.HUnit (Test(..), Counts(..), Assertion,
                   (~:), (~=?), assertEqual, assertBool, test, runTestTT)

-- ------------------------------------------------------------
-- * Types
-- ------------------------------------------------------------

-- |Extra constructor is required.  Uses the existential constructor
-- feature so we can have heterogeneous lists.
data QC = forall a. (Testable a) => QC String a

-- |Either HUnit or QuickCheck
type UnitTests = [Either Test -- HUnit test suite
                  QC]  -- QuickCheck test suite

hunitToUnitTest :: [Test] -> UnitTests
hunitToUnitTest = map Left

qcToUnitTest :: [QC] -> UnitTests
qcToUnitTest = map Right

listsToUnitTests :: [Test] -> [QC] -> UnitTests
listsToUnitTests hu qc
    = (map Left hu) ++ (map Right qc)

-- ------------------------------------------------------------
-- * Convinient Functions
-- ------------------------------------------------------------

-- |Beautify this test label.
prettyLab :: String -> String
prettyLab lab = "---+++ " ++ lab

-- |Print out the test label before execution.
runTest :: Test -> IO Counts
runTest t@(TestLabel lab _) = (putStrLn $ prettyLab lab) >> runTestTT t
runTest t                    = runTestTT t

-- |Given a collection of tests, run them through either quickcheck or
-- HUnit, as appropriate.
runAllTests :: UnitTests -> IO [Counts]
runAllTests t
    = do counts <- sequence $ map tester t
         return $ catMaybes counts
    where tester :: Either Test QC -> IO (Maybe Counts)
          tester (Left hUnitTest) = liftM Just (runTest hUnitTest)
          tester (Right (QC lab t')) = do putStrLn $ prettyLab lab; quickCheck t'; return Nothing


combineCounts :: Counts -> Counts -> Counts
combineCounts (Counts a b c d) (Counts a' b' c' d')
    = Counts (a + a') (b + b') (c + c') (d + d')

-- |Run this command, and assert it returns a successful error code.
assertCmd :: String -- ^Command
          -> String -- ^Comment
          -> Assertion
assertCmd command comment
    = system command >>= assertEqual (command ++ ":" ++ comment) ExitSuccess

-- ------------------------------------------------------------
-- * For Testing
-- ------------------------------------------------------------

testMain :: IO ()
testMain = do runAllTests ([Left $ TestLabel "foo" (TestList ["a" ~: "failed" ~: 3 ~=? (32::Int)]),
                                  Right (QC "first" (True ==> False)), (Right $ QC "snd" True)
                                 ])
              return ()