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