Some orphans work (#1092)

Removed `-Wno-orphans` from some modules.
Un-orphan some instances from `Ouroboros.Consensus.Util.Orphans`

Still draft because I need an instance in
IntersectMBO/ouroboros-network#4875

Author: jasagredo

cabal.project

@@ -36,3 +36,12 @@ import: ./asserts.cabal
 if(os(windows))
   constraints:
     bitvec -simd
+
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/ouroboros-network
+  tag: 431bb599940d2947b2cb99d3ae29b7f2c4cdd36d
+  --sha256: 1a62hqddpnc0j5r7nl54q79nrxyw77dphpsgp68hxij210dkpvca
+  subdir:
+    ouroboros-network-api
+    ouroboros-network-protocols

ouroboros-consensus/changelog.d/orphans-javier.md

@@ -0,0 +1,3 @@
+### Non-Breaking
+
+- Un-orphan instances for `Condense` and `HeaderHash (Ticked l)`.

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE TypeFamilies      #-}
 {-# LANGUAGE TypeOperators     #-}
-{-# OPTIONS_GHC -Wno-orphans   #-}
 
 -- | Definition is 'IsLedger'
 --
@@ -48,8 +47,6 @@ class GetTip l where
   -- Should be 'GenesisPoint' when no blocks have been applied yet
   getTip :: l -> Point l
 
-type instance HeaderHash (Ticked l) = HeaderHash l
-
 getTipHash :: GetTip l => l -> ChainHash l
 getTipHash = pointHash . getTip
 

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                       #-}
 {-# LANGUAGE DeriveAnyClass            #-}
 {-# LANGUAGE DeriveGeneric             #-}
 {-# LANGUAGE DerivingVia               #-}
@@ -14,7 +15,12 @@
 {-# LANGUAGE TypeFamilyDependencies    #-}
 {-# LANGUAGE TypeOperators             #-}
 {-# LANGUAGE UndecidableInstances      #-}
-{-# OPTIONS_GHC -Wno-orphans           #-}
+
+#if __GLASGOW_HASKELL__ >= 908
+-- GHC is a bit pickier for data family instances, but trying to remove this
+-- one forces us to reorganize the Protocol.* modules. TODO eventually.
+{-# OPTIONS_GHC -Wno-orphans #-}
+#endif
 
 module Ouroboros.Consensus.Protocol.PBFT (
     PBft

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT/Crypto.hs

@@ -11,7 +11,6 @@
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
 
-{-# OPTIONS_GHC -Wno-orphans #-}
 module Ouroboros.Consensus.Protocol.PBFT.Crypto (
     PBftCrypto (..)
   , PBftMockCrypto

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs

@@ -15,7 +15,6 @@
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-{-# OPTIONS_GHC -Wno-orphans #-}
 module Ouroboros.Consensus.Storage.ChainDB.API (
     -- * Main ChainDB API
     ChainDB (..)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ticked.hs

@@ -11,6 +11,7 @@ module Ouroboros.Consensus.Ticked (Ticked (..)) where
 import           Data.Kind (Type)
 import           Data.SOP.BasicFunctors
 import           NoThunks.Class (NoThunks)
+import           Ouroboros.Consensus.Block.Abstract
 
 {-------------------------------------------------------------------------------
   Ticked state
@@ -46,6 +47,8 @@ data family Ticked st :: Type
 data instance Ticked () = TickedTrivial
   deriving (Show)
 
+type instance HeaderHash (Ticked l) = HeaderHash l
+
 {-------------------------------------------------------------------------------
   Forwarding type class instances
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Condense.hs

@@ -25,9 +25,7 @@ import           Cardano.Crypto.KES (MockKES, NeverKES, SigKES, SignedKES (..),
                      pattern SigSingleKES, pattern SigSumKES,
                      pattern SignKeyMockKES, pattern VerKeyMockKES,
                      pattern VerKeySingleKES, pattern VerKeySumKES)
-import           Cardano.Slotting.Block (BlockNo (..))
-import           Cardano.Slotting.Slot (EpochNo (..), SlotNo (..),
-                     WithOrigin (..))
+import           Cardano.Slotting.Slot (EpochNo (..), WithOrigin (..))
 import           Control.Monad.Class.MonadTime.SI (Time (..))
 import qualified Data.ByteString as BS.Strict
 import qualified Data.ByteString.Lazy as BS.Lazy
@@ -44,7 +42,10 @@ import           Data.Word
 import           Numeric.Natural
 import           Ouroboros.Consensus.Util.HList (All, HList (..))
 import qualified Ouroboros.Consensus.Util.HList as HList
-import           Ouroboros.Network.Block (ChainHash (..), HeaderHash, Tip (..))
+import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
+import qualified Ouroboros.Network.AnchoredFragment as AF
+import           Ouroboros.Network.Block
+import           Ouroboros.Network.Mock.Chain hiding (length)
 import           Text.Printf (printf)
 
 {-------------------------------------------------------------------------------
@@ -168,7 +169,7 @@ instance All Condense as => Condense (HList as) where
   condense as = "(" ++ intercalate "," (HList.collapse (Proxy @Condense) condense as) ++ ")"
 
 {-------------------------------------------------------------------------------
-  Orphans for ouroboros-network
+  Instances for ouroboros-network
 -------------------------------------------------------------------------------}
 
 instance Condense BlockNo where
@@ -193,8 +194,21 @@ instance Condense a => Condense (WithOrigin a) where
   condense Origin = "origin"
   condense (At a) = condense a
 
+instance Condense (HeaderHash block) => Condense (Point block) where
+    condense GenesisPoint     = "Origin"
+    condense (BlockPoint s h) = "(Point " <> condense s <> ", " <> condense h <> ")"
+
+instance Condense block => Condense (Chain block) where
+    condense Genesis   = "Genesis"
+    condense (cs :> b) = condense cs <> " :> " <> condense b
+
+instance (Condense block, HasHeader block, Condense (HeaderHash block))
+    => Condense (AnchoredFragment block) where
+    condense (AF.Empty pt) = "EmptyAnchor " <> condense (AF.anchorToPoint pt)
+    condense (cs AF.:> b)  = condense cs <> " :> " <> condense b
+
 {-------------------------------------------------------------------------------
-  Orphans for cardano-crypto-classes
+  Instances for cardano-crypto-classes
 -------------------------------------------------------------------------------}
 
 instance Condense (SigDSIGN v) => Condense (SignedDSIGN v a) where

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs

@@ -27,33 +27,11 @@ import           Data.SOP.BasicFunctors
 import           NoThunks.Class (InspectHeap (..), InspectHeapNamed (..),
                      NoThunks (..), OnlyCheckWhnfNamed (..), allNoThunks,
                      noThunksInKeysAndValues)
-import           Ouroboros.Consensus.Block.Abstract
-import           Ouroboros.Consensus.Util.Condense
-import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
-import qualified Ouroboros.Network.AnchoredFragment as AF
-import           Ouroboros.Network.Mock.Chain (Chain (..))
 import           Ouroboros.Network.Util.ShowProxy
 import           System.FS.API (SomeHasFS)
 import           System.FS.API.Types (FsPath, Handle)
 import           System.FS.CRC (CRC (CRC))
 
-{-------------------------------------------------------------------------------
-  Condense
--------------------------------------------------------------------------------}
-
-instance Condense (HeaderHash block) => Condense (Point block) where
-    condense GenesisPoint     = "Origin"
-    condense (BlockPoint s h) = "(Point " <> condense s <> ", " <> condense h <> ")"
-
-instance Condense block => Condense (Chain block) where
-    condense Genesis   = "Genesis"
-    condense (cs :> b) = condense cs <> " :> " <> condense b
-
-instance (Condense block, HasHeader block, Condense (HeaderHash block))
-    => Condense (AnchoredFragment block) where
-    condense (AF.Empty pt) = "EmptyAnchor " <> condense (AF.anchorToPoint pt)
-    condense (cs AF.:> b)  = condense cs <> " :> " <> condense b
-
 {-------------------------------------------------------------------------------
   Serialise
 -------------------------------------------------------------------------------}
@@ -64,12 +42,6 @@ instance Serialise (VerKeyDSIGN MockDSIGN) where
   encode = encodeVerKeyDSIGN
   decode = decodeVerKeyDSIGN
 
-{-------------------------------------------------------------------------------
-  ShowProxy
--------------------------------------------------------------------------------}
-
-instance ShowProxy SlotNo where
-
 {-------------------------------------------------------------------------------
   NoThunks
 -------------------------------------------------------------------------------}
@@ -105,9 +77,10 @@ instance NoThunks a => NoThunks (Sum a)
   fs-api
 -------------------------------------------------------------------------------}
 
+deriving via InspectHeap FsPath instance NoThunks FsPath
+deriving newtype instance NoThunks CRC
 deriving via InspectHeapNamed "Handle" (Handle h)
     instance NoThunks (Handle h)
-deriving via InspectHeap FsPath instance NoThunks FsPath
 deriving via OnlyCheckWhnfNamed "SomeHasFS" (SomeHasFS m)
     instance NoThunks (SomeHasFS m)
-deriving newtype instance NoThunks CRC
+