content: {-# 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
  