Merge pull request #3357 from input-output-hk/intricate/CDEC-484

[CDEC-484] Remove usages of -fno-warn-orphans from chain

chain/cardano-sl-chain.cabal

@@ -86,7 +86,6 @@ library
                        Pos.Chain.Ssc.Toss.Pure
                        Pos.Chain.Ssc.Toss.Base
                        Pos.Chain.Ssc.Toss.Class
-                       Pos.Chain.Ssc.Toss.Trans
                        Pos.Chain.Ssc.Toss.Types
 
                        Pos.Chain.Update.BlockVersion

chain/src/Pos/Chain/Ssc/Error/Verify.hs

@@ -1,23 +1,19 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 -- | Possible failures during SSC verification.
 
 module Pos.Chain.Ssc.Error.Verify
        ( SscVerifyError (..)
        , sscIsCriticalVerifyError
        ) where
 
+import           Universum
+
 import           Formatting (bprint, build, ords, stext, (%))
 import qualified Formatting.Buildable
 import           Serokell.Util (listJson)
-import           Universum
 
 import           Pos.Core (EpochIndex, SlotId, StakeholderId)
 import           Pos.Core.Ssc (VssCertificate)
 
-instance Buildable (StakeholderId, VssCertificate) where
-    build (a, b) = bprint ("(id: "%build%" , cert: "%build%")") a b
-
 type NEStIds = NonEmpty StakeholderId
 
 -- | Type for verification error

chain/src/Pos/Chain/Ssc/Toss.hs

@@ -4,14 +4,11 @@ module Pos.Chain.Ssc.Toss
        , module Pos.Chain.Ssc.Toss.Class
        , module Pos.Chain.Ssc.Toss.Logic
        , module Pos.Chain.Ssc.Toss.Pure
-       , module Pos.Chain.Ssc.Toss.Trans
        , module Pos.Chain.Ssc.Toss.Types
        ) where
 
 import           Pos.Chain.Ssc.Toss.Base
 import           Pos.Chain.Ssc.Toss.Class
 import           Pos.Chain.Ssc.Toss.Logic
 import           Pos.Chain.Ssc.Toss.Pure
-import           Pos.Chain.Ssc.Toss.Trans
 import           Pos.Chain.Ssc.Toss.Types
-

chain/src/Pos/Chain/Ssc/Toss/Types.hs

@@ -10,20 +10,30 @@ module Pos.Chain.Ssc.Toss.Types
        , tmOpenings
        , tmShares
        , tmCertificates
+
+       , TossT
+       , runTossT
+       , evalTossT
+       , execTossT
        ) where
 
-import           Control.Lens (makeLenses)
+import           Universum hiding (id)
+
+import           Control.Lens (at, makeLenses, (%=), (.=))
+import qualified Ether
 import qualified Formatting.Buildable as Buildable
-import           Universum
 
 import           Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi,
                      deriveSimpleBiCxt)
-import           Pos.Chain.Ssc.Base (isCommitmentId, isCommitmentIdx,
+import           Pos.Chain.Ssc.Base (deleteSignedCommitment,
+                     insertSignedCommitment, isCommitmentId, isCommitmentIdx,
                      isOpeningId, isOpeningIdx, isSharesId, isSharesIdx)
+import           Pos.Chain.Ssc.Toss.Class (MonadToss (..), MonadTossEnv (..),
+                     MonadTossRead (..))
 import           Pos.Core (HasProtocolConstants, LocalSlotIndex, SlotId)
 import           Pos.Core.Ssc (CommitmentsMap, OpeningsMap, SharesMap,
-                     VssCertificatesMap)
-import           Pos.Util.Util (cborError)
+                     VssCertificatesMap, insertVss)
+import           Pos.Util.Util (cborError, ether)
 
 -- | Tag corresponding to SSC data.
 data SscTag
@@ -39,12 +49,6 @@ instance Buildable SscTag where
     build SharesMsg         = "shares"
     build VssCertificateMsg = "VSS certificate"
 
-deriveSimpleBi ''SscTag [
-    Cons 'CommitmentMsg [],
-    Cons 'OpeningMsg [],
-    Cons 'SharesMsg [],
-    Cons 'VssCertificateMsg []]
-
 isGoodSlotForTag :: HasProtocolConstants => SscTag -> LocalSlotIndex -> Bool
 isGoodSlotForTag CommitmentMsg     = isCommitmentIdx
 isGoodSlotForTag OpeningMsg        = isOpeningIdx
@@ -64,8 +68,6 @@ data TossModifier = TossModifier
     , _tmCertificates :: !VssCertificatesMap
     } deriving (Generic, Show, Eq)
 
-makeLenses ''TossModifier
-
 instance Semigroup TossModifier where
    (TossModifier leftComms leftOpens leftShares leftCerts)
      <> (TossModifier rightComms rightOpens rightShares rightCerts) =
@@ -80,10 +82,89 @@ instance Monoid TossModifier where
     mempty = TossModifier mempty mempty mempty mempty
     mappend = (<>)
 
+----------------------------------------------------------------------------
+-- Tranformer
+----------------------------------------------------------------------------
+
+-- | Monad transformer which stores TossModifier and implements
+-- writable MonadToss.
+--
+-- [WARNING] This transformer uses StateT and is intended for
+-- single-threaded usage only.
+type TossT = Ether.StateT' TossModifier
+
+----------------------------------------------------------------------------
+-- Runners
+----------------------------------------------------------------------------
+
+runTossT :: TossModifier -> TossT m a -> m (a, TossModifier)
+runTossT = flip Ether.runStateT
+
+evalTossT :: Monad m => TossModifier -> TossT m a -> m a
+evalTossT = flip Ether.evalStateT
+
+execTossT :: Monad m => TossModifier -> TossT m a -> m TossModifier
+execTossT = flip Ether.execStateT
+
+----------------------------------------------------------------------------
+-- MonadToss
+----------------------------------------------------------------------------
+
+makeLenses ''TossModifier
+
+instance MonadTossRead m =>
+         MonadTossRead (TossT m) where
+    getCommitments = ether $ (<>) <$> use tmCommitments <*> getCommitments
+    getOpenings = ether $ (<>) <$> use tmOpenings <*> getOpenings
+    getShares = ether $ (<>) <$> use tmShares <*> getShares
+    getVssCertificates = ether $ (<>) <$> use tmCertificates <*> getVssCertificates
+    getStableCertificates = ether . getStableCertificates
+
+instance MonadTossEnv m =>
+         MonadTossEnv (TossT m) where
+    getRichmen = ether . getRichmen
+    getAdoptedBVData = ether getAdoptedBVData
+
+instance MonadToss m =>
+         MonadToss (TossT m) where
+    putCommitment signedComm =
+        ether $ tmCommitments %= insertSignedCommitment signedComm
+    putOpening id op =
+        ether $ tmOpenings . at id .= Just op
+    putShares id sh =
+        ether $ tmShares . at id .= Just sh
+    -- NB. 'insertVss' might delete some certs from the map, but it
+    -- shouldn't actually happen in practice because
+    -- 'checkCertificatesPayload' ensures that there are no clashes between
+    -- the certificates in blocks and certificates in the map
+    putCertificate cert =
+        ether $ tmCertificates %= fst . insertVss cert
+    delCommitment id =
+        ether $ tmCommitments %= deleteSignedCommitment id
+    delOpening id =
+        ether $ tmOpenings . at id .= Nothing
+    delShares id =
+        ether $ tmShares . at id .= Nothing
+    resetCO = ether $ do
+        tmCommitments .= mempty
+        tmOpenings .= mempty
+        tmCertificates .= mempty
+        resetCO
+    resetShares = ether $ do
+        tmShares .= mempty
+        resetShares
+    setEpochOrSlot = ether . setEpochOrSlot
+
 deriveSimpleBiCxt [t|()|] ''TossModifier [
     Cons 'TossModifier [
         Field [| _tmCommitments  :: CommitmentsMap     |],
         Field [| _tmOpenings     :: OpeningsMap        |],
         Field [| _tmShares       :: SharesMap          |],
         Field [| _tmCertificates :: VssCertificatesMap |]
     ]]
+
+deriveSimpleBi ''SscTag [
+    Cons 'CommitmentMsg [],
+    Cons 'OpeningMsg [],
+    Cons 'SharesMsg [],
+    Cons 'VssCertificateMsg []]

core/src/Pos/Core/Ssc/VssCertificate.hs

@@ -23,12 +23,12 @@ import           Data.Hashable (Hashable (..))
 import           Data.SafeCopy (base, deriveSafeCopySimple)
 import           Formatting (bprint, build, int, (%))
 import qualified Formatting.Buildable as Buildable
-import           Pos.Core.Common (StakeholderId, addressHash)
 import           Text.JSON.Canonical (FromJSON (..), Int54, JSValue (..),
                      ReportSchemaErrors, ToJSON (..), fromJSField, mkObject)
 
 import           Pos.Binary.Class (AsBinary, Bi (..), encodeListLen,
                      enforceSize)
+import           Pos.Core.Common (StakeholderId, addressHash)
 import           Pos.Core.Genesis.Canonical ()
 import           Pos.Core.Slotting (EpochIndex)
 import           Pos.Crypto (ProtocolMagic, PublicKey, SecretKey,
@@ -75,6 +75,9 @@ instance Buildable VssCertificate where
     build UnsafeVssCertificate {..} = bprint
         ("vssCert:"%build%":"%int) vcSigningKey vcExpiryEpoch
 
+instance Buildable (StakeholderId, VssCertificate) where
+    build (a, b) = bprint ("(id: "%build%" , cert: "%build%")") a b
+
 instance Hashable VssCertificate where
     hashWithSalt s UnsafeVssCertificate{..} =
         hashWithSalt s (vcExpiryEpoch, vcVssKey, vcSigningKey, vcSignature)