Implement/Derive (de)serialization instances needed for test file

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)
 

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

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/OrphanInstances.hs

@@ -0,0 +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 (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 Test.Consensus.PointSchedule.Peers (PeerId, Peers (..))
+import Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..))
+import Test.Ouroboros.Consensus.ChainGenerator.Params (Delta (..))
+
+-- * 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)
+
+-- *** '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
+instance FromJSON PeerId
+
+deriving instance Generic (Peers a)
+instance ToJSON a => ToJSON (Peers a)
+instance FromJSON a => FromJSON (Peers a)
+
+deriving instance Generic (SchedulePoint blk)
+instance ToJSON blk => ToJSON (SchedulePoint blk)
+instance FromJSON blk => FromJSON (SchedulePoint blk)

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,15 +61,13 @@ 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')
 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]

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

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