Replace force with strict fields and nothunk test

`force` didn't help. It might have made things worse.

Testing in ghci with
`:set +s` and `iterate (updateStats msg1) s0 !! 100000` we get:
With force -> (0.42 secs, 297,818,512 bytes)
No force -> (0.16 secs, 86,713,928 bytes)
No force but with strict record fields -> (0.09 secs, 74,874,224 bytes)

So this commit simply uses strict record fields, instead.

And we also add nothunks tests as a sanity-check.

lib/core/cardano-wallet-core.cabal

@@ -75,6 +75,7 @@ library
     , mtl
     , network
     , network-uri
+    , nothunks
     , ntp-client
     , OddWord
     , ouroboros-consensus
@@ -287,6 +288,7 @@ test-suite unit
     , MonadRandom
     , network
     , network-uri
+    , nothunks
     , persistent
     , pretty-simple
     , regex-pcre-builtin

lib/core/src/Cardano/Wallet/Network.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
@@ -32,6 +33,12 @@ module Cardano.Wallet.Network
     -- * Logging
     , FollowLog (..)
 
+    -- * Logging (for testing)
+    , FollowStats (..)
+    , LogState (..)
+    , emptyStats
+    , updateStats
+
     -- * Initialization
     , defaultRetryPolicy
     ) where
@@ -61,8 +68,6 @@ import Cardano.Wallet.Primitive.Types.RewardAccount
     ( RewardAccount (..) )
 import Cardano.Wallet.Primitive.Types.Tx
     ( SealedTx )
-import Control.DeepSeq
-    ( NFData, force )
 import Control.Monad
     ( when )
 import Control.Monad.Class.MonadSTM
@@ -91,6 +96,8 @@ import Fmt
     ( pretty )
 import GHC.Generics
     ( Generic )
+import NoThunks.Class
+    ( AllowThunksIn (..), NoThunks (..) )
 import Safe
     ( lastMay )
 import UnliftIO.Async
@@ -453,7 +460,7 @@ data FollowLog msg
     | MsgDidRollback SlotNo SlotNo
     | MsgFailedRollingBack Text -- Reason
     | MsgWillIgnoreRollback SlotNo Text -- Reason
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic)
 
 instance ToText msg => ToText (FollowLog msg) where
     toText = \case
@@ -523,18 +530,23 @@ instance HasSeverityAnnotation msg => HasSeverityAnnotation (FollowLog msg) wher
 -- The @f@ allows us to use @LogState@ to keep track of both current and
 -- previously logged stats, and perform operations over it in a nice way.
 data FollowStats f = FollowStats
-    { blocksApplied :: f Int
-    , rollbacks :: f Int
-    , tip :: f SlotNo
-    , time :: f UTCTime
+    { blocksApplied :: !(f Int)
+    , rollbacks :: !(f Int)
+    , tip :: !(f SlotNo)
+    , time :: !(f UTCTime)
       -- ^ NOTE: Current time is not updated until @flush@ is called.
-    , prog :: f SyncProgress
+    , prog :: !(f SyncProgress)
       -- ^ NOTE: prog is not updated until @flush@ is called.
     } deriving (Generic)
 
+-- It seems UTCTime contains thunks internally. This shouldn't matter as we
+-- 1. Change it seldom - from @flush@, not from @updateStats@
+-- 2. Set to a completely new value when we do change it.
+deriving via (AllowThunksIn '["time"] (FollowStats LogState))
+    instance (NoThunks (FollowStats LogState))
+
 deriving instance Show (FollowStats LogState)
 deriving instance Eq (FollowStats LogState)
-deriving instance NFData (FollowStats LogState)
 
 -- | Change the @f@ wrapping each record field.
 hoistStats
@@ -556,11 +568,9 @@ hoistStats f FollowStats{blocksApplied,rollbacks,tip,time,prog} = FollowStats
 -- 2. Sometimes log the difference between the @current@ state and the most
 -- recently logged one.
 data LogState a = LogState
-    { prev :: a -- ^ Most previously logged state
-    , current :: a -- ^ Not-yet logged state
-    } deriving (Eq, Show, Functor, Generic)
-
-deriving instance NFData a => NFData (LogState a)
+    { prev :: !a -- ^ Most previously logged state
+    , current :: !a -- ^ Not-yet logged state
+    } deriving (Eq, Show, Functor, Generic, NoThunks)
 
 initLogState :: a -> LogState a
 initLogState a = LogState a a
@@ -598,7 +608,7 @@ emptyStats t = FollowStats (f 0) (f 0) (f $ SlotNo 0) (f t) (f prog)
 
 -- | Update the stats based on a new log message.
 updateStats :: FollowLog msg -> FollowStats LogState -> FollowStats LogState
-updateStats msg s = force $ case msg of
+updateStats msg s = case msg of
     MsgApplyBlocks _tip blocks ->
         s { blocksApplied = overCurrent (+ NE.length blocks) (blocksApplied s) }
     MsgDidRollback _ _ ->

lib/core/src/Cardano/Wallet/Primitive/SyncProgress.hs

@@ -41,6 +41,8 @@ import GHC.Generics
     ( Generic )
 import GHC.Stack
     ( HasCallStack )
+import NoThunks.Class
+    ( NoThunks (..) )
 import Ouroboros.Consensus.BlockchainTime.WallClock.Types
     ( RelativeTime (..), diffRelTime )
 
@@ -50,6 +52,8 @@ data SyncProgress
     | NotResponding
     deriving (Generic, Eq, Show)
 
+instance NoThunks SyncProgress
+
 instance NFData SyncProgress
 
 instance Ord SyncProgress where

lib/core/src/Data/Quantity.hs

@@ -64,6 +64,8 @@ import GHC.Generics
     ( Generic )
 import GHC.TypeLits
     ( KnownSymbol, Symbol, symbolVal )
+import NoThunks.Class
+    ( NoThunks (..) )
 
 import qualified Data.Text as T
 
@@ -95,6 +97,9 @@ newtype Quantity (unit :: Symbol) a = Quantity { getQuantity :: a }
     deriving stock (Generic, Show, Eq, Ord)
     deriving newtype (Bounded, Enum, Hashable)
 
+
+instance NoThunks a => NoThunks (Quantity unit a)
+
 instance Functor (Quantity any) where
     fmap f (Quantity a) = Quantity (f a)
 
@@ -142,6 +147,8 @@ newtype Percentage = Percentage
     { getPercentage :: Rational }
     deriving stock (Generic, Show, Eq, Ord)
 
+instance NoThunks Percentage
+
 instance NFData Percentage
 
 instance Buildable Percentage where

lib/core/test/unit/Cardano/Wallet/NetworkSpec.hs

@@ -1,19 +1,66 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Cardano.Wallet.NetworkSpec
     ( spec
     ) where
 
 import Prelude
 
+import Cardano.Wallet.Gen
+    ( genBlockHeader, genSlotNo )
 import Cardano.Wallet.Network
-    ( ErrPostTx (..) )
+    ( ErrPostTx (..), FollowLog (..), emptyStats, updateStats )
+import Cardano.Wallet.Primitive.Types
+    ( BlockHeader (..), SlotNo (..) )
+import Data.Time.Clock
+    ( getCurrentTime )
+import NoThunks.Class
+    ( wNoThunks )
 import Test.Hspec
-    ( Spec, describe, it )
+    ( Spec, describe, expectationFailure, it )
+
+import qualified Data.List.NonEmpty as NE
+import Test.QuickCheck
 
 spec :: Spec
 spec = do
     describe "Pointless tests to cover 'Show' instances for errors" $ do
         testShow $ ErrPostTxBadRequest mempty
         testShow $ ErrPostTxProtocolFailure mempty
 
+    describe "updateStats" $ do
+        it "results in no unexpected thunks" $ property $ \(msg :: FollowLog ()) -> do
+            -- This test is not /fully/ fool-proof. Adding lots of nested types to
+            -- LogState and logic in updateStats not covered by the generator
+            -- might cause us to miss a thunk.
+            --
+            -- But it should be decent enough.
+            t <- getCurrentTime
+            let s0 = emptyStats t
+            let s = updateStats msg s0
+            wNoThunks [] s >>= \case
+                Nothing -> return ()
+                Just x -> expectationFailure $ show x
+
+
+instance Arbitrary (FollowLog msg) where
+    arbitrary = oneof
+      [ MsgApplyBlocks
+          <$> arbitrary
+          <*> ((NE.fromList . getNonEmpty) <$> arbitrary)
+      , MsgDidRollback
+          <$> genSlotNo
+          <*> genSlotNo
+      , MsgFollowerTip . Just
+          <$> genBlockHeader (SlotNo 3)
+      , pure $ MsgFollowerTip Nothing
+      , pure MsgHaltMonitoring
+      ]
+  -- Shrinking not that important here
+
+instance Arbitrary BlockHeader where
+    arbitrary = genBlockHeader =<< genSlotNo
+
 testShow :: Show a => a -> Spec
 testShow a = it (show a) True