{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
module Hcompta.Format.JCC.Amount.Style where

import           Control.DeepSeq
import           Data.Bool
import           Data.Char (Char)
import           Data.Data
import           Data.Eq (Eq(..))
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(..))
import           Data.Typeable ()
import           Data.Word (Word8)
import           Prelude (($), Int, Show(..), const, seq)

import           Hcompta.Format.JCC.Unit (Unit)

-- * Type 'Style'

data Style
 =   Style
 { fractioning         :: Maybe Fractioning
 , grouping_integral   :: Maybe Grouping
 , grouping_fractional :: Maybe Grouping
 -- TODO: , sign_plus     :: Maybe Bool
 , unit_side           :: Maybe Side
 , unit_spaced         :: Maybe Spacing
 } deriving (Data, Eq, Ord, Show, Typeable)
instance NFData Style where
	rnf (Style f gi gf ui up) =
		rnf f  `seq`
		rnf gi `seq`
		rnf gf `seq`
		rnf ui `seq`
		rnf up
instance Monoid Style where
	mempty  = empty
	mappend = union

type Fractioning
 = Char

data Grouping
 =   Grouping Char [Int]
 deriving (Data, Eq, Ord, Show, Typeable)
instance NFData Grouping where
	rnf (Grouping s d) = rnf s `seq` rnf d

type Precision
 = Word8

type Spacing
 = Bool

data Side
 =   Side_Left
 |   Side_Right
 deriving (Data, Eq, Ord, Show, Typeable)
instance NFData Side where
	rnf Side_Left  = ()
	rnf Side_Right = ()

-- * Type 'Styles'

newtype Styles
 =      Styles (Map Unit Style)
 deriving (Eq, Data, NFData, Show, Typeable)
instance Monoid Styles where
	mempty = Styles mempty
	mappend (Styles x) (Styles y) =
		Styles (Map.unionWith mappend x y)

-- * Type 'Styled'

type Styled t = (Style, t)

-- * Constructors

empty :: Style
empty =
	Style
	 { fractioning         = Nothing
	 , grouping_integral   = Nothing
	 , grouping_fractional = Nothing
	 , unit_side           = Nothing
	 , unit_spaced         = Nothing
	 }

style :: Styles -> Unit -> Style
style (Styles s) u = Map.findWithDefault empty u s

-- * Operators

cons :: (Unit, Style) -> Styles -> Styles
cons (u, s) (Styles ss) =
	Styles $
	Map.insertWith mappend u s ss

union :: Style -> Style -> Style
union
 sty@Style
 { fractioning=fractioning_
 , grouping_integral=grouping_integral_
 , grouping_fractional=grouping_fractional_
 , unit_side=side
 , unit_spaced=spaced
 }
 sty'@Style
 { fractioning=fractioning'
 , grouping_integral=grouping_integral_'
 , grouping_fractional=grouping_fractional_'
 , unit_side=side'
 , unit_spaced=spaced'
 } =
	if sty == sty'
	then sty'
	else
		Style
		 { fractioning=maybe fractioning' (const fractioning_) fractioning_
		 , grouping_integral=maybe grouping_integral_' (const grouping_integral_) grouping_integral_
		 , grouping_fractional=maybe grouping_fractional_' (const grouping_fractional_) grouping_fractional_
		 , unit_side=maybe side' (const side) side
		 , unit_spaced=maybe spaced' (const spaced) spaced
		 }