{-# LANGUAGE TemplateHaskell, Rank2Types, CPP #-}
#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
import Control.Monad
import qualified System.IO as S
polyQuickCheck :: Name -> ExpQ
polyQuickCheck :: Name -> ExpQ
polyQuickCheck Name
x = [| quickCheck $(monomorphic x) |]
polyVerboseCheck :: Name -> ExpQ
polyVerboseCheck :: Name -> ExpQ
polyVerboseCheck Name
x = [| verboseCheck $(monomorphic 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 (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
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
forAllProperties :: Q Exp
forAllProperties :: ExpQ
forAllProperties = [| runQuickCheckAll $allProperties |]
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
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 (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 = [| $(forAllProperties) quickCheckResult |]
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