lib/Hcompta/Quantity.hs

   1 {-# LANGUAGE ConstrainedClassMethods #-}
   2 {-# LANGUAGE DefaultSignatures #-}
   3 {-# LANGUAGE StandaloneDeriving #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 module Hcompta.Quantity where
   6
   7 import           Data.Bool
   8 import           Data.Data (Data)
   9 import           Data.Decimal (Decimal, DecimalRaw(..), roundTo)
  10 import           Data.Eq (Eq(..))
  11 import qualified Data.Foldable as Foldable
  12 import           Data.Function (flip)
  13 import           Data.Map.Strict (Map)
  14 import qualified Data.Map.Strict as Map
  15 import           Data.Ord (Ord(..), Ordering(..))
  16 import           Data.Word (Word8)
  17 import           Prelude (Integer, Integral, Num(..), fromIntegral)
  18
  19 -- * Class 'Quantity'
  20 class Zero q => Quantity q
  21 instance Quantity Integer
  22 instance Quantity Decimal
  23 instance Quantity qty => Quantity (Map unit qty)
  24
  25 -- * Class 'Zero'
  26 class Zero q where
  27         quantity_zero :: q
  28         quantity_null :: q -> Bool
  29         default quantity_null :: Eq q => q -> Bool
  30         quantity_null = (== quantity_zero)
  31         quantity_sign :: Ord q => q -> Ordering
  32         default quantity_sign :: Ord q => q -> Ordering
  33         quantity_sign q =
  34                 case () of
  35                  _ | quantity_null q -> EQ
  36                  _ | q < quantity_zero -> LT
  37                  _ -> GT
  38
  39 instance Zero Integer where
  40         quantity_zero = 0
  41         quantity_null = (==) 0
  42 instance Zero Decimal where
  43         quantity_zero = 0
  44         quantity_null = (==) 0
  45 instance -- Map unit qty
  46  Quantity qty => Zero (Map unit qty) where
  47         quantity_zero = Map.empty
  48         quantity_null = Foldable.all quantity_null
  49
  50 -- * Class 'Addable'
  51 class Addable q where
  52         quantity_add :: q -> q -> q
  53 instance Addable Integer where
  54         quantity_add = (+)
  55 instance Addable Decimal where
  56         quantity_add d1 d2 =
  57                 Decimal e (fromIntegral (n1 + n2))
  58                 where (e, n1, n2) = decimal_round_min d1 d2
  59 instance -- Map unit qty
  60  (Ord unit, Addable qty) => Addable (Map unit qty) where
  61         quantity_add = Map.unionWith (flip quantity_add)
  62
  63 -- * Class 'Negable'
  64 class Negable q where
  65         quantity_neg  :: q -> q
  66 instance Negable Integer where
  67         quantity_neg = negate
  68 instance Negable Decimal where
  69         quantity_neg = negate
  70 instance -- Map unit qty
  71  Negable qty => Negable (Map unit qty) where
  72         quantity_neg = Map.map quantity_neg
  73
  74 -- * Class 'Subable'
  75 class Subable q where
  76         quantity_sub :: q -> q -> q
  77 instance Subable Integer where
  78         quantity_sub = (-)
  79 instance Subable Decimal where
  80         quantity_sub = (-)
  81 instance -- Map unit qty
  82  ( Ord unit
  83  , Addable qty
  84  , Negable qty
  85  ) => Subable (Map unit qty) where
  86         quantity_sub x y =
  87                 Map.unionWith (flip quantity_add) x (quantity_neg y)
  88
  89 -- * Type 'Decimal' (with orphan Data instance)
  90
  91 -- Orphan instance
  92 deriving instance Data Decimal
  93
  94 -- | Round the two 'DecimalRaw' values to the smallest exponent.
  95 decimal_round_min
  96  :: Integral i
  97  => DecimalRaw i
  98  -> DecimalRaw i
  99  -> (Word8, i, i)
 100 decimal_round_min d1@(Decimal e1 _) d2@(Decimal e2 _) = (e, n1, n2)
 101         where
 102                 e = min e1 e2
 103                 Decimal _ n1 = roundTo e d1
 104                 Decimal _ n2 = roundTo e d2