{-# LANGUAGE TemplateHaskell, Rank2Types, CPP #-}
#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
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 $(monomorphic 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 $(monomorphic 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Info -> Type
infoType (Name -> Q Info
reify Name
t)
  let err :: [Char] -> a
err [Char]
msg = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
msg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
ty0
  ([Name]
polys, Cxt
ctx, Type
ty) <- Error -> Type -> Q ([Name], Cxt, Type)
deconstructType Error
err Type
ty0
  case [Name]
polys of
    [] -> Exp -> ExpQ
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 Error
err Type
integer Type
ty
      Exp -> ExpQ
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' :: [Char] -> Bool
isVar' (Char
c:[Char]
_) = Bool -> Bool
not (Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
":[")
            isVar' [Char]
_     = Bool
True
        in [Char] -> Bool
isVar' ([Char] -> Bool) -> (Name -> [Char]) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
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]
xs Cxt
ctx Type
ty) = do
#if MIN_VERSION_template_haskell(2,17,0)
  let plain (PlainTV nm _)        = return nm
      plain (KindedTV nm _ StarT) = return nm
#else
  let plain :: TyVarBndr -> m Name
plain (PlainTV Name
nm)          = Name -> m Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm
#  if MIN_VERSION_template_haskell(2,8,0)
      plain (KindedTV Name
nm Type
StarT)   = Name -> m Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
nm
#  else
      plain (KindedTV nm StarK)   = return nm
#  endif
#endif
      plain TyVarBndr
_                     = [Char] -> m Name
Error
err [Char]
"Higher-kinded type variables in type"
  [Name]
xs' <- (TyVarBndr -> Q Name) -> [TyVarBndr] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> Q Name
forall (m :: * -> *). Monad m => TyVarBndr -> m Name
plain [TyVarBndr]
xs
  ([Name], Cxt, Type) -> Q ([Name], Cxt, Type)
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 (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 (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 Error
err Type
mono Type
t1) (Error -> Type -> Type -> Q Type
monomorphiseType Error
err Type
mono Type
t2)
monomorphiseType Error
err Type
mono ty :: Type
ty@(ForallT [TyVarBndr]
_ Cxt
_ Type
_) = [Char] -> Q Type
Error
err ([Char] -> Q Type) -> [Char] -> Q Type
forall a b. (a -> b) -> a -> b
$ [Char]
"Higher-ranked type"
monomorphiseType Error
err Type
mono Type
ty = Type -> Q Type
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 $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 -> [Char]
loc_filename = [Char]
filename } <- Q Loc
location
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
filename [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"<interactive>") (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
forall a. HasCallStack => [Char] -> a
error [Char]
"don't run this interactively"
  [[Char]]
ls <- IO [[Char]] -> Q [[Char]]
forall a. IO a -> Q a
runIO (([Char] -> [[Char]]) -> IO [Char] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> [[Char]]
lines ([Char] -> IO [Char]
readUTF8File [Char]
filename))
  let prefixes :: [[Char]]
prefixes = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> [Char] -> [Char]
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
'\'') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
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
'>')) [[Char]]
ls
      idents :: [(Int, [Char])]
idents = ((Int, [Char]) -> (Int, [Char]) -> Bool)
-> [(Int, [Char])] -> [(Int, [Char])]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(Int, [Char])
x (Int, [Char])
y -> (Int, [Char]) -> [Char]
forall a b. (a, b) -> b
snd (Int, [Char])
x [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, [Char]) -> [Char]
forall a b. (a, b) -> b
snd (Int, [Char])
y) (((Int, [Char]) -> Bool) -> [(Int, [Char])] -> [(Int, [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char]
"prop_" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([Char] -> Bool)
-> ((Int, [Char]) -> [Char]) -> (Int, [Char]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [Char]) -> [Char]
forall a b. (a, b) -> b
snd) ([Int] -> [[Char]] -> [(Int, [Char])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [[Char]]
prefixes))
#if MIN_VERSION_template_haskell(2,8,0)
      warning :: [Char] -> Q ()
warning [Char]
x = [Char] -> Q ()
reportWarning ([Char]
"Name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" 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, [Char]) -> Q [Exp]
quickCheckOne (Int
l, [Char]
x) = do
        Bool
exists <- ([Char] -> Q ()
warning [Char]
x Q () -> Q Bool -> Q Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Q Bool
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 ([Char] -> Name
mkName [Char]
x) Q Info -> Q Bool -> Q Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Q Bool
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)
sequence [ [| ($(stringE $ x ++ " from " ++ filename ++ ":" ++ show l),
                                     property $(monomorphic (mkName x))) |] ]
         else [Exp] -> Q [Exp]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  [| $(fmap (ListE . concat) (mapM quickCheckOne idents)) :: [(String, Property)] |]

readUTF8File :: [Char] -> IO [Char]
readUTF8File [Char]
name = [Char] -> IOMode -> IO Handle
S.openFile [Char]
name IOMode
S.ReadMode IO Handle -> (Handle -> IO Handle) -> IO Handle
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    Handle -> IO Handle
set_utf8_io_enc IO Handle -> (Handle -> IO [Char]) -> IO [Char]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    Handle -> IO [Char]
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 (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 = [| $(forAllProperties) 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 = [| $(forAllProperties) verboseCheckResult |]

runQuickCheckAll :: [(String, Property)] -> (Property -> IO Result) -> IO Bool
runQuickCheckAll :: [([Char], Property)] -> (Property -> IO Result) -> IO Bool
runQuickCheckAll [([Char], Property)]
ps Property -> IO Result
qc =
  ([Bool] -> Bool) -> IO [Bool] -> IO Bool
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)
-> ((([Char], Property) -> IO Bool) -> IO [Bool])
-> (([Char], Property) -> IO Bool)
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Char], Property)]
-> (([Char], Property) -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], Property)]
ps ((([Char], Property) -> IO Bool) -> IO Bool)
-> (([Char], Property) -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \([Char]
xs, Property
p) -> do
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"=== " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
xs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ==="
    Result
r <- Property -> IO Result
qc Property
p
    [Char] -> IO ()
putStrLn [Char]
""
    Bool -> IO Bool
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