{-# LANGUAGE Rank2Types, CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
#ifndef NO_SAFE_HASKELL
{-# LANGUAGE Trustworthy #-}
#endif
module Test.QuickCheck.All(
quickCheckAll,
verboseCheckAll,
forAllProperties,
allProperties,
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
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
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
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
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
forAllProperties :: Q Exp
forAllProperties :: ExpQ
forAllProperties = [| runQuickCheckAll |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
allProperties
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
set_utf8_io_enc :: S.Handle -> IO S.Handle
#if __GLASGOW_HASKELL__ > 611
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
quickCheckAll :: Q Exp
quickCheckAll :: ExpQ
quickCheckAll = ExpQ
forAllProperties forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [| quickCheckResult |]
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