Move instances from #3 into new orphans module

Author: ninioArtillero

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,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)

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