{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hcompta.Format.JCC.Amount where import Control.DeepSeq import Data.Bool import Data.Char (Char) import Data.Data import Data.Decimal import Data.Eq (Eq(..)) import Data.Function (($), (.), const) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (Maybe(..), maybe) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..), Ordering(..)) import Data.Text (Text) import Data.String (IsString) import Data.Typeable () import Data.Word (Word8) import Prelude (Int, seq) import Text.Show (Show(..)) import qualified Hcompta.Amount as Amount import qualified Hcompta.Filter as Filter import qualified Hcompta.Filter.Amount as Filter.Amount import qualified Hcompta.Polarize as Polarize import qualified Hcompta.Quantity as Quantity import qualified Hcompta.Unit as Unit -- * Type 'Quantity' type Quantity = Filter.Amount.Quantity -- ** Operators quantity_round :: Word8 -> Quantity -> Quantity quantity_round = Data.Decimal.roundTo -- * Type 'Unit' newtype Unit = Unit Text deriving (Data, Eq, IsString, Ord, Show, Typeable) instance Unit.Unit Unit where unit_empty = Unit "" unit_text (Unit t) = t instance NFData Unit where rnf (Unit t) = rnf t -- ** Example 'Unit's -- | 'Unit.unit_empty'. unit_scalar :: Unit unit_scalar = Unit.unit_empty -- | unit of currency. unit_chf :: Unit unit_chf = Unit "CHF" -- | unit of currency. unit_cny :: Unit unit_cny = Unit "Ұ" -- | unit of currency. unit_eur :: Unit unit_eur = Unit "€" -- | unit of currency. unit_gbp :: Unit unit_gbp = Unit "£" -- | unit of currency. unit_inr :: Unit unit_inr = Unit "₹" -- | unit of currency. unit_jpy :: Unit unit_jpy = 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. unit_rub :: Unit unit_rub = Unit "Ꝑ" -- | unit of currency. unit_usd :: Unit unit_usd = Unit "$" -- * Type 'Amount_Style' data Amount_Style = Amount_Style { amount_style_fractioning :: Maybe Amount_Style_Fractioning , amount_style_grouping_integral :: Maybe Amount_Style_Grouping , amount_style_grouping_fractional :: Maybe Amount_Style_Grouping -- TODO: , amount_style_sign_plus :: Maybe Bool , amount_style_unit_side :: Maybe Amount_Style_Side , amount_style_unit_spaced :: Maybe Amount_Style_Spacing } deriving (Data, Eq, Ord, Show, Typeable) instance NFData Amount_Style where rnf (Amount_Style f gi gf ui up) = rnf f `seq` rnf gi `seq` rnf gf `seq` rnf ui `seq` rnf up instance Monoid Amount_Style where mempty = amount_style mappend = amount_style_union amount_style :: Amount_Style amount_style = Amount_Style { amount_style_fractioning = Nothing , amount_style_grouping_integral = Nothing , amount_style_grouping_fractional = Nothing , amount_style_unit_side = Nothing , amount_style_unit_spaced = Nothing } amount_style_union :: Amount_Style -> Amount_Style -> Amount_Style amount_style_union sty@Amount_Style { amount_style_fractioning=f , amount_style_grouping_integral=gi , amount_style_grouping_fractional=gf , amount_style_unit_side=side , amount_style_unit_spaced=spaced } sty'@Amount_Style { amount_style_fractioning=f' , amount_style_grouping_integral=gi' , amount_style_grouping_fractional=gf' , amount_style_unit_side=side' , amount_style_unit_spaced=spaced' } = if sty == sty' then sty' else Amount_Style { amount_style_fractioning = maybe f' (const f) f , amount_style_grouping_integral = maybe gi' (const gi) gi , amount_style_grouping_fractional = maybe gf' (const gf) gf , amount_style_unit_side = maybe side' (const side) side , amount_style_unit_spaced = maybe spaced' (const spaced) spaced } -- ** Type 'Amount_Style_Fractioning' type Amount_Style_Fractioning = Char -- ** Type 'Amount_Style_Grouping' data Amount_Style_Grouping = Amount_Style_Grouping Char [Int] deriving (Data, Eq, Ord, Show, Typeable) instance NFData Amount_Style_Grouping where rnf (Amount_Style_Grouping s d) = rnf s `seq` rnf d -- ** Type 'Amount_Style_Precision' type Amount_Style_Precision = Word8 -- ** Type 'Amount_Style_Spacing' type Amount_Style_Spacing = Bool -- ** Type 'Amount_Style_Side' data Amount_Style_Side = Amount_Style_Side_Left | Amount_Style_Side_Right deriving (Data, Eq, Ord, Show, Typeable) instance NFData Amount_Style_Side where rnf Amount_Style_Side_Left = () rnf Amount_Style_Side_Right = () -- ** Type 'Amount_Styles' newtype Amount_Styles = Amount_Styles (Map Unit Amount_Style) deriving (Data, Eq, NFData, Show, Typeable) instance Monoid Amount_Styles where mempty = Amount_Styles mempty mappend (Amount_Styles x) (Amount_Styles y) = Amount_Styles (Map.unionWith mappend x y) -- ** Operators amount_style_cons :: (Unit, Amount_Style) -> Amount_Styles -> Amount_Styles amount_style_cons (u, s) (Amount_Styles ss) = Amount_Styles $ Map.insertWith mappend u s ss amount_style_find :: Amount_Styles -> Unit -> Amount_Style amount_style_find (Amount_Styles s) u = Map.findWithDefault mempty u s -- *** Example 'Amount_Styles' amount_styles :: Amount_Styles amount_styles = Amount_Styles $ Map.fromList [ (unit_scalar,) Amount_Style { amount_style_fractioning = Just '.' , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3] , amount_style_grouping_integral = Just $ Amount_Style_Grouping ',' [3] , amount_style_unit_side = Just Amount_Style_Side_Right , amount_style_unit_spaced = Just False } , (unit_chf,) Amount_Style { amount_style_fractioning = Just ',' , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3] , amount_style_grouping_integral = Just $ Amount_Style_Grouping '.' [3] , amount_style_unit_side = Just Amount_Style_Side_Right , amount_style_unit_spaced = Just False } , (unit_cny,) Amount_Style { amount_style_fractioning = Just ',' , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3] , amount_style_grouping_integral = Just $ Amount_Style_Grouping '.' [3] , amount_style_unit_side = Just Amount_Style_Side_Right , amount_style_unit_spaced = Just False } , (unit_eur,) Amount_Style { amount_style_fractioning = Just ',' , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3] , amount_style_grouping_integral = Just $ Amount_Style_Grouping '.' [3] , amount_style_unit_side = Just Amount_Style_Side_Right , amount_style_unit_spaced = Just False } , (unit_gbp,) Amount_Style { amount_style_fractioning = Just '.' , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3] , amount_style_grouping_integral = Just $ Amount_Style_Grouping ',' [3] , amount_style_unit_side = Just Amount_Style_Side_Left , amount_style_unit_spaced = Just False } , (unit_inr,) Amount_Style { amount_style_fractioning = Just ',' , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3] , amount_style_grouping_integral = Just $ Amount_Style_Grouping '.' [3] , amount_style_unit_side = Just Amount_Style_Side_Right , amount_style_unit_spaced = Just False } , (unit_jpy,) Amount_Style { amount_style_fractioning = Just '.' , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3] , amount_style_grouping_integral = Just $ Amount_Style_Grouping ',' [3] , amount_style_unit_side = Just Amount_Style_Side_Left , amount_style_unit_spaced = Just False } , (unit_rub,) Amount_Style { amount_style_fractioning = Just '.' , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3] , amount_style_grouping_integral = Just $ Amount_Style_Grouping ',' [3] , amount_style_unit_side = Just Amount_Style_Side_Left , amount_style_unit_spaced = Just False } , (unit_usd,) Amount_Style { amount_style_fractioning = Just '.' , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3] , amount_style_grouping_integral = Just $ Amount_Style_Grouping ',' [3] , amount_style_unit_side = Just Amount_Style_Side_Left , amount_style_unit_spaced = Just False } ] -- ** Type 'Amount_Styled' type Amount_Styled t = (Amount_Style, t) amount_styled :: Amount_Styles -> Amount -> Amount_Styled Amount amount_styled styles amt = (amount_amount_style styles amt, amt) -- * Type 'Amount' data Amount = Amount { amount_unit :: !Unit , amount_quantity :: !Quantity } deriving (Data, Show, Typeable) instance Amount.Amount Amount where type Amount_Quantity Amount = Quantity type Amount_Unit Amount = Unit amount_quantity = amount_quantity amount_unit = amount_unit instance Filter.Amount Amount where type Amount_Quantity Amount = Quantity type Amount_Unit Amount = Unit amount_quantity = Polarize.polarize . amount_quantity amount_unit = amount_unit instance NFData Amount where rnf (Amount q u) = rnf q `seq` rnf u instance Quantity.Zero Amount where quantity_zero = Amount Unit.unit_empty Quantity.quantity_zero quantity_null = (==) Quantity.quantity_zero . amount_quantity amount :: Amount amount = Amount { amount_quantity = Quantity.quantity_zero , amount_unit = "" } -- ** Extractors amount_amount_style :: Amount_Styles -> Amount -> Amount_Style amount_amount_style styles = amount_style_find styles . amount_unit amount_sign :: Amount -> Ordering amount_sign a = case amount_quantity a of 0 -> EQ q | q < 0 -> LT _ -> GT -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero. -- -- NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded -- at 'Amount'’s 'amount_amount_style'’s 'amount_style_precision'. amount_null :: Amount -> Bool amount_null = Quantity.quantity_null . amount_quantity {- instance Eq Amount where (==) Amount{amount_quantity=q0, amount_unit=u0} Amount{amount_quantity=q1, amount_unit=u1} = case compare u0 u1 of LT -> False GT -> False EQ -> (==) q0 q1 -- NOTE: MUST already be rounded to amount_style_precision instance Ord Amount where compare Amount{amount_quantity=q0, amount_unit=u0} Amount{amount_quantity=q1, amount_unit=u1} = case compare u0 u1 of LT -> LT GT -> GT EQ -> compare q0 q1 -- NOTE: MUST already be rounded to amount_style_precision -} {- instance GL.Amount Amount where type Amount_Unit Amount = Unit amount_add = (+) instance GL.Amount (Map Unit Amount) where type Amount_Unit (Map Unit Amount) = Unit amount_add = Data.Map.unionWith (+) -} {- -- | 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{amount_quantity=q} = a{amount_quantity=abs q} fromInteger = scalar . fromInteger negate a@Amount{amount_quantity=q} = a{amount_quantity=negate q} signum a@Amount{amount_quantity=q} = a{amount_quantity=signum q} (+) a b = let s@(Style.Style{Style.precision=p}) = Style.union (amount_style a) (amount_style b) in a{ amount_quantity = quantity_round p $ amount_quantity a + amount_quantity b , amount_style = s , amount_unit = if amount_unit a == amount_unit b then amount_unit a else error "(+) on non-homogeneous units" } (*) a b = let Style.Style{Style.precision=p} = s in a{ amount_quantity = quantity_round p $ amount_quantity a * amount_quantity b , amount_style = s , amount_unit = u } where (s, u) | amount_unit a == "" = if amount_unit b == "" then (Style.union (amount_style a) (amount_style b), "") else (amount_style b, amount_unit b) | amount_unit b == "" = (amount_style a, amount_unit a) | otherwise = error "(*) by non-scalar amount_unit" -} {- -- * Type 'Amount_by_Unit' mapping type Amount_by_Unit = Map Unit Amount type By_Unit = Amount_by_Unit -- | 'Amount_by_Unit'’s is a partially valid 'Num' instance. -- -- * (*) operator is not defined. instance Num Amount_by_Unit where abs = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=abs q}) fromInteger = Data.Map.singleton "" . fromInteger negate = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=negate q}) signum = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=signum q}) (+) = Data.Map.unionWith (+) (*) = error "(*) not-supported" type Signs = (Int, Int) signs :: Amount_by_Unit -> Signs signs = Data.Map.foldl' (\(nega, plus) amt -> case flip compare 0 $ amount_quantity amt of LT -> (nega - 1, plus) EQ -> (nega, plus) GT -> (nega, plus + 1)) (0, 0) -- ** Constructors nil_By_Unit :: Amount_by_Unit nil_By_Unit = Data.Map.empty -- ** Tests -- | Return 'True' if and only if all 'Amount's satisfy 'null'. amount_nulls :: Amount_by_Unit -> Bool amount_nulls = all amount_null -- | Return a tuple associating the given 'Amount' with its 'Unit'. assoc_by_unit :: Amount -> (Unit, Amount) assoc_by_unit amt = (amount_unit amt, amt) -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'. from_List :: [Amount] -> 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 -}