QuickCheckWrapper.hs

{-# LANGUAGE FlexibleInstances,OverlappingInstances,UndecidableInstances,
             ExistentialQuantification,DeriveDataTypeable,ScopedTypeVariables,CPP #-}

--
-- Copyright (c) 2005,2009-2012 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,

  -- * Pending properties
  qcPending,

  -- * 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

import Test.Framework.TestManager
import Test.Framework.TestManagerInternal

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 =
    atomicModifyIORef' qcState $ \state -> (state { qc_args = args }, ())

-- | 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

-- | 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 (True, msg)
                       ,Handler $ \(e::SomeException) -> return $ Left (False, show (e::SomeException))]
                case res of
                  Left (isPending, err) ->
                      if isPending
                         then quickCheckTestPending err
                         else quickCheckTestError (Just err)
                  Right (Success { output=msg }) ->
                      quickCheckTestPass (adjustOutput msg)
                  Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) ->
                      if pendingPrefix `List.isPrefixOf` reason
                         then let pendingMsg = let s = drop (length pendingPrefix) reason
                                               in take (length s - length pendingSuffix) s
                              in quickCheckTestPending pendingMsg
                         else do let replay = "Replay argument: " ++ (show (show (Just (gen, size))))
                                 quickCheckTestFail (Just (adjustOutput msg ++ "\n" ++ replay))
                  Right (GaveUp { output=msg }) ->
                      quickCheckTestFail (Just (adjustOutput msg))
                  Right (NoExpectedFailure { output=msg }) ->
                      quickCheckTestFail (Just (adjustOutput msg))
                return ()
    where
      pendingPrefix = "Exception: 'QCPendingException \""
      pendingSuffix = "\"'"
      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 Testable a => QCAssertion a where
    argsModifier _ = id
    testable = AnyTestable

instance 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)