+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Literate.Accounting.Math where
+
+import Control.Applicative (Applicative (..))
+import Control.Exception (Exception, throw)
+import Control.Monad.Classes qualified as MC
+import Control.Monad.Classes.Run qualified as MC
+import Control.Monad.Trans.Except as MT
+import Control.Monad.Trans.Reader as MT
+import Data.Bool
+import Data.Data (Data)
+import Data.Either (Either (..), either)
+import Data.Eq (Eq (..))
+import Data.Foldable (Foldable, foldl')
+import Data.Function (flip, id, ($), (.))
+import Data.Functor ((<$>))
+import Data.Functor.Identity (Identity (..))
+import Data.Int (Int)
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Maybe (Maybe (..))
+import Data.Monoid (Endo (..))
+import Data.Ord (Ord (..), Ordering (..))
+import Data.Proxy (Proxy (..))
+import Data.Ratio (Rational)
+import Data.String (String)
+import Data.Text (Text)
+import Data.Typeable (Typeable)
+import Data.Word
+import GHC.Generics (Generic)
+import GHC.Real (FractionalExponentBase (Base10), Ratio ((:%)), (%))
+import GHC.Stack (HasCallStack)
+import GHC.TypeLits (KnownNat, Nat, Symbol, natVal, type (<=))
+import Literate.Prelude
+import Numeric.Natural
+import Text.Read (Read)
+import Text.Show (Show (..), ShowS, showParen, showString, showsPrec)
+import Prelude (Integer, Integral, error, fromIntegral, maxBound)
+import Prelude qualified
+
+-- import Data.Decimal (Decimal, DecimalRaw (..), roundTo)
+-- import Data.Validity qualified as Validity
+-- import Data.Reflection (Reifies(..), reify)
+-- import Data.Modular
+-- import Literate.Accounting.Rebindable (fromInteger, FromRational(..))
+
+errorWithStack :: HasCallStack => String -> a
+errorWithStack = error -- (msg <> "\n" <> prettyCallStack callStack)
+
+-- * Class 'Zeroable'
+class Zeroable a where
+ zero :: a
+ isZero :: a -> Bool
+ default isZero :: Zeroable a => Eq a => a -> Bool
+ isZero = (== zero)
+instance Zeroable String where
+ zero = ""
+ isZero = null
+instance Zeroable Word32 where
+ zero = (0 :: Int) & fromIntegral
+instance Zeroable Word64 where
+ zero = (0 :: Int) & fromIntegral
+
+-- instance Zeroable Decimal where
+-- zero = 0
+instance Zeroable (Map.Map k a) where
+ zero = Map.empty
+ isZero = Map.null
+
+{-
+instance Zeroable Decimal where
+ zero = 0
+instance Zeroable (Map k a) where
+ zero = Map.empty
+-}
+
+-- * Class 'Signable'
+class Signable a where
+ sign :: a -> Ordering
+ default sign :: Zeroable a => Ord a => a -> Ordering
+ sign a =
+ case () of
+ _ | isZero a -> EQ
+ _ | a < zero -> LT
+ _ -> GT
+
+-- instance Signable Decimal
+
+-- * Class 'Addable'
+
+-- | Can be added.
+class Addable a where
+ (+) :: HasCallStack => a -> a -> a
+ infixl 6 +
+ default (+) :: Prelude.Num a => HasCallStack => a -> a -> a
+ (+) = (Prelude.+)
+
+-- | For @'Addable' ('Map' k ())@.
+instance Addable () where
+ (+) () () = ()
+
+instance (Ord k, Addable a) => Addable (Map k a) where
+ (+) = Map.unionWith (flip (+))
+instance Addable a => Addable (Maybe a) where
+ Nothing + Nothing = Nothing
+ Just x + Nothing = Just x
+ Nothing + Just y = Just y
+ Just x + Just y = Just (x + y)
+
+{-
+instance Addable Decimal where
+ (+) x y = Decimal e (fromIntegral (nx Prelude.+ ny))
+ where
+ (e, nx, ny) = roundMinDecimal x y
+
+-- | Round the two 'DecimalRaw' values to the smallest exponent.
+roundMinDecimal :: Integral i => DecimalRaw i -> DecimalRaw i -> (Word8, i, i)
+roundMinDecimal d1@(Decimal e1 _) d2@(Decimal e2 _) = (e, n1, n2)
+ where
+ e = min e1 e2
+ Decimal _ n1 = roundTo e d1
+ Decimal _ n2 = roundTo e d2
+-}
+
+-- * Class 'Negable'
+class Negable a where
+ negate :: a -> a
+ default negate :: Prelude.Num a => a -> a
+ negate = Prelude.negate
+
+-- | For @'Negable' ('Map' k ())@.
+instance Negable () where
+ negate () = ()
+
+instance Negable Int
+instance Negable Integer
+
+-- instance Negable Decimal
+instance Negable a => Negable (Map k a) where
+ negate = Map.map negate
+instance Negable a => Negable (Endo a) where
+ negate (Endo f) = Endo (f . negate)
+instance Negable a => Negable [a] where
+ negate = (negate <$>)
+
+-- * Class 'Substractable'
+class Substractable a where
+ (-) :: a -> a -> a
+ infixl 6 -
+ default (-) :: Prelude.Num a => a -> a -> a
+ (-) = (Prelude.-)
+
+-- | For @'Substractable' ('Map' k ())@.
+instance Substractable () where
+ (-) () () = ()
+
+instance Substractable Int
+instance Substractable Integer
+
+-- instance Substractable Decimal
+instance (Ord k, Addable a, Negable a) => Substractable (Map k a) where
+ (-) x y = Map.unionWith (flip (+)) x (negate y)
+
+-- * Constraint 'MinQty'
+type QuantFact n = (KnownNat n, 1 <= n, n <= 4294967295 {-Word32-})
+quantisationFactor :: forall qf. QuantFact qf => Word32
+quantisationFactor = Prelude.fromIntegral (natVal (Proxy @qf))
+
+data Unit
+ = UnitName Symbol
+ | (:*:) Unit Unit
+ | (:/:) Unit Unit
+
+class UnitShowS (u :: Unit) where
+ unitShowS :: Int -> ShowS
+instance KnownSymbol u => UnitShowS (UnitName u) where
+ unitShowS _prec = showString (symbolVal (Proxy @u))
+instance (UnitShowS x, UnitShowS y) => UnitShowS (x :*: y) where
+ unitShowS p = showParen (7 <= p) $ unitShowS @x 7 . showString "\x202F*\x202F" . unitShowS @y 7
+instance (UnitShowS x, UnitShowS y) => UnitShowS (x :/: y) where
+ unitShowS p = showParen (7 <= p) $ unitShowS @x 7 . showString "\x202F/\x202F" . unitShowS @y 7
+
+unitShow :: forall u. UnitShowS u => String
+unitShow = unitShowS @u 0 ""
+
+-- * Type 'Amount'
+newtype Amount (qf :: Nat) (unit :: Unit) = Amount
+ { amountQuantity :: Quantity qf
+ }
+ deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
+instance QuantFact qf => FromInteger (MT.Except ErrorQuantity (Amount qf unit)) where
+ fromInteger i = fromRational (i :% 1)
+
+-- * Type 'Quantity'
+newtype Quantity qf = Quantity
+ { unQuantity :: Word64
+ }
+ deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
+
+instance Zeroable (Quantity qf) where
+ zero = Quantity 0
+ isZero (Quantity q) = q == 0
+
+-- instance Validity Quantity
+-- instance NFData Quantity
+instance QuantFact qf => FromInteger (MT.Except ErrorQuantity (Quantity qf)) where
+ fromInteger n = fromRational (n :% 1)
+instance QuantFact qf => FromInteger (Quantity qf) where
+ fromInteger n = fromRational (n :% 1)
+instance QuantFact qf => FromInteger (Amount qf unit) where
+ fromInteger = fromInteger >>> Amount
+
+instance Integral a => Addable (Ratio a) where
+ x + y = x Prelude.+ y
+instance Addable (Maybe (Quantity qf)) where
+ (+) mx my = do
+ Quantity x <- mx
+ Quantity y <- my
+ let res = fromIntegral x Prelude.+ fromIntegral y
+ if res > fromIntegral @Word64 maxBound
+ then Nothing
+ else Just (Quantity (Prelude.fromInteger res))
+instance Addable (Quantity qf) where
+ (+) x y = do
+ let res = fromIntegral (unQuantity x) Prelude.+ fromIntegral (unQuantity y)
+ if res > fromIntegral (maxBound @Word64)
+ then errorWithStack "Quantity overflow"
+ else Quantity (Prelude.fromInteger res)
+instance Addable (Amount qf unit) where
+ Amount x + Amount y = Amount (x + y)
+
+{-
+sum :: forall f. Foldable f => f Amount -> Maybe Amount
+sum l =
+ let maxBoundI :: Integer
+ maxBoundI = fromIntegral (maxBound :: Word64)
+ r :: Integer
+ r = foldl' (\acc a -> (toInteger :: Word64 -> Integer) (amountQuantity a) + acc) 0 l
+ in if r > maxBoundI
+ then Nothing
+ else Just (Amount ((fromInteger :: Integer -> Word64) r))
+-}
+
+instance Substractable (Maybe (Quantity qf)) where
+ (-) mx my = do
+ Quantity x <- mx
+ Quantity y <- my
+ let res = fromIntegral x - fromIntegral y
+ if res < 0
+ then Nothing
+ else Just (Quantity (Prelude.fromInteger res))
+
+sumAmounts :: forall qf unit f. Functor f => Foldable f => f (Amount qf unit) -> Maybe (Amount qf unit)
+sumAmounts l = l <&> amountQuantity & sumQuantities <&> Amount
+
+sumQuantities :: forall qf f. Foldable f => f (Quantity qf) -> Maybe (Quantity qf)
+sumQuantities l =
+ let res = foldl' (\acc a -> Prelude.toInteger (unQuantity a) Prelude.+ acc) 0 l
+ in if res > fromIntegral (maxBound @Word64)
+ then Nothing
+ else Just (Quantity (Prelude.fromInteger res))
+
+multiply :: Word32 -> Quantity qf -> Maybe (Quantity qf)
+multiply c (Quantity qty) =
+ let
+ res :: Integer
+ res = Prelude.fromIntegral c Prelude.* Prelude.fromIntegral qty
+ in
+ if res > fromIntegral (maxBound @Word64)
+ then Nothing
+ else Just (Quantity (Prelude.fromInteger res))
+
+-- * Type 'CurrencyEnv'
+newtype CurrencyEnv = CurrencyEnv
+ { currencyDefault :: Text
+ }
+
+-- newtype CurrencyT repr a = CurrencyT { unCurrencyT :: MT.ReaderT CurrencyEnv repr a }
+
+-- * Class 'CurrencyUSD'
+class CurrencyUSD repr where
+ usd :: repr a -> repr a
+instance CurrencyUSD (MT.ReaderT CurrencyEnv repr) where
+ usd = MT.local (\c -> c{currencyDefault = "$"})
+
+-- * Type 'ErrorQuantity'
+data ErrorQuantity
+ = ErrorQuantityNaN
+ | ErrorQuantityInfinite
+ | ErrorQuantityNotNormalised
+ | ErrorQuantityOverflow Natural
+ | ErrorQuantityNegative
+ | ErrorQuantityNotMultipleOfMinimalQuantity (Rational) (Word32) Natural Natural
+ deriving (Eq, Show)
+instance Exception ErrorQuantity
+
+newtype MinimalQuantity = MinimalQuantity Word32
+
+{-
+quantityFromRational ::
+ forall qf m.
+ MC.MonadExcept ErrorQuantity m =>
+ MC.MonadReader MinimalQuantity m =>
+ --Reifies qf MinimalQuantity =>
+ Rational ->
+ m (Quantity qf)
+-}
+
+instance QuantFact qf => FromRational (MT.Except ErrorQuantity (Quantity qf)) where
+ fromRational r@(rn :% rd)
+ -- ToDo: replace with isValid
+ | rd == 0 = MC.throw $ if rn == 0 then ErrorQuantityNaN else ErrorQuantityInfinite
+ | gcd < 0 || Prelude.quot rn gcd :% Prelude.quot rd gcd /= rn :% rd =
+ MC.throw ErrorQuantityNotNormalised
+ | r < 0 = MC.throw ErrorQuantityNegative
+ | (fromIntegral :: Word64 -> Natural) (maxBound :: Word64) < ceiled = MC.throw $ ErrorQuantityOverflow ceiled
+ | floored == ceiled = pure $ Quantity $ fromIntegral floored
+ | otherwise = MC.throw $ ErrorQuantityNotMultipleOfMinimalQuantity r minQty floored ceiled
+ where
+ gcd = Prelude.gcd rn rd
+ minQty = quantisationFactor @qf
+ qty :: Rational
+ qty = r Prelude.* fromIntegral minQty
+ ceiled :: Natural
+ ceiled = Prelude.ceiling qty
+ floored :: Natural
+ floored = Prelude.floor qty
+instance QuantFact qf => FromRational (MT.Except ErrorQuantity (Amount qf unit)) where
+ fromRational r = Amount <$> fromRational r
+
+-- | Warning(functional/completeness/partial)
+instance QuantFact qf => FromRational (Quantity qf) where
+ fromRational = fromRational >>> MT.runExcept >>> either (throw @_ @_ @ErrorQuantity) id
+
+instance QuantFact qf => FromRational (Amount qf unit) where
+ fromRational = Amount . fromRational
+
+-- | Turn an amount of money into a 'Ratio'.
+--
+-- WARNING: that the result will be @Quantity :% 0@ if the quantisation factor is @0@.
+quantityToRatio :: forall qf. QuantFact qf => Quantity qf -> Ratio Natural
+quantityToRatio (Quantity q) =
+ -- \| isZero qf = Prelude.fromIntegral q :% 0
+ -- \| otherwise =
+ (Prelude.fromIntegral :: Word64 -> Natural) q % (Prelude.fromIntegral :: Word32 -> Natural) qf
+ where
+ qf = quantisationFactor @qf
+
+-- | Turn an amount of money into a 'Rational'.
+--
+-- WARNING: that the result will be @Quantity :% 0@ if the quantisation factor is @0@.
+quantityToRational :: QuantFact qf => Quantity qf -> Rational
+quantityToRational q = q & quantityToRatio & Prelude.toRational
+
+-- instance QuantFact qf => FromRational (Amount qf unit) where
+-- fromRational = either (throw @_ @_ @ErrorQuantity) id . MT.runExcept . fromRational
+
+{-
+validateNotNaN :: RealFloat a => a -> Validation
+validateNotNaN x | isNaN x =
+
+validateNotInfinite :: RealFloat a => a -> Validation
+validateNotInfinite d = declare "The RealFloat is not infinite." $ not (isInfinite d)
+
+validateRatioNotNaN :: Integral a => Ratio a -> Validation
+validateRatioNotNaN r = declare "The Ratio is not NaN." $
+ case r of
+ (0 :% 0) -> False
+ _ -> True
+
+validateRatioNotInfinite :: Integral a => Ratio a -> Validation
+validateRatioNotInfinite r = declare "The Ratio is not infinite." $
+ case r of
+ (1 :% 0) -> False
+ ((-1) :% 0) -> False
+ _ -> True
+
+validateRatioNormalised :: Integral a => Ratio a -> Validation
+validateRatioNormalised (n :% d) = declare "The Ratio is normalised." $
+ case d of
+ 0 -> False
+ _ ->
+ let g = gcd n d
+ gcdOverflows = g < 0
+ n' :% d' = (n `quot` g) :% (d `quot` g)
+ valueIsNormalised = n' :% d' == n :% d
+ in not gcdOverflows && valueIsNormalised
+-}
+{-
+
+-- | Turn a 'Ratio' into an amount of money.
+--
+-- This function will fail if the 'Ratio':
+--
+-- * Is NaN (0 :% 0)
+-- * Is infinite (1 :% 0) or (-1 :% 0)
+-- * Is non-normalised (5 :% 5)
+-- * Does represent an integer number of minimal quantisations.
+fromRatio :: Word32 -> Ratio Natural -> Maybe Quantity
+fromRatio quantisationFactor r = quantityFromRational quantisationFactor (Prelude.quantityToRational r)
+
+-- | Distribute an amount of money into chunks that are as evenly distributed as possible.
+distribute :: Quantity -> Word32 -> QuantityDistribution
+distribute (Quantity 0) _ = DistributedZeroQuantity
+distribute _ 0 = DistributedIntoZeroChunks
+distribute (Quantity a) f =
+ let smallerChunkSize, rest :: Word64
+ (smallerChunkSize, rest) = divMod a ((fromIntegral :: Word32 -> Word64) f)
+ smallerChunk :: Quantity
+ smallerChunk = Quantity smallerChunkSize
+ in if rest == 0
+ then DistributedIntoEqualChunks f smallerChunk
+ else
+ let -- This 'fromIntegral' is theoretically not safe, but it's
+ -- necessarily smaller than f so it will fit.
+ numberOfLargerChunks :: Word32
+ numberOfLargerChunks = (fromIntegral :: Word64 -> Word32) rest
+ numberOfSmallerChunks :: Word32
+ numberOfSmallerChunks = f - numberOfLargerChunks
+ largerChunk :: Quantity
+ largerChunk = Quantity $ succ smallerChunkSize
+ in DistributedIntoUnequalChunks
+ numberOfLargerChunks
+ largerChunk
+ numberOfSmallerChunks
+ smallerChunk
+
+-- | The result of 'distribute'
+data QuantityDistribution
+ = -- | The second argument was zero.
+ DistributedIntoZeroChunks
+ | -- | The first argument was a zero amount.
+ DistributedZeroQuantity
+ | -- | Distributed into this many equal chunks of this amount
+ DistributedIntoEqualChunks !Word32 !Quantity
+ | -- | Distributed into unequal chunks, this many of the first (larger) amount, and this many of the second (slightly smaller) amount.
+ DistributedIntoUnequalChunks !Word32 !Quantity !Word32 !Quantity
+ deriving (Show, Read, Eq, Generic)
+
+instance Validity QuantityDistribution where
+ validate ad =
+ mconcat
+ [ genericValidate ad,
+ case ad of
+ DistributedIntoUnequalChunks _ a1 _ a2 ->
+ declare "The larger chunks are larger" $
+ a1 > a2
+ _ -> valid
+ ]
+
+instance NFData QuantityDistribution
+
+-- | Validate that an 'Quantity' is strictly positive. I.e. not 'zero'.
+validateStrictlyPositive :: Quantity -> Validation
+validateStrictlyPositive amount = declare "The Quantity is strictly positive" $ amount > zero
+-}
+
+-- | Fractional multiplication
+fraction ::
+ Zeroable (Quantity qf) =>
+ Ratio Natural ->
+ Quantity qf ->
+ (Quantity qf, Ratio Natural)
+fraction frac (Quantity 0) = (zero, frac)
+fraction 0 _ = (zero, 0)
+fraction frac (Quantity a) =
+ let
+ theoreticalResult :: Ratio Natural
+ theoreticalResult = (fromIntegral :: Word64 -> Ratio Natural) a Prelude.* frac
+ roundedResult :: Word64
+ roundedResult = (Prelude.round :: Ratio Natural -> Word64) theoreticalResult
+ actualRate :: Ratio Natural
+ actualRate =
+ (fromIntegral :: Word64 -> Natural) roundedResult
+ % (fromIntegral :: Word64 -> Natural) a
+ in
+ (Quantity roundedResult, actualRate)
sourcephile / git / tmp / julm / literate-invoice.git / commitdiff