{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.LCC.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, flip)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..), maybe)
import           Data.Monoid (Monoid(..))
import qualified Data.MonoTraversable as MT
import           Data.Ord (Ord(..))
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 as H

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

type instance H.Unit H.:@ Amount = Unit
instance H.GetI H.Unit Amount where
	getI _ = amount_unit
instance H.SetI H.Unit Amount where
	setI _ amount_unit a = a{amount_unit}

type instance H.Quantity H.:@ Amount = Quantity
instance H.GetI H.Quantity Amount where
	getI _ = amount_quantity
instance H.SetI H.Quantity Amount where
	setI _ amount_quantity a = a{amount_quantity}

instance H.Zero Amount where
	quantity_zero = Amount H.unit_empty H.quantity_zero
	quantity_null = H.quantity_null . amount_quantity
	--  NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
	--        at 'Amount'’s 'amount_amount_style'’s 'amount_style_precision'.
	quantity_sign = H.quantity_sign . amount_quantity

amount :: Amount
amount =
	Amount
	 { amount_quantity = H.quantity_zero
	 , amount_unit     = ""
	 }

amount_amount_style :: Amount_Styles -> Amount -> Amount_Style
amount_amount_style styles = amount_style_find styles . amount_unit

-- * Type 'Quantity'
type Quantity = Decimal

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

-- | <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 (flip 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 (flip 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 'Amounts'
newtype Amounts = Amounts (Map Unit Quantity)
 deriving (Data, Eq, NFData, Show, Typeable
 , H.Zero, H.Addable, H.Negable, H.Subable)
instance Monoid Amounts where
	mempty = Amounts mempty
	mappend (Amounts x) (Amounts y) =
		Amounts (Map.unionWith (flip H.quantity_add) x y)

type instance MT.Element Amounts = Amount
instance H.Amounts Amounts

instance H.Get (H.Balance_Amounts Unit Quantity) Amounts where
	get (Amounts a) = a