{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Hcompta.Format.Ledger.Write where

import           Control.Applicative ((<$>), (<*>), (<*))
import           Control.Monad (Monad(..))
import           Data.Bool
import           Data.Char (Char, isSpace)
import qualified Data.Char as Char
import           Data.Either (Either(..))
import           Data.Eq (Eq(..))
import           Data.Maybe (Maybe(..), maybe, fromMaybe)
import qualified Data.Foldable
import           Data.Foldable (Foldable(..))
import           Data.Function (($), (.), flip, id)
import           Data.Functor (Functor(..))
import qualified Data.Functor.Compose
import           Data.List ((++))
import qualified Data.List as List
import qualified Data.List.NonEmpty
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Monoid (Monoid(..))
import           Data.Ord (Ord(..))
import           Data.Tuple (fst)
import           Data.Decimal
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Time.LocalTime as Time
import           GHC.Exts (Int(..))
import           GHC.Integer.Logarithms (integerLogBase#)
import           Prelude (Bounded(..), Integer, Num(..), RealFrac(..), Show(..), fromIntegral)
import           System.IO (IO, Handle)
import           Text.Parsec (Stream, ParsecT)
import qualified Text.Parsec as R hiding (satisfy, char)


import           Hcompta.Account (Account_Tags(..))
import qualified Hcompta.Account as Account
import qualified Hcompta.Amount as Amount
import qualified Hcompta.Chart as Chart
import qualified Hcompta.Unit as Unit
import           Hcompta.Date (Date)
import qualified Hcompta.Date as Date
import           Hcompta.Lib.Leijen (Doc, (<>))
import qualified Hcompta.Lib.Leijen as W
import qualified Hcompta.Lib.Parsec as R
import qualified Hcompta.Lib.TreeMap as TreeMap
import           Hcompta.Tag (Tag, Tags(..))

import           Hcompta.Format.Ledger
import qualified Hcompta.Format.Ledger.Read as Read

-- * Write 'Date'

write_date :: Date -> Doc
write_date dat = do
	let (y, mo, d) = Date.gregorian dat
	(if y == 0 then W.empty else W.integer y <> sep '-') <> do
	int2 mo <> do
	sep '-' <> int2 d <> do
	(case Date.tod dat of
	 Time.TimeOfDay 0 0 0 -> W.empty
	 Time.TimeOfDay h m s ->
		sep '_' <> int2 h <> do
		sep ':' <> int2 m <> do
		(case s of
		 0 -> W.empty
		 _ -> sep ':' <> do
			(if s < 10 then W.char '0' else W.empty) <> do
			W.strict_text $ Text.pack $ show $ (truncate s::Integer)))
	-- (case tz_min of
	--  0 -> W.empty
	--  _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
	--  _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
	where
		int2 :: Int -> Doc
		int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
		sep :: Char -> Doc
		sep = W.bold . W.dullblack . W.char

write_date_length :: Date -> Int
write_date_length dat = do
	let (y, _, _) = Date.gregorian dat
	(case y of
	 0 -> 0
	 _ ->
		(if y < 0 then 1 else 0) -- sign
		+ (1 + (I# (integerLogBase# 10 (abs y)))) -- year
		+ 1) -- -
	+ 2 -- month
	+ 1 -- -
	+ 2 -- dom
	+ (case Date.tod dat of
	 Time.TimeOfDay 0 0 0 -> 0
	 Time.TimeOfDay _ _ s ->
		1 -- _
		+ 2 -- hour
		+ 1 -- :
		+ 2 -- min
		+ (case s of
		 0 -> 0
		 _ -> 1 + 2 -- : sec
		)
	)

-- * Write 'Account'

write_account :: Posting_Type -> Account -> Doc
write_account type_ =
	case type_ of
	 Posting_Type_Regular -> account_
	 Posting_Type_Virtual -> \acct ->
		W.char Read.read_posting_type_virtual_begin <> do
		account_ acct <> do
		W.char Read.read_posting_type_virtual_end
	 Posting_Type_Virtual_Balanced -> \acct ->
		W.char Read.read_posting_type_virtual_balanced_begin <> do
		account_ acct <> do
		W.char Read.read_posting_type_virtual_balanced_end
	where
		account_ :: Account -> Doc
		account_ acct =
			W.align $ W.hcat $
				Data.List.NonEmpty.toList $
				Data.List.NonEmpty.intersperse
				 (W.bold $ W.dullblack $ W.char Read.read_account_section_sep)
				 (Data.List.NonEmpty.map write_account_section acct)

write_account_section :: Account.Account_Section Account -> Doc
write_account_section = W.strict_text

write_account_length :: Posting_Type -> Account -> Int
write_account_length type_ acct =
	Data.Foldable.foldl
	 (\acc -> (1 +) . (acc +) . Text.length)
	 (- 1) acct +
	case type_ of
	 Posting_Type_Regular -> 0
	 Posting_Type_Virtual -> 2
	 Posting_Type_Virtual_Balanced -> 2

-- * Write 'Amount'

write_amount :: Amount_Styled Amount -> Doc
write_amount
 ( sty@(Amount_Style
	 { amount_style_unit_side
	 , amount_style_unit_spaced
	 })
 , amt ) =
	let unt = Amount.amount_unit amt in
	case amount_style_unit_side of
	 Just Amount_Style_Side_Left ->
		write_unit unt <>
		case amount_style_unit_spaced of
		 Just True | unt /= Unit.unit_empty -> W.space
		 _ -> W.empty
	 _ -> W.empty
	<> write_quantity (sty, Amount.amount_quantity amt)
	<> case amount_style_unit_side of
	 (Just Amount_Style_Side_Right) ->
		(case amount_style_unit_spaced of
		 Just True | unt /= Unit.unit_empty -> W.space
		 _ -> W.empty) <>
		write_unit unt
	 Nothing ->
		(case amount_style_unit_spaced of
		 Just True | unt /= Unit.unit_empty -> W.space
		 _ -> W.empty) <>
		write_unit unt
	 _ -> W.empty

write_amount_length :: Amount_Styled Amount -> Int
write_amount_length (sty@(Amount_Style { amount_style_unit_spaced }), amt) =
	let unt = Amount.amount_unit amt in
	write_unit_length unt
	+ (case amount_style_unit_spaced of
		 { Just True | unt /= Unit.unit_empty -> 1; _ -> 0 })
	+ write_quantity_length sty (Amount.amount_quantity amt)

-- ** Write 'Amount's

write_amounts :: Amount_Styles -> Map Unit Quantity -> Doc
write_amounts styles =
	Map.foldlWithKey
	 (\doc unit qty ->
		(if W.is_empty doc
		then doc
		else doc <> W.space <>
			(W.bold $ W.yellow $ W.char Read.read_amount_sep) <>
			W.space) <>
		(write_amount $
		amount_styled styles $
		Amount unit qty))
	 W.empty

write_amounts_length :: Amount_Styles -> Map Unit Quantity -> Int
write_amounts_length styles amts =
	if Map.null amts
	then 0
	else
		Map.foldrWithKey
		 (\unit qty -> (3 +) . (+)
			 (write_amount_length $
				amount_styled styles $
				Amount unit qty))
		 (-3) amts

-- * Write 'Unit'

write_unit :: Unit -> Doc
write_unit u =
	let t = Unit.unit_text u in
	W.yellow $
	if Text.all
	 (\c -> case Char.generalCategory c of
		 Char.CurrencySymbol  -> True
		 Char.LowercaseLetter -> True
		 Char.ModifierLetter  -> True
		 Char.OtherLetter     -> True
		 Char.TitlecaseLetter -> True
		 Char.UppercaseLetter -> True
		 _ -> False
	 ) t
	then W.strict_text t
	else W.hcat $ W.strict_text <$> ["\"", t, "\""]

write_unit_length :: Unit -> Int
write_unit_length u =
	let t = Unit.unit_text u in
	Text.length t +
	if Text.all
	 (\c -> case Char.generalCategory c of
		 Char.CurrencySymbol  -> True
		 Char.LowercaseLetter -> True
		 Char.ModifierLetter  -> True
		 Char.OtherLetter     -> True
		 Char.TitlecaseLetter -> True
		 Char.UppercaseLetter -> True
		 _ -> False) t
	then 0
	else 2

-- * Write 'Quantity'

write_quantity :: Amount_Styled Quantity -> Doc
write_quantity
 ( Amount_Style
	 { amount_style_fractioning
	 , amount_style_grouping_integral
	 , amount_style_grouping_fractional
	 }
 , qty ) = do
	let Decimal e n = qty
	let num = show $ abs $ n
	let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
	case e == 0 of
	 True  -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num)
	 False -> do
		let num_len = List.length num
		let padded =
			List.concat
			 [ List.replicate (fromIntegral e + 1 - num_len) '0'
			 , num
			 -- , replicate (fromIntegral precision - fromIntegral e) '0'
			 ]
		let (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded
		let default_fractioning =
			List.head $
			del_grouping_sep amount_style_grouping_integral $
			del_grouping_sep amount_style_grouping_fractional $
			['.', ',']
		sign <> do
		W.bold $ W.blue $ do
			W.text (TL.pack $ maybe id
			 (\g -> List.reverse . group g . List.reverse)
			 amount_style_grouping_integral $ int) <> do
			(W.yellow $ W.char (fromMaybe default_fractioning amount_style_fractioning)) <> do
			W.text (TL.pack $ maybe id group amount_style_grouping_fractional frac)
	where
		group :: Amount_Style_Grouping -> [Char] -> [Char]
		group (Amount_Style_Grouping sep sizes_) =
			List.concat . List.reverse .
			List.map List.reverse . fst .
			List.foldl'
			 (flip (\digit x -> case x of
				 ([], sizes) -> ([[digit]], sizes)
				 (digits:groups, []) -> ((digit:digits):groups, [])
				 (digits:groups, curr_sizes@(size:sizes)) ->
					if List.length digits < size
					then (      (digit:digits):groups, curr_sizes)
					else ([digit]:[sep]:digits:groups, if List.null sizes then curr_sizes else sizes)
			 ))
			 ([], sizes_)
		del_grouping_sep grouping =
			case grouping of
			 Just (Amount_Style_Grouping sep _) -> List.delete sep
			 _ -> id

write_quantity_length :: Amount_Style -> Quantity -> Int
write_quantity_length Amount_Style
 { amount_style_grouping_integral
 , amount_style_grouping_fractional
 } qty =
	let Decimal e n     = qty in
	let sign_len        = if n < 0 then 1 else 0 in
	let fractioning_len = if e > 0 then 1 else 0 in
	let num_len         = if n == 0 then 0 else (1 +) $ I# (integerLogBase# 10 (abs n)) in
	let pad_left_len    = max 0 (fromIntegral e + 1 - num_len) in
	-- let pad_right_len   = max 0 (fromIntegral precision - fromIntegral e) in
	let padded_len      = pad_left_len + num_len {-+ pad_right_len-} in
	let int_len         = max 1 (num_len - fromIntegral e) in
	let frac_len        = max 0 (padded_len - int_len) in
	( sign_len
	+ fractioning_len
	+ padded_len
	+ maybe 0 (group int_len)  amount_style_grouping_integral
	+ maybe 0 (group frac_len) amount_style_grouping_fractional
	)
	where
		group :: Int -> Amount_Style_Grouping -> Int
		group num_len (Amount_Style_Grouping _sep sizes_) =
			if num_len <= 0
			then 0
			else loop 0 num_len sizes_
			where
				loop :: Int -> Int -> [Int] -> Int
				loop pad len =
					\x -> case x of
					 [] -> 0
					 sizes@[size] ->
						let l = len - size in
						if l <= 0 then pad
						else loop (pad + 1) l sizes
					 size:sizes ->
						let l = len - size in
						if l <= 0 then pad
						else loop (pad + 1) l sizes

-- * Write 'Comment'

write_comment :: Comment -> Doc
write_comment com =
	W.cyan $ do
		W.char Read.read_comment_begin
		<> (case Text.uncons com of
		 Just (c, _) | not $ Data.Char.isSpace c -> W.space
		 _ -> W.empty)
		<> do W.if_color colorize (W.strict_text com)
	where
		colorize :: Doc
		colorize =
			case R.runParser (do
				pre <- R.many $ R.try $ do
					ns <- R.many $ R.satisfy
					 (\c -> c /= Read.read_tag_value_sep
						 && not (Data.Char.isSpace c))
					sh <- R.space_horizontal
					return (ns ++ [sh])
				((W.text $ TL.pack $ mconcat pre) <>) <$> tags <* R.eof)
			 () "" com of
			 Left _ -> W.strict_text com
			 Right doc -> doc
		tags :: Stream s m Char => ParsecT s u m Doc
		tags = do
			(<>)
			 <$> tag_
			 <*> (W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_))))
			where
				tag_sep :: Stream s m Char => ParsecT s u m Doc
				tag_sep = do
					s <- R.char Read.read_tag_sep
					sh <- R.many R.space_horizontal
					return $
						do W.cyan $ W.char s
						<> do W.text $ TL.pack sh
				tag_ :: Stream s m Char => ParsecT s u m Doc
				tag_ = do
					(p, v) <- Read.read_tag
					return $
						foldMap (\s -> W.dullyellow (W.strict_text s) <> do
							W.bold $ W.dullblack $ W.char Read.read_tag_value_sep) p <>
						(W.red $ W.strict_text v)

write_comments :: Doc -> [Comment] -> Doc
write_comments prefix =
	W.hcat .
	List.intersperse W.line .
	List.map (\c -> prefix <> write_comment c)

-- * Write 'Tag'

write_tag :: Tag -> Doc
write_tag (p, v) =
	foldMap (\s -> W.dullyellow (W.strict_text s) <> W.char Read.read_tag_value_sep) p <>
	(W.dullred $ W.strict_text v)

-- * Write 'Posting'

write_posting :: Amount_Styles -> Posting_Lengths -> Posting -> Doc
write_posting styles max_posting_length
 p@Posting
 { posting_account
 , posting_amounts
 , posting_comments
 -- , posting_dates
 , posting_status
 -- , posting_tags
 } = do
	let type_ = posting_type p
	W.char '\t' <> do
	write_status posting_status <> do
		case Map.null posting_amounts of
		 True -> write_account type_ posting_account
		 False ->
			let len_acct = write_account_length type_ posting_account in
			let len_amts = write_amounts_length styles posting_amounts in
			write_account type_ posting_account <> do
			W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <> do
			write_amounts styles posting_amounts
	<> (case posting_comments of
	 [] -> W.empty
	 [c] -> W.space <> write_comment c
	 _ -> W.line <> do write_comments (W.text "\t ") posting_comments)

write_status :: Status -> Doc
write_status = \x -> case x of
	 True  -> W.char '!'
	 False -> W.empty

-- ** Type 'Posting_Lengths'

type Posting_Lengths = (Int)

write_postings_lengths
 :: Amount_Styles
 -> Map Account [Posting]
 -> Posting_Lengths
 -> Posting_Lengths
write_postings_lengths styles ps pl =
	Data.Foldable.foldr
	 (\p ->
		max
		 ( write_account_length (posting_type p) (posting_account p)
		 + write_amounts_length styles (posting_amounts p) )
	 ) pl
	 (Data.Functor.Compose.Compose ps)

-- * Write 'Transaction'

write_transaction :: Amount_Styles -> Transaction -> Doc
write_transaction styles t =
	write_transaction_with_lengths
	 styles (write_transaction_lengths styles t 0) t

write_transactions :: Foldable j => Amount_Styles -> j Transaction -> Doc
write_transactions styles j = do
	let transaction_lengths_ =
		Data.Foldable.foldr (write_transaction_lengths styles) 0 j
	Data.Foldable.foldr
	 (\t doc ->
		write_transaction_with_lengths styles transaction_lengths_ t <>
		(if W.is_empty doc then W.empty else W.line <> doc)
	 )
	 W.empty
	 j

write_transaction_with_lengths
 :: Amount_Styles
 -> Transaction_Lengths
 -> Transaction -> Doc
write_transaction_with_lengths
 styles
 posting_lengths_
 Transaction
 { transaction_code
 , transaction_comments_before
 , transaction_comments_after
 , transaction_dates=(first_date, dates)
 , transaction_postings
 , transaction_status
 -- , transaction_tags
 , transaction_wording
 } = do
	(case transaction_comments_before of
	 [] -> W.empty
	 _  -> write_comments W.space transaction_comments_before <> W.line) <> do
	(W.hcat $
		List.intersperse
		 (W.char Read.read_date_sep)
		 (write_date <$> (first_date:dates))) <> do
	(case transaction_status of
	 True -> W.space <> write_status transaction_status
	 False -> W.empty) <> do
	write_code transaction_code <> do
	(case transaction_wording of
	 "" -> W.empty
	 _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_wording)) <> do
	W.line <> do
	(case transaction_comments_after of
	 [] -> W.empty
	 _  -> write_comments W.space transaction_comments_after <> W.line) <> do
	W.intercalate W.line
	 (W.vsep . fmap (write_posting styles posting_lengths_))
	 transaction_postings
	 <> W.line

write_code :: Code -> Doc
write_code = \x -> case x of
	 "" -> W.empty
	 t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'

-- ** Type 'Transaction_Lengths'

type Transaction_Lengths = Posting_Lengths

write_transaction_lengths
 :: Amount_Styles
 -> Transaction
 -> Posting_Lengths
 -> Posting_Lengths
write_transaction_lengths
 styles
 Transaction
 { transaction_postings
 } posting_lengths = do
	List.foldl'
	 (flip $ write_postings_lengths styles)
	 posting_lengths
	 [ transaction_postings ]

-- * Write 'Journal'

write_journal
 :: ( Foldable j
    , Monoid (j Transaction)
    ) => Journal (j Transaction) -> Doc
write_journal Journal
 { journal_amount_styles
 , journal_content
 } = write_transactions journal_amount_styles journal_content

-- * Write 'Chart'

write_chart :: Chart -> Doc
write_chart =
	TreeMap.foldl_with_Path
	 (\doc acct (Account_Tags (Tags ca)) ->
		doc <>
		write_account Posting_Type_Regular acct <> W.line <>
		Map.foldlWithKey
		 (\dd tn tvs ->
			dd <>
			List.foldl'
			 (\ddd tv ->
				ddd <> W.char '\t' <> write_tag (tn, tv) <> W.line)
			 W.empty
			 tvs
		 )
		 W.empty
		 ca
	 ) W.empty .
	Chart.chart_accounts

-- * Type 'Write_Style'

data Write_Style
 =   Write_Style
 { write_style_align :: Bool
 , write_style_color :: Bool
 }
write_style :: Write_Style
write_style =
	Write_Style
	 { write_style_align = True
	 , write_style_color = True
	 }

-- * Write
write :: Write_Style -> Doc -> TL.Text
write Write_Style
 { write_style_color
 , write_style_align } =
	W.displayT .
	if write_style_align
	then W.renderPretty  write_style_color 1.0 maxBound
	else W.renderCompact write_style_color

writeIO :: Write_Style -> Doc -> Handle -> IO ()
writeIO Write_Style
 { write_style_color
 , write_style_align
 } doc handle =
	W.displayIO handle $
		if write_style_align
		then W.renderPretty  write_style_color 1.0 maxBound doc
		else W.renderCompact write_style_color doc