src/Literate/Accounting/Math.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2
   3 module Literate.Accounting.Math where
   4
   5 import Data.Bool
   6 import Data.Decimal (Decimal, DecimalRaw (..), roundTo)
   7 import Data.Eq (Eq (..))
   8 import Data.Function (flip, (.))
   9 import Data.Functor ((<$>))
  10 import Data.Int (Int)
  11 import Data.Map.Strict (Map)
  12 import Data.Map.Strict qualified as Map
  13 import Data.Maybe (Maybe (..))
  14 import Data.Monoid (Endo (..))
  15 import Data.Ord (Ord (..), Ordering (..))
  16 import Data.String (String)
  17 import Data.Word (Word8)
  18 import Prelude (Integer, Integral, fromIntegral)
  19 import Prelude qualified
  20
  21 -- * Class 'Zeroable'
  22 class Zeroable a where
  23   zero :: a
  24 instance Zeroable String where
  25   zero = ""
  26 instance Zeroable Decimal where
  27   zero = 0
  28 instance Zeroable (Map.Map k a) where
  29   zero = Map.empty
  30
  31 {-
  32 instance Zeroable Decimal where
  33   zero = 0
  34 instance Zeroable (Map k a) where
  35   zero = Map.empty
  36 -}
  37
  38 -- * Class 'Nullable'
  39 class Nullable a where
  40   null :: a -> Bool
  41   default null :: Zeroable a => Eq a => a -> Bool
  42   null = (== zero)
  43 instance Nullable String
  44 instance Nullable Decimal
  45
  46 {-
  47 instance Nullable Decimal where
  48   null = (==) zero
  49 instance Nullable a => Nullable (Map k a) where
  50   null = Foldable.all null
  51 -}
  52
  53 -- * Class 'Signable'
  54 class Signable a where
  55   sign :: a -> Ordering
  56   default sign :: Zeroable a => Nullable a => Ord a => a -> Ordering
  57   sign a =
  58     case () of
  59       _ | null a -> EQ
  60       _ | a < zero -> LT
  61       _ -> GT
  62
  63 -- instance Signable Decimal
  64
  65 -- * Class 'Addable'
  66
  67 -- | Can be added.
  68 class Addable a where
  69   (+) :: a -> a -> a
  70   infixl 6 +
  71   default (+) :: Prelude.Num a => a -> a -> a
  72   (+) = (Prelude.+)
  73
  74 -- | For @'Addable' ('Map' k ())@.
  75 instance Addable () where
  76   (+) () () = ()
  77
  78 instance (Ord k, Addable a) => Addable (Map k a) where
  79   (+) = Map.unionWith (flip (+))
  80 instance Addable a => Addable (Maybe a) where
  81   Nothing + Nothing = Nothing
  82   Just x + Nothing = Just x
  83   Nothing + Just y = Just y
  84   Just x + Just y = Just (x + y)
  85 instance Addable Decimal where
  86   (+) x y = Decimal e (fromIntegral (nx Prelude.+ ny))
  87    where
  88     (e, nx, ny) = roundMinDecimal x y
  89
  90 -- | Round the two 'DecimalRaw' values to the smallest exponent.
  91 roundMinDecimal :: Integral i => DecimalRaw i -> DecimalRaw i -> (Word8, i, i)
  92 roundMinDecimal d1@(Decimal e1 _) d2@(Decimal e2 _) = (e, n1, n2)
  93  where
  94   e = min e1 e2
  95   Decimal _ n1 = roundTo e d1
  96   Decimal _ n2 = roundTo e d2
  97
  98 -- * Class 'Negable'
  99 class Negable a where
 100   negate :: a -> a
 101   default negate :: Prelude.Num a => a -> a
 102   negate = Prelude.negate
 103
 104 -- | For @'Negable' ('Map' k ())@.
 105 instance Negable () where
 106   negate () = ()
 107
 108 instance Negable Int
 109 instance Negable Integer
 110 instance Negable Decimal
 111 instance Negable a => Negable (Map k a) where
 112   negate = Map.map negate
 113 instance Negable a => Negable (Endo a) where
 114   negate (Endo f) = Endo (f . negate)
 115 instance Negable a => Negable [a] where
 116   negate = (negate <$>)
 117
 118 -- * Class 'Subable'
 119 class Subable a where
 120   (-) :: a -> a -> a
 121   infixl 6 -
 122   default (-) :: Prelude.Num a => a -> a -> a
 123   (-) = (Prelude.-)
 124
 125 -- | For @'Subable' ('Map' k ())@.
 126 instance Subable () where
 127   (-) () () = ()
 128
 129 instance Subable Int
 130 instance Subable Integer
 131 instance Subable Decimal
 132 instance (Ord k, Addable a, Negable a) => Subable (Map k a) where
 133   (-) x y = Map.unionWith (flip (+)) x (negate y)