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

@@ -206,7 +206,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
@@ -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
 

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,75 +76,117 @@ 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)
     => (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 +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))