{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Hcompta.LCC.Document where

import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Decimal
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), flip, id)
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Tuple (fst)
import GHC.Exts (Int(..))
import Prelude (Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral)
import qualified Data.ByteString as BS
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.Encoding as Enc
import qualified Data.TreeMap.Strict as TreeMap

import qualified Language.Symantic.Document as D

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 Debug.Trace (trace)
-- dbg msg x = trace (msg <> " = " <> show x) x

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

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

-- * Document 'Date'
d_date dat =
	let (y, mo, d) = H.date_gregorian dat in
	(if y == 0 then D.empty else D.integer y <> sep char_ymd_sep) <>
	int2 mo <>
	sep char_ymd_sep <> int2 d <>
	(case H.date_tod dat of
	 (0, 0, 0) -> D.empty
	 (h, m, s) ->
		sep '_' <> int2 h <>
		sep ':' <> int2 m <>
		(case s of
		 0 -> D.empty
		 _ -> sep ':' <>
			(if s < 10 then D.charH '0' else D.empty) <>
			D.integer ((truncate s::Integer))))
	where
	int2 i = (if i < 10 then D.charH '0' else D.empty) <> D.int i
	sep = D.blacker . D.charH

-- * Document 'Account'
d_account (acct::Account) =
	(`MT.ofoldMap` acct) $ \a ->
		D.blacker (D.charH char_account_sep) <>
		d_account_section a
w_account = D.width . D.dim . d_account

d_account_section = D.textH . unName

-- ** Document 'Account_Ref'
d_account_ref (Tag_Path path) =
	D.catH $
		(:) (op $ D.charH char_account_tag_prefix) $
		List.intersperse
		 (op $ D.charH char_tag_sep)
		 (D.textH . unName <$> NonNull.toNullable path)
	where op = D.yellower
w_account_ref = D.width . D.dim . d_account_ref

-- ** Document 'Account_Tag'
d_account_tag (Account_Tag (Tag (Tag_Path path) (Tag_Data value))) =
	D.catH (
		(:) (op $ D.charH char_account_tag_prefix) $
		List.intersperse
		 (op $ D.charH char_tag_sep)
		 (D.textH . unName <$> NonNull.toNullable path) ) <>
	if Text.null value
	then D.empty
	else
		op (D.charH char_tag_data_prefix) <>
		D.textH value
	where op = D.yellower

-- * Document 'Amount'
d_amount
 ( sty@(Style_Amount
	 { style_amount_unit_side=uside
	 , style_amount_unit_spaced=uspaced
	 })
 , Amount u q ) =
	case uside of
	 S.Just L ->
		d_unit u <>
		case uspaced of
		 S.Just True | u /= H.unit_empty -> D.space
		 _ -> D.empty
	 _ -> D.empty
	<> d_quantity (sty, q)
	<> case uside of
	 S.Just R ->
		(case uspaced of
		 S.Just True | u /= H.unit_empty -> D.space
		 _ -> D.empty) <>
		d_unit u
	 S.Nothing ->
		(case uspaced of
		 S.Just True | u /= H.unit_empty -> D.space
		 _ -> D.empty) <>
		d_unit u
	 _ -> D.empty
w_amount = D.width . D.dim . d_amount

-- * Document 'Unit'
d_unit u =
	let t = H.unit_text u in
	D.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 D.textH t
	else D.dquote $ D.textH t

-- * Document 'Quantity'
d_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 = D.bold $ D.yellow $ D.textH (if n < 0 then "-" else "")
	if e == 0
	 then sign <> D.bold (D.blue $ D.stringH 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 <>
		 D.bold (D.blue $
			D.stringH (S.maybe id
			 (\g -> List.reverse . group g . List.reverse)
			 style_amount_grouping_integral $ int) <>
			D.yellow (D.charH (S.fromMaybe default_fractioning style_amount_fractioning)) <>
			D.stringH (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

-- * Document 'Comment'
d_comment (Comment com) =
	D.cyan $
		D.charH char_comment_prefix
		<> (case Text.uncons com of
		 Just (c, _) | not $ Char.isSpace c -> D.space
		 _ -> D.empty)
		<> D.textH com

d_comments prefix =
	D.catH .
	List.intersperse D.eol .
	List.map (\c -> prefix <> d_comment c)

-- * Document 'Posting'
d_posting ctx
 Posting
 { posting_account
 , posting_account_ref
 , posting_amounts
 , posting_comments
 -- , posting_dates
 -- , posting_tags
 } =
	let d_indent = D.spaces 2 in
	d_indent <>
	let (doc_acct, w_acct) =
		case posting_account_ref of
		 S.Just (a S.:!: sa) | context_write_account_ref ctx ->
			( d_account_ref a <> S.maybe D.empty d_account sa
			, w_account_ref a +  S.maybe 0       w_account sa )
		 _ -> (d_account posting_account, w_account posting_account) in
	(case posting_amounts of
	 Amounts amts | Map.null amts -> doc_acct
	 Amounts amts ->
		fromMaybe D.empty $
		Map.foldlWithKey
		 (\mdoc unit qty -> Just $
			let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
			let pad = max 0 $ context_write_width_acct_amt ctx - (w_acct + w_amount amt) in
			(case mdoc of
			 Nothing -> D.empty
			 Just doc -> doc <> D.eol <> d_indent) <>
			doc_acct <> D.spaces pad <> D.space <> d_amount amt
		 ) Nothing amts) <>
	(case posting_comments of
	 []  -> D.empty
	 [c] -> D.space <> d_comment c
	 _   -> D.eol   <> d_comments (d_indent <> D.space) posting_comments)
w_posting  ctx = D.width . D.dim . d_posting ctx

-- * Document 'Transaction'
d_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_width_acct_amt =
		let w = context_write_width_acct_amt ctx in
		if w == 0
		then w_postings_acct_amt ctx t
		else w } in
	D.catH (
		List.intersperse
		 (D.charH char_transaction_date_sep)
		 (d_date <$> NonNull.toNullable transaction_dates)) <>
	(case transaction_wording of
	 "" -> D.empty
	 _  -> D.space <> D.magenta (D.textH transaction_wording)) <>
	D.eol <>
	(case transaction_comments of
	 [] -> D.empty
	 _  -> d_comments D.space transaction_comments <> D.eol) <>
	TreeMap.foldr_with_Path
	 (\path -> flip $
		foldr (\value -> (<>) (D.spaces 2 <>
		d_transaction_tag (Transaction_Tag (Tag (Tag_Path path) value)) <> D.eol)))
	 D.empty tags <>
	D.catV (d_posting ctx' <$> Compose transaction_postings)

d_transactions ctx j =
	let ctx' = ctx{context_write_width_acct_amt =
		foldr (max . w_postings_acct_amt ctx) 0 j} in
	fromMaybe D.empty $
	foldr (\t mdoc -> Just $
		d_transaction ctx' t <>
		case mdoc of
		 Nothing  -> D.eol
		 Just doc -> D.eol <> D.eol <> doc
	 ) Nothing j

-- w_postings ctx = MT.ofoldr (max . w_posting ctx) 0
-- | Return the width of given 'Postings',
-- considering only 'Account's and 'Amount's (not indentation, 'Comment's, nor 'Posting_Tag's).
w_postings_acct_amt :: H.Get Postings a => Context_Write -> a -> Int
w_postings_acct_amt ctx =
	MT.ofoldr (\Posting
	 { posting_account
	 , posting_account_ref
	 , posting_amounts
	 } -> max $
		let w_acct =
			case posting_account_ref of
			 S.Just (a S.:!: sa) | context_write_account_ref ctx ->
				w_account_ref a + S.maybe 0 w_account sa
			 _ -> w_account posting_account in
		let w_amt =
			case posting_amounts of
			 Amounts amts | Map.null amts -> 0
			 Amounts amts ->
				Map.foldrWithKey
				 (\unit qty -> max $
					let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
					w_amount amt)
				 1 amts in
		w_acct + w_amt
	 ) 0 .
	H.get @Postings

-- ** Document 'Transaction_Tag'
d_transaction_tag (Transaction_Tag (Tag (Tag_Path path) (Tag_Data value))) =
	D.catH (
		(:) (op $ D.charH char_tag_prefix) $
		List.intersperse
		 (op $ D.charH char_tag_sep)
		 (d_transaction_tag_section <$> NonNull.toNullable path)) <>
	if Text.null value
	then D.empty
	else op (D.charH char_tag_data_prefix) <> D.textH value
	where
	op = D.yellower

d_transaction_tag_section = D.bold . D.textH . unName

-- * Document 'Journal'
d_journal ctx jnl =
	d_transactions ctx $
	Compose $ journal_content jnl

-- * Document 'Journals'
d_journals ctx (Journals js) =
	Map.foldl
	 (\doc j@Journal{journal_file=PathFile jf, journal_content=jc} ->
		doc <>
		d_comment (Comment $ Text.pack jf) <> D.eol <>
		if null jc then D.empty else (D.eol <> d_journal ctx j)
	 ) D.empty js

-- * Document 'Chart'
d_chart =
	TreeMap.foldl_with_Path
	 (\doc acct (Account_Tags (Tags ca)) ->
		doc <>
		d_account (H.get acct) <> D.eol <>
		TreeMap.foldl_with_Path
		 (\doc' tp tvs ->
			doc' <>
			foldl'
			 (\doc'' tv ->
				doc'' <> D.spaces 2 <>
				d_account_tag (Account_Tag (Tag (Tag_Path tp) tv)) <>
				D.eol)
			 D.empty
			 tvs)
		 D.empty
		 ca
	 ) D.empty .
	chart_accounts

-- * Document 'Terms'
d_terms (ts::Terms) =
	Map.foldl (\doc t -> doc <> D.text t <> D.eol) D.empty ts

-- * Document 'Compta'
d_compta ctx Compta
 { compta_journals=js
 , compta_chart=c@Chart{chart_accounts=ca}
 , compta_style_amounts=amts
 , compta_terms=ts
 } =
	(if null ts then D.empty else (d_terms ts <> D.eol)) <>
	(if TreeMap.null ca then D.empty else (d_chart c <> D.eol)) <>
	d_journals ctx{context_write_amounts=context_write_amounts ctx <> amts} js

-- * Document 'SourcePos'
d_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 $ 0 : (List.length <$> ns)
	let ns' = (<$> ns) $ \n ->
		List.replicate (max_len_n - List.length n) ' ' <> n
	let quote =
		D.catV $
		List.zipWith (\(n, sn) q ->
			D.spaces 2 <> D.blacker (D.stringH sn) <>
			D.spaces 2 <> (if n == l then mark q else D.textH q)
		 ) (List.zip [ll..] ns') qs
	return $ quote <> D.eol
	where
	size_ctx = 2
	intFrom = fromInteger . toInteger
	mark q =
		let (b, a) = Text.splitAt (intFrom c - 1) q in
		D.textH b <>
		case Text.uncons a of
		 Nothing -> D.red D.space
		 Just (a0, a') -> D.red (D.charH a0) <> D.textH a'