{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RequiredTypeArguments #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Test.Hindsight.Generate (
createRoundtripTests,
createGoldenTests,
GoldenTestConfig (..),
defaultGoldenTestConfig,
ValidTestPayloadForVersion,
)
where
import Data.Aeson (ToJSON, decode, encode)
import Data.Aeson.Encode.Pretty qualified as AE
import Data.ByteString.Lazy qualified as BL
import Data.Kind (Type)
import Data.Text qualified as T
import Data.Typeable (Proxy (..), Typeable)
import GHC.TypeLits
import Hindsight.Events
import System.FilePath ((</>))
import Test.QuickCheck
import Test.QuickCheck.Gen (unGen)
import Test.QuickCheck.Random (mkQCGen)
import Test.Tasty
import Test.Tasty.Golden (goldenVsString)
import Test.Tasty.QuickCheck (testProperty)
data GoldenTestConfig = GoldenTestConfig
{ GoldenTestConfig
-> forall (event :: Symbol) (ver :: PeanoNat).
(Event event, ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> FilePath
goldenPathFor :: forall event ver. (Event event, ReifiablePeanoNat ver) => Proxy event -> Proxy ver -> FilePath
, GoldenTestConfig -> forall a. Num a => a
goldenTestCaseCount :: forall a. (Num a) => a
, GoldenTestConfig -> forall a. Num a => a
goldenTestSeed :: forall a. (Num a) => a
, GoldenTestConfig -> forall a. Num a => a
goldenTestSizeParam :: forall a. (Num a) => a
}
type TestPayloadRequirements event idx payload = (VersionPayloadRequirements event idx payload, Arbitrary payload)
class (TestPayloadRequirements event idx payload) => ValidTestPayloadForVersion (event :: Symbol) (idx :: PeanoNat) (payload :: Type)
instance (TestPayloadRequirements event idx payload) => ValidTestPayloadForVersion event idx payload
defaultGoldenTestConfig :: GoldenTestConfig
defaultGoldenTestConfig :: GoldenTestConfig
defaultGoldenTestConfig =
GoldenTestConfig
{ goldenPathFor :: forall (event :: Symbol) (ver :: PeanoNat).
(Event event, ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> FilePath
goldenPathFor = \(Proxy event
_pEvent :: Proxy event) (Proxy ver
_ :: Proxy ver) ->
let name :: Text
name = getEventName event
version :: FilePath
version = Integer -> FilePath
forall a. Show a => a -> FilePath
show (Integer -> FilePath) -> Integer -> FilePath
forall a b. (a -> b) -> a -> b
$ forall (n :: PeanoNat). ReifiablePeanoNat n => Integer
reifyPeanoNat @ver
in FilePath
"test/golden/events" FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack Text
name FilePath -> FilePath -> FilePath
</> (FilePath
version FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".json")
, goldenTestCaseCount :: forall a. Num a => a
goldenTestCaseCount = a
forall a. Num a => a
10
, goldenTestSeed :: forall a. Num a => a
goldenTestSeed = a
forall a. Num a => a
42
, goldenTestSizeParam :: forall a. Num a => a
goldenTestSizeParam = a
forall a. Num a => a
30
}
generateTest ::
forall event.
String ->
( forall ver payload.
( ValidTestPayloadForVersion event ver payload
, Typeable ver
, ReifiablePeanoNat ver
) =>
Proxy event ->
Proxy ver ->
Proxy payload ->
TestTree
) ->
VersionConstraints (EventVersionVector event) (ValidTestPayloadForVersion event) ->
TestTree
generateTest :: forall (event :: Symbol).
FilePath
-> (forall (ver :: PeanoNat) payload.
(ValidTestPayloadForVersion event ver payload, Typeable ver,
ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> Proxy payload -> TestTree)
-> VersionConstraints
(EventVersionVector event) (ValidTestPayloadForVersion event)
-> TestTree
generateTest FilePath
desc forall (ver :: PeanoNat) payload.
(ValidTestPayloadForVersion event ver payload, Typeable ver,
ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> Proxy payload -> TestTree
makeTest VersionConstraints
(EventVersionVector event) (ValidTestPayloadForVersion event)
constraints =
FilePath -> [TestTree] -> TestTree
testGroup FilePath
desc ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$ [TestTree]
-> VersionConstraints
(FromList (Versions event)) (ValidTestPayloadForVersion event)
-> [TestTree]
forall {startsAt :: PeanoNat} {finalCount :: PeanoNat}
(ts :: EventVersions startsAt finalCount).
[TestTree]
-> VersionConstraints ts (ValidTestPayloadForVersion event)
-> [TestTree]
go [] VersionConstraints
(FromList (Versions event)) (ValidTestPayloadForVersion event)
VersionConstraints
(EventVersionVector event) (ValidTestPayloadForVersion event)
constraints
where
go :: [TestTree] -> VersionConstraints ts (ValidTestPayloadForVersion event) -> [TestTree]
go :: forall {startsAt :: PeanoNat} {finalCount :: PeanoNat}
(ts :: EventVersions startsAt finalCount).
[TestTree]
-> VersionConstraints ts (ValidTestPayloadForVersion event)
-> [TestTree]
go [TestTree]
acc (VersionConstraintsLast (Proxy startsAt
pVer :: Proxy ver, Proxy t
pPayload :: Proxy payload)) =
Proxy event -> Proxy startsAt -> Proxy t -> TestTree
forall (ver :: PeanoNat) payload.
(ValidTestPayloadForVersion event ver payload, Typeable ver,
ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> Proxy payload -> TestTree
makeTest (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @event) Proxy startsAt
pVer Proxy t
pPayload TestTree -> [TestTree] -> [TestTree]
forall a. a -> [a] -> [a]
: [TestTree]
acc
go [TestTree]
acc (VersionConstraintsCons (Proxy startsAt
pVer :: Proxy ver, Proxy t
pPayload :: Proxy payload) VersionConstraints ts' (ValidTestPayloadForVersion event)
rest) =
[TestTree]
-> VersionConstraints ts' (ValidTestPayloadForVersion event)
-> [TestTree]
forall {startsAt :: PeanoNat} {finalCount :: PeanoNat}
(ts :: EventVersions startsAt finalCount).
[TestTree]
-> VersionConstraints ts (ValidTestPayloadForVersion event)
-> [TestTree]
go (Proxy event -> Proxy startsAt -> Proxy t -> TestTree
forall (ver :: PeanoNat) payload.
(ValidTestPayloadForVersion event ver payload, Typeable ver,
ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> Proxy payload -> TestTree
makeTest (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @event) Proxy startsAt
pVer Proxy t
pPayload TestTree -> [TestTree] -> [TestTree]
forall a. a -> [a] -> [a]
: [TestTree]
acc) VersionConstraints ts' (ValidTestPayloadForVersion event)
rest
makeRoundtripTest ::
forall event ver payload.
(ValidTestPayloadForVersion event ver payload) =>
Proxy event ->
Proxy ver ->
Proxy payload ->
TestTree
makeRoundtripTest :: forall (event :: Symbol) (ver :: PeanoNat) payload.
ValidTestPayloadForVersion event ver payload =>
Proxy event -> Proxy ver -> Proxy payload -> TestTree
makeRoundtripTest Proxy event
_ Proxy ver
_ Proxy payload
_ =
FilePath -> (payload -> Property) -> TestTree
forall a. Testable a => FilePath -> a -> TestTree
testProperty
(FilePath
"Version " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Integer -> FilePath
forall a. Show a => a -> FilePath
show (forall (n :: PeanoNat). ReifiablePeanoNat n => Integer
reifyPeanoNat @ver) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" roundtrip")
((payload -> Property) -> TestTree)
-> (payload -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \(payload
payload :: payload) ->
ByteString -> Maybe payload
forall a. FromJSON a => ByteString -> Maybe a
decode (payload -> ByteString
forall a. ToJSON a => a -> ByteString
encode payload
payload) Maybe payload -> Maybe payload -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== payload -> Maybe payload
forall a. a -> Maybe a
Just payload
payload
encodePretty :: (ToJSON a) => a -> BL.ByteString
encodePretty :: forall a. ToJSON a => a -> ByteString
encodePretty = a -> ByteString
forall a. ToJSON a => a -> ByteString
AE.encodePretty
makeGoldenTest ::
forall event ver payload.
(Event event, ValidTestPayloadForVersion event ver payload) =>
GoldenTestConfig ->
Proxy event ->
Proxy ver ->
Proxy payload ->
TestTree
makeGoldenTest :: forall (event :: Symbol) (ver :: PeanoNat) payload.
(Event event, ValidTestPayloadForVersion event ver payload) =>
GoldenTestConfig
-> Proxy event -> Proxy ver -> Proxy payload -> TestTree
makeGoldenTest GoldenTestConfig
config Proxy event
pEvent Proxy ver
pVer (Proxy payload
_ :: Proxy payload) =
FilePath -> FilePath -> IO ByteString -> TestTree
goldenVsString
(FilePath
"Version " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Integer -> FilePath
forall a. Show a => a -> FilePath
show (forall (n :: PeanoNat). ReifiablePeanoNat n => Integer
reifyPeanoNat @ver) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" golden")
(GoldenTestConfig
-> forall (event :: Symbol) (ver :: PeanoNat).
(Event event, ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> FilePath
goldenPathFor GoldenTestConfig
config Proxy event
pEvent Proxy ver
pVer)
((Arbitrary payload, ToJSON payload) =>
GoldenTestConfig -> IO ByteString
GoldenTestConfig -> IO ByteString
forall a ->
(Arbitrary a, ToJSON a) => GoldenTestConfig -> IO ByteString
generateGoldenContent payload GoldenTestConfig
config)
generateGoldenContent ::
forall a ->
(Arbitrary a, ToJSON a) =>
GoldenTestConfig ->
IO BL.ByteString
generateGoldenContent :: forall a ->
(Arbitrary a, ToJSON a) => GoldenTestConfig -> IO ByteString
generateGoldenContent a GoldenTestConfig
config = do
let gen :: Gen [a]
gen = Int -> Gen a -> Gen [a]
forall a. Int -> Gen a -> Gen [a]
vectorOf (GoldenTestConfig -> forall a. Num a => a
goldenTestCaseCount GoldenTestConfig
config) (forall a. Arbitrary a => Gen a
arbitrary @a)
qcGen :: QCGen
qcGen = Int -> QCGen
mkQCGen (GoldenTestConfig -> forall a. Num a => a
goldenTestSeed GoldenTestConfig
config)
samples :: [a]
samples = Gen [a] -> QCGen -> Int -> [a]
forall a. Gen a -> QCGen -> Int -> a
unGen Gen [a]
gen QCGen
qcGen (GoldenTestConfig -> forall a. Num a => a
goldenTestSizeParam GoldenTestConfig
config)
ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [a] -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty [a]
samples
createRoundtripTests ::
forall event ->
( Event event
, HasFullEvidenceList event ValidTestPayloadForVersion
) =>
TestTree
createRoundtripTests :: forall (event :: Symbol) ->
(Event event,
HasFullEvidenceList event ValidTestPayloadForVersion) =>
TestTree
createRoundtripTests event =
FilePath
-> (forall (ver :: PeanoNat) payload.
(ValidTestPayloadForVersion event ver payload, Typeable ver,
ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> Proxy payload -> TestTree)
-> VersionConstraints
(EventVersionVector event) (ValidTestPayloadForVersion event)
-> TestTree
forall (event :: Symbol).
FilePath
-> (forall (ver :: PeanoNat) payload.
(ValidTestPayloadForVersion event ver payload, Typeable ver,
ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> Proxy payload -> TestTree)
-> VersionConstraints
(EventVersionVector event) (ValidTestPayloadForVersion event)
-> TestTree
generateTest
(FilePath
eventName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" Roundtrip Tests")
Proxy event -> Proxy ver -> Proxy payload -> TestTree
forall (event :: Symbol) (ver :: PeanoNat) payload.
ValidTestPayloadForVersion event ver payload =>
Proxy event -> Proxy ver -> Proxy payload -> TestTree
forall (ver :: PeanoNat) payload.
(ValidTestPayloadForVersion event ver payload, Typeable ver,
ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> Proxy payload -> TestTree
makeRoundtripTest
(getPayloadEvidence event ValidTestPayloadForVersion)
where
name :: Text
name = getEventName event
eventName :: FilePath
eventName = Text -> FilePath
T.unpack Text
name
createGoldenTests ::
forall event ->
( Event event
, HasFullEvidenceList event ValidTestPayloadForVersion
) =>
GoldenTestConfig ->
TestTree
createGoldenTests :: forall (event :: Symbol) ->
(Event event,
HasFullEvidenceList event ValidTestPayloadForVersion) =>
GoldenTestConfig -> TestTree
createGoldenTests event GoldenTestConfig
config =
FilePath
-> (forall (ver :: PeanoNat) payload.
(ValidTestPayloadForVersion event ver payload, Typeable ver,
ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> Proxy payload -> TestTree)
-> VersionConstraints
(EventVersionVector event) (ValidTestPayloadForVersion event)
-> TestTree
forall (event :: Symbol).
FilePath
-> (forall (ver :: PeanoNat) payload.
(ValidTestPayloadForVersion event ver payload, Typeable ver,
ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> Proxy payload -> TestTree)
-> VersionConstraints
(EventVersionVector event) (ValidTestPayloadForVersion event)
-> TestTree
generateTest
(FilePath
eventName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" Golden Tests")
(GoldenTestConfig
-> Proxy event -> Proxy ver -> Proxy payload -> TestTree
forall (event :: Symbol) (ver :: PeanoNat) payload.
(Event event, ValidTestPayloadForVersion event ver payload) =>
GoldenTestConfig
-> Proxy event -> Proxy ver -> Proxy payload -> TestTree
makeGoldenTest GoldenTestConfig
config)
(getPayloadEvidence event ValidTestPayloadForVersion)
where
name :: Text
name = getEventName event
eventName :: FilePath
eventName = Text -> FilePath
T.unpack Text
name