[input-output-hk/cardano-sl] [CO-347] Wallet’s UTXO histogram view (#3402)

KtorZ commented on this pull request.

> +{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Cardano.Wallet.Types.UtxoStatistics
+ ( — * Types
+ UtxoStatistics
+ , BoundType
+ , UtxoStatisticsError(..)
+
+ — * Constructing ‘UtxoStatistics’
+ , computeUtxoStatistics
+
+ — * Constructing ‘BoundType’
+ , log10
+ ) where

@paweljakubas Only exposing opaque types here with smart-constructors.
Note that I have removed the few externals calls to `mkUtxoStatistics` for they were not really needed and could simply rely on `computeUtxoStatistics`. This function should be our one and single constructor for the outside world.

We now use `mkUtxostatistics` internally only (in the `FromJSON` instance).
Note also, I’ve removed the `Haphazard` constructor for the `BoundType` and here again, to keep the module easy to extend, we hide the implementation to the outside world, only having a «smart-constructor» `log10` which does the trick.

> +
+
+—
+— TYPES
+—
+
+data UtxoStatistics = UtxoStatistics
+ { theHistogram :: ![HistogramBar]
+ , theAllStakes :: !Word64
+ } deriving (Show, Generic, Ord)
+
+data UtxoStatisticsError
+ = ErrEmptyHistogram
+ | ErrInvalidBounds !Text
+ | ErrInvalidTotalStakes !Text
+ deriving (Eq, Show, Read, Generic)

@paweljakubas I’ve factored out a couple of errors as they were semantically referring to the same thing, only with a small difference which can be captured in a message `Text`. It makes the error type a bit less bloated but still rather expressive.

> + sorted :: [HistogramBar] -> [HistogramBar]
+ sorted = sortOn (\(HistogramBarCount key _) -> key)
+
+instance ToJSON UtxoStatistics where
+ toJSON (UtxoStatistics bars allStakes) =
+ let
+ histogramObject =
+ Object . HMS.fromList . map extractBarKey
+
+ extractBarKey (HistogramBarCount bound stake) =
+ show bound .= stake
+ in
+ object
+ [ «histogram» .= histogramObject bars
+ , «allStakes» .= allStakes
+ , «boundType» .= log10

Note that we need `»boundType»` in the JSON representation otherwise we simply force the bound type upon decoding a JSON object to `Log10` and there’s no point of keeping that flexible.

> + & at «45000000000000000» ?~ wordRef
+ )
+ )
+ )
+
+—
+— CONSTRUCTING
+—
+
+— | Smart-constructor to create bounds using a log-10 scale
+log10 :: BoundType
+log10 = Log10
+{-# INLINE log10 #-}
+
+— | Compute UtxoStatistics from a bunch of UTXOs
+computeUtxoStatistics :: BoundType -> [Utxo] -> UtxoStatistics

Also a change here we’ve suggested in the past and then forgot about. The API used to take `[Word64]` only, but that gives us poor type-guarantees and requires the caller to know about how to extract the correct value from an `Utxo`. Here, we take care of that burden ourselves and even get documentation for free!

> + case Map.lookupGE a x of
+ Just (k, v) -> Map.insert k (v+1) x
+ Nothing -> Map.adjust (+1) (head bounds) x
+ initial :: Map Word64 Word64
+ initial =
+ Map.fromList $ zip (NL.toList bounds) (repeat 0)
+ extract :: Map Word64 Word64 -> [HistogramBar]
+ extract =
+ map (uncurry HistogramBarCount) . Map.toList
+ in
+ L.Fold step initial extract
+
+—
+— INTERNALS
+—
+

Everything below is actually internal stuff and doesn’t need to be exported :+1:

> + Log10 -> NL.fromList $ map (\toPower -> 10 ^! toPower) [1..16] ++ [45 * (10 ^! 15)]
+
+getPossibleBounds :: Map Word64 Word64 -> (Word64, Word64)
+getPossibleBounds histogram =
+ (calculatePossibleBound fst, calculatePossibleBound snd)
+ where
+ createBracketPairs :: Num a => [a] -> [(a,a)]
+ createBracketPairs (reverse -> (x:xs)) = zip (map (+1) $ reverse (xs ++ [0])) (reverse (x:xs))
+ createBracketPairs _ = []
+ matching fromPair (key,value) =
+ map ( (*value) . fromPair ) . filter (\(_,upper) -> key == upper)
+ acceptedKeys = NL.toList $ generateBounds log10
+ calculatePossibleBound fromPair =
+ sum .
+ concatMap (\pair -> matching fromPair pair $ createBracketPairs acceptedKeys) $
+ Map.toList histogram

I honestly haven’t verified much of this as my brain isn’t much capable of it right now :(