#ifndef NO_SAFE_HASKELL
#endif
module Test.QuickCheck.All(
quickCheckAll,
verboseCheckAll,
forAllProperties,
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 x = [| quickCheck $(monomorphic x) |]
polyVerboseCheck :: Name -> ExpQ
polyVerboseCheck x = [| verboseCheck $(monomorphic x) |]
type Error = forall a. String -> a
monomorphic :: Name -> ExpQ
monomorphic t = do
ty0 <- fmap infoType (reify t)
let err msg = error $ msg ++ ": " ++ pprint ty0
(polys, ctx, ty) <- deconstructType err ty0
case polys of
[] -> return (VarE t)
_ -> do
integer <- [t| Integer |]
ty' <- monomorphiseType err integer ty
return (SigE (VarE t) ty')
infoType :: Info -> Type
infoType (ClassOpI _ ty _ _) = ty
infoType (DataConI _ ty _ _) = ty
infoType (VarI _ ty _ _) = ty
deconstructType :: Error -> Type -> Q ([Name], Cxt, Type)
deconstructType err ty0@(ForallT xs ctx ty) = do
let plain (PlainTV _) = True
#ifndef MIN_VERSION_template_haskell
plain (KindedTV _ StarT) = True
#else
#if MIN_VERSION_template_haskell(2,8,0)
plain (KindedTV _ StarT) = True
#else
plain (KindedTV _ StarK) = True
#endif
#endif
plain _ = False
unless (all plain xs) $ err "Higher-kinded type variables in type"
return (map (\(PlainTV x) -> x) xs, ctx, ty)
deconstructType _ ty = return ([], [], ty)
monomorphiseType :: Error -> Type -> Type -> TypeQ
monomorphiseType err mono ty@(VarT n) = return mono
monomorphiseType err mono (AppT t1 t2) = liftM2 AppT (monomorphiseType err mono t1) (monomorphiseType err mono t2)
monomorphiseType err mono ty@(ForallT _ _ _) = err $ "Higher-ranked type"
monomorphiseType err mono ty = return ty
forAllProperties :: Q Exp
forAllProperties = do
Loc { loc_filename = filename } <- location
when (filename == "<interactive>") $ error "don't run this interactively"
ls <- runIO (fmap lines (readUTF8File filename))
let prefixes = map (takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') . dropWhile (\c -> isSpace c || c == '>')) ls
idents = nubBy (\x y -> snd x == snd y) (filter (("prop_" `isPrefixOf`) . snd) (zip [1..] prefixes))
#if __GLASGOW_HASKELL__ > 705
warning x = reportWarning ("Name " ++ x ++ " 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 (l, x) = do
exists <- (warning x >> return False) `recover` (reify (mkName x) >> return True)
if exists then sequence [ [| ($(stringE $ x ++ " from " ++ filename ++ ":" ++ show l),
property $(monomorphic (mkName x))) |] ]
else return []
[| runQuickCheckAll $(fmap (ListE . concat) (mapM quickCheckOne idents)) |]
readUTF8File name = S.openFile name S.ReadMode >>=
set_utf8_io_enc >>=
S.hGetContents
set_utf8_io_enc :: S.Handle -> IO S.Handle
#if __GLASGOW_HASKELL__ > 611
set_utf8_io_enc h = do S.hSetEncoding h S.utf8; return h
#else
set_utf8_io_enc h = return h
#endif
quickCheckAll :: Q Exp
quickCheckAll = [| $(forAllProperties) quickCheckResult |]
verboseCheckAll :: Q Exp
verboseCheckAll = [| $(forAllProperties) verboseCheckResult |]
runQuickCheckAll :: [(String, Property)] -> (Property -> IO Result) -> IO Bool
runQuickCheckAll ps qc =
fmap and . forM ps $ \(xs, p) -> do
putStrLn $ "=== " ++ xs ++ " ==="
r <- qc p
putStrLn ""
return $ case r of
Success { } -> True
Failure { } -> False
NoExpectedFailure { } -> False
GaveUp { } -> False
InsufficientCoverage { } -> False