module Test.QuickCheck.Test where

--------------------------------------------------------------------------
-- imports

import Test.QuickCheck.Gen
import Test.QuickCheck.Property hiding ( Result( reason, interrupted ) )
import qualified Test.QuickCheck.Property as P
import Test.QuickCheck.Text
import Test.QuickCheck.State
import Test.QuickCheck.Exception

import System.Random
  ( RandomGen(..)
  , newStdGen
  , StdGen
  )

import Data.Char
  ( isSpace
  )

import Data.List
  ( sort
  , group
  , groupBy
  , intersperse
  )

--------------------------------------------------------------------------
-- quickCheck

-- * Running tests

-- | Args specifies arguments to the QuickCheck driver
data Args
  = Args
  { replay     :: Maybe (StdGen,Int) -- ^ should we replay a previous test?
  , maxSuccess :: Int                -- ^ maximum number of successful tests before succeeding
  , maxDiscard :: Int                -- ^ maximum number of discarded tests before giving up
  , maxSize    :: Int                -- ^ size to use for the biggest test cases
  }
 deriving ( Show, Read )

-- | Result represents the test result
data Result
  = Success                         -- a successful test run
    { labels      :: [(String,Int)] -- ^ labels and frequencies found during all tests
    }
  | GaveUp                          -- given up
    { numTests    :: Int            -- ^ number of successful tests performed
    , labels      :: [(String,Int)] -- ^ labels and frequencies found during all tests
    }
  | Failure                         -- failed test run
    { usedSeed    :: StdGen         -- ^ what seed was used
    , usedSize    :: Int            -- ^ what was the test size
    , reason      :: String         -- ^ what was the reason
    , labels      :: [(String,Int)] -- ^ labels and frequencies found during all successful tests
    }
  | NoExpectedFailure               -- the expected failure did not happen
    { labels      :: [(String,Int)] -- ^ labels and frequencies found during all successful tests
    }
 deriving ( Show, Read )

-- | isSuccess checks if the test run result was a success
isSuccess :: Result -> Bool
isSuccess Success{} = True
isSuccess _         = False

-- | stdArgs are the default test arguments used
stdArgs :: Args
stdArgs = Args
  { replay     = Nothing
  , maxSuccess = 100
  , maxDiscard = 500
  , maxSize    = 100
-- noShrinking flag?
  }

-- | Tests a property and prints the results to 'stdout'.
quickCheck :: Testable prop => prop -> IO ()
quickCheck p = quickCheckWith stdArgs p

-- | Tests a property, using test arguments, and prints the results to 'stdout'.
quickCheckWith :: Testable prop => Args -> prop -> IO ()
quickCheckWith args p = quickCheckWithResult args p >> return ()

-- | Tests a property, produces a test result, and prints the results to 'stdout'.
quickCheckResult :: Testable prop => prop -> IO Result
quickCheckResult p = quickCheckWithResult stdArgs p

-- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'.
quickCheckWithResult :: Testable prop => Args -> prop -> IO Result
quickCheckWithResult args p =
  do tm  <- newTerminal
     rnd <- case replay args of
              Nothing      -> newStdGen
              Just (rnd,_) -> return rnd
     test MkState{ terminal          = tm
                 , maxSuccessTests   = maxSuccess args
                 , maxDiscardedTests = maxDiscard args
                 , computeSize       = case replay args of
                                         Nothing    -> computeSize (maxSuccess args) (maxSize args)
                                         Just (_,s) -> \_ _ -> s
                 , numSuccessTests   = 0
                 , numDiscardedTests = 0
                 , collected         = []
                 , expectedFailure   = False
                 , randomSeed        = rnd
                 , isShrinking       = False
                 , numSuccessShrinks = 0
                 , numTryShrinks     = 0
                 } (unGen (property p))
  where computeSize maxSuccess maxSize n d
          -- e.g. with maxSuccess = 250, maxSize = 100, goes like this:
          -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98.
          | n `roundTo` maxSize + maxSize <= maxSuccess ||
            n >= maxSuccess ||
            maxSuccess `mod` maxSize == 0 = n `mod` maxSize + d `div` 10
          | otherwise =
            (n `mod` maxSize) * maxSize `div` (maxSuccess `mod` maxSize) + d `div` 10
        n `roundTo` m = (n `div` m) * m

--------------------------------------------------------------------------
-- main test loop

test :: State -> (StdGen -> Int -> Prop) -> IO Result
test st f
  | numSuccessTests st   >= maxSuccessTests st   = doneTesting st f
  | numDiscardedTests st >= maxDiscardedTests st = giveUp st f
  | otherwise                                    = runATest st f

doneTesting :: State -> (StdGen -> Int -> Prop) -> IO Result
doneTesting st f =
  do -- CALLBACK done_testing?
     if expectedFailure st then
       putPart (terminal st)
         ( "+++ OK, passed "
        ++ show (numSuccessTests st)
        ++ " tests"
         )
      else
       putPart (terminal st)
         ( bold ("*** Failed!")
        ++ " Passed "
        ++ show (numSuccessTests st)
        ++ " tests (expected failure)"
         )
     success st
     if expectedFailure st then
       return Success{ labels = summary st }
      else
       return NoExpectedFailure{ labels = summary st }
  
giveUp :: State -> (StdGen -> Int -> Prop) -> IO Result
giveUp st f =
  do -- CALLBACK gave_up?
     putPart (terminal st)
       ( bold ("*** Gave up!")
      ++ " Passed only "
      ++ show (numSuccessTests st)
      ++ " tests"
       )
     success st
     return GaveUp{ numTests = numSuccessTests st
                  , labels   = summary st
                  }

runATest :: State -> (StdGen -> Int -> Prop) -> IO Result
runATest st f =
  do -- CALLBACK before_test
     putTemp (terminal st)
        ( "("
       ++ number (numSuccessTests st) "test"
       ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded"
                 | numDiscardedTests st > 0
                 ]
       ++ ")"
        )
     let size = computeSize st (numSuccessTests st) (numDiscardedTests st)
     MkRose mres ts <- protectRose (unProp (f rnd1 size))
     res <- mres
     callbackPostTest st res
     
     case ok res of
       Just True -> -- successful test
         do test st{ numSuccessTests = numSuccessTests st + 1
                   , randomSeed      = rnd2
                   , collected       = stamp res : collected st
                   , expectedFailure = expect res
                   } f
       
       Nothing -> -- discarded test
         do test st{ numDiscardedTests = numDiscardedTests st + 1
                   , randomSeed        = rnd2
                   , expectedFailure   = expect res
                   } f
         
       Just False -> -- failed test
         do if expect res
              then putPart (terminal st) (bold "*** Failed! ")
              else putPart (terminal st) "+++ OK, failed as expected. "
            putTemp (terminal st)
              ( short 30 (P.reason res)
             ++ " (after "
             ++ number (numSuccessTests st+1) "test"
             ++ ")..."
              )
            foundFailure st res ts
            if not (expect res) then
              return Success{ labels = summary st }
             else
              return Failure{ usedSeed    = randomSeed st -- correct! (this will be split first)
                            , usedSize    = size
                            , reason      = P.reason res
                            , labels      = summary st
                            }
 where
  (rnd1,rnd2) = split (randomSeed st)

summary :: State -> [(String,Int)]
summary st = reverse
           . sort
           . map (\ss -> (head ss, (length ss * 100) `div` numSuccessTests st))
           . group
           . sort
           $ [ concat (intersperse ", " s')
             | s <- collected st
             , let s' = [ t | (t,_) <- s ]
             , not (null s')
             ]

success :: State -> IO ()
success st =
  case labels ++ covers of
    []    -> do putLine (terminal st) "."
    [pt]  -> do putLine (terminal st)
                  ( " ("
                 ++ dropWhile isSpace pt
                 ++ ")."
                  )
    cases -> do putLine (terminal st) ":"
                sequence_ [ putLine (terminal st) pt | pt <- cases ]
 where
  labels = reverse
         . sort
         . map (\ss -> (showP ((length ss * 100) `div` numSuccessTests st) ++ head ss))
         . group
         . sort
         $ [ concat (intersperse ", " s')
           | s <- collected st
           , let s' = [ t | (t,0) <- s ]
           , not (null s')
           ]
  
  covers = [ ("only " ++ show occurP ++ "% " ++ fst (head lps) ++ "; not " ++ show reqP ++ "%")
           | lps <- groupBy first
                  . sort
                  $ [ lp
                    | lps <- collected st
                    , lp <- maxi lps
                    , snd lp > 0
                    ]
           , let occurP = (100 * length lps) `div` maxSuccessTests st
                 reqP   = maximum (map snd lps)
           , occurP < reqP
           ]
  
  (x,_) `first` (y,_) = x == y 

  maxi = map (\lps -> (fst (head lps), maximum (map snd lps)))
       . groupBy first
       . sort

  showP p = (if p < 10 then " " else "") ++ show p ++ "% "

--------------------------------------------------------------------------
-- main shrinking loop

foundFailure :: State -> P.Result -> [Rose (IO P.Result)] -> IO ()
foundFailure st res ts =
  do localMin st{ numTryShrinks = 0, isShrinking = True } res ts

localMin :: State -> P.Result -> [Rose (IO P.Result)] -> IO ()
localMin st res _ | P.interrupted res = localMinFound st res
localMin st res [] = localMinFound st res

localMin st res (t : ts) =
  do -- CALLBACK before_test
     MkRose mres' ts' <- protectRose t
     res' <- mres'
     putTemp (terminal st)
       ( short 35 (P.reason res)
      ++ " (after " ++ number (numSuccessTests st+1) "test"
      ++ concat [ " and "
               ++ show (numSuccessShrinks st)
               ++ concat [ "." ++ show (numTryShrinks st) | numTryShrinks st > 0 ]
               ++ " shrink"
               ++ (if numSuccessShrinks st == 1
                   && numTryShrinks st == 0
                   then "" else "s")
                | numSuccessShrinks st > 0 || numTryShrinks st > 0
                ]
      ++ ")..."
       )
     callbackPostTest st res'
     if ok res' == Just False
       then foundFailure st{ numSuccessShrinks = numSuccessShrinks st + 1 } res' ts'
       else localMin st{ numTryShrinks = numTryShrinks st + 1 } res ts

localMinFound :: State -> P.Result -> IO ()
localMinFound st res =
  do putLine (terminal st)
       ( P.reason res
      ++ " (after " ++ number (numSuccessTests st+1) "test"
      ++ concat [ " and " ++ number (numSuccessShrinks st) "shrink"
                | numSuccessShrinks st > 0
                ]
      ++ "):  "
       )
     callbackPostFinalFailure st res

--------------------------------------------------------------------------
-- callbacks

callbackPostTest :: State -> P.Result -> IO ()
callbackPostTest st res =
  sequence_ [ f st res | PostTest f <- callbacks res ]

callbackPostFinalFailure :: State -> P.Result -> IO ()
callbackPostFinalFailure st res =
  sequence_ [ f st res | PostFinalFailure f <- callbacks res ]

--------------------------------------------------------------------------
-- the end.