{-# 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 Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Strict.Maybe
import Data.String (IsString)
import Data.Text (Text)
import Data.Typeable ()
import Data.Word (Word8)
import Prelude (Int, seq)
import Text.Show (Show(..))
import qualified Data.Map.Strict as Map
import qualified Data.MonoTraversable as MT
import qualified Data.Strict as S

import qualified Hcompta as H

-- * Type 'Amount'
data Amount
 =   Amount
 {   amount_unit     :: !Unit
 ,   amount_quantity :: !Quantity
 } deriving (Data, Eq, Ord, 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_style'’s 'style_amount_precision'.
	quantity_sign = H.quantity_sign . amount_quantity

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

amount_style :: Style_Amounts -> Amount -> Style_Amount
amount_style styles = style_amount_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 'Style_Amount'
data Style_Amount
 =   Style_Amount
 { style_amount_fractioning         :: !(S.Maybe Style_Amount_Fractioning)
 , style_amount_grouping_integral   :: !(S.Maybe Style_Amount_Grouping)
 , style_amount_grouping_fractional :: !(S.Maybe Style_Amount_Grouping)
 , style_amount_unit_side           :: !(S.Maybe LR)
 , style_amount_unit_spaced         :: !(S.Maybe Style_Amount_Spacing)
 -- TODO: , style_amount_sign_plus     :: S.Maybe Bool
 } deriving (Data, Eq, Ord, Show, Typeable)
instance NFData Style_Amount where
	rnf (Style_Amount f gi gf ui up) =
		rnf f  `seq`
		rnf gi `seq`
		rnf gf `seq`
		rnf ui `seq`
		rnf up
instance Semigroup Style_Amount where
	(<>) = style_amount_union
instance Monoid Style_Amount where
	mempty  = style_amount
	mappend = (<>)

style_amount :: Style_Amount
style_amount =
	Style_Amount
	 { style_amount_fractioning         = Nothing
	 , style_amount_grouping_integral   = Nothing
	 , style_amount_grouping_fractional = Nothing
	 , style_amount_unit_side           = Nothing
	 , style_amount_unit_spaced         = Nothing
	 }

style_amount_union
 :: Style_Amount
 -> Style_Amount
 -> Style_Amount
style_amount_union
 sty@Style_Amount
 { style_amount_fractioning=f
 , style_amount_grouping_integral=gi
 , style_amount_grouping_fractional=gf
 , style_amount_unit_side=side
 , style_amount_unit_spaced=spaced
 }
 sty'@Style_Amount
 { style_amount_fractioning=f'
 , style_amount_grouping_integral=gi'
 , style_amount_grouping_fractional=gf'
 , style_amount_unit_side=side'
 , style_amount_unit_spaced=spaced'
 } =
	if sty == sty'
	then sty'
	else
		Style_Amount
		 { style_amount_fractioning         = S.maybe f'      (const f)      f
		 , style_amount_grouping_integral   = S.maybe gi'     (const gi)     gi
		 , style_amount_grouping_fractional = S.maybe gf'     (const gf)     gf
		 , style_amount_unit_side           = S.maybe side'   (const side)   side
		 , style_amount_unit_spaced         = S.maybe spaced' (const spaced) spaced
		 }

-- ** Type 'Style_Amount_Fractioning'
type Style_Amount_Fractioning
 = Char

-- ** Type 'Style_Amount_Grouping'
data Style_Amount_Grouping
 =   Style_Amount_Grouping Char [Int]
 deriving (Data, Eq, Ord, Show, Typeable)
instance NFData Style_Amount_Grouping where
	rnf (Style_Amount_Grouping s d) = rnf s `seq` rnf d

-- ** Type 'Style_Amount_Precision'
type Style_Amount_Precision
 = Word8

-- ** Type 'Style_Amount_Spacing'
type Style_Amount_Spacing
 = Bool

-- ** Type 'LR'
data LR = L | R
 deriving (Data, Eq, Ord, Show, Typeable)
instance NFData LR where
	rnf L = ()
	rnf R = ()

-- ** Type 'Style_Amounts'
newtype Style_Amounts
 =      Style_Amounts (Map Unit Style_Amount)
 deriving (Data, Eq, NFData, Ord, Show, Typeable)
unStyle_Amounts :: Style_Amounts -> Map Unit Style_Amount
unStyle_Amounts (Style_Amounts fp) = fp
instance Semigroup Style_Amounts where
	Style_Amounts x <> Style_Amounts y =
		Style_Amounts (Map.unionWith (flip (<>)) x y)
instance Monoid Style_Amounts where
	mempty  = Style_Amounts mempty
	mappend = (<>)

-- ** Operators
style_amount_cons :: (Unit, Style_Amount) -> Style_Amounts -> Style_Amounts
style_amount_cons (u, s) (Style_Amounts ss) =
	Style_Amounts $
	Map.insertWith (flip (<>)) u s ss

style_amount_find :: Style_Amounts -> Unit -> Style_Amount
style_amount_find (Style_Amounts s) u = Map.findWithDefault mempty u s

-- *** Example 'Style_Amounts'
style_amounts :: Style_Amounts
style_amounts = Style_Amounts $ Map.fromList
 [ (unit_scalar,) Style_Amount
    { style_amount_fractioning         = Just '.'
    , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
    , style_amount_grouping_integral   = Just $ Style_Amount_Grouping ',' [3]
    , style_amount_unit_side           = Just R
    , style_amount_unit_spaced         = Just False
    }
 , (unit_chf,) Style_Amount
    { style_amount_fractioning         = Just ','
    , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
    , style_amount_grouping_integral   = Just $ Style_Amount_Grouping '.' [3]
    , style_amount_unit_side           = Just R
    , style_amount_unit_spaced         = Just False
    }
 , (unit_cny,) Style_Amount
    { style_amount_fractioning         = Just ','
    , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
    , style_amount_grouping_integral   = Just $ Style_Amount_Grouping '.' [3]
    , style_amount_unit_side           = Just R
    , style_amount_unit_spaced         = Just False
    }
 , (unit_eur,) Style_Amount
    { style_amount_fractioning         = Just ','
    , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
    , style_amount_grouping_integral   = Just $ Style_Amount_Grouping '.' [3]
    , style_amount_unit_side           = Just R
    , style_amount_unit_spaced         = Just False
    }
 , (unit_gbp,) Style_Amount
    { style_amount_fractioning         = Just '.'
    , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
    , style_amount_grouping_integral   = Just $ Style_Amount_Grouping ',' [3]
    , style_amount_unit_side           = Just L
    , style_amount_unit_spaced         = Just False
    }
 , (unit_inr,) Style_Amount
    { style_amount_fractioning         = Just ','
    , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
    , style_amount_grouping_integral   = Just $ Style_Amount_Grouping '.' [3]
    , style_amount_unit_side           = Just R
    , style_amount_unit_spaced         = Just False
    }
 , (unit_jpy,) Style_Amount
    { style_amount_fractioning         = Just '.'
    , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
    , style_amount_grouping_integral   = Just $ Style_Amount_Grouping ',' [3]
    , style_amount_unit_side           = Just L
    , style_amount_unit_spaced         = Just False
    }
 , (unit_rub,) Style_Amount
    { style_amount_fractioning         = Just '.'
    , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
    , style_amount_grouping_integral   = Just $ Style_Amount_Grouping ',' [3]
    , style_amount_unit_side           = Just L
    , style_amount_unit_spaced         = Just False
    }
 , (unit_usd,) Style_Amount
    { style_amount_fractioning         = Just '.'
    , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
    , style_amount_grouping_integral   = Just $ Style_Amount_Grouping ',' [3]
    , style_amount_unit_side           = Just L
    , style_amount_unit_spaced         = Just False
    }
 ]

-- ** Type 'Styled_Amount'
type Styled_Amount t = (Style_Amount, t)

styled_amount :: Style_Amounts -> Amount -> Styled_Amount Amount
styled_amount styles amt = (amount_style styles amt, amt)

-- * Type 'Amounts'
newtype Amounts = Amounts (Map Unit Quantity)
 deriving (Data, Eq, NFData, Ord, Show, Typeable
 , H.Addable, H.Negable, H.Subable)
unAmounts :: Amounts -> Map Unit Quantity
unAmounts (Amounts a) = a
instance H.Zero Amounts where
	quantity_zero = Amounts H.quantity_zero
instance Semigroup Amounts where
	Amounts x <> Amounts y =
		Amounts (Map.unionWith (flip H.quantity_add) x y)
instance Monoid Amounts where
	mempty  = Amounts mempty
	mappend = (<>)

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

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