{-# LANGUAGE TemplateHaskell #-}

-- | This module exports TH utilities intended to be useful to users.
--
-- 'makeStore' can be used to generate a 'Store' instance for types,
-- when all the type variables also require 'Store' instances. If some
-- do not, then instead use "TH.Derive" like this:
--
-- @
-- \{\-\# LANGUAGE TemplateHaskell \#\-\}
-- \{\-\# LANGUAGE ScopedTypeVariables \#\-\}
--
-- import TH.Derive
-- import Data.Store
--
-- data Foo a = Foo a | Bar Int
--
-- \$($(derive [d|
--     instance Store a => Deriving (Store (Foo a))
--     |]))
-- @
--
-- Note that when used with datatypes that require type variables, the
-- ScopedTypeVariables extension is required.
--
-- One advantage of using this Template Haskell definition of Store
-- instances is that in some cases they can be faster than the instances
-- defined via Generics. Specifically, sum types which can yield
-- 'ConstSize' from 'size' will be faster when used in array-like types.
-- The instances generated via generics always use 'VarSize' for sum
-- types.
module Data.Store.TH
    ( makeStore
    -- * Testing Store instances
    , 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)

------------------------------------------------------------------------
-- Testing

-- | Test a 'Store' instance using 'smallcheck' and 'hspec'.
smallcheckManyStore :: Bool -> Int -> [TypeQ] -> ExpQ
smallcheckManyStore :: Bool -> Int -> [TypeQ] -> ExpQ
smallcheckManyStore Bool
verbose 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 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 (String
"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]
++ String
")", Exp
expr)

assertRoundtrip :: (Eq a, Show a, Store a, Fail.MonadFail m, Typeable a) => Bool -> a -> m ()
assertRoundtrip :: Bool -> a -> m ()
assertRoundtrip Bool
verbose 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
$ String
"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)

-- | Check if a given value succeeds in decoding its encoded
-- representation.
checkRoundtrip :: (Eq a, Show a, Store a) => Bool -> a -> Bool
checkRoundtrip :: Bool -> a -> Bool
checkRoundtrip Bool
verbose 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 String
"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 String
"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 (\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
>>= \(String
name, Exp
expr) -> ExpQ -> StmtQ
noBindS [e| it name $ $(return expr) |])

verboseTrace :: Show a => Bool -> String -> a -> a
verboseTrace :: Bool -> String -> a -> a
verboseTrace Bool
True String
msg 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 Bool
False String
_ a
x = a
x