{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | A 'TestSuite' data structure for quick access to 'ConformanceTest' values.
-- It encodes a hierarchical nested structure allowing it to compile into a
-- tasty 'TestTree'.
-- It's purpose is interfacing between property test execution and the
-- conformance testing harness.
module Test.Consensus.Genesis.TestSuite
  ( -- * 'SmallKey' class
    -- $deriveSmallkey
    Generic
  , Generically (..)
  , SmallKey

    -- * 'TestSuite' API
  , TestSuite
  , at
  , getTest
  , group
  , grouping
  , mkTestSuite
  , newTestSuite
  , toTestTree
  ) where

import Data.Foldable (toList)
import Data.Map.Monoidal (MonoidalMap)
import qualified Data.Map.Monoidal as MMap
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Monoid (Endo (..))
import GHC.Generics (Generic, Generically (..))
import Ouroboros.Consensus.Block
  ( BlockSupportsDiffusionPipelining
  , ConvertRawHash
  , Header
  )
import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode)
import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory)
import Ouroboros.Consensus.Ledger.Basics (LedgerState)
import Ouroboros.Consensus.Ledger.Inspect (InspectLedger)
import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras)
import Ouroboros.Consensus.Ledger.SupportsProtocol
  ( LedgerSupportsProtocol
  )
import Ouroboros.Consensus.Storage.ChainDB (SerialiseDiskConstraints)
import Ouroboros.Consensus.Storage.LedgerDB.API
  ( CanUpgradeLedgerTables
  )
import Ouroboros.Consensus.Util.Condense (Condense, CondenseList)
import Ouroboros.Network.Util.ShowProxy (ShowProxy)
import Test.Consensus.Genesis.Setup
  ( ConformanceTest (..)
  , runConformanceTest
  )
import Test.Consensus.Genesis.TestSuite.SmallKey (SmallKey, getAllKeys)
import Test.Consensus.PeerSimulator.StateView (StateView)
import Test.Consensus.PointSchedule (HasPointScheduleTestParams)
import Test.Consensus.PointSchedule.NodeState (NodeState)
import Test.Tasty (TestTree, testGroup)
import Test.Util.TersePrinting (Terse)

data TestSuiteData blk = TestSuiteData
  { forall blk. TestSuiteData blk -> [String]
tsPrefix :: [String]
  -- ^ A prefix representing a path through the test group tree.
  -- The convention is to nest by appending, i.e. the head of the prefix
  -- corresponds to the top-level test group.
  , forall blk. TestSuiteData blk -> ConformanceTest blk
tsTest :: ConformanceTest blk
  -- ^ The test itself.
  }

-- | A @TestSuite blk key@ contains one 'ConformanceTest'@blk@ for each @key@.
newtype TestSuite blk key = TestSuite (Map key (TestSuiteData blk))

-- | Build a 'TestSuite' by looking 'at' 'TestSuiteData', allowing to preserve the
-- hierarchical structure of a previously constructed 'TestSuite'.
--
-- See NOTE [DeriveSmallKey]
mkTestSuite ::
  (Ord key, SmallKey key) =>
  (key -> TestSuiteData blk) ->
  TestSuite blk key
mkTestSuite :: forall key blk.
(Ord key, SmallKey key) =>
(key -> TestSuiteData blk) -> TestSuite blk key
mkTestSuite key -> TestSuiteData blk
toData =
  Map key (TestSuiteData blk) -> TestSuite blk key
forall blk key. Map key (TestSuiteData blk) -> TestSuite blk key
TestSuite (Map key (TestSuiteData blk) -> TestSuite blk key)
-> ([key] -> Map key (TestSuiteData blk))
-> [key]
-> TestSuite blk key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(key, TestSuiteData blk)] -> Map key (TestSuiteData blk)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(key, TestSuiteData blk)] -> Map key (TestSuiteData blk))
-> ([key] -> [(key, TestSuiteData blk)])
-> [key]
-> Map key (TestSuiteData blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (key -> (key, TestSuiteData blk))
-> [key] -> [(key, TestSuiteData blk)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) (key -> TestSuiteData blk -> (key, TestSuiteData blk))
-> (key -> key)
-> key
-> TestSuiteData blk
-> (key, TestSuiteData blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> key -> key
forall a. a -> a
id (key -> TestSuiteData blk -> (key, TestSuiteData blk))
-> (key -> TestSuiteData blk) -> key -> (key, TestSuiteData blk)
forall a b. (key -> a -> b) -> (key -> a) -> key -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> key -> TestSuiteData blk
toData) ([key] -> TestSuite blk key) -> [key] -> TestSuite blk key
forall a b. (a -> b) -> a -> b
$ [key]
forall k. SmallKey k => [k]
getAllKeys

-- | Build a 'TestSuite' from a function mapping a @key@ type to 'ConformanceTest'
-- making all tests top-level.
--
-- See NOTE [DeriveSmallKey]
newTestSuite ::
  (Ord key, SmallKey key) =>
  (key -> ConformanceTest blk) ->
  TestSuite blk key
newTestSuite :: forall key blk.
(Ord key, SmallKey key) =>
(key -> ConformanceTest blk) -> TestSuite blk key
newTestSuite key -> ConformanceTest blk
toConformanceTest =
  let toData :: key -> TestSuiteData blk
toData key
k =
        TestSuiteData
          { tsPrefix :: [String]
tsPrefix = []
          , tsTest :: ConformanceTest blk
tsTest = key -> ConformanceTest blk
toConformanceTest key
k
          }
   in (key -> TestSuiteData blk) -> TestSuite blk key
forall key blk.
(Ord key, SmallKey key) =>
(key -> TestSuiteData blk) -> TestSuite blk key
mkTestSuite key -> TestSuiteData blk
toData

-- $deriveSmallKey
--
-- NOTE [DeriveSmallKey]
-- The 'SmallKey' constraint on 'TestSuite' @key@s is meant to be derived
-- @via Generically@ only; because of this, some its class methods are not
-- exported to prevent users of this class from instantiating it for large
-- finite data types (such as 'Int' or 'Word32'), which are likely to flood the
-- memory when constructing a 'TestSuite' because 'allKeys' are used
-- operationally to drive its exhaustive construction. As precaution, product
-- and syntactically-recursive types are forbidden from instanciating it and
-- some large types have been explicitly black-listed.
--
-- The rationale behind the enforced restrictions is that @keys@ are expected
-- to be constructed /primarily/ from user defined enumeration types (i.e.
-- coproducts of nullary constructors) corresponding to single tests
-- module wise, but this is not a hard requirement. For instance, keys can be
-- aggregated into higher order types to define hierarchical 'TestSuite's
-- by means of 'mkTestSuite' and 'at'.

at :: Ord key => TestSuite blk key -> key -> TestSuiteData blk
at :: forall key blk.
Ord key =>
TestSuite blk key -> key -> TestSuiteData blk
at (TestSuite Map key (TestSuiteData blk)
m) key
k = case key -> Map key (TestSuiteData blk) -> Maybe (TestSuiteData blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup key
k Map key (TestSuiteData blk)
m of
  Just TestSuiteData blk
t -> TestSuiteData blk
t
  Maybe (TestSuiteData blk)
Nothing -> String -> TestSuiteData blk
forall a. HasCallStack => String -> a
error String
"TestSuite.at: Impossible! A TestSuite is a total map."

getTest :: TestSuiteData blk -> ConformanceTest blk
getTest :: forall blk. TestSuiteData blk -> ConformanceTest blk
getTest = TestSuiteData blk -> ConformanceTest blk
forall blk. TestSuiteData blk -> ConformanceTest blk
tsTest

-- | Appends the given string to the prefix of all tests in the 'TestSuite',
-- effectively grouping them on a `TestTree` of the given name when compiled.
group :: String -> TestSuite blk key -> TestSuite blk key
group :: forall blk key. String -> TestSuite blk key -> TestSuite blk key
group String
name = (key -> String) -> TestSuite blk key -> TestSuite blk key
forall key blk.
(key -> String) -> TestSuite blk key -> TestSuite blk key
grouping (String -> key -> String
forall a b. a -> b -> a
const String
name)

-- | A more general version of 'group' that allows to group tests by a key
-- specific prefix.
grouping :: (key -> String) -> TestSuite blk key -> TestSuite blk key
grouping :: forall key blk.
(key -> String) -> TestSuite blk key -> TestSuite blk key
grouping key -> String
f (TestSuite Map key (TestSuiteData blk)
m) =
  Map key (TestSuiteData blk) -> TestSuite blk key
forall blk key. Map key (TestSuiteData blk) -> TestSuite blk key
TestSuite (Map key (TestSuiteData blk) -> TestSuite blk key)
-> Map key (TestSuiteData blk) -> TestSuite blk key
forall a b. (a -> b) -> a -> b
$
    (key -> TestSuiteData blk -> TestSuiteData blk)
-> Map key (TestSuiteData blk) -> Map key (TestSuiteData blk)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
      (\key
k TestSuiteData blk
testData -> TestSuiteData blk
testData{tsPrefix = f k : tsPrefix testData})
      Map key (TestSuiteData blk)
m

{-------------------------------------------------------------------------------
   Compile a TestSuite into a TestTree
-------------------------------------------------------------------------------}

-- | Intermediary representation for a 'TestSuite' to be compiled
-- into a 'TestTree'.
data TestTrie = TestTrie
  { TestTrie -> [TestTree]
_here :: ![TestTree]
  -- ^ Top level tests (whose prefix ends here).
  , TestTrie -> MonoidalMap String TestTrie
_children :: !(MonoidalMap String TestTrie)
  -- ^ Grouped tests correspond to prefix maps.
  }
  deriving stock (forall x. TestTrie -> Rep TestTrie x)
-> (forall x. Rep TestTrie x -> TestTrie) -> Generic TestTrie
forall x. Rep TestTrie x -> TestTrie
forall x. TestTrie -> Rep TestTrie x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestTrie -> Rep TestTrie x
from :: forall x. TestTrie -> Rep TestTrie x
$cto :: forall x. Rep TestTrie x -> TestTrie
to :: forall x. Rep TestTrie x -> TestTrie
Generic
  deriving (NonEmpty TestTrie -> TestTrie
TestTrie -> TestTrie -> TestTrie
(TestTrie -> TestTrie -> TestTrie)
-> (NonEmpty TestTrie -> TestTrie)
-> (forall b. Integral b => b -> TestTrie -> TestTrie)
-> Semigroup TestTrie
forall b. Integral b => b -> TestTrie -> TestTrie
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: TestTrie -> TestTrie -> TestTrie
<> :: TestTrie -> TestTrie -> TestTrie
$csconcat :: NonEmpty TestTrie -> TestTrie
sconcat :: NonEmpty TestTrie -> TestTrie
$cstimes :: forall b. Integral b => b -> TestTrie -> TestTrie
stimes :: forall b. Integral b => b -> TestTrie -> TestTrie
Semigroup, Semigroup TestTrie
TestTrie
Semigroup TestTrie =>
TestTrie
-> (TestTrie -> TestTrie -> TestTrie)
-> ([TestTrie] -> TestTrie)
-> Monoid TestTrie
[TestTrie] -> TestTrie
TestTrie -> TestTrie -> TestTrie
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: TestTrie
mempty :: TestTrie
$cmappend :: TestTrie -> TestTrie -> TestTrie
mappend :: TestTrie -> TestTrie -> TestTrie
$cmconcat :: [TestTrie] -> TestTrie
mconcat :: [TestTrie] -> TestTrie
Monoid) via (Generically TestTrie)

-- | Create a 'TestTrie' with a single value.
mkTestTrie :: [String] -> TestTree -> TestTrie
mkTestTrie :: [String] -> TestTree -> TestTrie
mkTestTrie [String]
pfs TestTree
t =
  let nest :: String -> Endo TestTrie
      nest :: String -> Endo TestTrie
nest String
pf = (TestTrie -> TestTrie) -> Endo TestTrie
forall a. (a -> a) -> Endo a
Endo ((TestTrie -> TestTrie) -> Endo TestTrie)
-> (TestTrie -> TestTrie) -> Endo TestTrie
forall a b. (a -> b) -> a -> b
$ \TestTrie
tt -> [TestTree] -> MonoidalMap String TestTrie -> TestTrie
TestTrie [] (String -> TestTrie -> MonoidalMap String TestTrie
forall k a. k -> a -> MonoidalMap k a
MMap.singleton String
pf TestTrie
tt)
      leaf :: TestTrie
leaf = [TestTree] -> MonoidalMap String TestTrie -> TestTrie
TestTrie [Item [TestTree]
TestTree
t] MonoidalMap String TestTrie
forall a. Monoid a => a
mempty
   in Endo TestTrie -> TestTrie -> TestTrie
forall a. Endo a -> a -> a
appEndo ((String -> Endo TestTrie) -> [String] -> Endo TestTrie
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap String -> Endo TestTrie
nest [String]
pfs) TestTrie
leaf

-- | Fold a 'TestTrie' into a list of 'TestTree's by recursively
-- rendering each trie node as a 'testGroup'.
render :: TestTrie -> [TestTree]
render :: TestTrie -> [TestTree]
render (TestTrie [TestTree]
here MonoidalMap String TestTrie
children) =
  [TestTree]
here
    [TestTree] -> [TestTree] -> [TestTree]
forall a. Semigroup a => a -> a -> a
<> ((String, TestTrie) -> TestTree)
-> [(String, TestTrie)] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (\(String
p, TestTrie
tt) -> String -> [TestTree] -> TestTree
testGroup String
p (TestTrie -> [TestTree]
render TestTrie
tt))
      (MonoidalMap String TestTrie -> [(String, TestTrie)]
forall k a. MonoidalMap k a -> [(k, a)]
MMap.toList MonoidalMap String TestTrie
children)

-- | Compile a 'TestSuite' into a list of tasty 'TestTree'.
toTestTree ::
  ( Condense (StateView blk)
  , CondenseList (NodeState blk)
  , ShowProxy blk
  , ShowProxy (Header blk)
  , ConfigSupportsNode blk
  , LedgerSupportsProtocol blk
  , LedgerSupportsPeras blk
  , SerialiseDiskConstraints blk
  , BlockSupportsDiffusionPipelining blk
  , InspectLedger blk
  , HasHardForkHistory blk
  , ConvertRawHash blk
  , CanUpgradeLedgerTables (LedgerState blk)
  , HasPointScheduleTestParams blk
  , Eq (Header blk)
  , Eq blk
  , Terse blk
  , Condense (NodeState blk)
  ) =>
  TestSuite blk key -> [TestTree]
toTestTree :: forall blk key.
(Condense (StateView blk), CondenseList (NodeState blk),
 ShowProxy blk, ShowProxy (Header blk), ConfigSupportsNode blk,
 LedgerSupportsProtocol blk, LedgerSupportsPeras blk,
 SerialiseDiskConstraints blk, BlockSupportsDiffusionPipelining blk,
 InspectLedger blk, HasHardForkHistory blk, ConvertRawHash blk,
 CanUpgradeLedgerTables (LedgerState blk),
 HasPointScheduleTestParams blk, Eq (Header blk), Eq blk, Terse blk,
 Condense (NodeState blk)) =>
TestSuite blk key -> [TestTree]
toTestTree (TestSuite Map key (TestSuiteData blk)
m) =
  TestTrie -> [TestTree]
render (TestTrie -> [TestTree]) -> TestTrie -> [TestTree]
forall a b. (a -> b) -> a -> b
$ [TestTrie] -> TestTrie
forall a. Monoid a => [a] -> a
mconcat ([TestTrie] -> TestTrie) -> [TestTrie] -> TestTrie
forall a b. (a -> b) -> a -> b
$ do
    TestSuiteData{tsPrefix, tsTest} <- Map key (TestSuiteData blk) -> [TestSuiteData blk]
forall a. Map key a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map key (TestSuiteData blk)
m
    pure $ mkTestTrie tsPrefix $ runConformanceTest tsTest