Add a tailored semigroup instance to TimedSeq

The instance is meant to not repeat times when during concatenation

lib/customer-deposit-wallet/customer-deposit-wallet.cabal

@@ -202,7 +202,6 @@ test-suite unit
     , customer-deposit-wallet:http
     , customer-deposit-wallet:rest
     , directory
-    , fingertree
     , hspec
     , hspec-golden
     , openapi3

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
@@ -67,11 +66,13 @@ import Data.Map.Monoidal.Strict
 import Data.Monoid
     ( Last (..)
     )
+import GHC.IsList
+    ( IsList (..)
+    )
 import Prelude hiding
     ( lookup
     )
 
-import qualified Data.FingerTree as FingerTree
 import qualified Data.Map.Monoidal.Strict as MonoidalMap
 
 -- | Infix form of MonoidalMap type
@@ -146,7 +147,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 +161,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 +177,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 +186,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 +208,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 +262,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 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
+toFinger (Map w m) = Finger w $ fromList $ do
     (k, v) <- MonoidalMap.toList m
     pure $ Timed (Last (Just k)) v
 

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs

@@ -7,14 +7,16 @@
 
 module Cardano.Wallet.Deposit.Map.Timed
     ( Timed (..)
-    , TimedSeq
+    , TimedSeq (..)
     , takeAfter
     , takeBefore
     , extractInterval
     , minKey
     , maxKey
     , dropAfter
     , dropBefore
+    , fmapTimedSeq
+    , singleton
     )
 where
 
@@ -31,6 +33,7 @@ import Data.FingerTree
     , ViewL (..)
     , ViewR (..)
     , dropUntil
+    , fmap'
     , split
     , takeUntil
     , viewl
@@ -67,74 +70,107 @@ 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)
+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 => t -> a -> TimedSeq t a
+singleton t a = TimedSeq $ FingerTree.singleton (Timed (Last (Just t)) a)
+
+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
 
 instance Monoid a => IsList (TimedSeq t a) where
     type Item (TimedSeq t a) = Timed t a
-    fromList = FingerTree.fromList
-    toList = F.toList
+    fromList = TimedSeq . FingerTree.fromList
+    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)
     => (t -> q)
     -> 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)
     => (t -> q)
     -> 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
         _ :> Timed (Last hd) _ -> hd
     )
 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 +188,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 +210,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))

lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs

@@ -18,10 +18,6 @@ import Cardano.Wallet.Deposit.Map.Timed
     , takeAfter
     , takeBefore
     )
-import Data.FingerTree
-    ( fromList
-    , (<|)
-    )
 import Data.List
     ( sort
     , unfoldr
@@ -36,6 +32,9 @@ import Data.Time
     , parseTimeOrError
     , pattern YearMonthDay
     )
+import GHC.IsList
+    ( IsList (..)
+    )
 import Test.Hspec
     ( Spec
     , describe
@@ -83,14 +82,14 @@ result
     :: [UTimed]
     -> Maybe UTimed
     -> (TimedSeq UTCTime (Sum Int), Maybe UTCTime)
-result included next = (foldr (<|) mempty included, nextTime)
+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 = fmap fromList
 
 byYear :: UTCTime -> Integer
 byYear (UTCTime (YearMonthDay y _ _) _) = y
@@ -364,19 +363,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

lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs

@@ -21,6 +21,7 @@ import Cardano.Wallet.Deposit.Map
     )
 import Cardano.Wallet.Deposit.Map.Timed
     ( Timed (..)
+    , TimedSeq (unTimedSeq)
     )
 import Cardano.Wallet.Deposit.Pure
     ( ValueTransfer (..)
@@ -114,7 +115,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 $ toList . unTimedSeq $ value mtxs
   where
     f
         :: Timed DownTime (Map '[W (First Slot) TxId] ValueTransfer)