{-# 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 |] ExpQ -> ExpQ -> ExpQ
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 |] 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
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
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
forAllProperties :: Q Exp
forAllProperties :: ExpQ
forAllProperties = [| runQuickCheckAll |] ExpQ -> ExpQ -> ExpQ
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
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
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; 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
quickCheckAll :: Q Exp
quickCheckAll :: ExpQ
quickCheckAll = ExpQ
forAllProperties ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [| quickCheckResult |]
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