{-# 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *}. Quote m => m Type -> m (String, Exp)
testRoundtrip
  where
    testRoundtrip :: m Type -> m (String, Exp)
testRoundtrip m Type
tyq = do
        Type
ty <- m Type
tyq
        Exp
expr <- [e| property $ changeDepth (\_ -> depth) $ \x -> checkRoundtrip verbose (x :: $(return ty)) |]
        forall (m :: * -> *) a. Monad m => a -> m a
return (String
"Roundtrips (" forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
ty forall a. [a] -> [a] -> [a]
++ String
")", Exp
expr)

assertRoundtrip :: (Eq a, Show a, Store a, Fail.MonadFail m, Typeable a) => Bool -> a -> m ()
assertRoundtrip :: forall a (m :: * -> *).
(Eq a, Show a, Store a, MonadFail m, Typeable a) =>
Bool -> a -> m ()
assertRoundtrip Bool
verbose a
x
    | forall a. (Eq a, Show a, Store a) => Bool -> a -> Bool
checkRoundtrip Bool
verbose a
x = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to roundtrip "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (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 :: forall a. (Eq a, Show a, Store a) => Bool -> a -> Bool
checkRoundtrip Bool
verbose a
x = Either PeekException a
decoded forall a. Eq a => a -> a -> Bool
== forall a b. b -> Either a b
Right a
x
  where
    encoded :: ByteString
encoded = forall a. Show a => Bool -> String -> a -> a
verboseTrace Bool
verbose String
"encoded" (forall a. Store a => a -> ByteString
encode a
x)
    decoded :: Either PeekException a
decoded = forall a. Show a => Bool -> String -> a -> a
verboseTrace Bool
verbose String
"decoded" (forall a. Store a => ByteString -> Either PeekException a
decode ByteString
encoded)

smallcheckMany :: [Q (String, Exp)] -> ExpQ
smallcheckMany :: [Q (String, Exp)] -> ExpQ
smallcheckMany = forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Q (String, Exp)
f -> Q (String, Exp)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(String
name, Exp
expr) -> forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS [e| it name $ $(return expr) |])

verboseTrace :: Show a => Bool -> String -> a -> a
verboseTrace :: forall a. Show a => Bool -> String -> a -> a
verboseTrace Bool
True String
msg a
x = forall a. String -> a -> a
trace (forall a. Show a => a -> String
show (String
msg, a
x)) a
x
verboseTrace Bool
False String
_ a
x = a
x