Example usage of safe-decimal package

safe-decimal.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumericUnderscores #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Lib where

import Control.Monad.State.Strict
import Control.Exception
import Data.Coerce
import Data.Scientific
import Data.WideWord.Word128
import Data.Word
import Numeric.Decimal

newtype Satoshi = Satoshi Word64
  deriving (Show, Eq, Ord, Enum, Num, Real, Integral)

instance Bounded Satoshi where
  minBound = Satoshi 0
  maxBound = Satoshi 21_000_000_00000000

data NoRounding

type BitcoinDecimal = Decimal NoRounding 8 Satoshi

newtype Bitcoin = Bitcoin BitcoinDecimal
  deriving (Eq, Ord, Bounded)

instance Show Bitcoin where
  show (Bitcoin b) = show b

mkBitcoin :: MonadThrow m => Rational -> m Bitcoin
mkBitcoin r = Bitcoin <$> fromRationalDecimalBoundedWithoutLoss r

plusBitcoins :: MonadThrow m => Bitcoin -> Bitcoin -> m Bitcoin
plusBitcoins b1 b2 = toBitcoin <$> (fromBitcoin b1 `plusDecimalBounded` fromBitcoin b2)

toBitcoin :: BitcoinDecimal -> Bitcoin
toBitcoin = coerce

fromBitcoin :: Bitcoin -> BitcoinDecimal
fromBitcoin = coerce

minusBitcoins :: MonadThrow m => Bitcoin -> Bitcoin -> m Bitcoin
minusBitcoins b1 b2 = toBitcoin <$> (fromBitcoin b1 `minusDecimalBounded` fromBitcoin b2)

data UnsupportedOperation
  = UnsupportedMultiplication
  | UnsupportedDivision
  deriving (Show)
instance Exception UnsupportedOperation


instance Num (Arith Bitcoin) where
  (+) = bindM2 plusBitcoins
  (-) = bindM2 minusBitcoins
  (*) = bindM2 (\_ _ -> throwM UnsupportedMultiplication)
  abs = id
  signum mb = fmap toBitcoin . signumDecimalBounded . fromBitcoin =<< mb
  fromInteger i = toBitcoin <$> fromIntegerDecimalBoundedIntegral i

instance Fractional (Arith Bitcoin) where
  (/) = bindM2 (\_ _ -> throwM UnsupportedDivision)
  fromRational = mkBitcoin

newtype Balance = Balance Bitcoin deriving Show

sendBitcoin :: MonadThrow m => Balance -> Scientific -> m (Bitcoin, Balance)
sendBitcoin startingBalance rawAmount =
  flip runStateT startingBalance $ do
    amount <- toBitcoin <$> fromScientificDecimalBounded rawAmount
    Balance balance <- get
    newBalance <- minusBitcoins balance amount
    put $ Balance newBalance
    pure amount


instance Round RoundHalfUp Word128 where
  roundDecimal = roundHalfUp

type CDecimal = Decimal RoundHalfUp 33 Word128


futureValue :: MonadThrow m => CDecimal -> CDecimal -> CDecimal -> Int -> m CDecimal
futureValue startBalance dailyRefill apy days = do
  dailyScale <- -- apy is in % and the year of 2020 is a leap year
    fromIntegralDecimalBounded (100 * 366)
  dailyRate <- divideDecimalBoundedWithRounding apy dailyScale
  let go curBalance day
        | day < days = do
          accruedDaily <- timesDecimalBoundedWithRounding curBalance dailyRate
          nextDayBalance <- sumDecimalBounded [curBalance, dailyRefill, accruedDaily]
          go nextDayBalance (day + 1)
        | otherwise = pure curBalance
  go startBalance 0

futureValueBitcoin :: MonadThrow m => Balance -> Bitcoin -> Rational -> Int -> m (Balance, CDecimal)
futureValueBitcoin (Balance (Bitcoin balance)) (Bitcoin dailyRefill) apy days = do
  balance' <- scaleUpBounded (fromIntegral <$> castRounding balance)
  dailyRefill' <- scaleUpBounded (fromIntegral <$> castRounding dailyRefill)
  apy' <- fromRationalDecimalBoundedWithoutLoss apy
  endBalance <- futureValue balance' dailyRefill' apy' days
  endBalanceRounded <- integralDecimalToDecimalBounded (roundDecimal endBalance)
  pure (Balance $ Bitcoin $ castRounding endBalanceRounded, endBalance)

computeBalance :: Arith (Balance, CDecimal)
computeBalance = do
  balance <- Balance <$> 10000
  topup <- 10
  futureValueBitcoin balance topup 1.9 30


fv :: Double -> Int -> Double -> Double -> Double
fv rate nper pmt pv = -(pv * tmp + pmt * fact)
  where
    fact = (tmp - 1) / rate
    tmp = (1 + rate) ** fromIntegral nper