{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.Format.Ledger.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

-- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
unit_chf :: Unit
unit_chf = Unit "CHF"

-- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
unit_cny :: Unit
unit_cny = Unit "Ұ"

-- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
unit_eur :: Unit
unit_eur = Unit "€"

-- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
unit_gbp :: Unit
unit_gbp = Unit "£"

-- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
unit_inr :: Unit
unit_inr = Unit "₹"

-- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
unit_jpy :: Unit
unit_jpy = 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.
unit_rub :: Unit
unit_rub = Unit "Ꝑ"

-- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> 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

-}