Util.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
module Test.Hspec.Core.QuickCheck.Util (
  liftHook
, aroundProperty

, QuickCheckResult(..)
, Status(..)
, QuickCheckFailure(..)
, parseQuickCheckResult

, formatNumbers

, mkGen
, newSeed
#ifdef TEST
, stripSuffix
, splitBy
#endif
) where

import           Prelude ()
import           Test.Hspec.Core.Compat

import           Data.Int
import           System.Random

import           Test.QuickCheck
import           Test.QuickCheck.Text (isOneLine)
import qualified Test.QuickCheck.Property as QCP
import           Test.QuickCheck.Property hiding (Result(..))
import           Test.QuickCheck.Gen
import           Test.QuickCheck.IO ()
import           Test.QuickCheck.Random
import qualified Test.QuickCheck.Test as QC (showTestCount)
import           Test.QuickCheck.State (State(..))

import           Test.Hspec.Core.Util

liftHook
  :: r
  -- ^ Default result, taken if the hook decides to not run the test
  -> ((a -> IO ()) -> IO ())
  -- ^ Hook: given an action to actually run the test, potentially does
  -- some IO actions before the test, runs it while supplying an argument (or
  -- skips it!), then may execute some more actions after running it.
  -> (a -> IO r)
  -- ^ The actual test being run, producing a result
  -> IO r
liftHook def hook inner = do
  ref <- newIORef def
  hook $ inner >=> writeIORef ref
  readIORef ref

aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property
aroundProperty hook p = MkProperty . MkGen $ \r n -> aroundProp hook $ \a -> (unGen . unProperty $ p a) r n

aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop
aroundProp hook p = MkProp $ aroundRose hook (\a -> unProp $ p a)

aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result
aroundRose hook r = ioRose $ do
  liftHook (return QCP.succeeded) hook $ \ a -> reduceRose (r a)

newSeed :: IO Int
newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$>
  newQCGen

mkGen :: Int -> QCGen
mkGen = mkQCGen

formatNumbers :: Int -> Int -> String
formatNumbers n shrinks = "(after " ++ pluralize n "test" ++ shrinks_ ++ ")"
  where
    shrinks_
      | shrinks > 0 = " and " ++ pluralize shrinks "shrink"
      | otherwise = ""

data QuickCheckResult = QuickCheckResult {
  quickCheckResultNumTests :: Int
, quickCheckResultInfo :: String
, quickCheckResultStatus :: Status
} deriving Show

data Status =
    QuickCheckSuccess
  | QuickCheckFailure QuickCheckFailure
  | QuickCheckOtherFailure String
  deriving Show

data QuickCheckFailure = QCFailure {
  quickCheckFailureNumShrinks :: Int
, quickCheckFailureException :: Maybe SomeException
, quickCheckFailureReason :: String
, quickCheckFailureCounterexample :: [String]
} deriving Show

parseQuickCheckResult :: Result -> QuickCheckResult
parseQuickCheckResult r = case r of
  Success {..} -> result output QuickCheckSuccess

  Failure {..} ->
    case stripSuffix outputWithoutVerbose output of
      Just xs -> result verboseOutput (QuickCheckFailure $ QCFailure numShrinks theException reason failingTestCase)
        where
          verboseOutput
            | xs == "*** Failed! " = ""
            | otherwise = maybeStripSuffix "*** Failed!" (strip xs)
      Nothing -> couldNotParse output
    where
      outputWithoutVerbose = reasonAndNumbers ++ unlines failingTestCase
      reasonAndNumbers
        | isOneLine reason = reason ++ " " ++ numbers ++ colonNewline
        | otherwise = numbers ++ colonNewline ++ ensureTrailingNewline reason
      numbers = formatNumbers numTests numShrinks
      colonNewline = ":\n"

  GaveUp {..} ->
    case stripSuffix outputWithoutVerbose output of
      Just info -> otherFailure info ("Gave up after " ++ numbers ++ "!")
      Nothing -> couldNotParse output
    where
      numbers = showTestCount numTests numDiscarded
      outputWithoutVerbose = "*** Gave up! Passed only " ++ numbers ++ " tests.\n"

  NoExpectedFailure {..} -> case splitBy "*** Failed! " output of
    Just (info, err) -> otherFailure info err
    Nothing -> couldNotParse output

  where
    result = QuickCheckResult (numTests r) . strip
    otherFailure info err = result info (QuickCheckOtherFailure $ strip err)
    couldNotParse = result "" . QuickCheckOtherFailure

showTestCount :: Int -> Int -> String
showTestCount success discarded = QC.showTestCount state
  where
    state = MkState {
      terminal                  = undefined
    , maxSuccessTests           = undefined
    , maxDiscardedRatio         = undefined
    , coverageConfidence        = undefined
#if MIN_VERSION_QuickCheck(2,15,0)
    , maxTestSize               = 0
    , replayStartSize           = undefined
#else
    , computeSize               = undefined
#endif
    , numTotMaxShrinks          = 0
    , numSuccessTests           = success
    , numDiscardedTests         = discarded
    , numRecentlyDiscardedTests = 0
    , labels                    = mempty
    , classes                   = mempty
    , tables                    = mempty
    , requiredCoverage          = mempty
    , expected                  = True
    , randomSeed                = mkGen 0
    , numSuccessShrinks         = 0
    , numTryShrinks             = 0
    , numTotTryShrinks          = 0
    }

ensureTrailingNewline :: String -> String
ensureTrailingNewline = unlines . lines

maybeStripPrefix :: String -> String -> String
maybeStripPrefix prefix m = fromMaybe m (stripPrefix prefix m)

maybeStripSuffix :: String -> String -> String
maybeStripSuffix suffix = reverse . maybeStripPrefix (reverse suffix) . reverse

stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse

splitBy :: String -> String -> Maybe (String, String)
splitBy sep xs = listToMaybe [
    (x, y) | (x, Just y) <- zip (inits xs) (map stripSep $ tails xs)
  ]
  where
    stripSep = stripPrefix sep