{-# 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
`appE` Name -> ExpQ
monomorphic Name
x
polyVerboseCheck :: Name -> ExpQ
polyVerboseCheck :: Name -> ExpQ
polyVerboseCheck Name
x = [| verboseCheck |] ExpQ -> ExpQ -> ExpQ
`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 (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 |] ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
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
[ [ExpQ] -> ExpQ
tupE
[ [Char] -> ExpQ
stringE ([Char] -> ExpQ) -> [Char] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" from " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
filename [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
l
, [| property |] ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
monomorphic ([Char] -> Name
mkName [Char]
x)
]
]
else [Exp] -> Q [Exp]
forall (m :: * -> *) a. Monad m => a -> m a
return []
([[Exp]] -> Exp) -> Q [[Exp]] -> ExpQ
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, [Char]) -> Q [Exp]) -> [(Int, [Char])] -> Q [[Exp]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, [Char]) -> Q [Exp]
quickCheckOne [(Int, [Char])]
idents) ExpQ -> Q Type -> ExpQ
`sigE` [t| [(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 = ExpQ
forAllProperties ExpQ -> ExpQ -> ExpQ
`appE` [| quickCheckResult |]
verboseCheckAll :: Q Exp
verboseCheckAll :: ExpQ
verboseCheckAll = ExpQ
forAllProperties ExpQ -> ExpQ -> ExpQ
`appE` [| 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