lib/Hcompta/Quantity.hs

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