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

import           Data.Bool
import           Data.Char (Char)
import qualified Data.Char as Char
import           Data.Decimal
import           Data.Eq (Eq(..))
import           Data.Foldable (Foldable)
import qualified Data.Foldable as Foldable
import           Data.Function (($), (.), flip, id)
import           Data.Functor ((<$>))
import qualified Data.Functor.Compose
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..), maybe, fromMaybe)
import           Data.Monoid ((<>))
import qualified Data.MonoTraversable as MT
import qualified Data.NonNull as NonNull
import           Data.Ord (Ord(..))
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.TreeMap.Strict as TreeMap
import           Data.Tuple (fst)
import           GHC.Exts (Int(..))
import           GHC.Integer.Logarithms (integerLogBase#)
import           Prelude (Bounded(..), Integer, Num(..), RealFrac(..), Show(..), fromIntegral)
import           System.IO (IO, Handle)
import           Text.WalderLeijen.ANSI.Text (Doc)
import qualified Text.WalderLeijen.ANSI.Text as W

import qualified Hcompta as H

import Hcompta.LCC.Account
import Hcompta.LCC.Amount
import Hcompta.LCC.Anchor
import Hcompta.LCC.Chart
import Hcompta.LCC.Journal
import Hcompta.LCC.Name
import Hcompta.LCC.Posting
import Hcompta.LCC.Read
import Hcompta.LCC.Tag
import Hcompta.LCC.Transaction

-- * Write 'Date'
write_date :: 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 char_date_ymd_sep) <>
	int2 mo <>
	sep char_date_ymd_sep <> int2 d <>
	(case H.date_tod dat of
	 (0, 0, 0) -> W.empty
	 (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 :: 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
	 (0, 0, 0) -> 0
	 (_, _, s) ->
		1 -- _
		+ 2 -- hour
		+ 1 -- :
		+ 2 -- min
		+ (case s of
		 0 -> 0
		 _ -> 1 + 2 -- : sec
		)
	)

-- * Write 'Account'
write_account :: Account -> Doc
write_account =
	MT.ofoldMap $ \a ->
		W.bold (W.dullblack $ W.char char_account_sep) <>
		write_account_section a

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

write_account_length :: Account -> Int
write_account_length =
	MT.ofoldl'
	 (\acc -> (1 +) . (acc +) . Text.length . unName)
	 0

-- ** Write 'Account_Anchor'
write_account_anchor :: Account_Anchor -> Doc
write_account_anchor (Account_Anchor (Anchor anchor)) =
	W.hcat $
		(:) (op $ W.char char_account_anchor_prefix) $
		List.intersperse
		 (op $ W.char char_account_anchor_sep)
		 (W.strict_text . unName <$> NonNull.toNullable anchor)
	where op = W.bold . W.dullyellow

write_account_anchor_length :: Account_Anchor -> Int
write_account_anchor_length (Account_Anchor anch) =
	MT.ofoldl'
	 (\acc -> (1 +) . (acc +) . MT.olength)
	 0 anch

-- ** Write 'Account_Tag'
write_account_tag :: Account_Tag -> Doc
write_account_tag (Account_Tag (Tag (Tag_Path path) (Tag_Value value))) =
	W.hcat (
		(:) (op $ W.char char_account_tag_prefix) $
		List.intersperse
		 (op $ W.char char_tag_section_sep)
		 (W.strict_text . unName <$> NonEmpty.toList path) ) <>
	if Text.null value
	then W.empty
	else
		op (W.char char_tag_value_prefix) <>
		W.strict_text value
	where op = W.bold . W.dullyellow

-- * 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_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, 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 unit = amount_unit amt in
	write_unit_length unit
	+ (case amount_style_unit_spaced of
		 Just True | unit /= H.unit_empty -> 1
		 _ -> 0)
	+ write_quantity_length sty (amount_quantity amt)

-- * 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 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 <>
		 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 (Comment com) =
	W.cyan $
		W.char char_comment_prefix
		<> (case Text.uncons com of
		 Just (c, _) | not $ Char.isSpace c -> W.space
		 _ -> W.empty)
		<> W.strict_text com

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

-- * Write 'Posting'
write_posting :: Amount_Styles -> Posting_Lengths -> Posting -> Doc
write_posting styles max_posting_length
 Posting
 { posting_account
 , posting_account_anchor
 , posting_amounts
 , posting_comments=cmts
 -- , posting_dates
 -- , posting_tags
 } =
	W.string "  " <>
	let (doc_acct, len_acct) =
		case posting_account_anchor of
		 Nothing ->
			( write_account        posting_account
			, write_account_length posting_account )
		 Just (a, sa) ->
			( write_account_anchor        a <> maybe W.empty write_account sa
			, write_account_anchor_length a + maybe 0 write_account_length sa ) in
	(case posting_amounts of
	 Amounts amts | Map.null amts -> doc_acct
	 Amounts amts ->
		Map.foldlWithKey
		 (\doc unit qty ->
			let amt = amount_styled styles $ Amount unit qty in
			let len_amt = write_amount_length amt in
			doc <>
			(if W.is_empty doc then W.empty else W.line <> W.string "  ") <>
			doc_acct <>
			W.fill (max_posting_length - (len_acct + len_amt)) W.space <>
			write_amount amt
		 ) W.empty amts) <>
	(case cmts of
	 []  -> W.empty
	 [c] -> W.space <> write_comment c
	 _   -> W.line  <> write_comments (W.text "   ") cmts)

-- ** Type 'Posting_Lengths'
type Posting_Lengths = Int

write_postings_lengths
 :: Amount_Styles
 -> Postings
 -> Posting_Lengths
 -> Posting_Lengths
write_postings_lengths styles (Postings ps) pl =
	Foldable.foldr (\Posting{posting_account=acct, posting_amounts=Amounts amts} -> max $
		(write_account_length acct +) $
		(\len -> if len > 0 then 1 + len else len) $
		Map.foldrWithKey
		 (\unit qty -> max $
			write_amount_length $
			amount_styled styles $
			Amount unit qty)
		 0 amts
	 ) 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_ =
		Foldable.foldr (write_transaction_lengths styles) 0 j
	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_comments
 , transaction_dates
 , transaction_wording=Wording transaction_wording
 , transaction_postings=Postings transaction_postings
 , transaction_anchors=Transaction_Anchors (Anchors anchors)
 , transaction_tags=Transaction_Tags (Tags tags)
 } =
	W.hcat (
		List.intersperse
		 (W.char char_transaction_date_sep)
		 (write_date <$> NonNull.toNullable transaction_dates)) <>
	(case transaction_wording of
	 "" -> W.empty
	 _  -> W.space <> W.dullmagenta (W.strict_text transaction_wording)) <>
	W.line <>
	(case transaction_comments of
	 [] -> W.empty
	 _  -> write_comments W.space transaction_comments <> W.line) <>
	Map.foldrWithKey
	 (\path () -> ((W.string "  " <>
		write_transaction_anchor (Transaction_Anchor path) <> W.line) <>))
	 W.empty anchors <>
	TreeMap.foldr_with_Path
	 (\path -> flip $
		Foldable.foldr (\value -> (<>) (W.string "  " <>
		write_transaction_tag (Transaction_Tag (Tag (Tag_Path path) value)) <> W.line)))
	 W.empty tags <>
	W.intercalate W.line
	 (W.vsep . (write_posting styles posting_lengths_ <$>))
	 transaction_postings <> W.line

-- ** 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 'Transaction_Tag'
write_transaction_tag :: Transaction_Tag -> Doc
write_transaction_tag (Transaction_Tag (Tag (Tag_Path path) (Tag_Value value))) =
	W.hcat (
		(:) (W.bold $ W.dullyellow $ W.char char_transaction_tag_prefix) $
		List.intersperse
		 (op $ W.char char_tag_section_sep)
		 (write_transaction_tag_section <$> NonEmpty.toList path)) <>
	if Text.null value
	then W.empty
	else
		op (W.char char_tag_value_prefix) <>
		W.strict_text value
	where
		op = W.bold . W.yellow

write_transaction_tag_section :: Name -> Doc
write_transaction_tag_section = W.bold . W.strict_text . unName

-- ** Write 'Transaction_Anchor'
write_transaction_anchor :: Transaction_Anchor -> Doc
write_transaction_anchor (Transaction_Anchor (Anchor anch)) =
	W.hcat $
		(:) (op $ W.char char_transaction_anchor_prefix) $
		List.intersperse
		 (op $ W.char char_anchor_section_sep)
		 (write_transaction_anchor_section <$> NonNull.toNullable anch)
	where
		op = W.bold . W.yellow

write_transaction_anchor_section :: Name -> Doc
write_transaction_anchor_section = W.bold . W.strict_text . unName

-- * Write 'Journal'
write_journal :: Foldable j => 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 (H.get acct) <> W.line <>
		TreeMap.foldl_with_Path
		 (\dd tp tvs ->
			dd <>
			Foldable.foldl'
			 (\ddd tv ->
				ddd <> W.string "  " <>
				write_account_tag (Account_Tag (Tag (Tag_Path tp) 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