{-# LANGUAGE TemplateHaskell #-}
module Data.Store.TH
( makeStore
, smallcheckManyStore
, checkRoundtrip
, assertRoundtrip
) where
import qualified Control.Monad.Fail as Fail
import Data.Complex ()
import Data.Store.Impl
import Data.Typeable (Typeable, typeOf)
import Debug.Trace (trace)
import Language.Haskell.TH
import Prelude
import Test.Hspec
import Test.Hspec.SmallCheck (property)
import Test.SmallCheck
import Data.Store.TH.Internal (makeStore)
smallcheckManyStore :: Bool -> Int -> [TypeQ] -> ExpQ
smallcheckManyStore :: Bool -> Int -> [TypeQ] -> ExpQ
smallcheckManyStore verbose :: Bool
verbose depth :: Int
depth = [Q (String, Exp)] -> ExpQ
smallcheckMany ([Q (String, Exp)] -> ExpQ)
-> ([TypeQ] -> [Q (String, Exp)]) -> [TypeQ] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeQ -> Q (String, Exp)) -> [TypeQ] -> [Q (String, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map TypeQ -> Q (String, Exp)
testRoundtrip
where
testRoundtrip :: TypeQ -> Q (String, Exp)
testRoundtrip tyq :: TypeQ
tyq = do
Type
ty <- TypeQ
tyq
Exp
expr <- [e| property $ changeDepth (\_ -> depth) $ \x -> checkRoundtrip verbose (x :: $(return ty)) |]
(String, Exp) -> Q (String, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return ("Roundtrips (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")", Exp
expr)
assertRoundtrip :: (Eq a, Show a, Store a, Fail.MonadFail m, Typeable a) => Bool -> a -> m ()
assertRoundtrip :: Bool -> a -> m ()
assertRoundtrip verbose :: Bool
verbose x :: a
x
| Bool -> a -> Bool
forall a. (Eq a, Show a, Store a) => Bool -> a -> Bool
checkRoundtrip Bool
verbose a
x = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "Failed to roundtrip " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
x)
checkRoundtrip :: (Eq a, Show a, Store a) => Bool -> a -> Bool
checkRoundtrip :: Bool -> a -> Bool
checkRoundtrip verbose :: Bool
verbose x :: a
x = Either PeekException a
decoded Either PeekException a -> Either PeekException a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Either PeekException a
forall a b. b -> Either a b
Right a
x
where
encoded :: ByteString
encoded = Bool -> String -> ByteString -> ByteString
forall a. Show a => Bool -> String -> a -> a
verboseTrace Bool
verbose "encoded" (a -> ByteString
forall a. Store a => a -> ByteString
encode a
x)
decoded :: Either PeekException a
decoded = Bool -> String -> Either PeekException a -> Either PeekException a
forall a. Show a => Bool -> String -> a -> a
verboseTrace Bool
verbose "decoded" (ByteString -> Either PeekException a
forall a. Store a => ByteString -> Either PeekException a
decode ByteString
encoded)
smallcheckMany :: [Q (String, Exp)] -> ExpQ
smallcheckMany :: [Q (String, Exp)] -> ExpQ
smallcheckMany = [StmtQ] -> ExpQ
doE ([StmtQ] -> ExpQ)
-> ([Q (String, Exp)] -> [StmtQ]) -> [Q (String, Exp)] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q (String, Exp) -> StmtQ) -> [Q (String, Exp)] -> [StmtQ]
forall a b. (a -> b) -> [a] -> [b]
map (\f :: Q (String, Exp)
f -> Q (String, Exp)
f Q (String, Exp) -> ((String, Exp) -> StmtQ) -> StmtQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(name :: String
name, expr :: Exp
expr) -> ExpQ -> StmtQ
noBindS [e| it name $ $(return expr) |])
verboseTrace :: Show a => Bool -> String -> a -> a
verboseTrace :: Bool -> String -> a -> a
verboseTrace True msg :: String
msg x :: a
x = String -> a -> a
forall a. String -> a -> a
trace ((String, a) -> String
forall a. Show a => a -> String
show (String
msg, a
x)) a
x
verboseTrace False _ x :: a
x = a
x