{-# 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 Data.Text as T

import qualified Hcompta as H

-- * Type 'Amount'
data Amount
 =   Amount
 {   amount_unit     :: !Unit
 ,   amount_quantity :: !Quantity
 } deriving (Data, Eq, Ord, Show, Typeable)

-- type instance H.UnitFor     Amount = Unit
-- type instance H.QuantityFor Amount = H.Polarized Quantity

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.Zeroable Amount where
	zero = Amount "" H.zero
instance H.Nullable Amount where
	null = H.null . amount_quantity
	 -- NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
	 --       at 'Amount'’s 'amount_style'’s 'style_amount_precision'.
instance H.Signable Amount where
	sign = H.sign . amount_quantity

amount :: Amount
amount =
	Amount
	 { amount_unit     = ""
	 , amount_quantity = H.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.Zeroable Unit where
	zero = Unit ""
instance H.Nullable Unit where
	null (Unit x) = T.null x
{-
instance H.Unit Unit where
	noUnit = Unit ""
	textUnit (Unit t) = t
-}
instance NFData Unit where
	rnf (Unit t) = rnf t

-- ** Example 'Unit's

-- | 'H.noUnit'.
unit_scalar :: Unit
unit_scalar = ""

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

-- type instance H.UnitFor     Amounts = Unit
-- type instance H.QuantityFor Amounts = Quantity

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 = (<>)
instance H.Zeroable Style_Amounts where
	zero = Style_Amounts mempty
instance H.Sumable Style_Amounts (Unit, Style_Amount) where
	Style_Amounts ss += (u, s) = Style_Amounts $ Map.insertWith (flip (<>)) u s ss

unStyle_Amounts :: Style_Amounts -> Map Unit Style_Amount
unStyle_Amounts (Style_Amounts fp) = fp

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.Zeroable Amounts where
	zero = Amounts H.zero
instance H.Nullable Amounts where
	null (Amounts x) = H.null x
instance Semigroup Amounts where
	Amounts x <> Amounts y = Amounts (Map.unionWith (flip (H.+)) 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