{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hcompta.Model.Amount where import Data.Data import qualified Data.List import qualified Data.Map.Strict as Data.Map import qualified Data.Foldable import Data.Typeable () import qualified Hcompta.Calc.Balance as Calc.Balance import qualified Hcompta.Model.Amount.Quantity as Quantity import qualified Hcompta.Model.Amount.Style as Style import qualified Hcompta.Model.Amount.Unit as Unit -- * Type synonyms to submodules type Quantity = Quantity.Quantity type Style = Style.Style type Unit = Unit.Unit -- * The 'Amount' type data Amount = Amount { quantity :: Quantity , style :: Style , unit :: Unit } deriving (Data, Read, Show, Typeable) instance Eq Amount where (==) Amount{quantity=q0, unit=u0} Amount{quantity=q1, unit=u1} = case compare u0 u1 of LT -> False GT -> False EQ -> (==) q0 q1 -- NOTE: MUST already be rounded to Style.precision instance Ord Amount where compare Amount{quantity=q0, unit=u0} Amount{quantity=q1, unit=u1} = case compare u0 u1 of LT -> LT GT -> GT EQ -> compare q0 q1 -- NOTE: MUST already be rounded to Style.precision instance Calc.Balance.Amount Amount where amount_is_zero = is_zero -- | An 'Amount' is a partially valid 'Num' instance: -- -- * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint). -- * (*) operator requires at least one operand with an empty 'Unit' ('scalar'). instance Num Amount where abs a@Amount{quantity=q} = a{quantity=abs q} fromInteger = scalar . fromInteger negate a@Amount{quantity=q} = a{quantity=negate q} signum a@Amount{quantity=q} = a{quantity=signum q} (+) a b = let s@(Style.Style{Style.precision=p}) = Style.union (style a) (style b) in a{ quantity = Quantity.round p $ quantity a + quantity b , style = s , unit = if unit a == unit b then unit a else error "(+) on non-homogeneous units" } (*) a b = let Style.Style{Style.precision=p} = s in a{ quantity = Quantity.round p $ quantity a * quantity b , style = s , unit = u } where (s, u) = if unit a == "" then if unit b == "" then (Style.union (style a) (style b), "") else (style b, unit b) else if unit b == "" then (style a, unit a) else error "(*) by non-scalar unit" -- ** Constructors nil :: Amount nil = Amount { quantity = Quantity.nil , style = Style.nil , unit = "" } -- *** From 'Quantity' -- | Return an 'Amount' with 'unit' = Unit.'Unit.nil'. scalar :: Quantity -> Amount scalar q = Amount { quantity = q , style = Style.Style { Style.fractioning = Just '.' , Style.grouping_fractional = Just $ Style.Grouping ',' [3] , Style.grouping_integral = Just $ Style.Grouping ',' [3] , Style.precision = maxBound , Style.unit_side = Just Style.Side_Right , Style.unit_spaced = Just False } , unit = "" } -- | unit of currency. chf :: Quantity -> Amount chf q = Amount { quantity = q , style = Style.Style { Style.fractioning = Just ',' , Style.grouping_fractional = Just $ Style.Grouping '.' [3] , Style.grouping_integral = Just $ Style.Grouping '.' [3] , Style.precision = 2 , Style.unit_side = Just Style.Side_Right , Style.unit_spaced = Just False } , unit = "CHF" } -- | unit of currency. cny :: Quantity -> Amount cny q = Amount { quantity = q , style = Style.Style { Style.fractioning = Just ',' , Style.grouping_fractional = Just $ Style.Grouping '.' [3] , Style.grouping_integral = Just $ Style.Grouping '.' [3] , Style.precision = 2 , Style.unit_side = Just Style.Side_Right , Style.unit_spaced = Just False } , unit = "Ұ" } -- | unit of currency. eur :: Quantity -> Amount eur q = Amount { quantity = q , style = Style.Style { Style.fractioning = Just ',' , Style.grouping_fractional = Just $ Style.Grouping '.' [3] , Style.grouping_integral = Just $ Style.Grouping '.' [3] , Style.precision = 2 , Style.unit_side = Just Style.Side_Right , Style.unit_spaced = Just False } , unit = "€" } -- | unit of currency. gbp :: Quantity -> Amount gbp q = Amount { quantity = q , style = Style.Style { Style.fractioning = Just '.' , Style.grouping_fractional = Just $ Style.Grouping ',' [3] , Style.grouping_integral = Just $ Style.Grouping ',' [3] , Style.precision = 2 , Style.unit_side = Just Style.Side_Left , Style.unit_spaced = Just False } , unit = "£" } -- | unit of currency. inr :: Quantity -> Amount inr q = Amount { quantity = q , style = Style.Style { Style.fractioning = Just ',' , Style.grouping_fractional = Just $ Style.Grouping '.' [3] , Style.grouping_integral = Just $ Style.Grouping '.' [3] , Style.precision = 2 , Style.unit_side = Just Style.Side_Right , Style.unit_spaced = Just False } , unit = "₹" } -- | unit of currency. jpy :: Quantity -> Amount jpy q = Amount { quantity = q , style = Style.Style { Style.fractioning = Just '.' , Style.grouping_fractional = Just $ Style.Grouping ',' [3] , Style.grouping_integral = Just $ Style.Grouping ',' [3] , Style.precision = 2 , Style.unit_side = Just Style.Side_Left , Style.unit_spaced = Just False } , unit = "¥" } -- | unit of currency. -- -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter, -- because GHC currently chokes on ₽ (U+20BD), -- which is the recently (2014/02) assigned Unicode code-point -- for this currency. rub :: Quantity -> Amount rub q = Amount { quantity = q , style = Style.Style { Style.fractioning = Just '.' , Style.grouping_fractional = Just $ Style.Grouping ',' [3] , Style.grouping_integral = Just $ Style.Grouping ',' [3] , Style.precision = 2 , Style.unit_side = Just Style.Side_Left , Style.unit_spaced = Just False } , unit = "Ꝑ" } -- | unit of currency. usd :: Quantity -> Amount usd q = Amount { quantity = q , style = Style.Style { Style.fractioning = Just '.' , Style.grouping_fractional = Just $ Style.Grouping ',' [3] , Style.grouping_integral = Just $ Style.Grouping ',' [3] , Style.precision = 2 , Style.unit_side = Just Style.Side_Left , Style.unit_spaced = Just False } , unit = "$" } -- ** Tests -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero. -- -- NOTE: the 'Amount'’s 'quantity' MUST be have been rounded at 'Amount'’s 'style'’s 'Style.precision'. is_zero :: Amount -> Bool is_zero = Quantity.is_zero . quantity -- * The 'By_Unit' mapping type By_Unit = Data.Map.Map Unit Amount -- | 'By_Unit'’s is a partially valid 'Num' instance. -- -- * (*) operator is not defined. instance Num By_Unit where abs = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=abs q}) fromInteger = Data.Map.singleton "" . fromInteger negate = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=negate q}) signum = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=signum q}) (+) = Data.Map.unionWith (+) (*) = error "(*) not-supported" type Signs = (Int, Int) signs :: By_Unit -> Signs signs = Data.Map.foldl (\(nega, plus) amt -> case flip compare 0 $ quantity amt of LT -> (nega - 1, plus) EQ -> (nega, plus) GT -> (nega, plus + 1)) (0, 0) -- ** Constructors nil_By_Unit :: By_Unit nil_By_Unit = Data.Map.empty -- ** Tests -- | Return 'True' if and only if all 'Amount's satisfy 'is_zero'. are_zero :: By_Unit -> Bool are_zero = Data.Foldable.all is_zero -- | Return a tuple associating the given 'Amount' with its 'Unit'. assoc_by_unit :: Amount -> (Unit, Amount) assoc_by_unit amount = (unit amount, amount) -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'. from_List :: [Amount] -> By_Unit from_List amounts = Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last. Data.List.map assoc_by_unit amounts