{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.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.Balance as Balance
-import qualified Hcompta.Amount.Quantity as Quantity
-import qualified Hcompta.Amount.Style as Style
-import qualified Hcompta.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, 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 Balance.Amount Amount where
- type Amount_Unit Amount = Unit
- amount_null = (==) Quantity.zero . quantity
- amount_add = (+)
- amount_negate = negate
- amount_positive a =
- case compare (quantity a) Quantity.zero of
- LT -> Nothing
- EQ -> Nothing
- _ -> Just a
- amount_negative a =
- case compare (quantity a) Quantity.zero of
- GT -> Nothing
- EQ -> Nothing
- _ -> Just a
-
--- | 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.zero
- , 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 = ""
- }
-
--- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> 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"
- }
--- | <https://en.wikipedia.org/wiki/Yuan Yuan> 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 = "Ұ"
- }
--- | <https://en.wikipedia.org/wiki/Euro Euro> 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 = "€"
- }
--- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> 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 = "£"
- }
--- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> 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 = "₹"
- }
--- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> 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 = "¥"
- }
--- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> 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 = "Ꝑ"
- }
--- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> 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 'Amount_by_Unit' mapping
-
-type Amount_by_Unit
- = Data.Map.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{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 :: Amount_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 :: Amount_by_Unit
-nil_By_Unit =
- Data.Map.empty
-
--- ** Tests
-
--- | Return 'True' if and only if all 'Amount's satisfy 'is_zero'.
-are_zero :: Amount_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] -> 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
+import Data.Data (Data)
+import Data.Eq (Eq(..))
+import Data.Functor (Functor(..))
+import Data.Ord (Ord(..), Ordering)
+import Data.Tuple (fst, snd)
+import Prelude (($), (.))
+
+import Hcompta.Polarize
+import Hcompta.Quantity
+import Hcompta.Unit (Unit(..))
+
+-- * Class 'Amount'
+
+class
+ ( Data a
+ , Eq (Amount_Quantity a)
+ , Zero (Amount_Quantity a)
+ , Unit (Amount_Unit a)
+ ) => Amount a where
+ type Amount_Quantity a
+ type Amount_Unit a
+ amount_quantity :: a -> Amount_Quantity a
+ amount_unit :: a -> Amount_Unit a
+instance
+ ( Zero quantity
+ , Eq quantity
+ , Unit unit
+ ) => Amount (unit, quantity) where
+ type Amount_Quantity (unit, quantity) = quantity
+ type Amount_Unit (unit, quantity) = unit
+ amount_quantity = snd
+ amount_unit = fst
+instance
+ ( Polarizable quantity
+ ) => Polarizable (unit, quantity) where
+ polarizable_positive (u, q) = fmap (u,) $ polarizable_positive q
+ polarizable_negative (u, q) = fmap (u,) $ polarizable_negative q
+
+amount_sign ::
+ ( Amount a
+ , Ord (Amount_Quantity a)
+ ) => a -> Ordering
+amount_sign =
+ quantity_sign . amount_quantity
sourcephile / git / comptalang.git / blobdiff