{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.Amount where

import           Control.DeepSeq
import           Data.Data
import qualified Data.List
import qualified Data.Map.Strict as Data.Map
import           Data.Map.Strict (Map)
import qualified Data.Foldable
import           Data.Typeable ()

import qualified Hcompta.Balance as Balance
import qualified Hcompta.GL as GL
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 NFData (Amount) where
	rnf (Amount q s u) = rnf q `seq` rnf s `seq` rnf u

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

instance Balance.Amount (Map Unit Amount) where
	type Amount_Unit (Map Unit Amount) = Unit
	amount_null = Data.Foldable.all ((==) Quantity.zero . quantity)
	amount_add = Data.Map.unionWith (+)
	amount_negate = Data.Map.map negate

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{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)
			| unit a == "" =
				if unit b == ""
				then (Style.union (style a) (style b), "")
				else (style b, unit b)
			| unit b == "" = (style a, unit a)
			| otherwise = error "(*) by non-scalar unit"

sign :: Amount -> Ordering
sign a =
	case quantity a of
	 0 -> EQ
	 q | q < 0 -> LT
	 _ -> GT

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

-- * Type 'Sum'

-- ** Class 'Sumable'
class
 ( Data (Sumable_Unit a)
 , Data a
 , Eq a
 , Ord  (Sumable_Unit a)
 , Show (Sumable_Unit a)
 , Show a
 , Typeable (Sumable_Unit a)
 , Typeable a
 ) => Sumable a where
	type Sumable_Unit a
	-- sumable_add      :: a -> a -> a
	sumable_positive :: a -> Maybe a
	sumable_negative :: a -> Maybe a

instance Sumable Amount where
	type Sumable_Unit Amount = Unit
	-- sumable_add = (+)
	sumable_positive a =
		case compare (quantity a) Quantity.zero of
		 LT -> Nothing
		 EQ -> Nothing
		 _  -> Just a
	sumable_negative a =
		case compare (quantity a) Quantity.zero of
		 GT -> Nothing
		 EQ -> Nothing
		 _  -> Just a

instance Sumable (Map Unit Amount) where
	type Sumable_Unit (Map Unit Amount) = Unit
	-- sumable_add = (+)
	sumable_positive a =
		let r = Data.Map.mapMaybe sumable_positive a in
		if Data.Map.null r
		then Nothing
		else Just r
	sumable_negative a =
		let r = Data.Map.mapMaybe sumable_negative a in
		if Data.Map.null r
		then Nothing
		else Just r

instance Sumable amount => Sumable (Sum amount) where
	type Sumable_Unit (Sum amount) = Sumable_Unit amount
	sumable_negative amt =
		case amt of
		 Sum_Negative _ -> Just $ amt
		 Sum_Positive _ -> Nothing
		 Sum_Both n _   -> Just $ Sum_Negative n
	sumable_positive amt =
		case amt of
		 Sum_Negative _ -> Nothing
		 Sum_Positive _ -> Just $ amt
		 Sum_Both _ p   -> Just $ Sum_Positive p

-- | Sum separately keeping track of negative and positive 'amount's.
data Sum amount
 =   Sum_Negative !amount
 |   Sum_Positive !amount
 |   Sum_Both     !amount !amount
 deriving (Data, Eq, Show, Typeable)
instance NFData amount => NFData (Sum amount) where
	rnf (Sum_Negative a) = rnf a
	rnf (Sum_Positive a) = rnf a
	rnf (Sum_Both a0 a1) = rnf a0 `seq` rnf a1

instance Functor Sum where
	fmap f (Sum_Negative a) = Sum_Negative (f a)
	fmap f (Sum_Positive a) = Sum_Positive (f a)
	fmap f (Sum_Both a0 a1) = Sum_Both (f a0) (f a1)

instance Balance.Amount a
 => Balance.Amount (Sum a) where
	type Amount_Unit (Sum a) = Balance.Amount_Unit a
	amount_null amt =
		case amt of
		 Sum_Negative n -> Balance.amount_null n
		 Sum_Positive p -> Balance.amount_null p
		 Sum_Both n p   -> Balance.amount_null (Balance.amount_add n p)
	amount_add a0 a1 =
		case (a0, a1) of
		 (Sum_Negative n0, Sum_Negative n1) -> Sum_Negative (Balance.amount_add n0 n1)
		 (Sum_Negative n , Sum_Positive p)  -> Sum_Both n p
		 (Sum_Negative n0, Sum_Both n1 p)   -> Sum_Both (Balance.amount_add n0 n1) p
		
		 (Sum_Positive p , Sum_Negative n)  -> Sum_Both n p
		 (Sum_Positive p0, Sum_Positive p1) -> Sum_Positive (Balance.amount_add p0 p1)
		 (Sum_Positive p , Sum_Both n1 p1)  -> Sum_Both n1 (Balance.amount_add p p1)
		
		 (Sum_Both n0 p0, Sum_Negative n)  -> Sum_Both (Balance.amount_add n0 n) p0
		 (Sum_Both n0 p0, Sum_Positive p1) -> Sum_Both n0 (Balance.amount_add p0 p1)
		 (Sum_Both n0 p0, Sum_Both n1 p1)  -> Sum_Both (Balance.amount_add n0 n1) (Balance.amount_add p0 p1)
	amount_negate amt =
		case amt of
		 Sum_Negative n -> Sum_Positive $ Balance.amount_negate n
		 Sum_Positive p -> Sum_Negative $ Balance.amount_negate p
		 Sum_Both n p   -> Sum_Both (Balance.amount_negate p) (Balance.amount_negate n)

instance GL.Amount (Sum (Map Unit Amount)) where
	type Amount_Unit (Sum (Map Unit Amount)) = Unit
	amount_add a0 a1 =
		case (a0, a1) of
		 (Sum_Negative n0, Sum_Negative n1) -> Sum_Negative (GL.amount_add n0 n1)
		 (Sum_Negative n , Sum_Positive p)  -> Sum_Both n p
		 (Sum_Negative n0, Sum_Both n1 p)   -> Sum_Both (GL.amount_add n0 n1) p
		
		 (Sum_Positive p , Sum_Negative n)  -> Sum_Both n p
		 (Sum_Positive p0, Sum_Positive p1) -> Sum_Positive (GL.amount_add p0 p1)
		 (Sum_Positive p , Sum_Both n1 p1)  -> Sum_Both n1 (GL.amount_add p p1)
		
		 (Sum_Both n0 p0, Sum_Negative n)  -> Sum_Both (GL.amount_add n0 n) p0
		 (Sum_Both n0 p0, Sum_Positive p1) -> Sum_Both n0 (GL.amount_add p0 p1)
		 (Sum_Both n0 p0, Sum_Both n1 p1)  -> Sum_Both (GL.amount_add n0 n1) (GL.amount_add p0 p1)

sum
 :: Sumable amount
 => amount -> Sum amount
sum amt =
	case ( sumable_negative amt
	     , sumable_positive amt ) of
	 (Just n, Nothing)  -> Sum_Negative n
	 (Nothing, Just p)  -> Sum_Positive p
	 (Just n, Just p)   -> Sum_Both n p
	 (Nothing, Nothing) -> Sum_Both amt amt

sum_negative
 :: Sum amount -> Maybe amount
sum_negative amt =
	case amt of
	 Sum_Negative n -> Just n
	 Sum_Positive _ -> Nothing
	 Sum_Both n _   -> Just n

sum_positive
 :: Sum amount -> Maybe amount
sum_positive amt =
	case amt of
	 Sum_Negative _ -> Nothing
	 Sum_Positive p -> Just p
	 Sum_Both _ p   -> Just p

sum_balance
 :: GL.Amount amount
 => Sum amount -> amount
sum_balance amt =
	case amt of
	 Sum_Negative n -> n
	 Sum_Positive p -> p
	 Sum_Both n p   -> GL.amount_add n p