{-# LANGUAGE FlexibleInstances,OverlappingInstances,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,

  -- * Pending properties
  qcPending,

  -- * Internal functions
  testableAsAssertion, asTestableWithQCArgs,
  TestableWithQCArgs, WithQCArgs

) 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 Control.Concurrent.MVar

import Test.QuickCheck

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

data QCState = QCState { qc_args :: Args }

qcState :: MVar QCState
qcState = unsafePerformIO (newMVar (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 withMVar qcState $ \state -> return (state { qc_args = args })
       return ()

-- | Retrieve the 'Args' currently used per default when evaluating quick check properties.
getCurrentArgs :: IO Args
getCurrentArgs =
    withMVar qcState $ \state -> 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.
testableAsAssertion :: (Testable t, WithQCArgs t) => t -> Assertion
testableAsAssertion t =
    withMVar qcState $ \state ->
        do eitherArgs <-
               (let a = (argsModifier t) (qc_args state)
                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 t' <- evaluate t
                              x <- 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 TestableWithQCArgs = forall a . Testable a =>
                          TestableWithQCArgs (Args -> Args) a

instance Testable TestableWithQCArgs where
    property (TestableWithQCArgs _ t) = property t

-- | Type class providing access to the custom 'Args' of a quick check property.
--   Used only internally.
class WithQCArgs a where
    argsModifier :: a -> (Args -> Args)
    original :: a -> Maybe TestableWithQCArgs

instance WithQCArgs a where
    argsModifier _ = id
    original _ = Nothing

instance WithQCArgs TestableWithQCArgs where
    argsModifier (TestableWithQCArgs f _) = f
    original a = Just a

-- | Run a 'Test.QuickCheck' property with modified quick check arguments 'Args'.
withQCArgs :: (WithQCArgs a, Testable a) => (Args -> Args) -- ^ Modification function for the default 'Args'
           -> a                                            -- ^ Property
           -> TestableWithQCArgs
withQCArgs = TestableWithQCArgs

-- | Turns a 'Test.QuickCheck' property with custom 'Args' into an 'Assertion'. This function
-- is used internally in the code generated by @htfpp@, do not use it directly.
asTestableWithQCArgs :: (WithQCArgs a, Testable a) => a -> TestableWithQCArgs
asTestableWithQCArgs a =
    case original a of
      Just a' -> a'
      Nothing -> TestableWithQCArgs id a

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