{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hcompta.JCC.Amount where import Control.DeepSeq import Data.Bool import Data.Char (Char) import Data.Data import Data.Decimal (Decimal, roundTo) 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 H import qualified Hcompta.Quantity as H import qualified Hcompta.Unit as H -- import qualified Hcompta.Polarize as Polarize -- import qualified Hcompta.Quantity as Quantity -- * Type 'Quantity' type Quantity = Decimal -- ** 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 H.Unit Unit where unit_empty = Unit "" unit_text (Unit t) = t instance NFData Unit where rnf (Unit t) = rnf t -- ** Example 'Unit's -- | 'H.unit_empty'. unit_scalar :: Unit unit_scalar = H.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, Eq, Show, Typeable) instance NFData Amount where rnf (Amount q u) = rnf q `seq` rnf u instance H.Amount Amount where type Amount_Quantity Amount = Quantity type Amount_Unit Amount = Unit amount_quantity = amount_quantity amount_unit = amount_unit instance H.Zero Amount where quantity_zero = Amount H.unit_empty H.quantity_zero quantity_null = (==) H.quantity_zero . amount_quantity amount :: Amount amount = Amount { amount_quantity = H.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 = H.quantity_null . amount_quantity