content: {-# LANGUAGE DataKinds      #-}
  {-# LANGUAGE KindSignatures #-}
  
  module Pos.Util.UnitsOfMeasure
      ( UnitOfMeasure (..)
      , MeasuredIn(..)
      ) where
  
  import           Control.Lens (at, (?~))
  import           Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object,
                       withObject, (.:), (.=))
  import qualified Data.Text.Lazy as T
  import qualified Data.Text.Lazy.Builder as B
  import           Formatting ((%))
  import qualified Formatting as F
  import           Formatting.Buildable (Buildable (..))
  import           Pos.Core.Util.LogSafe (BuildableSafeGen (..))
  import           Universum
  
  import           Data.Swagger (NamedSchema (..), Referenced (..),
                       SwaggerType (..), ToSchema (..), enum_, properties,
                       required, type_)
  
  -- | A finite sum type representing time units we might want to show to
  -- clients. The idea is that whenever we have a quantity represeting some
  -- form of time, we should render it together with the relevant unit, to
  -- not leave anything to guessing.
  data UnitOfMeasure =
        Seconds
      | Milliseconds
      | Microseconds
      -- | % ranging from 0 to 100.
      | Percentage100
      -- | Number of blocks.
      | Blocks
      -- | Number of blocks per second.
      | BlocksPerSecond
      | Bytes
      | Lovelace
      | LovelacePerByte
      deriving (Show, Eq, Ord)
  
  instance Buildable UnitOfMeasure where
      build = \case
          Bytes           -> "bytes"
          LovelacePerByte -> "lovelace/byte"
          Lovelace        -> "lovelace"
          Seconds         -> "seconds"
          Milliseconds    -> "milliseconds"
          Microseconds    -> "microseconds"
          Percentage100   -> "percent"
          Blocks          -> "blocks"
          BlocksPerSecond -> "blocks/second"
  
  instance ToJSON UnitOfMeasure where
      toJSON = String . T.toStrict . B.toLazyText . build
  
  -- | Represent data with a given unit of measure
  data MeasuredIn (u :: UnitOfMeasure) a
      = MeasuredIn a
      deriving (Show, Eq, Ord)
  
  instance (Demote u, Buildable a) => BuildableSafeGen (MeasuredIn u a) where
      buildSafeGen _ = build
  
  instance (Demote u, Buildable a) => Buildable (MeasuredIn u a) where
      build (MeasuredIn a) = F.bprint
          (F.build % " " % F.build)
          a
          (demote $ Proxy @u)
  
  instance (Demote u, ToJSON a) => ToJSON (MeasuredIn u a) where
      toJSON (MeasuredIn a) = object
          [ "unit"     .= demote (Proxy @u)
          , "quantity" .= toJSON a
          ]
  
  instance (Demote u, FromJSON a) => FromJSON (MeasuredIn u a) where
      parseJSON = withObject "MeasuredIn" $ \o -> do
          verifyUnit =<< o .: "unit"
          MeasuredIn <$> o .: "quantity"
        where
          unitS = toString $ T.toStrict $ B.toLazyText $ build $ demote $ Proxy @u
          verifyUnit = \case
              u@(String _) | u == toJSON (demote $ Proxy @u) ->
                  pure ()
              _ ->
                  fail
                  $  "failed to parse quantified value. Expected value in '"
                  <> unitS <> "' but got something else. e.g.: "
                  <> "{ \"unit\": \"" <> unitS <> "\", \"quantity\": ...}"
  
  instance (Demote u, ToSchema a) => ToSchema (MeasuredIn u a) where
      declareNamedSchema _ = do
          NamedSchema _ schema <- declareNamedSchema (Proxy @a)
          pure $ NamedSchema (Just "MeasuredIn") $ mempty
              & type_ ?~ SwaggerObject
              & required .~ ["quantity", "unit"]
              & properties .~ (mempty
                  & at "quantity" ?~ Inline schema
                  & at "unit" ?~ (Inline $ mempty
                      & type_ ?~ SwaggerString
                      & enum_ ?~ [toJSON $ demote $ Proxy @u]
                      )
                  )
  
  --
  -- Internal
  --
  
  -- | Bring a type back to the world of value (invert of promote)
  class Demote (u :: UnitOfMeasure) where
      demote :: Proxy u -> UnitOfMeasure
  instance Demote 'Bytes           where demote _ = Bytes
  instance Demote 'LovelacePerByte where demote _ = LovelacePerByte
  instance Demote 'Lovelace        where demote _ = Lovelace
  instance Demote 'Seconds         where demote _ = Seconds
  instance Demote 'Milliseconds    where demote _ = Milliseconds
  instance Demote 'Microseconds    where demote _ = Microseconds
  instance Demote 'Percentage100   where demote _ = Percentage100
  instance Demote 'Blocks          where demote _ = Blocks
  instance Demote 'BlocksPerSecond where demote _ = BlocksPerSecond
  