Skip to content

Commit

Permalink
Merge #1114
Browse files Browse the repository at this point in the history 
1114: Add `epochCeiling` function to `Primitive.Types`. r=jonathanknowles a=jonathanknowles

# Issue Number

#1086 

# Overview

This PR:

- [x] Adds the functions `epoch{Ceiling,Floor}`
  - `epochCeiling` calculates the _earliest_ `EpochNo` whose start time is _greater than or equal to_ the specified time. (Required by issue #1086.)
  - `epochFloor`  calculates the _latest_ `EpochNo` whose start time is _less than or equal to_ the specified time. (Added for completeness.)
- [x] Adds the `epochStartTime` and `epoch{Pred,Succ}` helper functions.
- [x] Adds a set of property tests for the above.

# Comments

The functions added by this PR follow the same general pattern as the following existing functions:
* `slot{Ceiling,Floor}`
* `slot{Pred,Succ}`
* `slotStartTime`

Co-authored-by: Jonathan Knowles <[email protected]>
  • Loading branch information
@iohk-bors @jonathanknowles
iohk-bors[bot] and jonathanknowles authored Dec 5, 2019
2 parents 936fdd1 + 93d713f commit b8233f4
Show file tree
Hide file tree
Showing 3 changed files with 319 additions and 18 deletions.
53 changes: 53 additions & 0 deletions lib/core/src/Cardano/Wallet/Primitive/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -89,6 +89,11 @@ module Cardano.Wallet.Primitive.Types
, SlotNo (..)
, EpochNo (..)
, unsafeEpochNo
, epochStartTime
, epochPred
, epochSucc
, epochCeiling
, epochFloor
, SlotParameters (..)
, SlotLength (..)
, EpochLength (..)
Expand Down Expand Up @@ -1095,6 +1100,54 @@ unsafeEpochNo epochNo
maxEpochNo :: Word32
maxEpochNo = fromIntegral @Word31 $ unEpochNo maxBound

-- | Calculate the time at which an epoch begins.
epochStartTime :: SlotParameters -> EpochNo -> UTCTime
epochStartTime sps e = slotStartTime sps $ SlotId e 0

-- | Return the epoch immediately before the given epoch, or 'Nothing' if there
-- is no representable epoch before the given epoch.
epochPred :: EpochNo -> Maybe EpochNo
epochPred (EpochNo e)
| e == minBound = Nothing
| otherwise = Just $ EpochNo $ pred e

-- | Return the epoch immediately after the given epoch, or 'Nothing' if there
-- is no representable epoch after the given epoch.
epochSucc :: EpochNo -> Maybe EpochNo
epochSucc (EpochNo e)
| e == maxBound = Nothing
| otherwise = Just $ EpochNo $ succ e

-- | For the given time 't', calculate the number of the earliest epoch with
-- start time 's' such that 't ≤ s'.
--
-- Returns 'Nothing' if the calculation would result in an epoch number that is
-- not representable.
epochCeiling :: SlotParameters -> UTCTime -> Maybe EpochNo
epochCeiling sps t
| t < timeMin = Just minBound
| t > timeMax = Nothing
| otherwise = case slotCeiling sps t of
SlotId epoch 0 -> Just epoch
SlotId epoch _ -> epochSucc epoch
where
timeMin = epochStartTime sps minBound
timeMax = epochStartTime sps maxBound

-- | For the given time 't', calculate the number of the latest epoch with
-- start time 's' such that 's ≤ t'.
--
-- Returns 'Nothing' if the calculation would result in an epoch number that is
-- not representable.
epochFloor :: SlotParameters -> UTCTime -> Maybe EpochNo
epochFloor sps t
| t < timeMin = Nothing
| t > timeMax = Just maxBound
| otherwise = epochNumber <$> slotFloor sps t
where
timeMin = epochStartTime sps minBound
timeMax = epochStartTime sps maxBound

instance NFData SlotId

instance Buildable SlotId where
Expand Down
225 changes: 223 additions & 2 deletions lib/core/test/unit/Cardano/Wallet/Primitive/TypesSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -54,6 +54,11 @@ import Cardano.Wallet.Primitive.Types
, WalletName (..)
, balance
, computeUtxoStatistics
, epochCeiling
, epochFloor
, epochPred
, epochStartTime
, epochSucc
, excluding
, flatSlot
, fromFlatSlot
Expand Down Expand Up @@ -121,7 +126,7 @@ import Data.Text
import Data.Text.Class
( TextDecodingError (..), fromText, toText )
import Data.Time
( UTCTime )
( Day (ModifiedJulianDay), UTCTime, toModifiedJulianDay, utctDay )
import Data.Time.Utils
( utcTimePred, utcTimeSucc )
import Data.Word
Expand All @@ -145,6 +150,7 @@ import Test.QuickCheck
, NonNegative (..)
, NonZero (..)
, Property
, Small (..)
, arbitraryBoundedEnum
, arbitraryPrintableChar
, arbitrarySizedBoundedIntegral
Expand All @@ -171,7 +177,7 @@ import Test.QuickCheck.Monadic
import Test.Text.Roundtrip
( textRoundtrip )
import Test.Utils.Time
( genUniformTime, getUniformTime )
( genUniformTime, genUniformTimeWithinRange, getUniformTime )

import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
Expand Down Expand Up @@ -413,6 +419,187 @@ spec = do
property $ \(a :: Int) (b :: Int) ->
compare (InclusiveBound a) (InclusiveBound b) === compare a b

describe "Epoch arithmetic: predecessors and successors" $ do

let succN n = applyN n (epochSucc =<<)
let predN n = applyN n (epochPred =<<)

it "epochPred minBound == Nothing" $
epochPred minBound === Nothing

it "epochSucc maxBound == Nothing" $
epochSucc maxBound === Nothing

it "(applyN n epochSucc) . (applyN n epochPred) == id" $
withMaxSuccess 1000 $ property $
\(Small epochWord) (Small n) ->
let epoch = EpochNo epochWord
withinBounds = minBound + n <= unEpochNo epoch
expectedResult =
if withinBounds then Just epoch else Nothing
in
checkCoverage $
cover 10 withinBounds "within bounds" $
cover 10 (not withinBounds) "out of bounds" $
expectedResult === succN n (predN n $ Just epoch)

it "(applyN n epochPred) . (applyN n epochSucc) == id" $
withMaxSuccess 1000 $ property $
\(Small epochWord) (Small n) ->
let epoch = EpochNo $ maxBound - epochWord
withinBounds = maxBound - n >= unEpochNo epoch
expectedResult =
if withinBounds then Just epoch else Nothing
in
checkCoverage $
cover 10 withinBounds "within bounds" $
cover 10 (not withinBounds) "out of bounds" $
expectedResult === predN n (succN n $ Just epoch)

describe "Epoch arithmetic: epochCeiling: core properties" $ do

it "epochStartTime (epochCeiling t) >= t" $
withMaxSuccess 1000 $ property $
\(SlotParametersAndTimePoint sps time) -> do
let timeMaximum = epochStartTime sps maxBound
let withinBounds = time <= timeMaximum
checkCoverage $
cover 10 withinBounds "within bounds" $
cover 10 (not withinBounds) "out of bounds" $
case epochCeiling sps time of
Nothing -> not withinBounds
Just en -> time <= epochStartTime sps en

it "epochStartTime (epochPred (epochCeiling t)) < t" $
withMaxSuccess 1000 $ property $
\(SlotParametersAndTimePoint sps time) -> do
let timeMaximum = epochStartTime sps maxBound
let withinBounds = time <= timeMaximum
checkCoverage $
cover 10 withinBounds "within bounds" $
cover 10 (not withinBounds) "out of bounds" $
case epochCeiling sps time of
Nothing -> not withinBounds
Just e1 -> case epochPred e1 of
Nothing -> e1 == minBound
Just e2 -> time > epochStartTime sps e2

describe "Epoch arithmetic: epochFloor: core properties" $ do

it "epochStartTime (epochFloor t) <= t" $
withMaxSuccess 1000 $ property $
\(SlotParametersAndTimePoint sps time) -> do
let timeMinimum = epochStartTime sps minBound
let withinBounds = time >= timeMinimum
checkCoverage $
cover 10 withinBounds "within bounds" $
cover 10 (not withinBounds) "out of bounds" $
case epochFloor sps time of
Nothing -> not withinBounds
Just en -> time >= epochStartTime sps en

it "epochStartTime (epochSucc (epochFloor t)) > t" $
withMaxSuccess 1000 $ property $
\(SlotParametersAndTimePoint sps time) -> do
let timeMinimum = epochStartTime sps minBound
let withinBounds = time >= timeMinimum
checkCoverage $
cover 10 withinBounds "within bounds" $
cover 10 (not withinBounds) "out of bounds" $
case epochFloor sps time of
Nothing -> not withinBounds
Just e1 -> case epochSucc e1 of
Nothing -> e1 == maxBound
Just e2 -> time < epochStartTime sps e2

describe "Epoch arithmetic: epochCeiling: boundary conditions" $ do

it "epochCeiling . epochStartTime == id" $
withMaxSuccess 1000 $ property $ \(sps, epoch) ->
epochCeiling sps (epochStartTime sps epoch)
=== Just epoch

it "epochCeiling . utcTimePred . epochStartTime == id" $
withMaxSuccess 1000 $ property $ \(sps, epoch) ->
epoch > minBound ==> do
let fun = epochCeiling sps
. utcTimePred
. epochStartTime sps
Just epoch === fun epoch

it "epochPred . epochCeiling . utcTimeSucc . epochStartTime == id" $
withMaxSuccess 1000 $ property $ \(sps, epoch) ->
epoch < maxBound ==> do
let fun = (epochPred =<<)
. epochCeiling sps
. utcTimeSucc
. epochStartTime sps
Just epoch === fun epoch

it "epochCeiling (epochStartTime minBound) == minBound" $
withMaxSuccess 1000 $ property $ \sps ->
epochCeiling sps (epochStartTime sps minBound)
=== Just minBound

it "epochCeiling (utcTimePred (epochStartTime minBound)) == minBound" $
withMaxSuccess 1000 $ property $ \sps ->
epochCeiling sps (utcTimePred (epochStartTime sps minBound))
=== Just minBound

it "epochCeiling (epochStartTime maxBound) == maxBound" $
withMaxSuccess 1000 $ property $ \sps ->
epochCeiling sps (epochStartTime sps maxBound)
=== Just maxBound

it "epochCeiling (utcTimeSucc (epochStartTime maxBound)) == Nothing" $
withMaxSuccess 1000 $ property $ \sps ->
epochCeiling sps (utcTimeSucc (epochStartTime sps maxBound))
=== Nothing

describe "Epoch arithmetic: epochFloor: boundary conditions" $ do

it "epochFloor . epochStartTime == id" $
withMaxSuccess 1000 $ property $ \(sps, epoch) ->
epochFloor sps (epochStartTime sps epoch)
=== Just epoch

it "epochFloor . utcTimeSucc . epochStartTime == id" $
withMaxSuccess 1000 $ property $ \(sps, epoch) ->
epoch < maxBound ==> do
let fun = epochFloor sps
. utcTimeSucc
. epochStartTime sps
Just epoch === fun epoch

it "epochSucc . epochFloor . utcTimePred . epochStartTime == id" $
withMaxSuccess 1000 $ property $ \(sps, epoch) ->
epoch > minBound ==> do
let fun = (epochSucc =<<)
. epochFloor sps
. utcTimePred
. epochStartTime sps
Just epoch === fun epoch

it "epochFloor (epochStartTime minBound) == minBound" $
withMaxSuccess 1000 $ property $ \sps ->
epochFloor sps (epochStartTime sps minBound)
=== Just minBound

it "epochFloor (utcTimePred (epochStartTime minBound)) == Nothing" $
withMaxSuccess 1000 $ property $ \sps ->
epochFloor sps (utcTimePred (epochStartTime sps minBound))
=== Nothing

it "epochFloor (epochStartTime maxBound) == maxBound" $
withMaxSuccess 1000 $ property $ \sps ->
epochFloor sps (epochStartTime sps maxBound)
=== Just maxBound

it "epochFloor (utcTimeSucc (epochStartTime maxBound)) == maxBound" $
withMaxSuccess 1000 $ property $ \sps ->
epochFloor sps (utcTimeSucc (epochStartTime sps maxBound))
=== Just maxBound

describe "Slot arithmetic" $ do

it "slotFloor (slotStartTime slotMinBound) == Just slotMinBound" $
Expand Down Expand Up @@ -1103,6 +1290,10 @@ instance Arbitrary BlockHeader where
, pure $ Hash "BLOCK03"
]

instance Arbitrary EpochNo where
arbitrary = EpochNo <$> arbitrary
shrink = genericShrink

instance Arbitrary SlotId where
shrink _ = []
arbitrary = do
Expand Down Expand Up @@ -1165,6 +1356,36 @@ instance {-# OVERLAPS #-} Arbitrary (SlotParameters, SlotId) where
(el', slot') <- shrink (el, slot)
pure (SlotParameters el' sl st, slot')

-- | Combines a 'SlotParameters' object and a single point in time.
--
-- The point in time falls into one of the following categories:
--
-- 1. occurs during the lifetime of the blockchain;
-- 2. occurs before the earliest representable slot;
-- 3. occurs after the latest representable slot.
--
data SlotParametersAndTimePoint = SlotParametersAndTimePoint
{ getSlotParameters :: SlotParameters
, getTimePoint :: UTCTime
} deriving (Eq, Show)

instance Arbitrary SlotParametersAndTimePoint where
arbitrary = do
sps <- arbitrary
let timeA = 0
let timeB = toModifiedJulianDay $ utctDay $ epochStartTime sps minBound
let timeC = toModifiedJulianDay $ utctDay $ epochStartTime sps maxBound
let timeD = timeC * 2
(lowerBound, upperBound) <- oneof $ fmap pure
[ (timeA, timeB)
, (timeB, timeC)
, (timeC, timeD)
]
time <- genUniformTimeWithinRange
(ModifiedJulianDay lowerBound)
(ModifiedJulianDay upperBound)
pure $ SlotParametersAndTimePoint sps time

-- | Note, for functions which works with both an epoch length and a slot id,
-- we need to make sure that the 'slotNumber' doesn't exceed the epoch length,
-- otherwise, all computations get mixed up.
Expand Down
Loading

0 comments on commit b8233f4

Please sign in to comment.