[CDEC-512] Fix roundTripsCanonicalJSONShow

Luke hit some weird type errors and I got them to go away by adding
a type signature.

This commit uses `roundTripsCanonicalJSONShow` to test `GenesisData`.

Author: Michael Hueschen

core/test/Test/Pos/Core/Gen.hs

@@ -416,13 +416,17 @@ genGenesisData pm =
     GenesisData
         <$> genGenesisWStakeholders
         <*> genGenesisDelegation pm
-        <*> genTimestamp
+        <*> genTimestampRoundedToSecond
         <*> genGenesisVssCertificatesMap pm
         <*> genGenesisNonAvvmBalances
-        <*> genBlockVersionData
+        <*> genBlockVersionDataByTxFP genLinearTxFP
         <*> genGenesisProtocolConstants
         <*> genGenesisAvvmBalances
         <*> genSharedSeed
+  where
+    -- @TxFeePolicy@s ToJSON instance crashes if we have a
+    -- TxFeePolicyUnknown value.
+    genLinearTxFP = TxFeePolicyTxSizeLinear <$> genTxSizeLinear
 
 genGenesisWStakeholders :: Gen GenesisWStakeholders
 genGenesisWStakeholders = do
@@ -558,6 +562,12 @@ genTimeDiff = TimeDiff <$> genMicrosecond
 genTimestamp :: Gen Timestamp
 genTimestamp = Timestamp <$> genMicrosecond
 
+-- Microseconds are rounded to the nearest second when enc/decoded to/from
+-- JSON. So here we round to the nearest 10^6.
+genTimestampRoundedToSecond :: Gen Timestamp
+genTimestampRoundedToSecond =
+    Timestamp . (* 1000000) . (`rem` 1000000) <$> genMicrosecond
+
 ----------------------------------------------------------------------------
 -- Pos.Core.Ssc Generators
 ----------------------------------------------------------------------------
@@ -756,7 +766,10 @@ genBlockVersion =
         <*> Gen.word8 Range.constantBounded
 
 genBlockVersionData :: Gen BlockVersionData
-genBlockVersionData =
+genBlockVersionData = genBlockVersionDataByTxFP genTxFeePolicy
+
+genBlockVersionDataByTxFP :: Gen TxFeePolicy -> Gen BlockVersionData
+genBlockVersionDataByTxFP genTxFP =
     BlockVersionData
         <$> genScriptVersion
         <*> genMillisecond
@@ -770,7 +783,7 @@ genBlockVersionData =
         <*> genCoinPortion
         <*> genFlatSlotId
         <*> genSoftforkRule
-        <*> genTxFeePolicy
+        <*> genTxFP
         <*> genEpochIndex
 
 

core/test/Test/Pos/Core/Json.hs

@@ -10,14 +10,15 @@ import           Test.Pos.Core.ExampleHelpers (exampleAddress, exampleAddress1,
                      exampleGenesisConfiguration_GCSpec0,
                      exampleGenesisConfiguration_GCSpec1,
                      exampleGenesisConfiguration_GCSpec2,
-                     exampleGenesisConfiguration_GCSrc, exampleGenesisData0, exampleGenesisData1, exampleGenesisData2,
+                     exampleGenesisConfiguration_GCSrc, exampleGenesisData0,
+                     exampleGenesisData1, exampleGenesisData2,
                      exampleGenesisProtocolConstants0,
                      exampleGenesisProtocolConstants1,
                      exampleGenesisProtocolConstants2, feedPM)
 import           Test.Pos.Core.Gen (genAddress, genBlockVersionData, genByte,
                      genCoin, genCoinPortion, genEpochIndex, genFlatSlotId,
                      genGenesisAvvmBalances, genGenesisConfiguration,
-                      genGenesisDelegation,
+                     genGenesisData, genGenesisDelegation,
                      genGenesisInitializer, genGenesisProtocolConstants,
                      genInvReqDataFlowLog, genSharedSeed, genSoftforkRule,
                      genTxFeePolicy)
@@ -27,7 +28,8 @@ import           Test.Pos.Util.Golden (discoverGolden, eachOf,
                      goldenTestCanonicalJSONDec, goldenTestJSON,
                      goldenTestJSONDec)
 import           Test.Pos.Util.Tripping (discoverRoundTrip,
-                     roundTripsAesonBuildable, roundTripsAesonShow)
+                     roundTripsAesonBuildable, roundTripsAesonShow,
+                     roundTripsCanonicalJSONShow)
 import           Universum
 
 --------------------------------------------------------------------------------
@@ -132,9 +134,9 @@ golden_GenesisDataDec2 =
             "test/golden/json/GenesisData2_NoNetworkMagic"
 
 -- TODO @intricate: roundTripsCanonicalJSONShow
---roundTripGenesisData :: Property
---roundTripGenesisData =
---    eachOf 100 (feedPM genGenesisData) roundTripsCanonicalJSONShow
+roundTripGenesisData :: Property
+roundTripGenesisData =
+    eachOf 100 (feedPM genGenesisData) roundTripsCanonicalJSONShow
 
 --------------------------------------------------------------------------------
 -- GenesisAvvmBalances

pkgs/default.nix

@@ -17463,6 +17463,7 @@ aeson
 async
 base
 bytestring
+canonical-json
 directory
 file-embed
 filepath

util/cardano-sl-util.cabal

@@ -157,6 +157,7 @@ test-suite test
                      , base
                      , bytestring
                      , async
+                     , canonical-json
                      , cardano-sl-util
                      , directory
                      , file-embed

util/test/Test/Pos/Util/Tripping.hs

@@ -13,10 +13,10 @@ import           Hedgehog.Internal.Property (Diff (..), failWith)
 import           Hedgehog.Internal.Show (valueDiff)
 import           Hedgehog.Internal.TH (TExpQ)
 import           System.IO (hSetEncoding, stderr, stdout, utf8)
---import qualified Text.JSON.Canonical as Canonical
+import qualified Text.JSON.Canonical as Canonical
 import           Text.Show.Pretty (Value (..), parseValue)
 
---import           Pos.Util.Json.Canonical (SchemaError (..))
+import           Pos.Util.Json.Canonical (SchemaError (..))
 
 discoverRoundTrip :: TExpQ Group
 discoverRoundTrip = discoverPrefix "roundTrip"
@@ -30,19 +30,25 @@ roundTripsAesonBuildable
     :: (Eq a, MonadTest m, ToJSON a, FromJSON a, Buildable a) => a -> m ()
 roundTripsAesonBuildable a = trippingBuildable a encode decode
 
+-- We want @SchemaError@s to show up different (register failure)
+instance Eq SchemaError where
+    _ == _ = False
+
 -- TODO @intricate: roundTripsCanonicalJSONShow
---roundTripsCanonicalJSONShow
---    :: ( Eq a
---       , MonadTest m
---       , Canonical.ToJSON Identity a
---       , Canonical.FromJSON (Either SchemaError) a
---       , HasCallStack
---       , Show a
---       )
---    => a
---    -> m ()
---roundTripsCanonicalJSONShow x =
---    tripping x (runIdentity . Canonical.toJSON) (Canonical.fromJSON :: Canonical.JSValue -> Either SchemaError a)
+roundTripsCanonicalJSONShow
+    :: forall m a
+     . ( Eq a
+       , MonadTest m
+       , Canonical.ToJSON Identity a
+       , Canonical.FromJSON (Either SchemaError) a
+       , HasCallStack
+       , Show a
+       )
+    => a
+    -> m ()
+roundTripsCanonicalJSONShow x =
+    tripping x (runIdentity . Canonical.toJSON :: a -> Canonical.JSValue)
+               (Canonical.fromJSON :: Canonical.JSValue -> Either SchemaError a)
 
 runTests :: [IO Bool] -> IO ()
 runTests tests' = do