{-# 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.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, Eq, Ord, Read, Show, Typeable)

-- | 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 = a{ quantity=quantity a + quantity b
	           , style=Style.union (style a) (style b)
	           , unit=if unit a == unit b then unit a else error "(+) on non-homogeneous units"
	           }
	(*) a b = a{ quantity=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 = ""
	 }

-- | <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 at 'Style'’s precision.
is_zero :: Amount -> Bool
is_zero amount =
	Quantity.is_zero
	 (Style.precision $ style amount) $
	quantity amount

-- * 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"

-- ** Constructors

nil_By_Unit :: By_Unit
nil_By_Unit =
	Data.Map.empty

-- ** Tests

-- | Return 'True' if and only if all 'Amount's are zero at their 'Style'’s precision.
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