From 9fe409a6ec6e651615040d08ea3da9a72c5385e9 Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 6 Nov 2024 08:57:22 +0000 Subject: [PATCH] Add a tailored semigroup instance to TimedSeq The instance is meant to not repeat times when during concatenation --- .../customer-deposit-wallet.cabal | 1 - .../src/Cardano/Wallet/Deposit/Map.hs | 23 ++-- .../src/Cardano/Wallet/Deposit/Map/Timed.hs | 124 +++++++++++++----- .../Cardano/Wallet/Deposit/Map/TimedSpec.hs | 64 ++++++--- .../Handlers/Addresses/Transactions.hs | 6 +- .../UI/Deposit/Handlers/Deposits/Times.hs | 7 +- 6 files changed, 156 insertions(+), 69 deletions(-) diff --git a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal index dceb4b27d7f..5ec4aeb30cf 100644 --- a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal +++ b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal @@ -206,7 +206,6 @@ test-suite unit , customer-deposit-wallet:http , customer-deposit-wallet:rest , directory - , fingertree , hspec , hspec-golden , openapi3 diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs index a7bb9c3612c..556e8354aec 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs @@ -54,9 +54,8 @@ import Cardano.Wallet.Deposit.Map.Timed ( Timed (..) , TimedSeq , extractInterval - ) -import Data.FingerTree - ( fmap' + , fmapTimedSeq + , singleton ) import Data.Kind ( Type @@ -71,7 +70,7 @@ import Prelude hiding ( lookup ) -import qualified Data.FingerTree as FingerTree +import qualified Cardano.Wallet.Deposit.Map.Timed as TimedSeq import qualified Data.Map.Monoidal.Strict as MonoidalMap -- | Infix form of MonoidalMap type @@ -146,7 +145,7 @@ instance (Functor (Map xs), forall a. Monoid (Map xs a)) => Functor (Map (F w x : xs)) where - fmap f (Finger w m) = Finger w $ fmap' (fmap $ fmap f) m + fmap f (Finger w m) = Finger w $ fmapTimedSeq (fmap f) m instance Monoid v => Monoid (Map '[] v) where mempty = Value mempty @@ -160,7 +159,7 @@ instance where mempty = Map mempty mempty -instance (Monoid (Map xs v), Monoid w) => Monoid (Map (F w x : xs) v) where +instance (Monoid (Map xs v), Monoid w, Eq x) => Monoid (Map (F w x : xs) v) where mempty = Finger mempty mempty instance Semigroup v => Semigroup (Map '[] v) where @@ -176,7 +175,7 @@ instance Map w a <> Map w' b = Map (w <> w') (a <> b) instance - (Monoid w, Monoid (Map xs v)) + (Monoid w, Monoid (Map xs v), Eq x) => Semigroup (Map (F w x : xs) v) where Finger wa a <> Finger wb b = Finger (wa <> wb) (a <> b) @@ -185,7 +184,7 @@ instance Foldable (Map '[]) where foldMap f (Value v) = f v instance (Foldable (Map xs), Ord x) => Foldable (Map (F w x : xs)) where - foldMap f (Finger _ m) = foldMap (foldMap $ foldMap f) m + foldMap f (Finger _ m) = foldMap (foldMap f) m instance (Foldable (Map xs), Ord x) => Foldable (Map (W w x : xs)) where foldMap f (Map _ m) = foldMap (foldMap f) m @@ -207,7 +206,7 @@ unPatch => y -> UnPatchF y unPatch (Map w m) = Map () $ fmap (fmap (w,)) m -unPatch (Finger w m) = Finger () $ fmap' (fmap $ fmap (w,)) m +unPatch (Finger w m) = Finger () $ fmapTimedSeq (fmap (w,)) m type family ForgetPatchF xs where ForgetPatchF (Map (W w x ': xs) v) = @@ -261,11 +260,11 @@ singletonMap w k = Map w . MonoidalMap.singleton k singletonFinger :: Monoid (Map xs v) => w -> k -> Map xs v -> Map (F w k ': xs) v singletonFinger w k m = - Finger w $ FingerTree.singleton (Timed (Last (Just k)) m) + Finger w $ singleton $ Timed (Last (Just k)) m toFinger - :: Monoid (Map ks a) => Map (W w k : ks) a -> Map (F w k : ks) a -toFinger (Map w m) = Finger w $ FingerTree.fromList $ do + :: (Monoid (Map ks a), Eq k) => Map (W w k : ks) a -> Map (F w k : ks) a +toFinger (Map w m) = Finger w $ TimedSeq.fromList $ do (k, v) <- MonoidalMap.toList m pure $ Timed (Last (Just k)) v diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs index cab26b65f70..2afb8af2042 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs @@ -6,15 +6,27 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Wallet.Deposit.Map.Timed - ( Timed (..) + ( + -- * Timed + Timed (..) + -- * TimedSeq , TimedSeq + -- ** Construction + , fromList + , singleton + -- ** Destruction + , toList + -- ** Query , takeAfter , takeBefore , extractInterval , minKey , maxKey + -- ** Modification , dropAfter , dropBefore + -- ** Functor + , fmapTimedSeq ) where @@ -31,6 +43,7 @@ import Data.FingerTree , ViewL (..) , ViewR (..) , dropUntil + , fmap' , split , takeUntil , viewl @@ -43,9 +56,6 @@ import Data.Function import Data.Monoid ( Last (..) ) -import GHC.IsList - ( IsList (..) - ) import qualified Data.FingerTree as FingerTree import qualified Data.Foldable as F @@ -66,41 +76,82 @@ instance Monoid a => Monoid (Timed t a) where instance Monoid a => Measured (Timed t a) (Timed t a) where measure = id --- | A sequence of timed values with a monoidal annotation as itself -type TimedSeq t a = FingerTree (Timed t a) (Timed t a) +-- | A sequence of timed values with a monoidal annotation as itself. +-- These values have a semigroup instance that will collapse adjacent values +-- with the same timestamp. +-- It's up to the user to maintain the invariant that +-- the sequence is sorted by timestamp. +newtype TimedSeq t a = TimedSeq + { unTimedSeq :: FingerTree (Timed t a) (Timed t a) + } + deriving (Eq, Show) + +fmapTimedSeq + :: (Monoid a1, Monoid a2) => (a1 -> a2) -> TimedSeq t a1 -> TimedSeq t a2 +fmapTimedSeq f = TimedSeq . fmap' (fmap f) . unTimedSeq + +singleton :: Monoid a => Timed t a -> TimedSeq t a +singleton = TimedSeq . FingerTree.singleton + +instance Foldable (TimedSeq t) where + foldMap f = foldMap (f . monoid) . unTimedSeq + +onFingerTree + :: ( FingerTree (Timed t a) (Timed t a) + -> FingerTree (Timed t a) (Timed t a) + ) + -> TimedSeq t a + -> TimedSeq t a +onFingerTree f = TimedSeq . f . unTimedSeq + +instance (Semigroup a, Monoid a, Eq t) => Semigroup (TimedSeq t a) where + TimedSeq a <> TimedSeq b = case (viewr a, viewl b) of + (EmptyR, _) -> TimedSeq b + (_, EmptyL) -> TimedSeq a + (a' :> Timed t1 v1, Timed t2 v2 :< b') + | t1 == t2 -> TimedSeq $ a' <> (Timed t1 (v1 <> v2) <| b') + | otherwise -> TimedSeq $ a <> b + +instance (Monoid a, Eq t) => Monoid (TimedSeq t a) where + mempty = TimedSeq FingerTree.empty + +-- | Construct a 'TimedSeq' from a list of 'Timed' values. +fromList :: (Monoid a, Eq t) => [Timed t a] -> TimedSeq t a +fromList = mconcat . fmap singleton -instance Monoid a => IsList (TimedSeq t a) where - type Item (TimedSeq t a) = Timed t a - fromList = FingerTree.fromList - toList = F.toList +-- | Convert a 'TimedSeq' to a list of 'Timed' values. +-- This is not the inverse of 'fromList' as some values may have been merged. But +-- fromList . toList == id. +toList :: TimedSeq t a -> [Timed t a] +toList = F.toList . unTimedSeq takeAfterElement :: (Monoid a, Ord q) => (t -> q) -> TimedSeq t a -> Maybe (Timed t a, TimedSeq t a) -takeAfterElement bucket tseq = case viewl tseq of +takeAfterElement bucket (TimedSeq tseq) = case viewl tseq of EmptyL -> Nothing hd :< _ -> let (taken, rest) = split (\q -> (bucket <$> time q) > (bucket <$> time hd)) tseq in - Just (measure taken, rest) + Just (measure taken, TimedSeq rest) takeBeforeElement :: (Monoid a, Ord q) => (t -> q) -> TimedSeq t a -> Maybe (Timed t a, TimedSeq t a) -takeBeforeElement bucket tseq = case viewr tseq of +takeBeforeElement bucket (TimedSeq tseq) = case viewr tseq of EmptyR -> Nothing _ :> hd -> let (rest, taken) = split (\q -> (bucket <$> time q) >= (bucket <$> time hd)) tseq in - Just (measure taken, rest) + Just (measure taken, TimedSeq rest) takeAfterElements :: (Monoid a, Ord q, Ord t) @@ -108,17 +159,18 @@ takeAfterElements -> Maybe Int -> TimedSeq t a -> (TimedSeq t a, Maybe t) -takeAfterElements _dt (Just 0) tseq = +takeAfterElements _dt (Just 0) (TimedSeq tseq) = ( mempty , case viewl tseq of EmptyL -> Nothing Timed (Last hd) _ :< _ -> hd ) -takeAfterElements bucket mn tseq = case takeAfterElement bucket tseq of - Just (v, rest) -> - first (v <|) - $ takeAfterElements bucket (subtract 1 <$> mn) rest - _ -> (mempty, Nothing) +takeAfterElements bucket mn tseq = + case takeAfterElement bucket tseq of + Just (v, rest) -> + first (onFingerTree (v <|)) + $ takeAfterElements bucket (subtract 1 <$> mn) rest + _ -> (mempty, Nothing) takeBeforeElements :: (Monoid a, Ord q, Ord t) @@ -126,7 +178,7 @@ takeBeforeElements -> Maybe Int -> TimedSeq t a -> (TimedSeq t a, Maybe t) -takeBeforeElements _dt (Just 0) tseq = +takeBeforeElements _dt (Just 0) (TimedSeq tseq) = ( mempty , case viewr tseq of EmptyR -> Nothing @@ -134,7 +186,7 @@ takeBeforeElements _dt (Just 0) tseq = ) takeBeforeElements bucket mn tseq = case takeBeforeElement bucket tseq of Just (v, rest) -> - first (v <|) + first (onFingerTree (v <|)) $ takeBeforeElements bucket (subtract 1 <$> mn) rest _ -> (mempty, Nothing) @@ -152,12 +204,13 @@ takeAfter -> TimedSeq t a -- ^ The timed sequence to extract elements from. -> (TimedSeq t a, Maybe t) -takeAfter bucket mstart mcount tseq = +takeAfter bucket mstart mcount = takeAfterElements bucket mcount - $ dropUntil - ( \q -> mstart & maybe True (\t -> time q >= Last (Just t)) + . onFingerTree + ( dropUntil + ( \q -> mstart & maybe True (\t -> time q >= Last (Just t)) + ) ) - tseq -- | Extract the last n elements from a timed seq before and excluding -- a given start time after applying a bucketing function. @@ -173,36 +226,37 @@ takeBefore -> TimedSeq t a -- ^ The timed sequence to extract elements from. -> (TimedSeq t a, Maybe t) -takeBefore bucket mstart mcount tseq = +takeBefore bucket mstart mcount = takeBeforeElements bucket mcount - $ takeUntil - (\q -> mstart & maybe False (\t -> time q > Last (Just t))) - tseq + . onFingerTree + ( takeUntil + (\q -> mstart & maybe False (\t -> time q > Last (Just t))) + ) -- | Try to extract the first element time from a tseq. minKey :: Monoid a => TimedSeq t a -> Maybe t -minKey tseq = case viewl tseq of +minKey (TimedSeq tseq) = case viewl tseq of Timed (Last (Just t)) _ :< _ -> Just t _ -> Nothing -- | Try to extract the last element time from a tseq. maxKey :: Monoid a => TimedSeq t a -> Maybe t -maxKey tseq = case viewr tseq of +maxKey (TimedSeq tseq) = case viewr tseq of _ :> Timed (Last (Just t)) _ -> Just t _ -> Nothing -- | Extract all elements from a tseq that are within the given time interval. extractInterval :: (Monoid a, Ord t) => t -> t -> TimedSeq t a -> Timed t a -extractInterval t0 t1 tseq = +extractInterval t0 t1 (TimedSeq tseq) = measure $ takeUntil (\q -> time q > Last (Just t1)) $ dropUntil (\q -> time q >= Last (Just t0)) tseq -- | Extract all elements from a tseq that are before the given time. dropAfter :: (Ord t, Monoid a) => t -> TimedSeq t a -> TimedSeq t a -dropAfter t = takeUntil (\q -> time q > Last (Just t)) +dropAfter t = onFingerTree $ takeUntil (\q -> time q > Last (Just t)) -- | Extract all elements from a tseq that are after the given time. dropBefore :: (Ord t, Monoid a) => t -> TimedSeq t a -> TimedSeq t a -dropBefore t = dropUntil (\q -> time q >= Last (Just t)) +dropBefore t = onFingerTree $ dropUntil (\q -> time q >= Last (Just t)) diff --git a/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs index 02f23e0b1bd..7bbceac8376 100644 --- a/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs +++ b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs @@ -13,14 +13,12 @@ import Cardano.Wallet.Deposit.Map.Timed , TimedSeq , dropAfter , dropBefore + , fromList , maxKey , minKey , takeAfter , takeBefore - ) -import Data.FingerTree - ( fromList - , (<|) + , toList ) import Data.List ( sort @@ -41,10 +39,13 @@ import Test.Hspec , describe , it , shouldBe + , shouldNotBe ) type UTimed = Timed UTCTime (Sum Int) +type UTimedSeq = TimedSeq UTCTime (Sum Int) + t :: String -> UTCTime t = parseTimeOrError False defaultTimeLocale "%Y-%m-%d %H:%M:%S" @@ -82,15 +83,15 @@ ts = sort [t0, t1, t2, t3, t4, t5, t6, t7] result :: [UTimed] -> Maybe UTimed - -> (TimedSeq UTCTime (Sum Int), Maybe UTCTime) -result included next = (foldr (<|) mempty included, nextTime) + -> (UTimedSeq, Maybe UTCTime) +result included next = (fromList included, nextTime) where nextTime = do Timed x _ <- next getLast x -results :: [[UTimed]] -> [TimedSeq UTCTime (Sum Int)] -results = fmap (foldr (<|) mempty) +results :: [[UTimed]] -> [UTimedSeq] +results = fmap fromList byYear :: UTCTime -> Integer byYear (UTCTime (YearMonthDay y _ _) _) = y @@ -122,7 +123,7 @@ scroll boot extract bucket count pager = unfoldr f $ boot pager spec :: Spec spec = do - describe "finger tree pager front" $ do + describe "takeAfter" $ do it "can extract without start" $ do takeAfter byDay @@ -229,7 +230,7 @@ spec = do (Just 1) (fromList ts) `shouldBe` result [t1 <> t2 <> t3] (Just t4) - describe "finger tree pager back" $ do + describe "takeBefore" $ do it "can extract without start" $ do takeBefore byDay @@ -310,7 +311,7 @@ spec = do (fromList ts) `shouldBe` result [t0 <> t1 <> t2 <> t3] Nothing - describe "finger tree pager scroll" $ do + describe "TimedSeq scroll" $ do it "can consume scrolling forward by 1 day" $ do scroll minKey takeAfter byDay 1 (fromList ts) `shouldBe` results @@ -364,19 +365,19 @@ spec = do describe "dropAfter function" $ do it "works on empty" $ do - dropAfter (t "2021-01-01 00:00:00") (fromList @UTimed []) + dropAfter @UTCTime @() (t "2021-01-01 00:00:00") (fromList []) `shouldBe` fromList [] it "drop a single" $ do - dropAfter (t "2021-01-01 00:00:00") (fromList @UTimed [t0]) + dropAfter (t "2021-01-01 00:00:00") (fromList [t0]) `shouldBe` fromList [t0] it "take one and drop the second, early cut" $ do - dropAfter (t "2021-01-01 00:00:00") (fromList @UTimed [t0, t1]) + dropAfter (t "2021-01-01 00:00:00") (fromList [t0, t1]) `shouldBe` fromList [t0] it "take one and drop the second, late cut" $ do - dropAfter (t "2021-01-01 23:59:59") (fromList @UTimed [t0, t1]) + dropAfter (t "2021-01-01 23:59:59") (fromList [t0, t1]) `shouldBe` fromList [t0] it "can take all" $ do - dropAfter (t "2021-01-02 00:00:00") (fromList @UTimed [t0, t1]) + dropAfter (t "2021-01-02 00:00:00") (fromList [t0, t1]) `shouldBe` fromList [t0, t1] describe "dropBefore function" $ do @@ -395,3 +396,34 @@ spec = do it "can take all" $ do dropBefore (t "2021-01-01 00:00:00") (fromList [t0, t1]) `shouldBe` fromList [t0, t1] + + describe "TimedSeq semigroup" $ do + it "can append two sequences of distinct times" $ do + fromList [t0, t1] <> fromList [t2, t3] + `shouldBe` fromList [t0, t1, t2, t3] + it "can append two sequences of overlapping edges in time" $ do + fromList [t0, t1] <> fromList [t1, t2] + `shouldBe` fromList + [ t0 + , Timed (time t1) (monoid t1 <> monoid t1) + , t2 + ] + it "is used in fromList" $ do + fromList [t0, t1, t1, t2] + `shouldBe` fromList + [ t0 + , Timed (time t1) (monoid t1 <> monoid t1) + , t2 + ] + describe "fromList" $ do + it "is the inverse of toList for different ts" $ do + fromList (toList (fromList ts)) `shouldBe` fromList ts + it "is the inverse of toList for overlapping ts" $ do + let ts' = [t0, t1, t1, t2] + fromList (toList (fromList ts')) + `shouldBe` fromList ts' + + describe "toList" $ do + it "is not the inverse of fromList for overlapping ts" $ do + let ts' = [t0, t1, t1, t2] + toList (fromList ts') `shouldNotBe` ts' diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs index 3ba9afa901e..060cee60e4c 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs @@ -62,9 +62,6 @@ import Cardano.Wallet.UI.Lib.Time.Direction import Data.Bifunctor ( first ) -import Data.Foldable - ( toList - ) import Data.Monoid ( First (..) , Last (..) @@ -79,6 +76,7 @@ import Servant ( Handler ) +import qualified Cardano.Wallet.Deposit.Map.Timed as TimedSeq import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.Map.Monoidal.Strict as MonoidalMap @@ -114,7 +112,7 @@ convert (Map [F (First Address) DownTime, W (First Slot) TxId] ValueTransfer) -> [(DownTime, (Slot, TxId, ValueTransfer))] convert Nothing = [] -convert (Just mtxs) = concatMap f $ toList $ value mtxs +convert (Just mtxs) = concatMap f $ TimedSeq.toList $ value mtxs where f :: Timed DownTime (Map '[W (First Slot) TxId] ValueTransfer) diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Times.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Times.hs index c6c98434681..5b1ec63bd76 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Times.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Times.hs @@ -71,6 +71,7 @@ import Data.Ord ( Down (..) ) +import qualified Cardano.Wallet.Deposit.Map.Timed as TimedSeq import qualified Data.Map.Strict as Map depositsPaginateM @@ -96,7 +97,11 @@ depositsPaginateM , pageAtIndex = \t -> do Paginate{pageAtIndex} <- history pure - $ second (Map.fromList . concatMap fromTimed . toList) + $ second + ( Map.fromList + . concatMap fromTimed + . TimedSeq.toList + ) <$> pageAtIndex t , minIndex = do Paginate{minIndex} <- paginate <$> retrieveByTime