{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
module Hcompta.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           Data.List
import           Data.Maybe (Maybe(..))
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.Amount as Amount
import           Hcompta.Amount (Amount, Unit)
import qualified Hcompta.Amount.Style as Style
import qualified Hcompta.Amount.Unit as Unit
import qualified Hcompta.Lib.Parsec as R

-- * Read 'Quantity'
data Quantity
 =   Quantity
 { integral :: [String]
 , fractional :: [String]
 , fractioning :: Maybe Style.Fractioning
 , grouping_integral :: Maybe Style.Grouping
 , grouping_fractional :: Maybe Style.Grouping
 }

quantity
 :: Stream s m Char
 => Char -- ^ Integral grouping separator.
 -> Char -- ^ Fractioning separator.
 -> Char -- ^ Fractional grouping separator.
 -> ParsecT s u m Quantity
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 $ reverse digits)
	return $
		Quantity
		 { 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 $
				map length $ digits
		canonicalize_grouping :: [Int] -> [Int]
		canonicalize_grouping groups =
			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 =
	(quoted <|> unquoted) <?> "unit"
	where
		unquoted :: Stream s m Char => ParsecT s u m Unit
		unquoted =
			fromString <$> do
			R.many1 $
				R.satisfy $ \c ->
					case Data.Char.generalCategory c of
					 Data.Char.CurrencySymbol  -> True
					 Data.Char.LowercaseLetter -> True
					 Data.Char.ModifierLetter  -> True
					 Data.Char.OtherLetter     -> True
					 Data.Char.TitlecaseLetter -> True
					 Data.Char.UppercaseLetter -> True
					 _ -> False
		quoted :: Stream s m Char => ParsecT s u m Unit
		quoted =
			fromString <$> do
			R.between (R.char '"') (R.char '"') $
				R.many1 $
					R.noneOf ";\n\""

-- * Read 'Amount'
amount :: Stream s m Char => ParsecT s u m Amount
amount = do
	left_signing <- sign
	left_unit <-
		R.option Nothing $ do
			u <- unit
			s <- R.many $ R.space_horizontal
			return $ Just $ (u, not $ null s)
	(quantity_, style) <- do
		signing <- sign
		Quantity
		 { 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 = Data.List.concat integral
		let frac_flat = Data.List.concat fractional
		let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
		let place = length frac
		guard (place <= 255)
		let mantissa = R.integer_of_digits 10 $ int ++ frac
		return $
		 ( Data.Decimal.Decimal
			 (fromIntegral place)
			 (signing mantissa)
		 , Style.nil
			 { Style.fractioning
			 , Style.grouping_integral
			 , Style.grouping_fractional
			 , Style.precision = fromIntegral $ length frac_flat
			 }
		 )
	(unit_, unit_side, unit_spaced) <-
		case left_unit of
		 Just (u, s) ->
			return (u, Just Style.Side_Left, Just s)
		 Nothing ->
			R.option (Unit.nil, Nothing, Nothing) $ R.try $ do
				s <- R.many $ R.space_horizontal
				u <- unit
				return $ (u, Just Style.Side_Right, Just $ not $ null s)
	return $
		Amount.Amount
		 { Amount.quantity = left_signing $ quantity_
		 , Amount.style = style
			 { Style.unit_side
			 , Style.unit_spaced
			 }
		 , Amount.unit = 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