ledger/Hcompta/Format/Ledger/Amount.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8 {-# OPTIONS_GHC -fno-warn-orphans #-}
   9 module Hcompta.Format.Ledger.Amount where
  10
  11 import           Control.DeepSeq
  12 import           Data.Bool
  13 import           Data.Data
  14 import           Data.Eq (Eq(..))
  15 -- import qualified Data.Foldable
  16 -- import qualified Data.List
  17 -- import           Data.Map.Strict (Map)
  18 import           Data.Ord (Ord(..), Ordering(..))
  19 -- import           Data.String (IsString)
  20 -- import           Data.Text (Text)
  21 -- import qualified Data.Text as Text
  22 import           Data.Typeable ()
  23 import           Prelude ((.), seq)
  24 -- import           Prelude (($), (.), Bounded(..), Int, Num(..), flip, seq, error)
  25 import           Text.Show (Show(..))
  26
  27 import qualified Hcompta.Amount as Amount
  28 import qualified Hcompta.Filter as Filter
  29 import qualified Hcompta.Polarize as Polarize
  30 import qualified Hcompta.Quantity as Quantity
  31 import qualified Hcompta.Unit as Unit
  32 import qualified Hcompta.Format.Ledger.Amount.Style as Style
  33 import           Hcompta.Format.Ledger.Quantity (Quantity)
  34 import           Hcompta.Format.Ledger.Unit (Unit(..))
  35
  36 -- * Type 'Style'
  37
  38 type Style    = Style.Style
  39 type Styles   = Style.Styles
  40 type Styled t = Style.Styled t
  41
  42 -- * Type 'Amount'
  43
  44 data Amount
  45  =   Amount
  46  { amount_unit     :: !Unit
  47  , amount_quantity :: !Quantity
  48  } deriving (Data, Show, Typeable)
  49 instance Amount.Amount Amount where
  50         type Amount_Quantity Amount = Quantity
  51         type Amount_Unit     Amount = Unit
  52         amount_quantity = amount_quantity
  53         amount_unit     = amount_unit
  54 instance Filter.Amount Amount where
  55         type Amount_Quantity Amount = Quantity
  56         type Amount_Unit     Amount = Unit
  57         amount_quantity = Polarize.polarize . amount_quantity
  58         amount_unit     = amount_unit
  59 instance NFData Amount where
  60         rnf (Amount q u) = rnf q `seq` rnf u
  61 {-
  62 instance Eq Amount where
  63         (==)
  64          Amount{amount_quantity=q0, amount_unit=u0}
  65          Amount{amount_quantity=q1, amount_unit=u1} =
  66                 case compare u0 u1 of
  67                  LT -> False
  68                  GT -> False
  69                  EQ -> (==) q0 q1 -- NOTE: MUST already be rounded to Style.precision
  70 instance Ord Amount where
  71         compare
  72          Amount{amount_quantity=q0, amount_unit=u0}
  73          Amount{amount_quantity=q1, amount_unit=u1} =
  74                 case compare u0 u1 of
  75                  LT -> LT
  76                  GT -> GT
  77                  EQ -> compare q0 q1 -- NOTE: MUST already be rounded to Style.precision
  78 -}
  79 instance Quantity.Zero Amount where
  80         quantity_zero = Amount Unit.unit_empty Quantity.quantity_zero
  81         quantity_null = (==) Quantity.quantity_zero . amount_quantity
  82
  83 amount_style :: Styles -> Amount -> Style
  84 amount_style styles = Style.style styles . amount_unit
  85
  86 style :: Styles -> Amount -> Styled Amount
  87 style styles amt = (amount_style styles amt, amt)
  88
  89 {-
  90 instance GL.Amount Amount where
  91         type Amount_Unit Amount = Unit
  92         amount_add = (+)
  93 instance GL.Amount (Map Unit Amount) where
  94         type Amount_Unit (Map Unit Amount) = Unit
  95         amount_add = Data.Map.unionWith (+)
  96 -}
  97
  98 {-
  99 -- | An 'Amount' is a partially valid 'Num' instance:
 100 --
 101 --   * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint).
 102 --   * (*) operator requires at least one operand with an empty 'Unit' ('scalar').
 103 instance Num Amount where
 104         abs    a@Amount{amount_quantity=q} = a{amount_quantity=abs q}
 105         fromInteger                        = scalar . fromInteger
 106         negate a@Amount{amount_quantity=q} = a{amount_quantity=negate q}
 107         signum a@Amount{amount_quantity=q} = a{amount_quantity=signum q}
 108         (+) a b =
 109                 let s@(Style.Style{Style.precision=p}) = Style.union (amount_style a) (amount_style b) in
 110                 a{ amount_quantity = quantity_round p $ amount_quantity a + amount_quantity b
 111                  , amount_style = s
 112                  , amount_unit =
 113                         if amount_unit a == amount_unit b
 114                         then amount_unit a
 115                         else error "(+) on non-homogeneous units"
 116                  }
 117         (*) a b =
 118                 let Style.Style{Style.precision=p} = s in
 119                 a{ amount_quantity = quantity_round p $ amount_quantity a * amount_quantity b
 120                  , amount_style = s
 121                  , amount_unit = u
 122                  }
 123                 where (s, u)
 124                         | amount_unit a == "" =
 125                                 if amount_unit b == ""
 126                                 then (Style.union (amount_style a) (amount_style b), "")
 127                                 else (amount_style b, amount_unit b)
 128                         | amount_unit b == "" = (amount_style a, amount_unit a)
 129                         | otherwise = error "(*) by non-scalar amount_unit"
 130 -}
 131
 132 sign :: Amount -> Ordering
 133 sign a =
 134         case amount_quantity a of
 135          0         -> EQ
 136          q | q < 0 -> LT
 137          _         -> GT
 138
 139 -- ** Constructors
 140
 141 amount :: Amount
 142 amount =
 143         Amount
 144          { amount_quantity = Quantity.quantity_zero
 145          , amount_unit     = ""
 146          }
 147
 148
 149 -- ** Tests
 150
 151 -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero.
 152 --
 153 --  NOTE: the 'Amount'’s 'amount_quantity' MUST have been rounded
 154 --        at 'Amount'’s 'amount_style'’s 'Style.precision'.
 155 null :: Amount -> Bool
 156 null = Quantity.quantity_null . amount_quantity
 157
 158 {-
 159 -- * Type 'Amount_by_Unit' mapping
 160
 161 type Amount_by_Unit
 162  = Map Unit Amount
 163 type By_Unit = Amount_by_Unit
 164
 165 -- | 'Amount_by_Unit'’s is a partially valid 'Num' instance.
 166 --
 167 --   * (*) operator is not defined.
 168 instance Num Amount_by_Unit where
 169         abs         = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=abs    q})
 170         fromInteger = Data.Map.singleton "" . fromInteger
 171         negate      = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=negate q})
 172         signum      = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=signum q})
 173         (+)         = Data.Map.unionWith (+)
 174         (*)         = error "(*) not-supported"
 175
 176 type Signs = (Int, Int)
 177
 178 signs :: Amount_by_Unit -> Signs
 179 signs = Data.Map.foldl'
 180  (\(nega, plus) amt ->
 181         case flip compare 0 $ amount_quantity amt of
 182          LT -> (nega - 1, plus)
 183          EQ -> (nega, plus)
 184          GT -> (nega, plus + 1))
 185  (0, 0)
 186
 187 -- ** Constructors
 188
 189 nil_By_Unit :: Amount_by_Unit
 190 nil_By_Unit =
 191         Data.Map.empty
 192
 193 -- ** Tests
 194
 195 -- | Return 'True' if and only if all 'Amount's satisfy 'null'.
 196 nulls :: Amount_by_Unit -> Bool
 197 nulls = Data.Foldable.all null
 198
 199 -- | Return a tuple associating the given 'Amount' with its 'Unit'.
 200 assoc_by_unit :: Amount -> (Unit, Amount)
 201 assoc_by_unit amt = (amount_unit amt, amt)
 202
 203 -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'.
 204 from_List :: [Amount] -> Amount_by_Unit
 205 from_List amounts =
 206         Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last.
 207         Data.List.map assoc_by_unit amounts
 208
 209 -}