src/Literate/Accounting/Quantity.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DataKinds #-}
   4 {-# LANGUAGE DefaultSignatures #-}
   5 {-# LANGUAGE DeriveDataTypeable #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE PolyKinds #-}
   8 {-# LANGUAGE UndecidableInstances #-}
   9
  10 module Literate.Accounting.Quantity where
  11
  12 import Control.Exception (Exception, throw)
  13 import Control.Monad.Classes qualified as MC
  14 import Control.Monad.Trans.Except as MT
  15 import Control.Monad.Trans.Reader as MT
  16 import Data.Bool
  17 import Data.Data (Data)
  18 import Data.Foldable (foldl')
  19 import Data.Map.Strict qualified as Map
  20 import Data.Word
  21 import GHC.Real (Ratio ((:%)), (%))
  22 import GHC.TypeLits (type (<=))
  23 import Literate.Prelude
  24 import Text.Read (Read)
  25 import Prelude (Integral, error, fromIntegral, maxBound)
  26 import Prelude qualified
  27
  28 errorWithStack :: HasCallStack => String -> a
  29 errorWithStack = error -- (msg <> "\n" <> prettyCallStack callStack)
  30
  31 -- * Class 'Zeroable'
  32 class Zeroable a where
  33   zero :: a
  34   isZero :: a -> Bool
  35   default isZero :: Zeroable a => Eq a => a -> Bool
  36   isZero = (== zero)
  37 instance Zeroable String where
  38   zero = ""
  39   isZero = null
  40 instance Zeroable Word32 where
  41   zero = (0 :: Int) & fromIntegral
  42 instance Zeroable Word64 where
  43   zero = (0 :: Int) & fromIntegral
  44
  45 -- instance Zeroable Decimal where
  46 --  zero = 0
  47 instance Zeroable (Map.Map k a) where
  48   zero = Map.empty
  49   isZero = Map.null
  50
  51 {-
  52 instance Zeroable Decimal where
  53   zero = 0
  54 instance Zeroable (Map k a) where
  55   zero = Map.empty
  56 -}
  57
  58 -- * Class 'Signable'
  59 class Signable a where
  60   sign :: a -> Ordering
  61   default sign :: Zeroable a => Ord a => a -> Ordering
  62   sign a =
  63     case () of
  64       _ | isZero a -> EQ
  65       _ | a < zero -> LT
  66       _ -> GT
  67
  68 -- instance Signable Decimal
  69
  70 -- * Class 'Addable'
  71
  72 -- | Can be added.
  73 class Addable a where
  74   (+) :: HasCallStack => a -> a -> a
  75   infixl 6 +
  76   default (+) :: Prelude.Num a => HasCallStack => a -> a -> a
  77   (+) = (Prelude.+)
  78
  79 -- | For @'Addable' ('Map' k ())@.
  80 instance Addable () where
  81   (+) () () = ()
  82
  83 instance (Ord k, Addable a) => Addable (Map k a) where
  84   (+) = Map.unionWith (flip (+))
  85 instance Addable a => Addable (Maybe a) where
  86   Nothing + Nothing = Nothing
  87   Just x + Nothing = Just x
  88   Nothing + Just y = Just y
  89   Just x + Just y = Just (x + y)
  90
  91 {-
  92 instance Addable Decimal where
  93   (+) x y = Decimal e (fromIntegral (nx Prelude.+ ny))
  94    where
  95     (e, nx, ny) = roundMinDecimal x y
  96
  97 -- | Round the two 'DecimalRaw' values to the smallest exponent.
  98 roundMinDecimal :: Integral i => DecimalRaw i -> DecimalRaw i -> (Word8, i, i)
  99 roundMinDecimal d1@(Decimal e1 _) d2@(Decimal e2 _) = (e, n1, n2)
 100  where
 101   e = min e1 e2
 102   Decimal _ n1 = roundTo e d1
 103   Decimal _ n2 = roundTo e d2
 104 -}
 105
 106 -- * Class 'Negable'
 107 class Negable a where
 108   negate :: a -> a
 109   default negate :: Prelude.Num a => a -> a
 110   negate = Prelude.negate
 111
 112 -- | For @'Negable' ('Map' k ())@.
 113 instance Negable () where
 114   negate () = ()
 115
 116 instance Negable Int
 117 instance Negable Integer
 118
 119 -- instance Negable Decimal
 120 instance Negable a => Negable (Map k a) where
 121   negate = Map.map negate
 122 instance Negable a => Negable (Endo a) where
 123   negate (Endo f) = Endo (f . negate)
 124 instance Negable a => Negable [a] where
 125   negate = (negate <$>)
 126
 127 -- * Class 'Substractable'
 128 class Substractable a where
 129   (-) :: a -> a -> a
 130   infixl 6 -
 131   default (-) :: Prelude.Num a => a -> a -> a
 132   (-) = (Prelude.-)
 133
 134 -- | For @'Substractable' ('Map' k ())@.
 135 instance Substractable () where
 136   (-) () () = ()
 137
 138 instance Substractable Int
 139 instance Substractable Integer
 140
 141 -- instance Substractable Decimal
 142 instance (Ord k, Addable a, Negable a) => Substractable (Map k a) where
 143   (-) x y = Map.unionWith (flip (+)) x (negate y)
 144
 145 -- * Constraint 'MinQty'
 146 type QuantFact n = (KnownNat n, 1 <= n, n <= 4294967295 {-Word32-})
 147 quantisationFactor :: forall qf. QuantFact qf => Word32
 148 quantisationFactor = Prelude.fromIntegral (natVal (Proxy @qf))
 149
 150 -- * Type 'Quantity'
 151 newtype Quantity qf = Quantity
 152   { unQuantity :: Word64
 153   }
 154   deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
 155
 156 instance Zeroable (Quantity qf) where
 157   zero = Quantity 0
 158   isZero (Quantity q) = q == 0
 159
 160 -- instance Validity Quantity
 161 -- instance NFData Quantity
 162 instance QuantFact qf => FromInteger (MT.Except ErrorQuantity (Quantity qf)) where
 163   fromInteger n = fromRational (n :% 1)
 164 instance QuantFact qf => FromInteger (Quantity qf) where
 165   fromInteger n = fromRational (n :% 1)
 166
 167 instance Integral a => Addable (Ratio a) where
 168   x + y = x Prelude.+ y
 169 instance Addable (Maybe (Quantity qf)) where
 170   (+) mx my = do
 171     Quantity x <- mx
 172     Quantity y <- my
 173     let res = fromIntegral x Prelude.+ fromIntegral y
 174     if res > fromIntegral @Word64 maxBound
 175       then Nothing
 176       else Just (Quantity (Prelude.fromInteger res))
 177 instance Addable (Quantity qf) where
 178   (+) x y = do
 179     let res = fromIntegral (unQuantity x) Prelude.+ fromIntegral (unQuantity y)
 180     if res > fromIntegral (maxBound @Word64)
 181       then errorWithStack "Quantity overflow"
 182       else Quantity (Prelude.fromInteger res)
 183
 184 instance Substractable (Maybe (Quantity qf)) where
 185   (-) mx my = do
 186     Quantity x <- mx
 187     Quantity y <- my
 188     let res = fromIntegral x - fromIntegral y
 189     if res < 0
 190       then Nothing
 191       else Just (Quantity (Prelude.fromInteger res))
 192
 193 sumQuantities :: forall qf f. Foldable f => f (Quantity qf) -> Maybe (Quantity qf)
 194 sumQuantities l =
 195   let res = foldl' (\acc a -> Prelude.toInteger (unQuantity a) Prelude.+ acc) 0 l
 196   in if res > fromIntegral (maxBound @Word64)
 197        then Nothing
 198        else Just (Quantity (Prelude.fromInteger res))
 199
 200 multiply :: Word32 -> Quantity qf -> Maybe (Quantity qf)
 201 multiply c (Quantity qty) =
 202   let
 203     res :: Integer
 204     res = Prelude.fromIntegral c Prelude.* Prelude.fromIntegral qty
 205   in
 206     if res > fromIntegral (maxBound @Word64)
 207       then Nothing
 208       else Just (Quantity (Prelude.fromInteger res))
 209
 210 -- * Type 'CurrencyEnv'
 211 newtype CurrencyEnv = CurrencyEnv
 212   { currencyDefault :: Text
 213   }
 214
 215 -- newtype CurrencyT repr a = CurrencyT { unCurrencyT :: MT.ReaderT CurrencyEnv repr a }
 216
 217 -- * Class 'CurrencyUSD'
 218 class CurrencyUSD repr where
 219   usd :: repr a -> repr a
 220 instance CurrencyUSD (MT.ReaderT CurrencyEnv repr) where
 221   usd = MT.local (\c -> c{currencyDefault = "$"})
 222
 223 -- * Type 'ErrorQuantity'
 224 data ErrorQuantity
 225   = ErrorQuantityNaN
 226   | ErrorQuantityInfinite
 227   | ErrorQuantityNotNormalised
 228   | ErrorQuantityOverflow Natural
 229   | ErrorQuantityNegative
 230   | ErrorQuantityNotMultipleOfMinimalQuantity (Rational) (Word32) Natural Natural
 231   deriving (Eq, Show)
 232 instance Exception ErrorQuantity
 233
 234 newtype MinimalQuantity = MinimalQuantity Word32
 235
 236 {-
 237 quantityFromRational ::
 238   forall qf m.
 239   MC.MonadExcept ErrorQuantity m =>
 240   MC.MonadReader MinimalQuantity m =>
 241   --Reifies qf MinimalQuantity =>
 242   Rational ->
 243   m (Quantity qf)
 244 -}
 245
 246 instance QuantFact qf => FromRational (MT.Except ErrorQuantity (Quantity qf)) where
 247   fromRational r@(rn :% rd)
 248     -- ToDo: replace with isValid
 249     | rd == 0 = MC.throw $ if rn == 0 then ErrorQuantityNaN else ErrorQuantityInfinite
 250     | gcd < 0 || Prelude.quot rn gcd :% Prelude.quot rd gcd /= rn :% rd =
 251         MC.throw ErrorQuantityNotNormalised
 252     | r < 0 = MC.throw ErrorQuantityNegative
 253     | (fromIntegral :: Word64 -> Natural) (maxBound :: Word64) < ceiled = MC.throw $ ErrorQuantityOverflow ceiled
 254     | floored == ceiled = pure $ Quantity $ fromIntegral floored
 255     | otherwise = MC.throw $ ErrorQuantityNotMultipleOfMinimalQuantity r minQty floored ceiled
 256     where
 257       gcd = Prelude.gcd rn rd
 258       minQty = quantisationFactor @qf
 259       qty :: Rational
 260       qty = r Prelude.* fromIntegral minQty
 261       ceiled :: Natural
 262       ceiled = Prelude.ceiling qty
 263       floored :: Natural
 264       floored = Prelude.floor qty
 265
 266 -- | Warning(functional/completeness/partial)
 267 instance QuantFact qf => FromRational (Quantity qf) where
 268   fromRational = fromRational >>> MT.runExcept >>> either (throw @_ @_ @ErrorQuantity) id
 269
 270 -- | Turn an amount of money into a 'Ratio'.
 271 --
 272 -- WARNING: that the result will be @Quantity :% 0@ if the quantisation factor is @0@.
 273 quantityToRatio :: forall qf. QuantFact qf => Quantity qf -> Ratio Natural
 274 quantityToRatio (Quantity q) =
 275   -- \| isZero qf = Prelude.fromIntegral q :% 0
 276   -- \| otherwise =
 277   (Prelude.fromIntegral :: Word64 -> Natural) q % (Prelude.fromIntegral :: Word32 -> Natural) qf
 278   where
 279     qf = quantisationFactor @qf
 280
 281 -- | Turn an amount of money into a 'Rational'.
 282 --
 283 -- WARNING: that the result will be @Quantity :% 0@ if the quantisation factor is @0@.
 284 quantityToRational :: QuantFact qf => Quantity qf -> Rational
 285 quantityToRational q = q & quantityToRatio & Prelude.toRational
 286
 287 {-
 288 validateNotNaN :: RealFloat a => a -> Validation
 289 validateNotNaN x | isNaN x =
 290
 291 validateNotInfinite :: RealFloat a => a -> Validation
 292 validateNotInfinite d = declare "The RealFloat is not infinite." $ not (isInfinite d)
 293
 294 validateRatioNotNaN :: Integral a => Ratio a -> Validation
 295 validateRatioNotNaN r = declare "The Ratio is not NaN." $
 296   case r of
 297     (0 :% 0) -> False
 298     _ -> True
 299
 300 validateRatioNotInfinite :: Integral a => Ratio a -> Validation
 301 validateRatioNotInfinite r = declare "The Ratio is not infinite." $
 302   case r of
 303     (1 :% 0) -> False
 304     ((-1) :% 0) -> False
 305     _ -> True
 306
 307 validateRatioNormalised :: Integral a => Ratio a -> Validation
 308 validateRatioNormalised (n :% d) = declare "The Ratio is normalised." $
 309   case d of
 310     0 -> False
 311     _ ->
 312       let g = gcd n d
 313           gcdOverflows = g < 0
 314           n' :% d' = (n `quot` g) :% (d `quot` g)
 315           valueIsNormalised = n' :% d' == n :% d
 316        in not gcdOverflows && valueIsNormalised
 317 -}
 318 {-
 319
 320 -- | Turn a 'Ratio' into an amount of money.
 321 --
 322 -- This function will fail if the 'Ratio':
 323 --
 324 -- * Is NaN (0 :% 0)
 325 -- * Is infinite (1 :% 0) or (-1 :% 0)
 326 -- * Is non-normalised (5 :% 5)
 327 -- * Does represent an integer number of minimal quantisations.
 328 fromRatio :: Word32 -> Ratio Natural -> Maybe Quantity
 329 fromRatio quantisationFactor r = quantityFromRational quantisationFactor (Prelude.quantityToRational r)
 330
 331 -- | Distribute an amount of money into chunks that are as evenly distributed as possible.
 332 distribute :: Quantity -> Word32 -> QuantityDistribution
 333 distribute (Quantity 0) _ = DistributedZeroQuantity
 334 distribute _ 0 = DistributedIntoZeroChunks
 335 distribute (Quantity a) f =
 336   let smallerChunkSize, rest :: Word64
 337       (smallerChunkSize, rest) = divMod a ((fromIntegral :: Word32 -> Word64) f)
 338       smallerChunk :: Quantity
 339       smallerChunk = Quantity smallerChunkSize
 340    in if rest == 0
 341         then DistributedIntoEqualChunks f smallerChunk
 342         else
 343           let -- This 'fromIntegral' is theoretically not safe, but it's
 344               -- necessarily smaller than f so it will fit.
 345               numberOfLargerChunks :: Word32
 346               numberOfLargerChunks = (fromIntegral :: Word64 -> Word32) rest
 347               numberOfSmallerChunks :: Word32
 348               numberOfSmallerChunks = f - numberOfLargerChunks
 349               largerChunk :: Quantity
 350               largerChunk = Quantity $ succ smallerChunkSize
 351            in DistributedIntoUnequalChunks
 352                 numberOfLargerChunks
 353                 largerChunk
 354                 numberOfSmallerChunks
 355                 smallerChunk
 356
 357 -- | The result of 'distribute'
 358 data QuantityDistribution
 359   = -- | The second argument was zero.
 360     DistributedIntoZeroChunks
 361   | -- | The first argument was a zero amount.
 362     DistributedZeroQuantity
 363   | -- | Distributed into this many equal chunks of this amount
 364     DistributedIntoEqualChunks !Word32 !Quantity
 365   | -- | Distributed into unequal chunks, this many of the first (larger) amount, and this many of the second (slightly smaller) amount.
 366     DistributedIntoUnequalChunks !Word32 !Quantity !Word32 !Quantity
 367   deriving (Show, Read, Eq, Generic)
 368
 369 instance Validity QuantityDistribution where
 370   validate ad =
 371     mconcat
 372       [ genericValidate ad,
 373         case ad of
 374           DistributedIntoUnequalChunks _ a1 _ a2 ->
 375             declare "The larger chunks are larger" $
 376               a1 > a2
 377           _ -> valid
 378       ]
 379
 380 instance NFData QuantityDistribution
 381
 382 -- | Validate that an 'Quantity' is strictly positive. I.e. not 'zero'.
 383 validateStrictlyPositive :: Quantity -> Validation
 384 validateStrictlyPositive amount = declare "The Quantity is strictly positive" $ amount > zero
 385 -}
 386
 387 -- | Fractional multiplication
 388 fraction ::
 389   Zeroable (Quantity qf) =>
 390   Ratio Natural ->
 391   Quantity qf ->
 392   (Quantity qf, Ratio Natural)
 393 fraction frac (Quantity 0) = (zero, frac)
 394 fraction 0 _ = (zero, 0)
 395 fraction frac (Quantity qty) =
 396   let
 397     theoreticalResult :: Ratio Natural
 398     theoreticalResult = frac Prelude.* (fromIntegral :: Word64 -> Ratio Natural) qty
 399     roundedResult :: Word64
 400     roundedResult = (Prelude.round :: Ratio Natural -> Word64) theoreticalResult
 401     actualRate :: Ratio Natural
 402     actualRate =
 403       (fromIntegral :: Word64 -> Natural) roundedResult
 404         % (fromIntegral :: Word64 -> Natural) qty
 405   in
 406     (Quantity roundedResult, actualRate)