lib/Hcompta/Quantity.hs

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