-----------------------------------------------------------------------------
-- Copyright 2015, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- A lightweight wrapper for organizing tests (including QuickCheck tests). It
-- introduces the notion of a test suite, and it stores the test results for
-- later inspection (e.g., for the generation of a test report). A TestSuite
-- is a monoid.
--
-----------------------------------------------------------------------------
--  $Id: TestSuite.hs 7524 2015-04-08 07:31:15Z bastiaan $

module Ideas.Common.Utils.TestSuite
   ( -- * TestSuite
     TestSuite, module Data.Monoid
   , suite, useProperty, usePropertyWith
   , assertTrue, assertNull, assertEquals, assertIO
   , assertMessage, assertMessageIO
   , onlyWarnings, rateOnError
     -- * Running a test suite
   , runTestSuite, runTestSuiteResult
     -- * Test Suite Result
   , Result, subResults, findSubResult
   , justOneSuite, allMessages, topMessages
   , nrOfTests, nrOfErrors, nrOfWarnings
   , timeInterval, makeSummary, printSummary
     -- * Message
   , Message, message, warning, messageLines
     -- * Status
   , Status, HasStatus(..)
   , isError, isWarning, isOk
     -- * Rating
   , Rating, HasRating(..)
   ) where

import Control.Exception
import Control.Monad
import Data.Foldable (toList)
import Data.IORef
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Time
import Prelude hiding (catch)
import System.IO
import Test.QuickCheck hiding (Result)
import qualified Data.Sequence as S

----------------------------------------------------------------
-- Test Suite

newtype TestSuite = TS (S.Seq Test)

data Test = Case  String (IO Message)
          | Suite String TestSuite

instance Monoid TestSuite where
   mempty = TS mempty
   TS xs `mappend` TS ys = TS (xs <> ys)

tests :: TestSuite -> [Test]
tests (TS xs) = toList xs

makeTestSuite :: Test -> TestSuite
makeTestSuite = TS . S.singleton

----------------------------------------------------------------
-- Test suite constructors

-- | Construct a (named) test suite containing test cases and other suites
suite :: String -> [TestSuite] -> TestSuite
suite s = makeTestSuite . Suite s . mconcat

-- | Turn a QuickCheck property into the test suite. The first argument is
-- a label for the property
useProperty :: Testable prop => String -> prop -> TestSuite
useProperty = flip usePropertyWith stdArgs

-- | Turn a QuickCheck property into the test suite, also providing a test
-- configuration (Args)
usePropertyWith :: Testable prop => String -> Args -> prop -> TestSuite
usePropertyWith s args =
   makeTestSuite . Case s . liftM make . quickCheckWithResult args {chatty=False}
 where
   make qc =
      case qc of
         Success {} ->
            mempty
         Failure {reason = msg} ->
            message msg
         NoExpectedFailure {} ->
            message "no expected failure"
         GaveUp {numTests = i} ->
            warning ("passed only " ++ show i ++ " tests")

assertTrue :: String -> Bool -> TestSuite
assertTrue s = assertIO s . return

assertNull :: Show a => String -> [a] -> TestSuite
assertNull s xs = assertMessages s (null xs) (map show xs)

assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite
assertEquals s x y = assertMessage s (x==y) $
   "not equal " ++ show x ++ " and " ++ show y

assertMessage :: String -> Bool -> String -> TestSuite
assertMessage s b = assertMessages s b . return

assertMessages :: String -> Bool -> [String] -> TestSuite
assertMessages s b xs = makeTestSuite . Case s $ return $
   if b then mempty else mconcat (map message xs)

assertIO :: String -> IO Bool -> TestSuite
assertIO s = makeTestSuite . Case s . liftM f
 where
   f b = if b then mempty else message "assertion failed"

assertMessageIO :: String -> IO Message -> TestSuite
assertMessageIO s = makeTestSuite . Case s

-- | All errors are turned into warnings
onlyWarnings :: TestSuite -> TestSuite
onlyWarnings = changeMessages $ \m ->
   m { messageStatus = messageStatus m  `min` Warning
     , messageRating = mempty
     }

rateOnError :: Int -> TestSuite -> TestSuite
rateOnError n = changeMessages $ \m ->
   if isError m then m { messageRating = Rating n } else m

changeMessages :: (Message -> Message) -> TestSuite -> TestSuite
changeMessages f = changeTS
 where
   changeTS   (TS xs)     = TS (fmap changeTest xs)
   changeTest (Case s io) = Case s (liftM f io)
   changeTest (Suite s t) = Suite s (changeTS t)

----------------------------------------------------------------
-- Running a test suite

runTestSuite :: Bool -> TestSuite -> IO ()
runTestSuite chattyIO = void . runTestSuiteResult chattyIO

runTestSuiteResult :: Bool -> TestSuite -> IO Result
runTestSuiteResult chattyIO ts = do
   hSetBuffering stdout NoBuffering
   ref <- newIORef 0
   result <- runner ref chattyIO ts
   newline ref
   return result
 where

runner :: IORef Int -> Bool -> TestSuite -> IO Result
runner ref chattyIO = runTS
 where
   runTS :: TestSuite -> IO Result
   runTS ts = do
      (res, dt) <- getDiffTime (foldM addTest mempty (tests ts))
      returnStrict res { diffTime = dt }

   runTest :: Test -> IO Result
   runTest t =
      case t of
         Suite s xs -> runSuite s xs
         Case s io  -> runTestCase s io

   runSuite ::String -> TestSuite -> IO Result
   runSuite s ts = do
      when chattyIO $ do
         newline ref
         putStrLn s
         reset ref
      result <- runTS ts
      returnStrict (suiteResult s result)

   runTestCase :: String -> IO Message -> IO Result
   runTestCase s io = do
      msg <- io `catch` handler
      case messageStatus msg of
         _ | not chattyIO -> return ()
         Ok -> dot ref
         _  -> do
            newlineIndent ref
            print msg
            reset ref
      returnStrict (caseResult (s, msg))
    where
      handler :: SomeException -> IO Message
      handler = return . message . show

   addTest :: Result -> Test -> IO Result
   addTest res t = liftM (res <>) (runTest t)

-- formatting helpers
type WriteIO a = IORef Int -> IO a

newline :: WriteIO ()
newline ref = do
   i <- readIORef ref
   when (i>0) (putChar '\n')
   reset ref

newlineIndent :: WriteIO ()
newlineIndent ref = do
   newline ref
   putStr "   "
   writeIORef ref 3

dot :: WriteIO ()
dot ref = do
   i <- readIORef ref
   unless (i>0 && i<60) (newlineIndent ref)
   putChar '.'
   modifyIORef ref (+1)

reset :: WriteIO ()
reset = (`writeIORef` 0)

----------------------------------------------------------------
-- Test Suite Result

data Result = Result
   { suites       :: S.Seq (String, Result)
   , cases        :: S.Seq (String, Message)
   , diffTime     :: !NominalDiffTime
   , nrOfTests    :: !Int
   , nrOfWarnings :: !Int
   , nrOfErrors   :: !Int
   , resultRating :: !Rating
   }

-- one-line summary
instance Show Result where
   show result =
      "(tests: "     ++ show (nrOfTests result)    ++
      ", errors: "   ++ show (nrOfErrors result)   ++
      ", warnings: " ++ show (nrOfWarnings result) ++
      ", "           ++ show (diffTime result)     ++ ")"

instance Monoid Result where
   mempty = Result mempty mempty 0 0 0 0 mempty
   x `mappend` y = Result
      { suites       = suites x <> suites y
      , cases        = cases x  <> cases y
      , diffTime     = diffTime x     + diffTime y
      , nrOfTests    = nrOfTests x    + nrOfTests y
      , nrOfWarnings = nrOfWarnings x + nrOfWarnings y
      , nrOfErrors   = nrOfErrors x   + nrOfErrors y
      , resultRating = resultRating x <> resultRating y
      }

instance HasStatus Result where
   getStatus r | nrOfErrors r   > 0 = Error
               | nrOfWarnings r > 0 = Warning
               | otherwise          = Ok

instance HasRating Result where
   rating   = rating . resultRating
   rate n a = a {resultRating = Rating n}

suiteResult :: String -> Result -> Result
suiteResult s res = mempty
   { suites       = S.singleton (s, res)
   , nrOfTests    = nrOfTests res
   , nrOfWarnings = nrOfWarnings res
   , nrOfErrors   = nrOfErrors res
   , resultRating = resultRating res
   }

caseResult :: (String, Message) -> Result
caseResult x@(_, msg) =
   case getStatus msg of
      Ok      -> new
      Warning -> new { nrOfWarnings = 1 }
      Error   -> new { nrOfErrors   = 1 }
 where
   new = mempty
      { cases        = S.singleton x
      , nrOfTests    = 1
      , resultRating = messageRating msg
      }

subResults :: Result -> [(String, Result)]
subResults = toList . suites

topMessages :: Result -> [(String, Message)]
topMessages = toList . cases

allMessages :: Result -> [(String, Message)]
allMessages res =
   topMessages res ++ concatMap (allMessages . snd) (subResults res)

findSubResult :: String -> Result -> Maybe Result
findSubResult name = listToMaybe . recs
 where
   recs = concatMap rec . subResults
   rec (n, t)
      | n == name = [t]
      | otherwise = recs t

justOneSuite :: Result -> Maybe (String, Result)
justOneSuite res =
   case subResults res of
      [x] | S.null (cases res) -> Just x
      _ -> Nothing

timeInterval :: Result -> Double
timeInterval = fromRational . toRational . diffTime

printSummary :: Result -> IO ()
printSummary = putStrLn . makeSummary

makeSummary :: Result -> String
makeSummary result = unlines $
   [ line
   , "Tests    : " ++ show (nrOfTests result)
   , "Errors   : " ++ show (nrOfErrors result)
   , "Warnings : " ++ show (nrOfWarnings result)
   , ""
   , "Time     : " ++ show (diffTime result)
   , ""
   , "Suites: "
   ] ++ map f (subResults result)
     ++ [line]
 where
   line = replicate 75 '-'
   f (name, r) = "   " ++ name ++ "   " ++ show r

-----------------------------------------------------
-- Message

data Message = M
   { messageStatus :: !Status
   , messageRating :: !Rating
   , messageLines  :: [String]
   }
 deriving Eq

instance Show Message where
   show a = st ++ sep ++ msg
    where
      msg = intercalate ", " (messageLines a)
      sep = if null st || null msg then "" else ": "
      st | isError a             = "error"
         | isWarning a           = "warning"
         | null (messageLines a) = "ok"
         | otherwise             = ""

instance Monoid Message where
   mempty = M mempty mempty mempty
   M s r xs `mappend` M t q ys = M (s <> t) (r <> q) (xs <> ys)

instance HasStatus Message where
   getStatus = messageStatus

instance HasRating Message where
   rating   = rating . messageRating
   rate n a = a {messageRating = Rating n}

message :: String -> Message
message = M Error (Rating 0) . return

warning :: String -> Message
warning = M Warning mempty . return

-----------------------------------------------------
-- Status

data Status = Ok | Warning | Error
   deriving (Eq, Ord)

instance Monoid Status where
   mempty  = Ok
   mappend = max

class HasStatus a where
   getStatus :: a -> Status

isOk, isWarning, isError :: HasStatus a => a -> Bool
isOk      = (== Ok)      . getStatus
isWarning = (== Warning) . getStatus
isError   = (== Error)   . getStatus

-----------------------------------------------------
-- Rating

data Rating = Rating !Int | MaxRating
   deriving (Eq, Ord)

instance Monoid Rating where
   mempty  = MaxRating
   mappend = min

class HasRating a where
   rating :: a -> Maybe Int
   rate   :: Int -> a -> a

instance HasRating Rating where
   rating (Rating n) = Just n
   rating MaxRating  = Nothing
   rate = const . Rating

-----------------------------------------------------
-- Utility function

getDiffTime :: IO a -> IO (a, NominalDiffTime)
getDiffTime action = do
   t0 <- getCurrentTime
   a  <- action
   t1 <- getCurrentTime
   return (a, diffUTCTime t1 t0)

returnStrict :: Monad m => a -> m a
returnStrict a = a `seq` return a