{-# 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 |] ExpQ -> ExpQ -> ExpQ
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 |] ExpQ -> ExpQ -> ExpQ
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 <- (Info -> Type) -> Q Info -> Q Type
forall a b. (a -> b) -> Q a -> Q b
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 = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
ty0
  ([Name]
polys, Cxt
ctx, Type
ty) <- Error -> Type -> Q ([Name], Cxt, Type)
deconstructType String -> a
Error
err Type
ty0
  case [Name]
polys of
    [] -> Exp -> ExpQ
forall a. a -> Q a
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 -> Q Type
monomorphiseType String -> a
Error
err Type
integer Type
ty
      Exp -> ExpQ
forall a. a -> Q a
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 Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
":[")
            isVar' String
_     = Bool
True
        in String -> Bool
isVar' (String -> Bool) -> (Name -> String) -> Name -> Bool
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
_)        = Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm
      plain (KindedTV Name
nm flag
_ Type
StarT) = Name -> m Name
forall a. a -> m a
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
_                     = String -> m Name
Error
err String
"Higher-kinded type variables in type"
  [Name]
xs' <- (TyVarBndr Specificity -> Q Name)
-> [TyVarBndr Specificity] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndr Specificity -> Q Name
forall {m :: * -> *} {flag}. Monad m => TyVarBndr flag -> m Name
plain [TyVarBndr Specificity]
xs
  ([Name], Cxt, Type) -> Q ([Name], Cxt, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name]
xs', Cxt
ctx, Type
ty)
deconstructType Error
_ Type
ty = ([Name], Cxt, Type) -> Q ([Name], Cxt, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], Type
ty)

monomorphiseType :: Error -> Type -> Type -> TypeQ
monomorphiseType :: Error -> Type -> Type -> Q Type
monomorphiseType Error
err Type
mono ty :: Type
ty@(VarT Name
n) = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
mono
monomorphiseType Error
err Type
mono (AppT Type
t1 Type
t2) = (Type -> Type -> Type) -> Q Type -> Q Type -> Q Type
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Type -> Type -> Type
AppT (Error -> Type -> Type -> Q Type
monomorphiseType String -> a
Error
err Type
mono Type
t1) (Error -> Type -> Type -> Q Type
monomorphiseType String -> a
Error
err Type
mono Type
t2)
monomorphiseType Error
err Type
mono ty :: Type
ty@(ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
_) = String -> Q Type
Error
err (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Higher-ranked type"
monomorphiseType Error
err Type
mono Type
ty = Type -> Q Type
forall a. a -> Q a
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 |] ExpQ -> ExpQ -> ExpQ
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
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
filename String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"<interactive>") (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. HasCallStack => String -> a
error String
"don't run this interactively"
  [String]
ls <- IO [String] -> Q [String]
forall a. IO a -> Q a
runIO ((String -> [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
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 = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>')) [String]
ls
      idents :: [(Int, String)]
idents = ((Int, String) -> (Int, String) -> Bool)
-> [(Int, String)] -> [(Int, String)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(Int, String)
x (Int, String)
y -> (Int, String) -> String
forall a b. (a, b) -> b
snd (Int, String)
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, String) -> String
forall a b. (a, b) -> b
snd (Int, String)
y) (((Int, String) -> Bool) -> [(Int, String)] -> [(Int, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
"prop_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (String -> Bool)
-> ((Int, String) -> String) -> (Int, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, String) -> String
forall a b. (a, b) -> b
snd) ([Int] -> [String] -> [(Int, String)]
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
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 Q () -> Q Bool -> Q Bool
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) Q Bool -> Q Bool -> Q Bool
forall a. Q a -> Q a -> Q a
`recover` (Name -> Q Info
reify (String -> Name
mkName String
x) Q Info -> Q Bool -> Q Bool
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
        if Bool
exists
         then [ExpQ] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
          [ [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE
            [ String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
l
            , [| property |] ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
monomorphic (String -> Name
mkName String
x)
            ]
          ]
         else [Exp] -> Q [Exp]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  ([[Exp]] -> Exp) -> Q [[Exp]] -> ExpQ
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Exp] -> Exp
ListE ([Exp] -> Exp) -> ([[Exp]] -> [Exp]) -> [[Exp]] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Exp]] -> [Exp]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (((Int, String) -> Q [Exp]) -> [(Int, String)] -> Q [[Exp]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int, String) -> Q [Exp]
quickCheckOne [(Int, String)]
idents) ExpQ -> Q Type -> ExpQ
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 IO Handle -> (Handle -> IO Handle) -> IO Handle
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    Handle -> IO Handle
set_utf8_io_enc IO Handle -> (Handle -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
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; Handle -> IO Handle
forall a. a -> IO a
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 ExpQ -> ExpQ -> ExpQ
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 ExpQ -> ExpQ -> ExpQ
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 =
  ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (IO [Bool] -> IO Bool)
-> (((String, Property) -> IO Bool) -> IO [Bool])
-> ((String, Property) -> IO Bool)
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Property)]
-> ((String, Property) -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, Property)]
ps (((String, Property) -> IO Bool) -> IO Bool)
-> ((String, Property) -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \(String
xs, Property
p) -> do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"=== " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ==="
    Result
r <- Property -> IO Result
qc Property
p
    String -> IO ()
putStrLn String
""
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ case Result
r of
      Success { } -> Bool
True
      Failure { } -> Bool
False
      NoExpectedFailure { } -> Bool
False
      GaveUp { } -> Bool
False