-----------------------------------------------------------------------------
-- Copyright 2016, Ideas project team. This file is distributed under the
-- terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are 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.
--
-----------------------------------------------------------------------------

module Ideas.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 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 . fmap 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")
         InsufficientCoverage {numTests = i} ->
            warning ("only performed " ++ 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 . fmap 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 (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

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 = (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