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

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


import qualified Hcompta as H
import           Text.WalderLeijen.ANSI.Text (Doc)
import qualified Text.WalderLeijen.ANSI.Text as W

import           Hcompta.Ledger.Account
import           Hcompta.Ledger.Amount
import           Hcompta.Ledger.Chart
import           Hcompta.Ledger.Posting
import           Hcompta.Ledger.Transaction
import           Hcompta.Ledger.Journal
import           Hcompta.Ledger.Read

-- * Write 'Date'

write_date :: H.Date -> Doc
write_date dat =
	let (y, mo, d) = H.date_gregorian dat in
	(if y == 0 then W.empty else W.integer y <> sep '-') <>
	int2 mo <>
	sep '-' <> int2 d <>
	(case H.date_tod dat of
	 Time.TimeOfDay 0 0 0 -> W.empty
	 Time.TimeOfDay h m s ->
		sep '_' <> int2 h <>
		sep ':' <> int2 m <>
		(case s of
		 0 -> W.empty
		 _ -> sep ':' <>
			(if s < 10 then W.char '0' else W.empty) <>
			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 :: H.Date -> Int
write_date_length dat = do
	let (y, _, _) = H.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 H.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_posting_type_virtual_begin <>
		account_ acct <>
		W.char read_posting_type_virtual_end
	 Posting_Type_Virtual_Balanced -> \acct ->
		W.char read_posting_type_virtual_balanced_begin <>
		account_ acct <>
		W.char 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_account_section_sep)
				 (Data.List.NonEmpty.map write_account_section acct)

write_account_section :: Account_Section -> 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 = H.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 /= H.unit_empty -> W.space
		 _ -> W.empty
	 _ -> W.empty
	<> write_quantity (sty, H.amount_quantity amt)
	<> case amount_style_unit_side of
	 (Just Amount_Style_Side_Right) ->
		(case amount_style_unit_spaced of
		 Just True | unt /= H.unit_empty -> W.space
		 _ -> W.empty) <>
		write_unit unt
	 Nothing ->
		(case amount_style_unit_spaced of
		 Just True | unt /= H.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 = H.amount_unit amt in
	write_unit_length unt
	+ (case amount_style_unit_spaced of
		 { Just True | unt /= H.unit_empty -> 1; _ -> 0 })
	+ write_quantity_length sty (H.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_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 = H.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 = H.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 "")
	if e == 0
	 then sign <> W.bold (W.blue $ W.strict_text $ Text.pack num)
	 else
		let num_len = List.length num in
		let padded =
			List.concat
			 [ List.replicate (fromIntegral e + 1 - num_len) '0'
			 , num
			 -- , replicate (fromIntegral precision - fromIntegral e) '0'
			 ] in
		let (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded in
		let default_fractioning =
			List.head $
			del_grouping_sep amount_style_grouping_integral $
			del_grouping_sep amount_style_grouping_fractional $
			['.', ','] in
		sign <>
		W.bold (W.blue $
			W.text (TL.pack $ maybe id
			 (\g -> List.reverse . group g . List.reverse)
			 amount_style_grouping_integral $ int) <>
			W.yellow (W.char (fromMaybe default_fractioning amount_style_fractioning)) <>
			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 $
		W.char read_comment_prefix
		<> (case Text.uncons com of
		 Just (c, _) | not $ Data.Char.isSpace c -> W.space
		 _ -> W.empty)
		<> 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_tag_value_sep
						 && not (Data.Char.isSpace c))
					sh <- R.spaceHorizontal
					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 =
			(<>)
			 <$> 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_tag_sep
					sh <- R.many R.spaceHorizontal
					return $
						W.cyan (W.char s) <>
						W.text (TL.pack sh)
				tag_ :: Stream s m Char => ParsecT s u m Doc
				tag_ = do
					(p, v) <- read_tag
					return $
						foldMap (\s -> W.dullyellow (W.strict_text s) <>
							W.bold (W.dullblack $ W.char 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 :: H.Tag -> Doc
write_tag (p, v) =
	foldMap (\s ->
		W.dullyellow (W.strict_text s) <>
		W.char 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
 } =
	let type_ = posting_type p in
	write_indent <>
	write_status posting_status <>
		if Map.null posting_amounts
		 then write_account type_ posting_account
		 else
			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 <>
			W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <>
			write_amounts styles posting_amounts
	<> (case posting_comments of
	 [] -> W.empty
	 [c] -> W.space <> write_comment c
	 _ -> W.line <> write_comments (write_indent <> W.space) posting_comments)

write_indent :: Doc
write_indent = W.space <> W.space

write_status :: Status -> Doc
write_status s =
	if s
	 then W.char '!'
	 else 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
 } =
	(case transaction_comments_before of
	 [] -> W.empty
	 _  -> write_comments W.space transaction_comments_before <> W.line) <>
	W.hcat
	 (List.intersperse
		 (W.char read_date_ymd_sep)
		 (write_date <$> (first_date:dates))) <>
	(if transaction_status
	 then W.space <> write_status transaction_status
	 else W.empty) <>
	write_code transaction_code <>
	(case transaction_wording of
	 "" -> W.empty
	 _  -> W.space <> W.dullmagenta (W.strict_text transaction_wording)) <>
	W.line <>
	(case transaction_comments_after of
	 [] -> W.empty
	 _  -> write_comments W.space transaction_comments_after <> W.line) <>
	W.intercalate W.line
	 (W.vsep . fmap (write_posting styles posting_lengths_))
	 transaction_postings
	 <> W.line

write_code :: Code -> Doc
write_code c =
	case c 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 =
	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 (H.Account_Tags (H.Tags ca)) ->
		doc <>
		write_account Posting_Type_Regular acct <> W.line <>
		Map.foldlWithKey
		 (\dd tn tvs ->
			dd <>
			List.foldl'
			 (\ddd tv ->
				ddd <> write_indent <> write_tag (tn, tv) <> W.line)
			 W.empty
			 tvs
		 )
		 W.empty
		 ca
	 ) W.empty .
	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