content: {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE CPP #-}
  
  --
  -- Copyright (c) 2005-2022 Stefan Wehr - http://www.stefanwehr.de
  --
  -- This library is free software; you can redistribute it and/or
  -- modify it under the terms of the GNU Lesser General Public
  -- License as published by the Free Software Foundation; either
  -- version 2.1 of the License, or (at your option) any later version.
  --
  -- This library is distributed in the hope that it will be useful,
  -- but WITHOUT ANY WARRANTY; without even the implied warranty of
  -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  -- Lesser General Public License for more details.
  --
  -- You should have received a copy of the GNU Lesser General Public
  -- License along with this library; if not, write to the Free Software
  -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
  --
  
  {- |
  
  This module integrates the 'Test.QuickCheck' library into HTF. It re-exports
  all functionality of 'Test.QuickCheck' and defines some additional functions.
  
  -}
  
  module Test.Framework.QuickCheckWrapper (
  
    module Test.QuickCheck,
  
    -- * Arguments for evaluating properties
    defaultArgs, getCurrentArgs, setDefaultArgs,
    withQCArgs, WithQCArgs, setReplayFromString,
    QCAssertion,
  
    -- * Pending properties
    qcPending,
  
    -- * Auxiliary functions
  #if !MIN_VERSION_QuickCheck(2,7,0)
    ioProperty,
  #endif
    assertionAsProperty,
  
    -- * Internal functions
    qcAssertion
  
  ) where
  
  #if !MIN_VERSION_base(4,6,0)
  import Prelude hiding ( catch )
  #endif
  import Control.Exception ( SomeException, Exception, Handler(..),
                             throw, catch, catches, evaluate )
  import Data.Typeable (Typeable)
  import Data.Char
  import qualified Data.List as List
  import System.IO.Unsafe (unsafePerformIO)
  import Data.IORef
  
  import Test.QuickCheck
  #if !MIN_VERSION_QuickCheck(2,7,0)
  import Test.QuickCheck.Property (morallyDubiousIOProperty)
  #endif
  import Test.Framework.TestInterface
  import Test.Framework.Utils
  
  _DEBUG_ :: Bool
  _DEBUG_ = False
  
  debug :: String -> IO ()
  debug s = if _DEBUG_ then putStrLn ("[DEBUG] " ++ s) else return ()
  
  data QCState = QCState { qc_args :: !Args }
  
  qcState :: IORef QCState
  qcState = unsafePerformIO (newIORef (QCState defaultArgs))
  {-# NOINLINE qcState #-}
  
  -- | The 'Args' used if not explicitly changed.
  defaultArgs :: Args
  defaultArgs = stdArgs { chatty = False }
  
  -- | Change the default 'Args' used to evaluate quick check properties.
  setDefaultArgs :: Args -> IO ()
  setDefaultArgs args =
      do force <- atomicModifyIORef qcState $ \state ->
                    let newState = state { qc_args = args }
                    in (newState, newState)
         force `seq` return ()
  
  -- | Retrieve the 'Args' currently used per default when evaluating quick check properties.
  getCurrentArgs :: IO Args
  getCurrentArgs =
      do state <- readIORef qcState
         return (qc_args state)
  
  data QCPendingException = QCPendingException String
                          deriving (Show,Read,Eq,Typeable)
  
  instance Exception QCPendingException
  
  quickCheckTestError :: Maybe String -> Assertion
  quickCheckTestError m = failHTF $ mkFullTestResult Error m
  
  quickCheckTestFail :: Maybe String -> Assertion
  quickCheckTestFail m = failHTF $ mkFullTestResult Fail m
  
  quickCheckTestPending :: String -> Assertion
  quickCheckTestPending m = failHTF $ mkFullTestResult Pending (Just m)
  
  quickCheckTestPass :: String -> Assertion
  quickCheckTestPass m = failHTF $ mkFullTestResult Pass (Just m)
  
  -- | Turns a 'Test.QuickCheck' property into an 'Assertion'. This function
  -- is used internally in the code generated by @htfpp@, do not use it directly.
  qcAssertion :: (QCAssertion t) => t -> Assertion
  qcAssertion qc =
      do origArgs <- getCurrentArgs
         eitherArgs <-
             (let a = (argsModifier qc) origArgs
              in do _ <- evaluate (length (show a))
                    return (Right a))
             `catch`
             (\e -> return $ Left (show (e :: SomeException)))
         case eitherArgs of
           Left err -> quickCheckTestError
                          (Just ("Cannot evaluate custom arguments: "
                                 ++ err))
           Right args ->
               do res <- do anyTestable <- evaluate (testable qc)
                            x <- case anyTestable of
                                   AnyTestable t' -> quickCheckWithResult args t'
                            return (Right x)
                        `catches`
                         [Handler $ \(QCPendingException msg) -> return $ Left msg]
                  debug ("QuickCheck result: " ++ show res)
                  case res of
                    Left err ->
                        quickCheckTestPending err
                    Right (Success { output=msg }) ->
                        quickCheckTestPass (adjustOutput msg)
                    Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) ->
                        case () of
                          _| pendingPrefix `List.isPrefixOf` reason ->
                               let pendingMsg = getPayload pendingPrefix pendingSuffix reason
                               in quickCheckTestPending pendingMsg
                           | failurePrefix `List.isPrefixOf` reason
                           , Just result <- readM (getPayload failurePrefix failureSuffix reason)
                              -> failHTF result
                           | otherwise ->
                               let replay = "Replay argument: " ++ (show (show (Just (gen, size))))
                                   out = adjustOutput msg
                               in quickCheckTestFail (Just (out ++ "\n" ++ replay))
                    Right (GaveUp { output=msg }) ->
                        quickCheckTestFail (Just (adjustOutput msg))
                    Right (NoExpectedFailure { output=msg }) ->
                        quickCheckTestFail (Just (adjustOutput msg))
  #if MIN_VERSION_QuickCheck(2,8,0) && !MIN_VERSION_QuickCheck(2,12,0)
                    Right (InsufficientCoverage { output=msg }) ->
                        quickCheckTestFail (Just (adjustOutput msg))
  #endif
                  return ()
      where
        pendingPrefix = "Exception: 'QCPendingException \""
        pendingSuffix = "\"'"
        failurePrefix = "Exception: 'HTFFailure "
        failureSuffix = "'"
        getPayload pref suf reason =
            let s = drop (length pref) reason
            in take (length s - length suf) s
        adjustOutput s = trimTrailing $
            case s of
              '+':'+':'+':' ':'O':'K':',':' ':'p':rest -> 'P':rest
              '*':'*':'*':' ':'F':'a':'i':'l':'e':'d':'!':' ':rest -> rest
              '*':'*':'*':' ':rest -> rest
              _ -> s
        trimTrailing = reverse . dropWhile isSpace . reverse
  
  -- | Abstract type for representing quick check properties with custom 'Args'.
  --   Used only internally.
  data WithQCArgs a = WithQCArgs (Args -> Args) a
  
  -- | Existential holding a 'Testable' value.
  --   Used only internally.
  data AnyTestable = forall a . Testable a => AnyTestable a
  
  -- | Type class providing access to the custom 'Args' of a quick check property.
  --   Used only internally.
  class QCAssertion a where
      argsModifier :: a -> (Args -> Args)
      testable :: a -> AnyTestable
  
  instance {-# OVERLAPPABLE #-} Testable a => QCAssertion a where
      argsModifier _ = id
      testable = AnyTestable
  
  instance {-# OVERLAPPING  #-} Testable a => QCAssertion (WithQCArgs a) where
      argsModifier (WithQCArgs f _) = f
      testable (WithQCArgs _ x) = AnyTestable x
  
  -- | Run a 'Test.QuickCheck' property with modified quick check arguments 'Args'.
  withQCArgs :: (Testable a) => (Args -> Args) -- ^ Modification function for the default 'Args'
             -> a                              -- ^ Property
             -> WithQCArgs a
  withQCArgs = WithQCArgs
  
  -- | Use @qcPending msg prop@ to mark the given quick check property as pending
  -- without removing it from the test suite and without deleting or commenting out the property code.
  qcPending :: Testable t => String -> t -> t
  qcPending msg _ = throw (QCPendingException msg)
  
  #if !MIN_VERSION_QuickCheck(2,7,0)
  ioProperty :: Testable prop => IO prop -> Property
  ioProperty = morallyDubiousIOProperty
  #endif
  
  assertionAsProperty :: IO () -> Property
  assertionAsProperty action =
      ioProperty $ action >> return True
  
  -- | Sets the 'replay' parameter of the 'Args' datatype by parsing the given string.
  setReplayFromString :: Args -> String -> Args
  setReplayFromString args str =
  #if !MIN_VERSION_QuickCheck(2,7,0)
      case readM str of
        Just x -> args { replay = x }
        Nothing -> error ("Could not parse replay parameter from string " ++ show str)
  #else
      -- Starting with QC 2.7 the type of the replay field changed from
      -- 'Maybe (StdGen, Int)' to 'Maybe (QCGen, Int)'
      case readM str of
        Just x -> args { replay = x }
        Nothing ->
            error ("Could not parse replay parameter from string " ++ show str)
  #endif
  