Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Example usage of safe-decimal package
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.