Merge pull request #277 from input-output-hk/nc/linearEpochInfo

Add `unsafeLinearExtendEpochInfo`.

slotting/cardano-slotting.cabal

@@ -1,4 +1,4 @@
-cabal-version: 2.2
+cabal-version: 3.0
 
 name:                cardano-slotting
 version:             0.1.0.0
@@ -24,7 +24,6 @@ common base                         { build-depends: base
 
 common project-config
   default-language:     Haskell2010
-  hs-source-dirs:       src
   ghc-options:          -Wall
                         -Wcompat
                         -Wincomplete-record-updates
@@ -37,11 +36,13 @@ common project-config
 
 library
   import:               base, project-config
+  hs-source-dirs:       src
 
   exposed-modules:
                         Cardano.Slotting.Block
                         Cardano.Slotting.EpochInfo
                         Cardano.Slotting.EpochInfo.API
+                        Cardano.Slotting.EpochInfo.Extend
                         Cardano.Slotting.EpochInfo.Impl
                         Cardano.Slotting.Slot
                         Cardano.Slotting.Time
@@ -56,3 +57,16 @@ library
                       , quiet
                       , serialise
                       , time             >=1.9.1 && <1.11
+
+test-suite tests
+  import:               base, project-config
+  type:                 exitcode-stdio-1.0
+  hs-source-dirs:       test
+  main-is:              Main.hs
+  other-modules:      Test.Cardano.Slotting.EpochInfo
+  build-depends:        base
+                      , cardano-slotting
+                      , tasty
+                      , tasty-quickcheck
+
+  ghc-options:          -threaded -rtsopts -with-rtsopts=-N

slotting/src/Cardano/Slotting/EpochInfo/API.hs

@@ -11,6 +11,7 @@ module Cardano.Slotting.EpochInfo.API
     epochInfoRange,
     epochInfoSlotToRelativeTime,
     epochInfoSlotToUTCTime,
+    epochInfoSlotLength,
 
     -- * Utility
     hoistEpochInfo,
@@ -19,7 +20,7 @@ module Cardano.Slotting.EpochInfo.API
 where
 
 import Cardano.Slotting.Slot (EpochNo (..), EpochSize (..), SlotNo (..))
-import Cardano.Slotting.Time (RelativeTime, SystemStart, fromRelativeTime)
+import Cardano.Slotting.Time (RelativeTime, SystemStart, fromRelativeTime, SlotLength)
 import Control.Monad.Morph (generalize)
 import Data.Functor.Identity
 import Data.Time.Clock (UTCTime)
@@ -59,7 +60,10 @@ data EpochInfo m
         --
         -- See also 'epochInfoSlotToUTCTime'.
         epochInfoSlotToRelativeTime_ ::
-          HasCallStack => SlotNo -> m RelativeTime
+          HasCallStack => SlotNo -> m RelativeTime,
+        -- | Return the length of the specified slot.
+        epochInfoSlotLength_ ::
+          HasCallStack => SlotNo -> m SlotLength
       }
   deriving NoThunks via OnlyCheckWhnfNamed "EpochInfo" (EpochInfo m)
 
@@ -105,6 +109,10 @@ epochInfoSlotToRelativeTime ::
   HasCallStack => EpochInfo m -> SlotNo -> m RelativeTime
 epochInfoSlotToRelativeTime = epochInfoSlotToRelativeTime_
 
+epochInfoSlotLength ::
+  HasCallStack => EpochInfo m -> SlotNo -> m SlotLength
+epochInfoSlotLength = epochInfoSlotLength_
+
 {-------------------------------------------------------------------------------
   Utility
 -------------------------------------------------------------------------------}
@@ -114,7 +122,8 @@ hoistEpochInfo f ei = EpochInfo
   { epochInfoSize_ = f . epochInfoSize ei,
     epochInfoFirst_ = f . epochInfoFirst ei,
     epochInfoEpoch_ = f . epochInfoEpoch ei,
-    epochInfoSlotToRelativeTime_ = f . epochInfoSlotToRelativeTime ei
+    epochInfoSlotToRelativeTime_ = f . epochInfoSlotToRelativeTime ei,
+    epochInfoSlotLength_ = f . epochInfoSlotLength ei
   }
 
 generalizeEpochInfo :: Monad m => EpochInfo Identity -> EpochInfo m

slotting/src/Cardano/Slotting/EpochInfo/Extend.hs

@@ -0,0 +1,72 @@
+module Cardano.Slotting.EpochInfo.Extend where
+
+import Cardano.Slotting.EpochInfo.API (EpochInfo (..))
+import Cardano.Slotting.Slot (EpochNo (EpochNo), EpochSize (EpochSize), SlotNo (SlotNo))
+import Cardano.Slotting.Time
+  ( SlotLength (getSlotLength),
+    addRelativeTime,
+    multNominalDiffTime,
+  )
+
+-- | Given a basis point, use it and its slot length to impute a linear
+-- relationship between slots and time in order to extend an 'EpochInfo' to
+-- infinity.
+--
+-- The returned `EpochInfo` may still fail (according to the semantics of the
+-- specified monad) if any of the underlying operations fail. For example, if we
+-- cannot translate the basis point.
+unsafeLinearExtendEpochInfo ::
+  Monad m =>
+  SlotNo ->
+  EpochInfo m ->
+  EpochInfo m
+unsafeLinearExtendEpochInfo basisSlot underlyingEI =
+  let lastKnownEpochM = epochInfoEpoch_ underlyingEI basisSlot
+
+      goSize = \en -> do
+        lke <- lastKnownEpochM
+        if en <= lke
+          then epochInfoSize_ underlyingEI en
+          else epochInfoSize_ underlyingEI lke
+      goFirst = \en -> do
+        lke <- lastKnownEpochM
+        if en <= lke
+          then epochInfoFirst_ underlyingEI en
+          else do
+            SlotNo lkeStart <- epochInfoFirst_ underlyingEI lke
+            EpochSize sz <- epochInfoSize_ underlyingEI en
+            let EpochNo numEpochs = en - lke
+            pure . SlotNo $ lkeStart + (numEpochs * sz)
+      goEpoch = \sn ->
+        if sn <= basisSlot
+          then epochInfoEpoch_ underlyingEI sn
+          else do
+            lke <- lastKnownEpochM
+            lkeStart <- epochInfoFirst_ underlyingEI lke
+            EpochSize sz <- epochInfoSize_ underlyingEI lke
+            let SlotNo slotsForward = sn - lkeStart
+            pure . (lke +) . EpochNo $ slotsForward `div` sz
+      goTime = \sn ->
+        if sn <= basisSlot
+          then epochInfoSlotToRelativeTime_ underlyingEI sn
+          else do
+            let SlotNo slotDiff = sn - basisSlot
+
+            a1 <- epochInfoSlotToRelativeTime_ underlyingEI basisSlot
+            lgth <- epochInfoSlotLength_ underlyingEI basisSlot
+
+            pure $
+              addRelativeTime
+                (multNominalDiffTime (getSlotLength lgth) slotDiff)
+                a1
+      goLength = \sn ->
+        if sn <= basisSlot
+          then epochInfoSlotLength_ underlyingEI sn
+          else epochInfoSlotLength_ underlyingEI basisSlot
+   in EpochInfo
+        { epochInfoSize_ = goSize,
+          epochInfoFirst_ = goFirst,
+          epochInfoEpoch_ = goEpoch,
+          epochInfoSlotToRelativeTime_ = goTime,
+          epochInfoSlotLength_ = goLength
+        }

slotting/src/Cardano/Slotting/EpochInfo/Impl.hs

@@ -20,7 +20,8 @@ fixedEpochInfo (EpochSize size) slotLength = EpochInfo
     epochInfoFirst_ = \e -> return $ fixedEpochInfoFirst (EpochSize size) e,
     epochInfoEpoch_ = \sl -> return $ fixedEpochInfoEpoch (EpochSize size) sl,
     epochInfoSlotToRelativeTime_ = \(SlotNo slot) ->
-      return $ RelativeTime (fromIntegral slot * getSlotLength slotLength)
+      return $ RelativeTime (fromIntegral slot * getSlotLength slotLength),
+    epochInfoSlotLength_ = const $ pure slotLength
   }
 
 -- | The pure computation underlying 'epochInfoFirst' applied to

slotting/src/Cardano/Slotting/Time.hs

@@ -11,7 +11,10 @@ module Cardano.Slotting.Time (
   , addRelativeTime
   , diffRelativeTime
   , fromRelativeTime
+  , multRelativeTime
   , toRelativeTime
+    -- * Nominal diff time
+  , multNominalDiffTime
     -- * Slot length
   , getSlotLength
   , mkSlotLength
@@ -28,7 +31,14 @@ import           Cardano.Binary (FromCBOR(..), ToCBOR(..))
 import           Codec.Serialise
 import           Control.Exception (assert)
 import           Data.Fixed
-import           Data.Time (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime)
+import           Data.Time
+                  ( NominalDiffTime,
+                    UTCTime,
+                    addUTCTime,
+                    diffUTCTime,
+                    nominalDiffTimeToSeconds,
+                    secondsToNominalDiffTime,
+                  )
 import           GHC.Generics (Generic)
 import           NoThunks.Class (InspectHeap (..), NoThunks)
 import           Quiet
@@ -70,6 +80,16 @@ toRelativeTime (SystemStart t) t' = assert (t' >= t) $
 fromRelativeTime :: SystemStart -> RelativeTime -> UTCTime
 fromRelativeTime (SystemStart t) (RelativeTime t') = addUTCTime t' t
 
+multRelativeTime :: Integral f => RelativeTime -> f -> RelativeTime
+multRelativeTime (RelativeTime t) =
+  RelativeTime . multNominalDiffTime t
+
+multNominalDiffTime :: Integral f => NominalDiffTime -> f -> NominalDiffTime
+multNominalDiffTime t f =
+  secondsToNominalDiffTime $
+    nominalDiffTimeToSeconds t * fromIntegral f
+
+
 {-------------------------------------------------------------------------------
   SlotLength
 -------------------------------------------------------------------------------}

slotting/test/Main.hs

@@ -0,0 +1,8 @@
+import Test.Tasty
+import Test.Cardano.Slotting.EpochInfo (epochInfoTests)
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests = testGroup "EpochInfo" [epochInfoTests]

slotting/test/Test/Cardano/Slotting/EpochInfo.hs

@@ -0,0 +1,49 @@
+module Test.Cardano.Slotting.EpochInfo where
+
+import Cardano.Slotting.EpochInfo.API (EpochInfo (..))
+import Cardano.Slotting.EpochInfo.Extend (unsafeLinearExtendEpochInfo)
+import Cardano.Slotting.EpochInfo.Impl (fixedEpochInfo)
+import Cardano.Slotting.Slot (EpochNo (EpochNo), EpochSize (EpochSize), SlotNo (SlotNo))
+import Cardano.Slotting.Time (slotLengthFromSec)
+import Data.Functor.Identity (Identity)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.QuickCheck as QC
+  ( Arbitrary (arbitrary),
+    choose,
+    testProperty,
+    (===),
+  )
+
+baseEpochInfo :: EpochInfo Identity
+baseEpochInfo = fixedEpochInfo (EpochSize 10) (slotLengthFromSec 10)
+
+-- An extended epoch info from a fixedEpochInfo should act as identity.
+extendedEpochInfo :: SlotNo -> EpochInfo Identity
+extendedEpochInfo sn = unsafeLinearExtendEpochInfo sn baseEpochInfo
+
+newtype TestSlotNo = TestSlotNo SlotNo
+  deriving (Eq, Show)
+
+instance Arbitrary TestSlotNo where
+  arbitrary = TestSlotNo . SlotNo <$> choose (1, 200)
+
+newtype TestEpochNo = TestEpochNo EpochNo
+  deriving (Eq, Show)
+
+instance Arbitrary TestEpochNo where
+  arbitrary = TestEpochNo . EpochNo <$> choose (0, 20)
+
+epochInfoTests :: TestTree
+epochInfoTests =
+  testGroup
+    "linearExtend"
+    [ QC.testProperty "epochSize matches" $ \(TestSlotNo basisSlot, TestEpochNo sn) ->
+        epochInfoSize_ baseEpochInfo sn === epochInfoSize_ (extendedEpochInfo basisSlot) sn,
+      QC.testProperty "epochFirst matches" $ \(TestSlotNo basisSlot, TestEpochNo sn) ->
+        epochInfoFirst_ baseEpochInfo sn === epochInfoFirst_ (extendedEpochInfo basisSlot) sn,
+      QC.testProperty "epochEpoch matches" $ \(TestSlotNo basisSlot, TestSlotNo sn) ->
+        epochInfoEpoch_ baseEpochInfo sn === epochInfoEpoch_ (extendedEpochInfo basisSlot) sn,
+      QC.testProperty "epochTime matches" $ \(TestSlotNo basisSlot, TestSlotNo sn) ->
+        epochInfoSlotToRelativeTime_ baseEpochInfo sn
+          === epochInfoSlotToRelativeTime_ (extendedEpochInfo basisSlot) sn
+    ]