{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Hcompta.JCC.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           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..), maybe, fromMaybe)
import           Data.Monoid (Monoid(..), (<>))
import           Data.Ord (Ord(..))
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           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.JCC.Account
import Hcompta.JCC.Amount
import Hcompta.JCC.Chart
import Hcompta.JCC.Posting
import Hcompta.JCC.Transaction
import Hcompta.JCC.Journal
import Hcompta.JCC.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 read_date_ymd_sep) <>
	int2 mo <>
	sep read_date_ymd_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 :: Account -> Doc
write_account =
	Foldable.foldMap $ \a ->
		W.bold (W.dullblack $ W.char read_account_section_sep) <>
		write_account_section a

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

write_account_length :: Account -> Int
write_account_length =
	Foldable.foldl
	 (\acc -> (1 +) . (acc +) . Text.length)
	 0

-- ** Write 'Account_Anchor'

write_account_anchor :: H.Account_Anchor -> Doc
write_account_anchor (H.Account_Anchor anchor) =
	W.hcat $
		(:) (op $ W.char read_account_anchor_prefix) $
		NonEmpty.toList $
		NonEmpty.intersperse
		 (op $ W.char read_account_anchor_sep)
		 (W.strict_text <$> anchor)
	where op = W.bold . W.dullyellow

write_account_anchor_length :: H.Account_Anchor -> Int
write_account_anchor_length (H.Account_Anchor anch) =
	Foldable.foldl
	 (\acc -> (1 +) . (acc +) . Text.length)
	 0 anch

-- ** Write 'Account_Tag'

write_account_tag :: H.Account_Tag -> Doc
write_account_tag (H.Account_Tag (path, value)) =
	W.hcat (
		(:) (op $ W.char read_account_tag_prefix) $
		NonEmpty.toList $
		NonEmpty.intersperse
		 (op $ W.char read_account_tag_sep)
		 (W.strict_text <$> path) ) <>
	if Text.null value
	then W.empty
	else
		op (W.char read_account_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 = 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 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 com =
	W.cyan $
		W.char read_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
	if Map.null posting_amounts
	 then doc_acct
	 else
		let len_amts = write_amounts_length styles posting_amounts in
		doc_acct <>
		W.fill (1 + max_posting_length - (len_acct + len_amts)) W.space <>
		write_amounts styles posting_amounts <>
	(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
 -> Map Account [Posting]
 -> Posting_Lengths
 -> Posting_Lengths
write_postings_lengths styles ps pl =
	Foldable.foldr (\p ->
		max
		 ( write_account_length (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_ =
		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=(first_date, dates)
 , transaction_wording
 , transaction_postings
 , transaction_anchors=H.Transaction_Anchors (H.Anchors anchors)
 , transaction_tags=H.Transaction_Tags (H.Tags tags)
 } =
	W.hcat (
		List.intersperse
		 (W.char read_transaction_date_sep)
		 (write_date <$> (first_date: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 (H.Transaction_Anchor path) <> W.line) <>))
	 W.empty anchors <>
	Map.foldrWithKey
	 (\path -> flip $
		Foldable.foldr (\value -> (<>) (W.string "  " <>
		write_transaction_tag (H.Transaction_Tag (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 :: H.Transaction_Tag -> Doc
write_transaction_tag (H.Transaction_Tag (path, value)) =
	W.hcat (
		(:) (W.bold $ W.dullyellow $ W.char read_transaction_tag_prefix) $
		NonEmpty.toList $
		NonEmpty.intersperse
		 (op $ W.char read_transaction_tag_sep)
		 (write_transaction_tag_section <$> path)) <>
	if Text.null value
	then W.empty
	else
		op (W.char read_transaction_tag_value_prefix) <>
		W.strict_text value
	where
		op = W.bold . W.yellow

write_transaction_tag_section :: H.Tag_Section -> Doc
write_transaction_tag_section = W.bold . W.strict_text

-- ** Write 'Transaction_Anchor'

write_transaction_anchor :: H.Transaction_Anchor -> Doc
write_transaction_anchor (H.Transaction_Anchor path) =
	W.hcat $
		(:) (op $ W.char read_transaction_anchor_prefix) $
		NonEmpty.toList $
		NonEmpty.intersperse
		 (op $ W.char read_transaction_anchor_sep)
		 (write_transaction_anchor_section <$> path)
	where
		op = W.bold . W.yellow

write_transaction_anchor_section :: H.Anchor_Section -> Doc
write_transaction_anchor_section = W.bold . W.strict_text

-- * 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 acct <> W.line <>
		Map.foldlWithKey
		 (\dd tn tvs ->
			dd <>
			Foldable.foldl'
			 (\ddd tv ->
				ddd <> W.string "  " <>
				write_account_tag (H.Account_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