lib/Hcompta/Filter/Amount.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE StandaloneDeriving #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Hcompta.Filter.Amount where
   8 import           Data.Data
   9 import           Data.Decimal (Decimal, DecimalRaw(..), roundTo)
  10 import           Data.Eq (Eq(..))
  11 import           Data.Maybe (Maybe(..))
  12 import           Data.Ord (Ord(..))
  13 import           Data.Text (Text)
  14 import qualified Data.Text as Text
  15 import           Data.Typeable ()
  16 import           Data.Word (Word8)
  17 import           Prelude (Integral, Num(..), fromIntegral)
  18 import           Text.Show (Show(..))
  19
  20 import           Hcompta.Quantity
  21 import           Hcompta.Polarize
  22 import qualified Hcompta.Unit as Unit
  23
  24 -- * Type 'Quantity'
  25 type Quantity = Decimal
  26 deriving instance Data Quantity
  27
  28 -- | Round the two 'DecimalRaw' values to the smallest exponent.
  29 round_min :: Integral i => DecimalRaw i -> DecimalRaw i -> (Word8, i, i)
  30 round_min d1@(Decimal e1 _) d2@(Decimal e2 _) = (e, n1, n2)
  31         where
  32                 e = min e1 e2
  33                 Decimal _ n1 = roundTo e d1
  34                 Decimal _ n2 = roundTo e d2
  35
  36 instance Zero Quantity where
  37         quantity_zero = 0
  38         quantity_null = (==) 0
  39 instance Addable Quantity where
  40         quantity_add d1 d2 =
  41                 Decimal e (fromIntegral (n1 + n2))
  42                 where (e, n1, n2) = round_min d1 d2
  43 instance Negable Quantity where
  44         quantity_neg = negate
  45 instance Polarizable Quantity where
  46         polarizable_negative q =
  47                 case q of
  48                  _ | q < 0 -> Just q
  49                  _         -> Nothing
  50         polarizable_positive q =
  51                 case q of
  52                  _ | q <= 0 -> Nothing
  53                  _          -> Just q
  54
  55 -- * Type 'Unit'
  56 newtype Unit
  57  =      Unit Text
  58  deriving (Data, Eq, Ord, Show, Typeable)
  59
  60 instance Unit.Unit Unit where
  61         unit_empty = Unit (Text.pack "")
  62         unit_text (Unit t) = t
  63
  64 -- * Type 'Amount'
  65 data Amount
  66  =   Amount
  67  { amount_unit     :: Unit
  68  , amount_quantity :: Quantity
  69  } deriving (Data, Eq, Show, Typeable)