{-# LANGUAGE Rank2Types, CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
#ifndef NO_SAFE_HASKELL
{-# LANGUAGE Trustworthy #-}
#endif

-- | __Note__: the contents of this module are re-exported by
-- "Test.QuickCheck". You do not need to import it directly.
--
-- Test all properties in the current module, using Template Haskell.
-- You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@ pragma in
-- your module for any of these to work.
module Test.QuickCheck.All(
  -- ** Testing all properties in a module
  quickCheckAll,
  verboseCheckAll,
  forAllProperties,
  allProperties,
  -- ** Testing polymorphic properties
  polyQuickCheck,
  polyVerboseCheck,
  monomorphic) where

import Language.Haskell.TH
import Test.QuickCheck.Property hiding (Result)
import Test.QuickCheck.Test
import Data.Char
import Data.List (isPrefixOf, nubBy)
import Control.Monad

import qualified System.IO as S

-- | Test a polymorphic property, defaulting all type variables to 'Integer'.
--
-- Invoke as @$('polyQuickCheck' 'prop)@, where @prop@ is a property.
-- Note that just evaluating @'quickCheck' prop@ in GHCi will seem to
-- work, but will silently default all type variables to @()@!
--
-- @$('polyQuickCheck' \'prop)@ means the same as
-- @'quickCheck' $('monomorphic' \'prop)@.
-- If you want to supply custom arguments to 'polyQuickCheck',
-- you will have to combine 'quickCheckWith' and 'monomorphic' yourself.
--
-- If you want to use 'polyQuickCheck' in the same file where you defined the
-- property, the same scoping problems pop up as in 'quickCheckAll':
-- see the note there about @return []@.
polyQuickCheck :: Name -> ExpQ
polyQuickCheck :: Name -> ExpQ
polyQuickCheck Name
x = [| quickCheck |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
monomorphic Name
x

-- | Test a polymorphic property, defaulting all type variables to 'Integer'.
-- This is just a convenience function that combines 'verboseCheck' and 'monomorphic'.
--
-- If you want to use 'polyVerboseCheck' in the same file where you defined the
-- property, the same scoping problems pop up as in 'quickCheckAll':
-- see the note there about @return []@.
polyVerboseCheck :: Name -> ExpQ
polyVerboseCheck :: Name -> ExpQ
polyVerboseCheck Name
x = [| verboseCheck |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
monomorphic Name
x

type Error = forall a. String -> a

-- | Monomorphise an arbitrary property by defaulting all type variables to 'Integer'.
--
-- For example, if @f@ has type @'Ord' a => [a] -> [a]@
-- then @$('monomorphic' 'f)@ has type @['Integer'] -> ['Integer']@.
--
-- If you want to use 'monomorphic' in the same file where you defined the
-- property, the same scoping problems pop up as in 'quickCheckAll':
-- see the note there about @return []@.
monomorphic :: Name -> ExpQ
monomorphic :: Name -> ExpQ
monomorphic Name
t = do
  Type
ty0 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Info -> Type
infoType (Name -> Q Info
reify Name
t)
  let err :: String -> a
err String
msg = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
msg forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
ty0
  ([Name]
polys, Cxt
ctx, Type
ty) <- Error -> Type -> Q ([Name], Cxt, Type)
deconstructType Error
err Type
ty0
  case [Name]
polys of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
expName Name
t)
    [Name]
_ -> do
      Type
integer <- [t| Integer |]
      Type
ty' <- Error -> Type -> Type -> TypeQ
monomorphiseType Error
err Type
integer Type
ty
      forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Type -> Exp
SigE (Name -> Exp
expName Name
t) Type
ty')

expName :: Name -> Exp
expName :: Name -> Exp
expName Name
n = if Name -> Bool
isVar Name
n then Name -> Exp
VarE Name
n else Name -> Exp
ConE Name
n

-- See section 2.4 of the Haskell 2010 Language Report, plus support for "[]"
isVar :: Name -> Bool
isVar :: Name -> Bool
isVar = let isVar' :: String -> Bool
isVar' (Char
c:String
_) = Bool -> Bool
not (Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
":[")
            isVar' String
_     = Bool
True
        in String -> Bool
isVar' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

infoType :: Info -> Type
#if MIN_VERSION_template_haskell(2,11,0)
infoType :: Info -> Type
infoType (ClassOpI Name
_ Type
ty Name
_) = Type
ty
infoType (DataConI Name
_ Type
ty Name
_) = Type
ty
infoType (VarI Name
_ Type
ty Maybe Dec
_) = Type
ty
#else
infoType (ClassOpI _ ty _ _) = ty
infoType (DataConI _ ty _ _) = ty
infoType (VarI _ ty _ _) = ty
#endif

deconstructType :: Error -> Type -> Q ([Name], Cxt, Type)
deconstructType :: Error -> Type -> Q ([Name], Cxt, Type)
deconstructType Error
err (ForallT [TyVarBndr Specificity]
xs Cxt
ctx Type
ty) = do
#if MIN_VERSION_template_haskell(2,17,0)
  let plain :: TyVarBndr flag -> m Name
plain (PlainTV Name
nm flag
_)        = forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm
      plain (KindedTV Name
nm flag
_ Type
StarT) = forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm
#else
  let plain (PlainTV nm)          = return nm
#  if MIN_VERSION_template_haskell(2,8,0)
      plain (KindedTV nm StarT)   = return nm
#  else
      plain (KindedTV nm StarK)   = return nm
#  endif
#endif
      plain TyVarBndr flag
_                     = Error
err String
"Higher-kinded type variables in type"
  [Name]
xs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {flag}. Monad m => TyVarBndr flag -> m Name
plain [TyVarBndr Specificity]
xs
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Name]
xs', Cxt
ctx, Type
ty)
deconstructType Error
_ Type
ty = forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], Type
ty)

monomorphiseType :: Error -> Type -> Type -> TypeQ
monomorphiseType :: Error -> Type -> Type -> TypeQ
monomorphiseType Error
err Type
mono ty :: Type
ty@(VarT Name
n) = forall (m :: * -> *) a. Monad m => a -> m a
return Type
mono
monomorphiseType Error
err Type
mono (AppT Type
t1 Type
t2) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Type -> Type -> Type
AppT (Error -> Type -> Type -> TypeQ
monomorphiseType Error
err Type
mono Type
t1) (Error -> Type -> Type -> TypeQ
monomorphiseType Error
err Type
mono Type
t2)
monomorphiseType Error
err Type
mono ty :: Type
ty@(ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
_) = Error
err forall a b. (a -> b) -> a -> b
$ String
"Higher-ranked type"
monomorphiseType Error
err Type
mono Type
ty = forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty

-- | Test all properties in the current module, using a custom
-- 'quickCheck' function. The same caveats as with 'quickCheckAll'
-- apply.
--
-- @$'forAllProperties'@ has type @('Property' -> 'IO' 'Result') -> 'IO' 'Bool'@.
-- An example invocation is @$'forAllProperties' 'quickCheckResult'@,
-- which does the same thing as @$'quickCheckAll'@.
--
-- 'forAllProperties' has the same issue with scoping as 'quickCheckAll':
-- see the note there about @return []@.
forAllProperties :: Q Exp -- :: (Property -> IO Result) -> IO Bool
forAllProperties :: ExpQ
forAllProperties = [| runQuickCheckAll |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
allProperties

-- | List all properties in the current module.
--
-- @$'allProperties'@ has type @[('String', 'Property')]@.
--
-- 'allProperties' has the same issue with scoping as 'quickCheckAll':
-- see the note there about @return []@.
allProperties :: Q Exp
allProperties :: ExpQ
allProperties = do
  Loc { loc_filename :: Loc -> String
loc_filename = String
filename } <- Q Loc
location
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
filename forall a. Eq a => a -> a -> Bool
== String
"<interactive>") forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"don't run this interactively"
  [String]
ls <- forall a. IO a -> Q a
runIO (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
lines (String -> IO String
readUTF8File String
filename))
  let prefixes :: [String]
prefixes = forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'>')) [String]
ls
      idents :: [(Int, String)]
idents = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(Int, String)
x (Int, String)
y -> forall a b. (a, b) -> b
snd (Int, String)
x forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> b
snd (Int, String)
y) (forall a. (a -> Bool) -> [a] -> [a]
filter ((String
"prop_" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [String]
prefixes))
#if MIN_VERSION_template_haskell(2,8,0)
      warning :: String -> Q ()
warning String
x = String -> Q ()
reportWarning (String
"Name " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
" found in source file but was not in scope")
#else
      warning x = report False ("Name " ++ x ++ " found in source file but was not in scope")
#endif
      quickCheckOne :: (Int, String) -> Q [Exp]
      quickCheckOne :: (Int, String) -> Q [Exp]
quickCheckOne (Int
l, String
x) = do
        Bool
exists <- (String -> Q ()
warning String
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) forall a. Q a -> Q a -> Q a
`recover` (Name -> Q Info
reify (String -> Name
mkName String
x) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
        if Bool
exists
         then forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
          [ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE
            [ forall (m :: * -> *). Quote m => String -> m Exp
stringE forall a b. (a -> b) -> a -> b
$ String
x forall a. [a] -> [a] -> [a]
++ String
" from " forall a. [a] -> [a] -> [a]
++ String
filename forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
l
            , [| property |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
monomorphic (String -> Name
mkName String
x)
            ]
          ]
         else forall (m :: * -> *) a. Monad m => a -> m a
return []
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, String) -> Q [Exp]
quickCheckOne [(Int, String)]
idents) forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`sigE` [t| [(String, Property)] |]

readUTF8File :: String -> IO String
readUTF8File String
name = String -> IOMode -> IO Handle
S.openFile String
name IOMode
S.ReadMode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    Handle -> IO Handle
set_utf8_io_enc forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    Handle -> IO String
S.hGetContents

-- Deal with UTF-8 input and output.
set_utf8_io_enc :: S.Handle -> IO S.Handle
#if __GLASGOW_HASKELL__ > 611
-- possibly if MIN_VERSION_base(4,2,0)
set_utf8_io_enc :: Handle -> IO Handle
set_utf8_io_enc Handle
h = do Handle -> TextEncoding -> IO ()
S.hSetEncoding Handle
h TextEncoding
S.utf8; forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h
#else
set_utf8_io_enc h = return h
#endif

-- | Test all properties in the current module.
-- The name of the property must begin with @prop_@.
-- Polymorphic properties will be defaulted to 'Integer'.
-- Returns 'True' if all tests succeeded, 'False' otherwise.
--
-- To use 'quickCheckAll', add a definition to your module along
-- the lines of
--
-- > return []
-- > runTests = $quickCheckAll
--
-- and then execute @runTests@.
--
-- Note: the bizarre @return []@ in the example above is needed on
-- GHC 7.8 and later; without it, 'quickCheckAll' will not be able to find
-- any of the properties. For the curious, the @return []@ is a
-- Template Haskell splice that makes GHC insert the empty list
-- of declarations at that point in the program; GHC typechecks
-- everything before the @return []@ before it starts on the rest
-- of the module, which means that the later call to 'quickCheckAll'
-- can see everything that was defined before the @return []@. Yikes!
quickCheckAll :: Q Exp
quickCheckAll :: ExpQ
quickCheckAll = ExpQ
forAllProperties forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [| quickCheckResult |]

-- | Test all properties in the current module.
-- This is just a convenience function that combines 'quickCheckAll' and 'verbose'.
--
-- 'verboseCheckAll' has the same issue with scoping as 'quickCheckAll':
-- see the note there about @return []@.
verboseCheckAll :: Q Exp
verboseCheckAll :: ExpQ
verboseCheckAll = ExpQ
forAllProperties forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [| verboseCheckResult |]

runQuickCheckAll :: [(String, Property)] -> (Property -> IO Result) -> IO Bool
runQuickCheckAll :: [(String, Property)] -> (Property -> IO Result) -> IO Bool
runQuickCheckAll [(String, Property)]
ps Property -> IO Result
qc =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, Property)]
ps forall a b. (a -> b) -> a -> b
$ \(String
xs, Property
p) -> do
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"=== " forall a. [a] -> [a] -> [a]
++ String
xs forall a. [a] -> [a] -> [a]
++ String
" ==="
    Result
r <- Property -> IO Result
qc Property
p
    String -> IO ()
putStrLn String
""
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Result
r of
      Success { } -> Bool
True
      Failure { } -> Bool
False
      NoExpectedFailure { } -> Bool
False
      GaveUp { } -> Bool
False