-- | Basic definitions for the HUnit library.
--
--   This module contains what you need to create assertions and test cases and
--   combine them into test suites. 
--
--   This module also provides infrastructure for 
--   implementing test controllers (which are used to execute tests). 
--   See "Test.HUnit.Text" for a great example of how to implement a test 
--   controller.

module Test.HUnit.Base
(
  -- ** Declaring tests
  Test(..),
  (~=?), (~?=), (~:), (~?),
  
  -- ** Making assertions
  assertFailure, {- from Test.HUnit.Lang: -}
  assertBool, assertEqual, assertString, 
  Assertion, {- from Test.HUnit.Lang: -}
  (@=?), (@?=), (@?),

  -- ** Extending the assertion functionality
  Assertable(..), ListAssertable(..),
  AssertionPredicate, AssertionPredicable(..),
  Testable(..),

  -- ** Test execution
  -- $testExecutionNote
  State(..), Counts(..), 
  Path, Node(..), 
  testCasePaths,
  testCaseCount,
  ReportStart, ReportProblem,
  performTest
)
where

import Control.Monad (unless, foldM)


-- Assertion Definition
-- ====================

import Test.HUnit.Lang


-- Conditional Assertion Functions
-- -------------------------------

-- | Asserts that the specified condition holds.
assertBool :: String    -- ^ The message that is displayed if the assertion fails
           -> Bool      -- ^ The condition
           -> Assertion
assertBool msg b = unless b (assertFailure msg)

-- | Signals an assertion failure if a non-empty message (i.e., a message
-- other than @\"\"@) is passed.
assertString :: String    -- ^ The message that is displayed with the assertion failure 
             -> Assertion
assertString s = unless (null s) (assertFailure s)

-- | Asserts that the specified actual value is equal to the expected value.
-- The output message will contain the prefix, the expected value, and the 
-- actual value.
--  
-- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted
-- and only the expected and actual values are output.
assertEqual :: (Eq a, Show a) => String -- ^ The message prefix 
                              -> a      -- ^ The expected value 
                              -> a      -- ^ The actual value
                              -> Assertion
assertEqual preface expected actual =
  unless (actual == expected) (assertFailure msg)
 where msg = (if null preface then "" else preface ++ "\n") ++
             "expected: " ++ show expected ++ "\n but got: " ++ show actual


-- Overloaded `assert` Function
-- ----------------------------

-- | Allows the extension of the assertion mechanism.
--
-- Since an 'Assertion' can be a sequence of @Assertion@s and @IO@ actions, 
-- there is a fair amount of flexibility of what can be achieved.  As a rule,
-- the resulting @Assertion@ should be the body of a 'TestCase' or part of
-- a @TestCase@; it should not be used to assert multiple, independent 
-- conditions.
--
-- If more complex arrangements of assertions are needed, 'Test's and
-- 'Testable' should be used.
class Assertable t
 where assert :: t -> Assertion

instance Assertable ()
 where assert = return

instance Assertable Bool
 where assert = assertBool ""

instance (ListAssertable t) => Assertable [t]
 where assert = listAssert

instance (Assertable t) => Assertable (IO t)
 where assert = (>>= assert)

-- | A specialized form of 'Assertable' to handle lists.
class ListAssertable t
 where listAssert :: [t] -> Assertion

instance ListAssertable Char
 where listAssert = assertString


-- Overloaded `assertionPredicate` Function
-- ----------------------------------------

-- | The result of an assertion that hasn't been evaluated yet.
--
-- Most test cases follow the following steps:
--
-- 1. Do some processing or an action.
--
-- 2. Assert certain conditions.
--
-- However, this flow is not always suitable.  @AssertionPredicate@ allows for
-- additional steps to be inserted without the initial action to be affected
-- by side effects.  Additionally, clean-up can be done before the test case
-- has a chance to end.  A potential work flow is:
--
-- 1. Write data to a file.
--
-- 2. Read data from a file, evaluate conditions.
--
-- 3. Clean up the file.
-- 
-- 4. Assert that the side effects of the read operation meet certain conditions.
--
-- 5. Assert that the conditions evaluated in step 2 are met.
type AssertionPredicate = IO Bool

-- | Used to signify that a data type can be converted to an assertion 
-- predicate.
class AssertionPredicable t
 where assertionPredicate :: t -> AssertionPredicate

instance AssertionPredicable Bool
 where assertionPredicate = return

instance (AssertionPredicable t) => AssertionPredicable (IO t)
 where assertionPredicate = (>>= assertionPredicate)


-- Assertion Construction Operators
-- --------------------------------

infix  1 @?, @=?, @?=

-- | Asserts that the condition obtained from the specified
--   'AssertionPredicable' holds.
(@?) :: (AssertionPredicable t) => t          -- ^ A value of which the asserted condition is predicated
                                -> String     -- ^ A message that is displayed if the assertion fails
                                -> Assertion
predi @? msg = assertionPredicate predi >>= assertBool msg

-- | Asserts that the specified actual value is equal to the expected value
--   (with the expected value on the left-hand side).
(@=?) :: (Eq a, Show a) => a -- ^ The expected value
                        -> a -- ^ The actual value
                        -> Assertion
expected @=? actual = assertEqual "" expected actual

-- | Asserts that the specified actual value is equal to the expected value
--   (with the actual value on the left-hand side).
(@?=) :: (Eq a, Show a) => a -- ^ The actual value
                        -> a -- ^ The expected value
                        -> Assertion
actual @?= expected = assertEqual "" expected actual



-- Test Definition
-- ===============

-- | The basic structure used to create an annotated tree of test cases.
data Test
    -- | A single, independent test case composed.
    = TestCase Assertion
    -- | A set of @Test@s sharing the same level in the hierarchy. 
    | TestList [Test]
    -- | A name or description for a subtree of the @Test@s.
    | TestLabel String Test

instance Show Test where
  showsPrec _ (TestCase _)    = showString "TestCase _"
  showsPrec _ (TestList ts)   = showString "TestList " . showList ts
  showsPrec p (TestLabel l t) = showString "TestLabel " . showString l
                                . showChar ' ' . showsPrec p t

-- Overloaded `test` Function
-- --------------------------

-- | Provides a way to convert data into a @Test@ or set of @Test@.
class Testable t
 where test :: t -> Test

instance Testable Test
 where test = id

instance (Assertable t) => Testable (IO t)
 where test = TestCase . assert

instance (Testable t) => Testable [t]
 where test = TestList . map test


-- Test Construction Operators
-- ---------------------------

infix  1 ~?, ~=?, ~?=
infixr 0 ~:

-- | Creates a test case resulting from asserting the condition obtained 
--   from the specified 'AssertionPredicable'.
(~?) :: (AssertionPredicable t) => t       -- ^ A value of which the asserted condition is predicated
                                -> String  -- ^ A message that is displayed on test failure
                                -> Test
predi ~? msg = TestCase (predi @? msg)

-- | Shorthand for a test case that asserts equality (with the expected 
--   value on the left-hand side, and the actual value on the right-hand
--   side).
(~=?) :: (Eq a, Show a) => a     -- ^ The expected value 
                        -> a     -- ^ The actual value
                        -> Test
expected ~=? actual = TestCase (expected @=? actual)

-- | Shorthand for a test case that asserts equality (with the actual 
--   value on the left-hand side, and the expected value on the right-hand
--   side).
(~?=) :: (Eq a, Show a) => a     -- ^ The actual value
                        -> a     -- ^ The expected value 
                        -> Test
actual ~?= expected = TestCase (actual @?= expected)

-- | Creates a test from the specified 'Testable', with the specified 
--   label attached to it.
--
-- Since 'Test' is @Testable@, this can be used as a shorthand way of attaching
-- a 'TestLabel' to one or more tests.  
(~:) :: (Testable t) => String -> t -> Test
label ~: t = TestLabel label (test t)



-- Test Execution
-- ==============

-- $testExecutionNote
-- Note: the rest of the functionality in this module is intended for 
-- implementors of test controllers. If you just want to run your tests cases,
-- simply use a test controller, such as the text-based controller in 
-- "Test.HUnit.Text".

-- | A data structure that hold the results of tests that have been performed
-- up until this point.
data Counts = Counts { cases, tried, errors, failures :: Int }
  deriving (Eq, Show, Read)

-- | Keeps track of the remaining tests and the results of the performed tests.
-- As each test is performed, the path is removed and the counts are
-- updated as appropriate.
data State = State { path :: Path, counts :: Counts }
  deriving (Eq, Show, Read)

-- | Report generator for reporting the start of a test run.
type ReportStart us = State -> us -> IO us

-- | Report generator for reporting problems that have occurred during
--   a test run. Problems may be errors or assertion failures.
type ReportProblem us = String -> State -> us -> IO us

-- | Uniquely describes the location of a test within a test hierarchy.
-- Node order is from test case to root.
type Path = [Node]

-- | Composed into 'Path's.
data Node  = ListItem Int | Label String
  deriving (Eq, Show, Read)

-- | Determines the paths for all 'TestCase's in a tree of @Test@s.
testCasePaths :: Test -> [Path]
testCasePaths t0 = tcp t0 []
 where tcp (TestCase _) p = [p]
       tcp (TestList ts) p =
         concat [ tcp t (ListItem n : p) | (t,n) <- zip ts [0..] ]
       tcp (TestLabel l t) p = tcp t (Label l : p)

-- | Counts the number of 'TestCase's in a tree of @Test@s.
testCaseCount :: Test -> Int
testCaseCount (TestCase _)    = 1
testCaseCount (TestList ts)   = sum (map testCaseCount ts)
testCaseCount (TestLabel _ t) = testCaseCount t

-- | Performs a test run with the specified report generators.  
--
-- This handles the actual running of the tests.  Most developers will want 
-- to use @HUnit.Text.runTestTT@ instead.  A developer could use this function 
-- to execute tests via another IO system, such as a GUI, or to output the 
-- results in a different manner (e.g., upload XML-formatted results to a 
-- webservice).  
--
-- Note that the counts in a start report do not include the test case
-- being started, whereas the counts in a problem report do include the
-- test case just finished.  The principle is that the counts are sampled
-- only between test case executions.  As a result, the number of test
-- case successes always equals the difference of test cases tried and
-- the sum of test case errors and failures.
performTest :: ReportStart us   -- ^ report generator for the test run start 
            -> ReportProblem us -- ^ report generator for errors during the test run
            -> ReportProblem us -- ^ report generator for assertion failures during the test run
            -> us 
            -> Test             -- ^ the test to be executed 
            -> IO (Counts, us)
performTest reportStart reportError reportFailure initialUs initialT = do
  (ss', us') <- pt initState initialUs initialT
  unless (null (path ss')) $ error "performTest: Final path is nonnull"
  return (counts ss', us')
 where
  initState  = State{ path = [], counts = initCounts }
  initCounts = Counts{ cases = testCaseCount initialT, tried = 0,
                       errors = 0, failures = 0}

  pt ss us (TestCase a) = do
    us' <- reportStart ss us
    r <- performTestCase a
    case r of Nothing         -> do return (ss', us')
              Just (True,  m) -> do usF <- reportFailure m ssF us'
                                    return (ssF, usF)
              Just (False, m) -> do usE <- reportError   m ssE us'
                                    return (ssE, usE)
   where c@Counts{ tried = n } = counts ss
         ss' = ss{ counts = c{ tried = n + 1 } }
         ssF = ss{ counts = c{ tried = n + 1, failures = failures c + 1 } }
         ssE = ss{ counts = c{ tried = n + 1, errors   = errors   c + 1 } }

  pt ss us (TestList ts) = foldM f (ss, us) (zip ts [0..])
   where f (ss', us') (t, n) = withNode (ListItem n) ss' us' t

  pt ss us (TestLabel label t) = withNode (Label label) ss us t

  withNode node ss0 us0 t = do (ss2, us1) <- pt ss1 us0 t
                               return (ss2{ path = path0 }, us1)
   where path0 = path ss0
         ss1 = ss0{ path = node : path0 }