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

-- import Control.Monad (Monad)
-- import Data.Time.LocalTime (TimeZone(..))
-- import qualified Control.Monad.Classes as MC
-- import qualified Control.Monad.Trans.Reader as R
-- import qualified Data.Time.Calendar  as Time
-- import qualified Data.Time.LocalTime as Time
import Data.Bool
import Data.Char (Char)
import Data.Decimal
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), flip, id)
import Control.Monad (Monad(..))
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Maybe (Maybe(..))
import Data.Monoid ((<>))
import Data.Ord (Ord(..))
import Data.Tuple (fst)
import GHC.Exts (Int(..))
import GHC.Integer.Logarithms (integerLogBase#)
import Prelude (Bounded(..), Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral)
import System.IO (IO, Handle)
import Text.WalderLeijen.ANSI.Text (Doc)
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.MonoTraversable as MT
import qualified Data.NonNull as NonNull
import qualified Data.Strict as S
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.TreeMap.Strict as TreeMap
import qualified Text.WalderLeijen.ANSI.Text as W
import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as Enc

import qualified Hcompta as H

import Hcompta.LCC.Account
import Hcompta.LCC.Amount
import Hcompta.LCC.Chart
import Hcompta.LCC.Journal
import Hcompta.LCC.Name
import Hcompta.LCC.Posting
import Hcompta.LCC.Tag
import Hcompta.LCC.Transaction
import Hcompta.LCC.Grammar
import Hcompta.LCC.Compta
-- import qualified Hcompta.LCC.Lib.Strict as S

-- * 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_ymd_sep) <>
	doc_int2 mo <>
	sep char_ymd_sep <> doc_int2 d <>
	(case H.date_tod dat of
	 (0, 0, 0) -> W.empty
	 (h, m, s) ->
		sep '_' <> doc_int2 h <>
		sep ':' <> doc_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
	doc_int2 :: Int -> Doc
	doc_int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
	sep :: Char -> Doc
	sep = gray . W.char

width_date :: Date -> Int
width_date 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 ->
		gray (W.char char_account_sep) <>
		write_account_section a

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

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

-- ** Write 'Account_Ref'
write_account_ref :: Tag_Path -> Doc
write_account_ref (Tag_Path path) =
	W.hcat $
		(:) (op $ W.char char_account_tag_prefix) $
		List.intersperse
		 (op $ W.char char_tag_sep)
		 (W.strict_text . unName <$> NonNull.toNullable path)
	where op = W.bold . W.dullyellow

width_account_ref :: Tag_Path -> Int
width_account_ref (Tag_Path 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_Data value))) =
	W.hcat (
		(:) (op $ W.char char_account_tag_prefix) $
		List.intersperse
		 (op $ W.char char_tag_sep)
		 (W.strict_text . unName <$> NonNull.toNullable path) ) <>
	if Text.null value
	then W.empty
	else
		op (W.char char_tag_data_prefix) <>
		W.strict_text value
	where op = W.bold . W.dullyellow

-- * Write 'Amount'
write_amount :: Styled_Amount Amount -> Doc
write_amount
 ( sty@(Style_Amount
	 { style_amount_unit_side
	 , style_amount_unit_spaced
	 })
 , amt ) =
	let unt = amount_unit amt in
	case style_amount_unit_side of
	 S.Just L ->
		write_unit unt <>
		case style_amount_unit_spaced of
		 S.Just True | unt /= H.unit_empty -> W.space
		 _ -> W.empty
	 _ -> W.empty
	<> write_quantity (sty, amount_quantity amt)
	<> case style_amount_unit_side of
	 (S.Just R) ->
		(case style_amount_unit_spaced of
		 S.Just True | unt /= H.unit_empty -> W.space
		 _ -> W.empty) <>
		write_unit unt
	 S.Nothing ->
		(case style_amount_unit_spaced of
		 S.Just True | unt /= H.unit_empty -> W.space
		 _ -> W.empty) <>
		write_unit unt
	 _ -> W.empty

width_amount :: Styled_Amount Amount -> Int
width_amount (sty@(Style_Amount { style_amount_unit_spaced }), amt) =
	let unit = amount_unit amt in
	width_unit unit
	+ (case style_amount_unit_spaced of
		 S.Just True | unit /= H.unit_empty -> 1
		 _ -> 0)
	+ width_quantity 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, "\""]

width_unit :: Unit -> Int
width_unit 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 :: Styled_Amount Quantity -> Doc
write_quantity
 ( Style_Amount
	 { style_amount_fractioning
	 , style_amount_grouping_integral
	 , style_amount_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 style_amount_grouping_integral $
			del_grouping_sep style_amount_grouping_fractional $
			['.', ',']
		sign <>
		 W.bold (W.blue $
			W.text (TL.pack $ S.maybe id
			 (\g -> List.reverse . group g . List.reverse)
			 style_amount_grouping_integral $ int) <>
			W.yellow (W.char (S.fromMaybe default_fractioning style_amount_fractioning)) <>
			W.text (TL.pack $ S.maybe id group style_amount_grouping_fractional frac))
	where
	group :: Style_Amount_Grouping -> [Char] -> [Char]
	group (Style_Amount_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
		 S.Just (Style_Amount_Grouping sep _) -> List.delete sep
		 _ -> id

width_quantity :: Style_Amount -> Quantity -> Int
width_quantity Style_Amount
 { style_amount_grouping_integral
 , style_amount_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
	+ S.maybe 0 (group int_len)  style_amount_grouping_integral
	+ S.maybe 0 (group frac_len) style_amount_grouping_fractional
	)
	where
	group :: Int -> Style_Amount_Grouping -> Int
	group num_len (Style_Amount_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
 :: Context_Write
 -> Posting -> Doc
write_posting ctx
 Posting
 { posting_account
 , posting_account_ref
 , posting_amounts
 , posting_comments=cmts
 -- , posting_dates
 -- , posting_tags
 } =
	W.string "  " <>
	let (doc_acct, wi_acct) =
		case posting_account_ref of
		 S.Just (a S.:!: sa) | context_write_account_ref ctx ->
			( write_account_ref a <> S.maybe W.empty write_account sa
			, width_account_ref a +  S.maybe 0       width_account sa )
		 _ ->
			( write_account posting_account
			, width_account posting_account ) in
	(case posting_amounts of
	 Amounts amts | Map.null amts -> doc_acct
	 Amounts amts ->
		Map.foldlWithKey
		 (\doc unit qty ->
			let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
			let wi_amt = width_amount amt in
			doc <>
			(if W.is_empty doc then W.empty else W.line <> W.string "  ") <>
			doc_acct <>
			W.fill (context_write_max_posting_width ctx - (wi_acct + wi_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 'Widths_Posting'
type Widths_Posting = Int

widths_postings
 :: Context_Write
 -> Postings
 -> Widths_Posting
widths_postings ctx (Postings ps) =
	foldr (\p -> max $
		((case posting_account_ref p of
			 S.Just (a S.:!: sa) | context_write_account_ref ctx ->
				width_account_ref a +
				S.maybe 0 width_account sa
			 _ -> width_account (posting_account p)
		 ) +) $
		(\len -> if len > 0 then 1 + len else len) $
		Map.foldrWithKey
		 (\unit qty -> max $
			width_amount $
			styled_amount (context_write_amounts ctx) $
			Amount unit qty)
		 0 (unAmounts $ posting_amounts p)
	 ) 0
	 (Compose ps)

-- * Write 'Transaction'
write_transaction
 :: Context_Write
 -> Transaction -> Doc
write_transaction ctx
 t@Transaction
 { transaction_comments
 , transaction_dates
 , transaction_wording  = Wording transaction_wording
 , transaction_postings = Postings transaction_postings
 , transaction_tags     = Transaction_Tags (Tags tags)
 } =
	let ctx' = ctx { context_write_max_posting_width =
		let wi = context_write_max_posting_width ctx in
		if wi == 0
		then widths_transaction ctx t
		else wi } in
	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) <>
	TreeMap.foldr_with_Path
	 (\path -> flip $
		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 ctx' <$>))
	 transaction_postings

write_transactions
 :: Foldable j
 => Context_Write
 -> j Transaction -> Doc
write_transactions ctx j =
	let ctx' = ctx{context_write_max_posting_width =
		foldr (max . widths_transaction ctx) 0 j} in
	foldr (\t doc ->
		write_transaction ctx' t <>
		(if W.is_empty doc then W.line else W.line <> W.line <> doc)
	 ) W.empty j

-- ** Type 'Widths_Transaction'
type Widths_Transaction = Widths_Posting

widths_transaction :: Context_Write -> Transaction -> Widths_Posting
widths_transaction ctx
 Transaction
 { transaction_postings
 } =
	foldr
	 (max . widths_postings ctx)
	 0 [ transaction_postings ]

-- ** Write 'Transaction_Tag'
write_transaction_tag :: Transaction_Tag -> Doc
write_transaction_tag (Transaction_Tag (Tag (Tag_Path path) (Tag_Data value))) =
	W.hcat (
		(:) (W.bold $ W.dullyellow $ W.char char_tag_prefix) $
		List.intersperse
		 (op $ W.char char_tag_sep)
		 (write_transaction_tag_section <$> NonNull.toNullable path)) <>
	if Text.null value
	then W.empty
	else
		op (W.char char_tag_data_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 'Journal'
write_journal :: Foldable j => Context_Write -> Journal (j [Transaction]) -> Doc
write_journal ctx jnl =
	write_transactions ctx $
	Compose $ journal_content jnl

-- * Write 'Journals'
write_journals :: Foldable j => Context_Write -> Journals (j [Transaction]) -> Doc
write_journals ctx (Journals js) =
	Map.foldl
	 (\doc j@Journal{journal_file=PathFile jf, journal_content=jc} ->
		doc <>
		write_comment (Comment $ Text.pack jf) <> W.line <>
		if null jc then W.empty else (W.line <> write_journal ctx j)
	 ) W.empty js

-- * 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 <>
			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

-- * Write 'Terms'

write_terms :: Terms -> Doc
write_terms ts =
	Map.foldl
	 (\doc t ->
		doc <>
		W.strict_text t <>
		W.line
	 ) W.empty ts

-- * Write 'Compta'
write_compta :: Context_Write -> Compta src ss -> Doc
write_compta ctx Compta
 { compta_journals=js
 , compta_chart=c@Chart{chart_accounts=ca}
 , compta_style_amounts=amts
 , compta_terms=ts
 } =
	(if null ts then W.empty else (write_terms ts <> W.line)) <>
	(if TreeMap.null ca then W.empty else (write_chart c <> W.line)) <>
	write_journals ctx{context_write_amounts=context_write_amounts ctx <> amts} js

-- * Write 'SourcePos'
write_sourcepos :: SourcePos -> IO Doc
write_sourcepos (SourcePos p (PosFile l) (PosFile c)) = do
	content <- Enc.decodeUtf8 <$> BS.readFile p
	let ls = Text.lines content
	let ll = max 1 $ l - size_ctx
	let qs =
		List.take (intFrom $ (l - ll) + 1 + size_ctx) $
		List.drop (intFrom $ ll-1) ls
	let ns = show <$> List.take (List.length qs) [ll..]
	let max_len_n = maximum $ List.length <$> ns
	let ns' = (<$> ns) $ \n ->
		List.replicate (max_len_n - List.length n) ' ' <> n
	let quote =
		W.vcat $
		List.zipWith (\(n, sn) q ->
			"  " <> gray (W.strict_text (Text.pack sn)) <>
			"  " <> (if n == l then mark q else W.strict_text q)
		 ) (List.zip [ll..] ns') qs
	return $ quote <> W.line
	where
	size_ctx = 2
	intFrom = fromInteger . toInteger
	mark q =
		let (b, a) = Text.splitAt (intFrom c - 1) q in
		W.strict_text b <>
		case Text.uncons a of
		 Nothing -> red " "
		 Just (a0, a') -> red (W.char a0) <> W.strict_text a'

gray :: Doc -> Doc
gray = W.bold . W.dullblack

red :: Doc -> Doc
red = W.onred


-- Type 'Context_Write'
data Context_Write
 =   Context_Write
 {   context_write_account_ref       :: Bool
 ,   context_write_amounts           :: Style_Amounts
 ,   context_write_max_posting_width :: Int
 }

context_write :: Context_Write
context_write =
	Context_Write
	 { context_write_account_ref       = True
	 , context_write_amounts           = Style_Amounts Map.empty
	 , context_write_max_posting_width = 0
	 }

{-
type Style_Anchor = Bool
type instance MC.CanDo (S.ReaderT Context_Write m) (MC.EffReader Context_Write) = 'True
instance Monad m => MC.MonadReaderN 'MC.Zero Context_Write (S.ReaderT Context_Write m) where
	askN _px = S.ReaderT R.ask
type instance MC.CanDo (S.ReaderT Context_Write m) (MC.EffReader Style_Anchor) = 'True
instance Monad m => MC.MonadReaderN 'MC.Zero Style_Anchor (S.ReaderT Context_Write m) where
	askN _px = S.ReaderT $ R.asks $ Style_Anchor . context_write_account_ref
-}

-- * Type 'Style_Write'
data Style_Write
 =   Style_Write
 {   style_write_align :: Bool
 ,   style_write_color :: Bool
 }
style_write :: Style_Write
style_write =
	Style_Write
	 { style_write_align = True
	 , style_write_color = True
	 }

-- * Write
write :: Style_Write -> Doc -> TL.Text
write Style_Write
 { style_write_color
 , style_write_align } =
	W.displayT .
	if style_write_align
	then W.renderPretty  style_write_color 1.0 maxBound
	else W.renderCompact style_write_color

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