{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hcompta.Format.Ledger.Read where

import           Control.Applicative ((<*), (<$>))
import qualified Control.Exception as Exn
import           Control.Monad (guard)
-- import           Control.Monad.Error
import qualified Data.Char
import           Data.Data
import qualified Data.Decimal
import qualified Data.List
-- import           Data.List.Split (wordsBy)
import qualified Data.Map
import           Data.Maybe
import qualified Data.Time.Calendar  as Time
import qualified Data.Time.Clock     as Time
import qualified Data.Time.LocalTime as Time
import           Data.Typeable ()
import           Safe (headDef, lastDef)
import qualified Text.Parsec as P
import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import           Text.Printf

import qualified Hcompta.Model as Model
import qualified Hcompta.Model.Account as Account
import           Hcompta.Model.Account (Account)
import qualified Hcompta.Model.Amount as Amount
import           Hcompta.Model.Amount (Amount, Conversion, Style, Unit)
import qualified Hcompta.Model.Amount.Conversion as Conversion
import qualified Hcompta.Model.Amount.Quantity as Quantity
import qualified Hcompta.Model.Amount.Style as Style
import qualified Hcompta.Model.Amount.Unit as Unit
import qualified Hcompta.Model.Date as Date
import           Hcompta.Format.Ledger.Journal as Journal

data Context
 =   Context
 { account_prefix :: !Account
 --, context_aliases :: ![AccountAlias]
 , unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
 , journal :: !Journal
 , year :: !Date.Year
 } deriving (Data, Eq, Read, Show, Typeable)

nil :: Context
nil =
	Context
	 { account_prefix = []
	 , unit_and_style = Nothing
	 , journal = Journal.nil
	 , year = (\(year, _ , _) -> year) $
		Time.toGregorian $ Time.utctDay $
		Journal.last_read_time Journal.nil
	 }

-- * Utilities

-- ** Combinators

-- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
choice_try :: Stream s m t => [ParsecT s st m a] -> ParsecT s st m a
choice_try = P.choice . Data.List.map P.try

-- ** Numbers

-- | Return the 'Integer' obtained by multiplying the given digits
--   with the power of the given base respective to their rank.
integer_of_digits
 :: Integer -- ^ Base.
 -> [Char]  -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
 -> Integer
integer_of_digits base =
	Data.List.foldl (\x d ->
		base*x + toInteger (Data.Char.digitToInt d)) 0

decimal :: Stream [Char] m Char => ParsecT [Char] st m Integer
decimal = integer 10 P.digit
hexadecimal :: Stream [Char] m Char => ParsecT [Char] st m Integer
hexadecimal = P.oneOf "xX" >> integer 16 P.hexDigit
octal :: Stream [Char] m Char => ParsecT [Char] st m Integer
octal = P.oneOf "oO" >> integer 8 P.octDigit

-- | Parse an 'Integer'.
integer :: Stream [Char] m Char
       => Integer -> ParsecT [Char] st m Char
       -> ParsecT [Char] st m Integer
integer base digit = do
	digits <- P.many1 digit
	let n = integer_of_digits base digits
	seq n (return n)

-- | Parse either '-' into 'negate', or '+' or '' into 'id'.
sign :: (Stream [Char] m Char, Num i) => ParsecT [Char] st m (i -> i)
sign =
	(P.char '-' >> return negate) <|>
	(P.char '+' >> return id) <|>
	return id

-- ** Whites

-- | Return 'True' if and only if the given 'Char' is an horizontal space.
is_space :: Char -> Bool
is_space c = c /= '\n' && c /= '\r' && Data.Char.isSpace c

space :: Stream [Char] m Char => ParsecT [Char] st m Char
space = P.satisfy is_space

-- * Parsing 'Account'.

-- | Parse an 'Account'.
account :: Stream [Char] m Char => ParsecT [Char] st m Account
account = do
	P.notFollowedBy $ P.satisfy is_space
	P.sepBy1 account_name account_separator

-- | Parse an Account.'Account.Name'.
account_name :: Stream [Char] m Char => ParsecT [Char] st m Account.Name
account_name = do
	P.many1 $ do
		P.satisfy is_space
			<* (P.lookAhead $ P.satisfy (not . Data.Char.isSpace))
		<|> (P.notFollowedBy account_separator >> P.anyChar)

account_separator :: Stream [Char] m Char => ParsecT [Char] st m Char
account_separator = P.char ':'

-- * Parsing 'Amount'.

-- | Parse an 'Amount'.
amount :: Stream [Char] m Char => ParsecT [Char] st m Amount
amount = do
	left_signing <- sign
	left_unit <-
		P.option Nothing $ do
			u <- unit
			s <- P.many $ P.satisfy is_space
			return $ Just $ (u, not $ null s)
	(quantity_, style) <- do
		signing <- sign
		Quantity
		 { integral
		 , fractional
		 , fractioning
		 , grouping_integral
		 , grouping_fractional
		 } <-
			choice_try
			 [ quantity '_' ',' '_' <* (P.notFollowedBy $ P.oneOf ",._")
			 , quantity '_' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
			 , quantity ',' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
			 , quantity '.' ',' '_' <* (P.notFollowedBy $ P.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 = integer_of_digits 10 $ int ++ frac
		return $
		 ( Data.Decimal.Decimal
			 (fromIntegral place)
			 (signing mantissa)
		 , Style.nil
			 { Style.fractioning = fractioning
			 , Style.grouping_integral = grouping_integral
			 , Style.grouping_fractional = grouping_fractional
			 , Style.precision = fromIntegral $ length frac_flat
			 }
		 )
	(unit_, side, spaced) <-
		case left_unit of
		 Just (u, s) ->
			return (u, Just Style.Side_Left, Just s)
		 Nothing ->
			P.option (Unit.nil, Nothing, Nothing) $ do
				s <- P.many $ P.satisfy is_space
				u <- unit
				return $ (u, Just Style.Side_Right, Just $ not $ null s)
	return $
		Amount.Amount
		 { Amount.conversion = Conversion.nil -- TODO
		 , Amount.quantity = left_signing $ quantity_
		 , Amount.style = style
			 { Style.unit_side = side
			 , Style.unit_spaced = spaced
			 }
		 , Amount.unit = unit_
		 }

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

-- | Parse a 'Quantity'.
quantity
 :: Stream [Char] m Char
 => Char -- ^ Integral grouping separator.
 -> Char -- ^ Fractioning separator.
 -> Char -- ^ Fractional grouping separator.
 -> ParsecT [Char] st m Quantity
quantity int_group_sep frac_sep frac_group_sep = do
	(integral, grouping_integral) <- do
		h <- P.many P.digit
		case h of
		 [] -> return ([], Nothing)
		 _ -> do
			t <- P.many $ P.char int_group_sep >> P.many1 P.digit
			let digits = h:t
			return (digits, grouping_of_digits int_group_sep digits)
	(fractional, fractioning, grouping_fractional) <-
		(case integral of
		 [] -> id
		 _ -> P.option ([], Nothing, Nothing)) $ do
			fractioning <- P.char frac_sep
			h <- P.many P.digit
			t <- P.many $ P.char frac_group_sep >> P.many1 P.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 =
			Data.List.foldl -- NOTE: remove duplicates at begining 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 begining.
			 l0:l1:t -> if l0 > l1 then groups else l1:t
			 _ -> groups

-- | Parse an 'Unit'.
unit :: Stream [Char] m Char => ParsecT [Char] st m Unit
unit =
	(quoted <|> unquoted) <?> "unit"
	where
		unquoted :: Stream [Char] m Char => ParsecT [Char] st m Unit
		unquoted =
			P.many1 $
				P.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 [Char] m Char => ParsecT [Char] st m Unit
		quoted =
			P.between (P.char '"') (P.char '"') $
				P.many1 $
					P.noneOf ";\n\""