Merge pull request #5545 from IntersectMBO/lehins/fix-nothunks-tests

Fix nightly CI

Author: lehins

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rewards.hs

@@ -104,6 +104,7 @@ import Cardano.Ledger.Slot (epochInfoSize)
 import Cardano.Ledger.Val (Val (..), invert, (<+>), (<->))
 import Cardano.Protocol.Crypto (VRF, hashVerKeyVRF)
 import Cardano.Slotting.Slot (EpochSize (..))
+import Control.DeepSeq
 import Control.Monad (replicateM)
 import Control.Monad.Trans.Reader (asks, runReader)
 import Data.Foldable as F (fold, foldl')
@@ -823,7 +824,7 @@ mkSnapShot activeStake delegs stakePools =
     , ssTotalActiveStake = totalActiveStake
     , ssDelegations = delegs
     , ssPoolParams = stakePools
-    , ssStakePoolsSnapShot = VMap.map snapShotFromStakePoolParams stakePools
+    , ssStakePoolsSnapShot = force $ VMap.map snapShotFromStakePoolParams stakePools
     }
   where
     snapShotFromStakePoolParams stakePoolParams =

libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs

@@ -129,7 +129,7 @@ internsFromMap m
             }
         ]
 
-internsFromVMap :: Ord k => VMap VB kv k a -> Interns k
+internsFromVMap :: (Ord k, VMap.Vector kv a) => VMap VB kv k a -> Interns k
 internsFromVMap m
   | VMap.size m == 0 = mempty
   | otherwise =

libs/cardano-ledger-core/src/Cardano/Ledger/State/SnapShots.hs

@@ -284,12 +284,10 @@ data SnapShot = SnapShot
   { ssStake :: !Stake -- TODO: rename to `ssActiveStake`
 
   -- ^ All of the stake for registered staking credentials that have a delegation to a stake pool.
-  , ssTotalActiveStake :: NonZero Coin -- Note: lazy on purpose
-
-  -- ^ Total active stake, which is the sum of all of the stake from `ssStake`, which is why it is
-  -- lazy.  It is primarily used in a denominator, therefore it cannot be zero and is defaulted to
-  -- 1. This is a reasonable assumption for a system that relies on non-zero active stake to produce
-  -- blocks.
+  , ssTotalActiveStake :: !(NonZero Coin)
+  -- ^ Total active stake, which is the sum of all of the stake from `ssStake`. It is primarily used
+  -- in a denominator, therefore it cannot be zero and is defaulted to 1. This is a reasonable
+  -- assumption for a system that relies on non-zero active stake to produce blocks.
   , ssDelegations :: VMap VB VB (Credential Staking) (KeyHash StakePool) -- TODO: remove (lazy on purpose)
   , ssPoolParams :: VMap VB VB (KeyHash StakePool) StakePoolParams -- TODO: remove (lazy on purpose)
   , ssStakePoolsSnapShot :: !(VMap VB VB (KeyHash StakePool) StakePoolSnapShot)
@@ -299,7 +297,7 @@ data SnapShot = SnapShot
   deriving (ToJSON) via KeyValuePairs SnapShot
   deriving
     (NoThunks)
-    via AllowThunksIn '["ssTotalActiveStake", "ssDelegations", "ssPoolParams"] SnapShot
+    via AllowThunksIn '["ssDelegations", "ssPoolParams"] SnapShot
 
 instance NFData SnapShot
 

libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs

@@ -85,6 +85,7 @@ import Cardano.Ledger.Plutus.Language (Language (..), nonNativeLanguages)
 import Cardano.Ledger.Rewards (Reward (..), RewardType (..))
 import Cardano.Ledger.State
 import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
+import Control.DeepSeq
 import Control.Monad (replicateM)
 import Control.Monad.Identity (Identity)
 import Control.Monad.Trans.Fail.String (errorFail)
@@ -696,7 +697,7 @@ instance Arbitrary SnapShot where
         stakePoolSnapShotFromParams poolId =
           mkStakePoolSnapShot ssStake ssTotalActiveStake
             . mkStakePoolState deposit (Map.findWithDefault mempty poolId delegationsPerStakePool)
-        ssStakePoolsSnapShot = VMap.mapWithKey stakePoolSnapShotFromParams ssPoolParams
+        ssStakePoolsSnapShot = force $ VMap.mapWithKey stakePoolSnapShotFromParams ssPoolParams
     pure SnapShot {..}
 
 instance Arbitrary SnapShots where

libs/vector-map/src/Data/VMap.hs

@@ -110,8 +110,8 @@ instance
 empty :: (VG.Vector kv k, VG.Vector vv v) => VMap kv vv k v
 empty = VMap VG.empty
 
-size :: VG.Vector kv k => VMap kv vv k v -> Int
-size = VG.length . KV.keysVector . unVMap
+size :: (VG.Vector kv k, VG.Vector vv v) => VMap kv vv k v -> Int
+size = VG.length . unVMap
 {-# INLINE size #-}
 
 lookup ::
@@ -230,11 +230,13 @@ fromDistinctAscListN n = VMap . KV.fromDistinctAscListN n
 {-# INLINE fromDistinctAscListN #-}
 
 map ::
-  (VG.Vector vv a, VG.Vector vv b) =>
+  (VG.Vector kv k, VG.Vector vv a, VG.Vector vv b) =>
   (a -> b) ->
   VMap kv vv k a ->
   VMap kv vv k b
-map f (VMap vec) = VMap (KV.mapValsKVVector f vec)
+map f (VMap vec) = VMap (VG.map (\(k, v) -> (k, f v)) vec)
+-- TODO: benchmark and switch to this implementation when we switch to Data.Vector.Strict
+-- VMap (KV.mapValsKVVector f vec)
 {-# INLINE map #-}
 
 mapMaybe ::
@@ -258,7 +260,9 @@ mapWithKey ::
   (k -> a -> b) ->
   VMap kv vv k a ->
   VMap kv vv k b
-mapWithKey f (VMap vec) = VMap (KV.mapWithKeyKVVector f vec)
+mapWithKey f (VMap vec) = VMap (VG.map (\(k, v) -> (k, f k v)) vec)
+-- TODO: benchmark and switch to this implementation when we switch to Data.Vector.Strict
+-- VMap (KV.mapWithKeyKVVector f vec)
 {-# INLINE mapWithKey #-}
 
 foldMapWithKey ::

libs/vector-map/src/Data/VMap/KVVector.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -25,8 +26,8 @@ module Data.VMap.KVVector (
   fromDistinctAscListN,
   fromList,
   fromListN,
-  mapValsKVVector,
-  mapWithKeyKVVector,
+  -- mapValsKVVector,
+  -- mapWithKeyKVVector,
   memberKVVector,
   lookupKVVector,
   lookupDefaultKVVector,
@@ -58,6 +59,13 @@ import qualified Data.Vector.Storable as VS
 import qualified GHC.Exts as Exts
 import GHC.Generics
 import NoThunks.Class
+#if MIN_VERSION_vector(0, 13, 2)
+import qualified Data.Vector.Strict as VBS
+
+instance NoThunks a => NoThunks (VBS.Vector a) where
+  showTypeOf _ = "Boxed..StrictVector"
+  wNoThunks ctxt = noThunksInValues ctxt . VBS.toList
+#endif
 
 -- | Convert a __sorted__ key/value vector into a `Map.Map`
 toMap ::
@@ -173,26 +181,28 @@ fromAscListWithKeyN n f xs
       VG.create $ VGM.unsafeNew n >>= fillWithList xs >>= removeDuplicates (\k v1 v2 -> f k v2 v1)
 {-# INLINE fromAscListWithKeyN #-}
 
-mapValsKVVector ::
-  (VG.Vector vv a, VG.Vector vv b) =>
-  (a -> b) ->
-  KVVector kv vv (k, a) ->
-  KVVector kv vv (k, b)
-mapValsKVVector f vec =
-  KVVector {keysVector = keysVector vec, valsVector = VG.map f (valsVector vec)}
-{-# INLINE mapValsKVVector #-}
-
-mapWithKeyKVVector ::
-  (VG.Vector kv k, VG.Vector vv a, VG.Vector vv b) =>
-  (k -> a -> b) ->
-  KVVector kv vv (k, a) ->
-  KVVector kv vv (k, b)
-mapWithKeyKVVector f KVVector {..} =
-  KVVector
-    { keysVector = keysVector
-    , valsVector = VG.imap (\i -> f (keysVector VG.! i)) valsVector
-    }
-{-# INLINE mapWithKeyKVVector #-}
+-- These guys are too lazy for the KVVector and would require `Data.Vector.Strict`
+--
+-- mapValsKVVector ::
+--   (VG.Vector vv a, VG.Vector vv b) =>
+--   (a -> b) ->
+--   KVVector kv vv (k, a) ->
+--   KVVector kv vv (k, b)
+-- mapValsKVVector f vec =
+--   KVVector {keysVector = keysVector vec, valsVector = VG.map f (valsVector vec)}
+-- {-# INLINE mapValsKVVector #-}
+
+-- mapWithKeyKVVector ::
+--   (VG.Vector kv k, VG.Vector vv a, VG.Vector vv b) =>
+--   (k -> a -> b) ->
+--   KVVector kv vv (k, a) ->
+--   KVVector kv vv (k, b)
+-- mapWithKeyKVVector f KVVector {..} =
+--   KVVector
+--     { keysVector = keysVector
+--     , valsVector = VG.imap (\i -> f (keysVector VG.! i)) valsVector
+--     }
+-- {-# INLINE mapWithKeyKVVector #-}
 
 internKVVectorMaybe :: (VG.Vector kv k, Ord k) => k -> KVVector kv vv (k, v) -> Maybe k
 internKVVectorMaybe key (KVVector keys _values) =

libs/vector-map/test/Main.hs

@@ -1,14 +1,40 @@
 module Main where
 
+import System.IO (
+  BufferMode (LineBuffering),
+  hSetBuffering,
+  hSetEncoding,
+  stdout,
+  utf8,
+ )
 import Test.Hspec
+import Test.Hspec.Core.Runner (ColorMode (ColorAlways), Config (..), defaultConfig, hspecWith)
 import Test.VMap
 
 -- ====================================================================================
 
+customSpecConfig :: Config
+customSpecConfig =
+  defaultConfig
+    { configTimes = True
+    , configColorMode = ColorAlways
+    }
+
+customSpecMainWithConfig :: Config -> Spec -> IO ()
+customSpecMainWithConfig conf spec = do
+  hSetBuffering stdout LineBuffering
+  hSetEncoding stdout utf8
+  hspecWith conf spec
+
+customSpecMain :: Spec -> IO ()
+customSpecMain = customSpecMainWithConfig customSpecConfig
+
+-- ====================================================================================
+
 tests :: Spec
 tests =
   describe "vector-map" $ do
     vMapTests
 
 main :: IO ()
-main = hspec tests
+main = customSpecMain tests

libs/vector-map/test/Test/VMap.hs

@@ -1,8 +1,11 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Test.VMap where
 
+import Control.Exception
 import qualified Data.List as List
 import qualified Data.Map.Strict as Map
 import Data.VMap as VMap
@@ -29,6 +32,11 @@ prop_AsMapTo fromVM fromM vm = fromVM vm === fromM (toMap vm)
 prop_AsMapFrom :: (a -> VMapT) -> (a -> MapT) -> a -> Property
 prop_AsMapFrom mkVMap mkMap a = toMap (mkVMap a) === mkMap a
 
+data ThunkException = ThunkException
+  deriving (Eq, Show)
+
+instance Exception ThunkException
+
 vMapTests :: Spec
 vMapTests =
   describe "VMap" $ do
@@ -38,6 +46,37 @@ vMapTests =
       prop "to/fromAscList" $ prop_Roundtrip VMap.toAscList VMap.fromAscList
       prop "to/fromList" $ prop_Roundtrip VMap.toAscList VMap.fromList
       prop "to/fromMap" $ prop_Roundtrip VMap.toMap VMap.fromMap
+    describe "strictness" $ do
+      let bottom :: a
+          bottom = throw ThunkException
+      prop "fromList" $ \xs ys -> do
+        let
+          vmapKeyThunk, vmapValueThunk :: VMap VB VB String String
+          vmapKeyThunk = VMap.fromList $ xs ++ [(bottom, "value")] ++ ys
+          vmapValueThunk = VMap.fromList $ xs ++ [("key", bottom)] ++ ys
+        evaluate vmapKeyThunk `shouldThrow` (== ThunkException)
+        evaluate vmapValueThunk `shouldThrow` (== ThunkException)
+      prop "map" $ \xs ys -> do
+        let
+          vmapValueThunk :: VMap VB VB String String
+          vmapValueThunk =
+            VMap.map (\v -> if v == "bottom" then bottom else v) $
+              VMap.fromList $
+                xs ++ [("key", "bottom")] ++ ys
+        evaluate vmapValueThunk `shouldThrow` (== ThunkException)
+      prop "mapWithKey" $ \xs ys -> do
+        let
+          vmapKeyThunk, vmapValueThunk :: VMap VB VB String String
+          vmapKeyThunk =
+            VMap.mapWithKey (\k v -> if k == "bottom" then bottom else v) $
+              VMap.fromList $
+                xs ++ [("bottom", "value")] ++ ys
+          vmapValueThunk =
+            VMap.mapWithKey (\_ v -> if v == "bottom" then bottom else v) $
+              VMap.fromList $
+                xs ++ [("key", "bottom")] ++ ys
+        evaluate vmapKeyThunk `shouldThrow` (== ThunkException)
+        evaluate vmapValueThunk `shouldThrow` (== ThunkException)
     describe "asMap" $ do
       prop "mapMaybeWithKey" $ \xs f ->
         prop_AsMapFrom

libs/vector-map/vector-map.cabal

@@ -84,6 +84,7 @@ test-suite tests
     base,
     containers,
     hspec,
+    hspec-core,
     quickcheck-classes-base,
     vector-map,