From 2ade2a5ab85752ce1637c4e4ebf2b571ec03f802 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20G=C3=B3ngora?= Date: Thu, 13 Nov 2025 13:05:55 -0600 Subject: [PATCH 1/2] Move instances from #3 into new orphans module --- .../app/conformance-test-runner/Main.hs | 1 + .../ouroboros-consensus-diffusion.cabal | 1 + .../Test/Consensus/OrphanInstances.hs | 40 +++++++++++++++++++ .../Test/Consensus/PointSchedule.hs | 22 ---------- .../Test/Consensus/PointSchedule/Peers.hs | 13 +----- .../Consensus/PointSchedule/SinglePeer.hs | 10 +---- 6 files changed, 44 insertions(+), 43 deletions(-) create mode 100644 ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/OrphanInstances.hs diff --git a/ouroboros-consensus-diffusion/app/conformance-test-runner/Main.hs b/ouroboros-consensus-diffusion/app/conformance-test-runner/Main.hs index 320ad9e2b..93cffc782 100644 --- a/ouroboros-consensus-diffusion/app/conformance-test-runner/Main.hs +++ b/ouroboros-consensus-diffusion/app/conformance-test-runner/Main.hs @@ -23,6 +23,7 @@ import Ouroboros.Network.PeerSelection.LedgerPeers (RelayAccessPoint (..), UseLe import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), WarmValency (..)) import Server (run) import System.Environment (getArgs) +import Test.Consensus.OrphanInstances () import Test.Consensus.PointSchedule (PointSchedule (..)) import Test.Consensus.PointSchedule.Peers (PeerId (..), Peers (Peers), getPeerIds) diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index ab941c5b6..67c51fa64 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -239,6 +239,7 @@ library unstable-consensus-conformance-testlib Test.Consensus.HardFork.Combinator.B Test.Consensus.Network.AnchoredFragment.Extras Test.Consensus.Node + Test.Consensus.OrphanInstances Test.Consensus.PeerSimulator.BlockFetch Test.Consensus.PeerSimulator.CSJInvariants Test.Consensus.PeerSimulator.ChainSync diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/OrphanInstances.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/OrphanInstances.hs new file mode 100644 index 000000000..6a0788f64 --- /dev/null +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/OrphanInstances.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Consensus.OrphanInstances () where + +import Control.Monad.Class.MonadTime.SI (Time) +import Data.Aeson + ( FromJSON + , ToJSON (toEncoding) + , defaultOptions + , genericToEncoding + ) +import GHC.Generics +import Test.Consensus.PointSchedule (PointSchedule (..)) +import Test.Consensus.PointSchedule.Peers (PeerId, Peers (..)) +import Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..)) + +deriving instance Generic (PointSchedule blk) +instance ToJSON blk => ToJSON (PointSchedule blk) where + toEncoding = genericToEncoding defaultOptions +instance FromJSON blk => FromJSON (PointSchedule blk) + +instance ToJSON Time where + toEncoding = genericToEncoding defaultOptions +instance FromJSON Time + +instance ToJSON PeerId where + toEncoding = genericToEncoding defaultOptions +instance FromJSON PeerId + +deriving instance Generic (Peers a) +instance ToJSON a => ToJSON (Peers a) where + toEncoding = genericToEncoding defaultOptions +instance FromJSON a => FromJSON (Peers a) + +deriving instance Generic (SchedulePoint blk) +instance ToJSON blk => ToJSON (SchedulePoint blk) where + toEncoding = genericToEncoding defaultOptions +instance FromJSON blk => FromJSON (SchedulePoint blk) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs index 2cfc1aa23..ddf76d70f 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -10,10 +9,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} --- Orphan instances for 'Time' were introduced temporarily (no pun intended) --- to implement generic 'ToJSON' and 'FromJSON' instances for 'PointSchedule'. --- Once implemented by hand, they should be removed. -{-# OPTIONS_GHC -Worphans #-} -- | Data types and generators for point schedules. -- @@ -66,7 +61,6 @@ import Control.Monad.Class.MonadTime.SI , diffTime ) import Control.Monad.ST (ST) -import Data.Aeson (ToJSON(toEncoding), FromJSON, genericToEncoding, defaultOptions) import Data.Bifunctor (first) import Data.Functor (($>)) import Data.List (mapAccumL, partition, scanl') @@ -74,7 +68,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Time (DiffTime) import Data.Word (Word64) -import GHC.Generics import Network.TypedProtocol import Ouroboros.Consensus.Block.Abstract (withOriginToMaybe) import Ouroboros.Consensus.Ledger.SupportsProtocol @@ -220,21 +213,6 @@ data PointSchedule blk = PointSchedule -- If no point in the schedule is larger than 'psMinEndTime', -- the simulation will still run until this time is reached. } - deriving (Generic) - -instance ToJSON blk => ToJSON (PointSchedule blk) where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON blk => FromJSON (PointSchedule blk) - --- | TODO(xavier): Remove orphan instance after writing the 'PointSchedule' --- instance above by hand. -instance ToJSON Time where - toEncoding = genericToEncoding defaultOptions - --- | TODO(xavier): Remove orphan instance after writing the 'PointSchedule' --- instance above by hand. -instance FromJSON Time -- | List of all blocks appearing in the schedules. peerSchedulesBlocks :: Peers (PeerSchedule blk) -> [blk] diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/Peers.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/Peers.hs index cc91576c3..5ee36b2b7 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/Peers.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/Peers.hs @@ -39,7 +39,6 @@ module Test.Consensus.PointSchedule.Peers , updatePeer ) where -import Data.Aeson (ToJSON(toEncoding), FromJSON, genericToEncoding, defaultOptions) import Data.Hashable (Hashable) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -79,11 +78,6 @@ instance CondenseList PeerId where instance Hashable PeerId -instance ToJSON PeerId where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON PeerId - -- | General-purpose functor associated with a peer. data Peer a = Peer @@ -117,12 +111,7 @@ data Peers a = Peers { honestPeers :: Map Int a , adversarialPeers :: Map Int a } - deriving (Eq, Show, Generic) - -instance ToJSON a => ToJSON (Peers a) where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON a => FromJSON (Peers a) + deriving (Eq, Show) -- | Variant of 'honestPeers' that returns a map with 'PeerId's as keys. honestPeers' :: Peers a -> Map PeerId a diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/SinglePeer.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/SinglePeer.hs index 400e6441a..2a75219e8 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/SinglePeer.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/SinglePeer.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -- | This module contains functions for generating random point schedules. -- -- A point schedule is a set of tables, having one table per simulated peer. @@ -100,12 +99,10 @@ module Test.Consensus.PointSchedule.SinglePeer import Cardano.Slotting.Slot (WithOrigin (At, Origin), withOrigin) import Control.Arrow (second) import Control.Monad.Class.MonadTime.SI (Time) -import Data.Aeson (ToJSON(toEncoding), FromJSON, genericToEncoding, defaultOptions) import Data.List (mapAccumL) import Data.Time.Clock (DiffTime) import Data.Vector (Vector) import qualified Data.Vector as Vector -import GHC.Generics import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (BlockNo (unBlockNo), blockSlot) import qualified System.Random.Stateful as R (StatefulGen) @@ -121,12 +118,7 @@ data SchedulePoint blk = ScheduleTipPoint (WithOrigin blk) | ScheduleHeaderPoint (WithOrigin blk) | ScheduleBlockPoint (WithOrigin blk) - deriving (Eq, Show, Generic) - -instance ToJSON blk => ToJSON (SchedulePoint blk) where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON blk => FromJSON (SchedulePoint blk) + deriving (Eq, Show) scheduleTipPoint :: blk -> SchedulePoint blk scheduleTipPoint = ScheduleTipPoint . At From fde4cf82124df1e7f6d2e472d83c702938e46ea8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20G=C3=B3ngora?= Date: Thu, 13 Nov 2025 16:42:07 -0600 Subject: [PATCH 2/2] Add instances needed to serialize a `GenesisTest` --- .../Test/Consensus/OrphanInstances.hs | 143 ++++++++++++++++-- 1 file changed, 129 insertions(+), 14 deletions(-) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/OrphanInstances.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/OrphanInstances.hs index 6a0788f64..23c3c8af9 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/OrphanInstances.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/OrphanInstances.hs @@ -1,40 +1,155 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +-- | This module contains (orphan) instances to serialize a 'GenesisTest' for +-- the @consensus-test-runner@ input test file. +-- +-- Types with 'Generic' instances can derive 'ToJSON' and 'FromJSON' +-- automatically; in turn, to standalone derive a 'Generic' instance, all of +-- its constructors must in scope. Because of this, opaque data type instances +-- need to be written manually. +-- +-- Note that most of the constraints in this instance declarations are caused +-- by the abstraction of the block type parameter. module Test.Consensus.OrphanInstances () where +import Cardano.Slotting.Time (SlotLength) import Control.Monad.Class.MonadTime.SI (Time) import Data.Aeson - ( FromJSON - , ToJSON (toEncoding) + ( FromJSON (parseJSON) + , KeyValue ((.=)) + , ToJSON (toEncoding, toJSON) , defaultOptions , genericToEncoding + , object + , withObject + , (.:) + ) +import GHC.Generics (Generic) +import Ouroboros.Consensus.Block.Abstract (GenesisWindow (..)) +import Ouroboros.Consensus.Config (SecurityParam (..)) +import Ouroboros.Network.AnchoredFragment (Anchor) +import Ouroboros.Network.AnchoredSeq + ( Anchorable (..) + , AnchoredSeq (..) + , fromOldestFirst + , toOldestFirst + ) +import Ouroboros.Network.Block (HasHeader, HeaderHash) +import Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..)) +import Test.Consensus.PointSchedule + ( BlockFetchTimeout (..) + , CSJParams (..) + , ChainSyncTimeout (..) + , ForecastRange (..) + , GenesisTest (..) + , LoPBucketParams (..) + , PointSchedule (..) ) -import GHC.Generics -import Test.Consensus.PointSchedule (PointSchedule (..)) import Test.Consensus.PointSchedule.Peers (PeerId, Peers (..)) import Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..)) +import Test.Ouroboros.Consensus.ChainGenerator.Params (Delta (..)) -deriving instance Generic (PointSchedule blk) -instance ToJSON blk => ToJSON (PointSchedule blk) where +-- * Target instances + +deriving instance Generic (GenesisTest blk schedule) +instance + (ToJSON (HeaderHash blk), HasHeader blk, ToJSON schedule, ToJSON blk) => + ToJSON (GenesisTest blk schedule) + where toEncoding = genericToEncoding defaultOptions +instance + (FromJSON (HeaderHash blk), HasHeader blk, FromJSON schedule, FromJSON blk) => + FromJSON (GenesisTest blk schedule) + +-- ** 'GenesisTest' field instances + +instance ToJSON SecurityParam +instance FromJSON SecurityParam + +deriving instance Generic GenesisWindow +instance ToJSON GenesisWindow +instance FromJSON GenesisWindow + +deriving instance Generic ForecastRange +instance ToJSON ForecastRange +instance FromJSON ForecastRange + +deriving instance Generic Delta +instance ToJSON Delta +instance FromJSON Delta + +deriving instance Generic (BlockTree blk) +instance (ToJSON (HeaderHash blk), HasHeader blk, ToJSON blk) => ToJSON (BlockTree blk) +instance (FromJSON (HeaderHash blk), HasHeader blk, FromJSON blk) => FromJSON (BlockTree blk) + +deriving instance Generic ChainSyncTimeout +instance ToJSON ChainSyncTimeout +instance FromJSON ChainSyncTimeout + +deriving instance Generic BlockFetchTimeout +instance ToJSON BlockFetchTimeout +instance FromJSON BlockFetchTimeout + +deriving instance Generic LoPBucketParams +instance ToJSON LoPBucketParams +instance FromJSON LoPBucketParams + +deriving instance Generic CSJParams +instance ToJSON CSJParams +instance FromJSON CSJParams + +instance ToJSON SlotLength +instance FromJSON SlotLength + +deriving instance Generic (PointSchedule blk) +instance ToJSON blk => ToJSON (PointSchedule blk) instance FromJSON blk => FromJSON (PointSchedule blk) -instance ToJSON Time where - toEncoding = genericToEncoding defaultOptions +-- *** 'BlockTree' field related instances + +-- | The underlying 'AnchoredFragment' type of a 'BlockTreeBranch' is +-- responsible for the 'HeaderHash' and 'HasHeader' constraints; the former is +-- a type family, which is justifies the need for @UndecidableInstances@ unless +-- a concrete block type is picked. +deriving instance Generic (BlockTreeBranch blk) + +instance (ToJSON (HeaderHash blk), HasHeader blk, ToJSON blk) => ToJSON (BlockTreeBranch blk) +instance (FromJSON (HeaderHash blk), HasHeader blk, FromJSON blk) => FromJSON (BlockTreeBranch blk) + +instance (ToJSON a, ToJSON b) => ToJSON (AnchoredSeq v a b) where + toJSON anchoredSeq = + object + [ "anchor" .= anchor anchoredSeq + , "sequence" .= toOldestFirst anchoredSeq + ] + +instance (Anchorable v a b, FromJSON a, FromJSON b) => FromJSON (AnchoredSeq v a b) where + parseJSON = withObject "AnchoredSeq" $ \obj -> do + a <- obj .: "anchor" + s <- obj .: "sequence" + pure $ fromOldestFirst a s + +instance ToJSON (HeaderHash blk) => ToJSON (Anchor blk) +instance FromJSON (HeaderHash blk) => FromJSON (Anchor blk) + +-- *** 'PointSchedule' field related instances + +instance ToJSON Time instance FromJSON Time -instance ToJSON PeerId where - toEncoding = genericToEncoding defaultOptions +instance ToJSON PeerId instance FromJSON PeerId deriving instance Generic (Peers a) -instance ToJSON a => ToJSON (Peers a) where - toEncoding = genericToEncoding defaultOptions +instance ToJSON a => ToJSON (Peers a) instance FromJSON a => FromJSON (Peers a) deriving instance Generic (SchedulePoint blk) -instance ToJSON blk => ToJSON (SchedulePoint blk) where - toEncoding = genericToEncoding defaultOptions +instance ToJSON blk => ToJSON (SchedulePoint blk) instance FromJSON blk => FromJSON (SchedulePoint blk)