{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
module Hcompta.Format.JCC.Amount.Read where

import           Control.Applicative ((<$>), (<*))
import           Control.Applicative ((<|>))
import           Control.Monad (Monad(..), guard)
import           Data.Bool
import           Data.Char
import qualified Data.Decimal
import           Data.Eq (Eq(..))
import qualified Data.List as List
import           Data.Maybe (Maybe(..))
import           Data.Monoid (Monoid(..))
import           Data.Ord (Ord(..))
import           Data.String (String, fromString)
import           Data.Typeable ()
import           Prelude (($), (.), Int, fromIntegral, Num(..), id)
import qualified Text.Parsec as R hiding
                  ( char
                  , noneOf
                  , oneOf
                  , satisfy
                  )
import           Text.Parsec (Stream, ParsecT, (<?>))

import qualified Hcompta.Unit as Unit
import           Hcompta.Format.JCC (Amount(..), Unit(..))
import qualified Hcompta.Format.JCC.Amount.Style as Style
import           Hcompta.Format.JCC.Common.Read
import qualified Hcompta.Lib.Parsec as R

-- * Read 'Quantity'

quantity
 :: Stream s m Char
 => Char -- ^ Integral grouping separator.
 -> Char -- ^ Fractioning separator.
 -> Char -- ^ Fractional grouping separator.
 -> ParsecT s u m
 ( [String] -- integral
 , [String] -- fractional
 , Maybe Style.Fractioning -- fractioning
 , Maybe Style.Grouping -- grouping_integral
 , Maybe Style.Grouping -- grouping_fractional
 )
quantity int_group_sep frac_sep frac_group_sep = do
	(integral, grouping_integral) <- do
		h <- R.many R.digit
		case h of
		 [] -> return ([], Nothing)
		 _ -> do
			t <- R.many $ R.char int_group_sep >> R.many1 R.digit
			let digits = h:t
			return (digits, grouping_of_digits int_group_sep digits)
	(fractional, fractioning, grouping_fractional) <-
		(case integral of
		 [] -> id
		 _ -> R.option ([], Nothing, Nothing)) $ do
			fractioning <- R.char frac_sep
			h <- R.many R.digit
			t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
			let digits = h:t
			return (digits, Just fractioning
			 , grouping_of_digits frac_group_sep $ List.reverse digits)
	return $
	 ( integral
	 , fractional
	 , fractioning
	 , grouping_integral
	 , grouping_fractional
	 )
	where
		grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
		grouping_of_digits group_sep digits =
			case digits of
			 []  -> Nothing
			 [_] -> Nothing
			 _   -> Just $
				Style.Grouping group_sep $
				canonicalize_grouping $
				List.map List.length $ digits
		canonicalize_grouping :: [Int] -> [Int]
		canonicalize_grouping groups =
			List.foldl' -- NOTE: remove duplicates at beginning and reverse.
			 (\acc l0 -> case acc of
				 l1:_ -> if l0 == l1 then acc else l0:acc
				 _ -> l0:acc) [] $
			case groups of -- NOTE: keep only longer at beginning.
			 l0:l1:t -> if l0 > l1 then groups else l1:t
			 _ -> groups

-- * Read 'Unit'
unit :: Stream s m Char => ParsecT s u m Unit
unit =
	(symbol <|> letters) <?> "unit"
	where
		symbol :: Stream s m Char => ParsecT s u m Unit
		symbol =
			fromString . (\c -> [c]) <$> do
			R.satisfy $ \c ->
				case Data.Char.generalCategory c of
				 Data.Char.CurrencySymbol -> True
				 _ -> False
		letters :: Stream s m Char => ParsecT s u m Unit
		letters =
			fromString <$> do
			R.many1 $
				R.satisfy $ \c ->
					case Data.Char.generalCategory c of
					 Data.Char.LowercaseLetter -> True
					 Data.Char.ModifierLetter  -> True
					 Data.Char.OtherLetter     -> True
					 Data.Char.TitlecaseLetter -> True
					 Data.Char.UppercaseLetter -> True
					 _ -> False

-- * Read 'Amount'
amount :: Stream s m Char => ParsecT s u m (Style.Styled Amount)
amount = do
	left_signing <- sign
	left_unit <-
		R.option Nothing $ do
			u <- unit
			s <- R.many space
			return $ Just $ (u, not $ List.null s)
	(qty, style) <- do
		signing <- sign
		(  integral
		 , fractional
		 , fractioning
		 , grouping_integral
		 , grouping_fractional
		 ) <-
			R.choice_try
			 [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
			 , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
			 , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
			 , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
			 ] <?> "quantity"
		let int  = List.concat integral
		let frac = List.concat fractional
		let precision = List.length frac
		guard (precision <= 255)
		let mantissa = R.integer_of_digits 10 $ int `mappend` frac
		return $
		 ( Data.Decimal.Decimal
			 (fromIntegral precision)
			 (signing mantissa)
		 , Style.empty
			 { Style.fractioning
			 , Style.grouping_integral
			 , Style.grouping_fractional
			 }
		 )
	(amount_unit, unit_side, unit_spaced) <-
		case left_unit of
		 Just (u, s) ->
			return (u, Just Style.Side_Left, Just s)
		 Nothing ->
			R.option (Unit.unit_empty, Nothing, Nothing) $ R.try $ do
				s <- R.many space
				u <- unit
				return $ (u, Just Style.Side_Right, Just $ not $ List.null s)
	return $
		( style
		 { Style.unit_side
		 , Style.unit_spaced
		 }
		,
		 Amount
		 { amount_quantity = left_signing qty
		 , amount_unit
		 }
		)

-- | Parse either '-' into 'negate', or '+' or '' into 'id'.
sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
sign =
	    (R.char '-' >> return negate)
	<|> (R.char '+' >> return id)
	<|> return id