Add new TimeInterpreter abstraction

- We will use it to correctly deal with time across hard-forks
- Added tests for equivalence with old implementation

lib/core/cardano-wallet-core.cabal

@@ -289,6 +289,7 @@ test-suite unit
       Cardano.Wallet.Primitive.CoinSelectionSpec
       Cardano.Wallet.Primitive.FeeSpec
       Cardano.Wallet.Primitive.ModelSpec
+      Cardano.Wallet.Primitive.SlottingSpec
       Cardano.Wallet.Primitive.SyncProgressSpec
       Cardano.Wallet.Primitive.TypesSpec
       Cardano.Wallet.RegistrySpec

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

@@ -11,8 +11,13 @@
 -- @UTCTime@.
 
 module Cardano.Wallet.Primitive.Slotting
-    ( -- * Legacy functions
-      unsafeEpochNo
+    ( -- * New api using ouroboros-concensus
+      epochOf
+    , singleEraInterpreter
+    , runQuery
+
+      -- * Old functions
+    , unsafeEpochNo
     , epochStartTime
     , epochPred
     , epochSucc
@@ -62,15 +67,50 @@ import Numeric.Natural
 import Ouroboros.Consensus.HardFork.History.EraParams
     ( EraParams (..), noLowerBoundSafeZone )
 import Ouroboros.Consensus.HardFork.History.Qry
+    ( Qry, runQuery, slotToEpoch )
 import Ouroboros.Consensus.HardFork.History.Summary
     ( Summary (..), neverForksSummary )
 
 import qualified Cardano.Slotting.Slot as Cardano
 import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as Cardano
 
+-- -----------------------------------------------------------------------------
+-- New Api using ouroboros-consensus. With the right interpreter, the
+-- calculations don't break on hard-forks.
+
+epochOf :: Cardano.SlotNo -> Qry EpochNo
+epochOf slot = do
+    (e, _, _) <- slotToEpoch slot
+    return $ EpochNo $ fromIntegral $ Cardano.unEpochNo e
+
+-- | An 'Interpreter' for a single era, where the slotting from
+-- @GenesisParameters@ cannot change.
+--
+-- TODO: The type should be changed to @Interpreter@ when we bump
+-- ouroboros-consensus.
+singleEraInterpreter :: GenesisParameters -> Summary '[x]
+singleEraInterpreter gp = neverForksSummary $
+    EraParams
+        { eraEpochSize =
+            Cardano.EpochSize
+            . fromIntegral
+            . unEpochLength
+            $ gp ^. #getEpochLength
+
+        , eraSlotLength =
+            Cardano.mkSlotLength
+            . unSlotLength
+            $ gp ^. #getSlotLength
+
+        , eraSafeZone =
+            noLowerBoundSafeZone (k * 2)
+        }
+  where
+    k = fromIntegral $ getQuantity $ getEpochStability gp
+
 -- -----------------------------------------------------------------------------
 -- Legacy functions
--- These only work for a single era. We need to stop using them.
+-- These only work for a single era. We need to stop using them
 
 -- | The essential parameters necessary for performing slot arithmetic.
 data SlotParameters = SlotParameters

lib/core/test/unit/Cardano/Wallet/Primitive/SlottingSpec.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Cardano.Wallet.Primitive.SlottingSpec
+    ( spec
+    ) where
+
+import Prelude
+
+import Cardano.Slotting.Slot
+    ( SlotNo (..) )
+import Cardano.Wallet.Gen
+    ( genActiveSlotCoefficient, shrinkActiveSlotCoefficient )
+import Cardano.Wallet.Primitive.Slotting
+    ( epochOf, fromFlatSlot, runQuery, singleEraInterpreter )
+import Cardano.Wallet.Primitive.Types
+    ( ActiveSlotCoefficient
+    , EpochLength (..)
+    , GenesisParameters (..)
+    , Hash (..)
+    , SlotId (epochNumber)
+    , SlotLength (..)
+    , StartTime (..)
+    )
+import Data.Quantity
+    ( Quantity (..) )
+import Data.Word
+    ( Word32 )
+import Test.Hspec
+    ( Spec, describe, it )
+import Test.QuickCheck
+    ( Arbitrary (..), choose, property, (===) )
+import Test.QuickCheck.Arbitrary.Generic
+    ( genericArbitrary, genericShrink )
+import Test.Utils.Time
+    ( genUniformTime )
+
+spec :: Spec
+spec = do
+    describe "slotting" $ do
+        it "runQuery epochNo singleEraInterpreter == epochNumber . fromFlatSlot"
+            $ property $ \gp slotNo -> do
+                let run q = runQuery q (singleEraInterpreter gp)
+                let Right res = run (epochOf slotNo)
+                let legacy = epochNumber $ fromFlatSlot
+                        (getEpochLength gp)
+                        (unSlotNo slotNo)
+                res === legacy
+
+instance Arbitrary SlotNo where
+    -- Don't generate /too/ large slots
+    arbitrary = SlotNo . fromIntegral <$> (arbitrary @Word32)
+    shrink (SlotNo x) = map SlotNo $ shrink x
+
+instance Arbitrary GenesisParameters where
+    arbitrary = genericArbitrary
+    shrink = genericShrink
+
+instance Arbitrary SlotLength where
+    arbitrary = SlotLength . fromRational . toRational <$> choose (0.1,10::Double)
+    shrink _ = []
+
+instance Arbitrary (Hash "Genesis") where
+    arbitrary = return $ Hash "Genesis Hash"
+    shrink _ = []
+
+instance Arbitrary StartTime where
+    arbitrary = StartTime <$> genUniformTime
+    shrink _ = []
+
+instance Arbitrary EpochLength where
+    arbitrary = EpochLength <$> choose (2,100000)
+    shrink _ = []
+
+instance Arbitrary ActiveSlotCoefficient where
+    arbitrary = genActiveSlotCoefficient
+    shrink = shrinkActiveSlotCoefficient
+
+instance Arbitrary (Quantity "block" Word32) where
+    arbitrary = Quantity <$> choose (1,100000)
+    shrink (Quantity x) = map Quantity $ shrink x