{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Hindsight.Generate 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)

-- | Configuration for test generation
data TestConfig = TestConfig
    { TestConfig
-> forall (event :: Symbol) (ver :: PeanoNat).
   (KnownSymbol event, ReifiablePeanoNat ver) =>
   Proxy event -> Proxy ver -> FilePath
goldenPathFor :: forall event ver. (KnownSymbol event, ReifiablePeanoNat ver) => Proxy event -> Proxy ver -> FilePath
    -- ^ Function to generate golden file path for a version
    , TestConfig -> forall a. Num a => a
goldenTestCaseCount :: forall a. (Num a) => a
    -- ^ Number of test cases to generate for golden tests
    , TestConfig -> forall a. Num a => a
goldenTestSeed :: forall a. (Num a) => a
    -- ^ Seed for reproducible random generation
    , TestConfig -> forall a. Num a => a
goldenTestSizeParam :: forall a. (Num a) => a
    -- ^ Size parameter for QuickCheck's generation (affects complexity of generated values)
    }

type TestPayloadRequirements event idx payload = (VersionPayloadRequirements event idx payload, Arbitrary payload)

-- | Evidence that a type is a valid payload for a version
class (TestPayloadRequirements event idx payload) => ValidTestPayloadForVersion (event :: Symbol) (idx :: PeanoNat) (payload :: Type) where
    testEvidence :: Dict (VersionPayloadRequirements event idx payload)

instance (TestPayloadRequirements event idx payload) => ValidTestPayloadForVersion event idx payload where
    testEvidence :: Dict (VersionPayloadRequirements event idx payload)
testEvidence = Dict
  (Serializable payload, MigrateVersion (FromPeanoNat idx) event,
   payload ~ payload, KnownSymbol event, ReifiablePeanoNat idx,
   Typeable payload, Typeable event, Typeable idx, payload ~ payload)
Dict (VersionPayloadRequirements event idx payload)
forall (c :: Constraint). c => Dict c
Dict

-- | Default test configuration
defaultTestConfig :: TestConfig
defaultTestConfig :: TestConfig
defaultTestConfig =
    TestConfig
        { goldenPathFor :: forall (event :: Symbol) (ver :: PeanoNat).
(KnownSymbol event, ReifiablePeanoNat ver) =>
Proxy event -> Proxy ver -> FilePath
goldenPathFor = \(Proxy event
pEvent :: Proxy event) (Proxy ver
_ :: Proxy ver) ->
            let name :: Text
name = Proxy event -> Text
forall (event :: Symbol). KnownSymbol event => Proxy event -> Text
getEventName Proxy event
pEvent
                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.
    TestConfig ->
    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).
TestConfig
-> 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 TestConfig
_ 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

-- | Generate roundtrip property test for a specific version
makeRoundtripTest ::
    forall event ver payload.
    (ValidTestPayloadForVersion event ver payload) =>
    TestConfig ->
    Proxy event ->
    Proxy ver ->
    Proxy payload ->
    TestTree
makeRoundtripTest :: forall (event :: Symbol) (ver :: PeanoNat) payload.
ValidTestPayloadForVersion event ver payload =>
TestConfig -> Proxy event -> Proxy ver -> Proxy payload -> TestTree
makeRoundtripTest TestConfig
_ 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

-- | Helper function to pretty print JSON
encodePretty :: (ToJSON a) => a -> BL.ByteString
encodePretty :: forall a. ToJSON a => a -> ByteString
encodePretty = a -> ByteString
forall a. ToJSON a => a -> ByteString
AE.encodePretty

-- | Generate golden test for a specific version
makeGoldenTest ::
    forall event ver payload.
    (ValidTestPayloadForVersion event ver payload) =>
    TestConfig ->
    Proxy event ->
    Proxy ver ->
    Proxy payload ->
    TestTree
makeGoldenTest :: forall (event :: Symbol) (ver :: PeanoNat) payload.
ValidTestPayloadForVersion event ver payload =>
TestConfig -> Proxy event -> Proxy ver -> Proxy payload -> TestTree
makeGoldenTest TestConfig
config Proxy event
pEvent Proxy ver
pVer 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")
        (TestConfig
-> forall (event :: Symbol) (ver :: PeanoNat).
   (KnownSymbol event, ReifiablePeanoNat ver) =>
   Proxy event -> Proxy ver -> FilePath
goldenPathFor TestConfig
config Proxy event
pEvent Proxy ver
pVer)
        (forall a. (Arbitrary a, ToJSON a) => TestConfig -> IO ByteString
generateGoldenContent @payload TestConfig
config)

-- | Generate content for golden tests
generateGoldenContent ::
    forall a.
    (Arbitrary a, ToJSON a) =>
    TestConfig ->
    IO BL.ByteString
generateGoldenContent :: forall a. (Arbitrary a, ToJSON a) => TestConfig -> IO ByteString
generateGoldenContent TestConfig
config = do
    let gen :: Gen [a]
gen = Int -> Gen a -> Gen [a]
forall a. Int -> Gen a -> Gen [a]
vectorOf (TestConfig -> forall a. Num a => a
goldenTestCaseCount TestConfig
config) (forall a. Arbitrary a => Gen a
arbitrary @a)
        qcGen :: QCGen
qcGen = Int -> QCGen
mkQCGen (TestConfig -> forall a. Num a => a
goldenTestSeed TestConfig
config)
        samples :: [a]
samples = Gen [a] -> QCGen -> Int -> [a]
forall a. Gen a -> QCGen -> Int -> a
unGen Gen [a]
gen QCGen
qcGen (TestConfig -> forall a. Num a => a
goldenTestSizeParam TestConfig
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

-- | Create selective test suites
createRoundtripTests ::
    forall event.
    ( KnownSymbol event
    , HasFullEvidenceList event ValidTestPayloadForVersion
    ) =>
    TestConfig ->
    TestTree
createRoundtripTests :: forall (event :: Symbol).
(KnownSymbol event,
 HasFullEvidenceList event ValidTestPayloadForVersion) =>
TestConfig -> TestTree
createRoundtripTests TestConfig
config =
    TestConfig
-> 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).
TestConfig
-> 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
        TestConfig
config
        (FilePath
eventName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" Roundtrip Tests")
        (TestConfig -> Proxy event -> Proxy ver -> Proxy payload -> TestTree
forall (event :: Symbol) (ver :: PeanoNat) payload.
ValidTestPayloadForVersion event ver payload =>
TestConfig -> Proxy event -> Proxy ver -> Proxy payload -> TestTree
makeRoundtripTest TestConfig
config)
        (forall (event :: Symbol)
       (c :: Symbol -> PeanoNat -> * -> Constraint).
HasFullEvidenceList event c =>
VersionConstraints (EventVersionVector event) (c event)
getPayloadEvidence @event @ValidTestPayloadForVersion)
  where
    name :: Text
name = Proxy event -> Text
forall (event :: Symbol). KnownSymbol event => Proxy event -> Text
getEventName (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @event)
    eventName :: FilePath
eventName = Text -> FilePath
T.unpack Text
name

createGoldenTests ::
    forall event.
    ( KnownSymbol event
    , HasFullEvidenceList event ValidTestPayloadForVersion
    ) =>
    TestConfig ->
    TestTree
createGoldenTests :: forall (event :: Symbol).
(KnownSymbol event,
 HasFullEvidenceList event ValidTestPayloadForVersion) =>
TestConfig -> TestTree
createGoldenTests TestConfig
config =
    TestConfig
-> 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).
TestConfig
-> 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
        TestConfig
config
        (FilePath
eventName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" Golden Tests")
        (TestConfig -> Proxy event -> Proxy ver -> Proxy payload -> TestTree
forall (event :: Symbol) (ver :: PeanoNat) payload.
ValidTestPayloadForVersion event ver payload =>
TestConfig -> Proxy event -> Proxy ver -> Proxy payload -> TestTree
makeGoldenTest TestConfig
config)
        (forall (event :: Symbol)
       (c :: Symbol -> PeanoNat -> * -> Constraint).
HasFullEvidenceList event c =>
VersionConstraints (EventVersionVector event) (c event)
getPayloadEvidence @event @ValidTestPayloadForVersion)
  where
    name :: Text
name = Proxy event -> Text
forall (event :: Symbol). KnownSymbol event => Proxy event -> Text
getEventName (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @event)
    eventName :: FilePath
eventName = Text -> FilePath
T.unpack Text
name

-- | Convert a Peano-encoded type-level natural to a String
showPeanoNat :: forall n. (ReifiablePeanoNat n) => String
showPeanoNat :: forall (n :: PeanoNat). ReifiablePeanoNat n => FilePath
showPeanoNat = 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 @n

{- | Convert a type-level event name to a String

Helper function parallel to 'showPeanoNat' for converting type-level
event names to strings for file paths and display.
-}
eventToString :: forall event. (KnownSymbol event) => String
eventToString :: forall (event :: Symbol). KnownSymbol event => FilePath
eventToString = Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Proxy event -> Text
forall (event :: Symbol). KnownSymbol event => Proxy event -> Text
getEventName (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @event)