-----------------------------------------------------------------------------
-- Copyright 2019, 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
   , 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.Semigroup as Sem
import Data.Time
import Ideas.Utils.Prelude (getDiffTime)
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 Sem.Semigroup TestSuite where
   TS xs <> TS ys = TS (xs S.>< ys)

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

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 Sem.Semigroup Result where
   x <> y = Result
      { suites       = suites x S.>< suites y
      , cases        = cases x  S.>< 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 Monoid Result where
   mempty  = Result mempty mempty 0 0 0 0 mempty
   mappend = (<>)

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 Sem.Semigroup Message where
   M s r xs <> M t q ys = M (s <> t) (r <> q) (xs <> ys)

instance Monoid Message where
   mempty  = M mempty mempty mempty
   mappend = (<>)

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 Sem.Semigroup Status where
   (<>) = max

instance Monoid Status where
   mempty  = Ok
   mappend = (<>)

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 Sem.Semigroup Rating where
   (<>) = min

instance Monoid Rating where
   mempty  = MaxRating
   mappend = (<>)

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

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