{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Hcompta.LCC.Write.Compta 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.Map.Strict (Map)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
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 System.IO (IO)
import qualified Data.ByteString as BS
import qualified Data.Char as Char
import qualified Data.List as L
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.Compta
import Hcompta.LCC.IO
import Hcompta.LCC.Journal
import Hcompta.LCC.Name
import Hcompta.LCC.Posting
import Hcompta.LCC.Tag
import Hcompta.LCC.Transaction
import qualified Hcompta.LCC.Read.Compta as G

-- * Class 'Writable'
class Writable d a where
	write :: a -> d
-- widthWrite :: forall d a. Writable d a => a -> Integer
widthWrite = D.width . D.dim . write

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

instance (D.Doc_Text d, D.Doc_Color d) =>
         Writable d Date where
	write dat =
		let (y, mo, d) = H.gregorianOf dat in
		(if y == 0 then D.empty else D.integer y <> sep G.char_ymd_sep) <>
		int2 mo <>
		sep G.char_ymd_sep <> int2 d <>
		(case H.todOf 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
instance (D.Doc_Text d, D.Doc_Color d, Monoid d) =>
         Writable d Account where
	write acct =
		(`MT.ofoldMap` acct) $ \a ->
			D.blacker (D.charH G.char_account_sep) <>
			write a
instance D.Doc_Text d =>
         Writable d NameAccount where
	write = D.textH . unName
instance (D.Doc_Text d, D.Doc_Color d) =>
         Writable d Tag_Path where
	write (Tag_Path path) =
		D.catH $
		(:) (D.yellower $ D.charH G.char_account_tag_prefix) $
		L.intersperse
		 (D.yellower $ D.charH G.char_tag_sep)
		 (D.textH . unName <$> NonNull.toNullable path)
instance (D.Doc_Text d, D.Doc_Color d) =>
         Writable d Account_Tag where
	write (Account_Tag (Tag (Tag_Path path) (Tag_Data value))) =
		D.catH (
			(:) (D.yellower $ D.charH G.char_account_tag_prefix) $
			L.intersperse
			 (D.yellower $ D.charH G.char_tag_sep)
			 (D.textH . unName <$> NonNull.toNullable path) ) <>
		if Text.null value
		then D.empty
		else
			D.yellower (D.charH G.char_tag_data_prefix) <>
			D.textH value
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
         Writable d (Styled_Amount Amount) where
	write
	 ( sty@Style_Amount
		 { style_amount_unit_side   = uside
		 , style_amount_unit_spaced = uspaced
		 }
	 , Amount u q
	 ) =
		case uside of
		 S.Just L ->
			write u <>
			case uspaced of
			 S.Just True | not (H.null u) -> D.space
			 _ -> D.empty
		 _ -> D.empty
		<> write (sty, q)
		<> case uside of
		 S.Just R ->
			(case uspaced of
			 S.Just True | not (H.null u) -> D.space
			 _ -> D.empty) <>
			write u
		 S.Nothing ->
			(case uspaced of
			 S.Just True | not (H.null u) -> D.space
			 _ -> D.empty) <>
			write u
		 _ -> D.empty
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
         Writable d Unit where
	write (Unit t) =
		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
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
         Writable d (Styled_Amount Quantity) where
	write
	 ( 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 = L.length num
			let padded =
				L.concat
				 [ L.replicate (fromIntegral e + 1 - num_len) '0'
				 , num
				 -- , replicate (fromIntegral precision - fromIntegral e) '0'
				 ]
			let (int, frac) = L.splitAt (max 1 (num_len - fromIntegral e)) padded
			let default_fractioning =
				L.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 -> L.reverse . group g . L.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_) =
			L.concat . L.reverse .
			L.map L.reverse . fst .
			L.foldl'
			 (flip (\digit x -> case x of
				 ([], sizes) -> ([[digit]], sizes)
				 (digits:groups, []) -> ((digit:digits):groups, [])
				 (digits:groups, curr_sizes@(size:sizes)) ->
					if L.length digits < size
					then (      (digit:digits):groups, curr_sizes)
					else ([digit]:[sep]:digits:groups, if L.null sizes then curr_sizes else sizes)
			 ))
			 ([], sizes_)
		del_grouping_sep grouping =
			case grouping of
			 S.Just (Style_Amount_Grouping sep _) -> L.delete sep
			 _ -> id
instance (D.Doc_Text d, D.Doc_Color d) =>
         Writable d Comment where
	write (Comment com) =
		D.cyan $
		D.charH G.char_comment_prefix
		<> (case Text.uncons com of
		 Just (c, _) | not $ Char.isSpace c -> D.space
		 _ -> D.empty)
		<> D.textH com
instance (D.Doc_Text d, D.Doc_Color d) =>
         Writable d (d, [Comment]) where
	write (prefix, com) =
		D.catH $
		L.intersperse D.eol $
		(\c -> prefix <> write c) <$> com
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
         Writable d (Context_Write, Posting) where
	write (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 (d_acct, w_acct) =
			case posting_account_ref of
			 S.Just (a S.:!: sa) | context_write_account_ref ctx ->
				( write a <> S.maybe D.empty write sa
				, widthWrite a + S.maybe 0 widthWrite sa )
			 _ -> (write posting_account, widthWrite posting_account) in
		(case posting_amounts of
		 Amounts amts | Map.null amts -> d_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 + widthWrite amt) in
				(case mdoc of
				 Nothing -> D.empty
				 Just doc -> doc <> D.eol <> d_indent) <>
				d_acct <> D.spaces pad <> D.space <> write amt
			 ) Nothing amts) <>
		(case posting_comments of
		 []  -> D.empty
		 [c] -> D.space <> write c
		 _   -> D.eol   <> write (d_indent <> D.space :: d, posting_comments))
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
         Writable d (Context_Write, Transaction) where
	write (ctx,
	 txn@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_Transaction ctx txn
			else w } in
		D.catH (
			L.intersperse
			 (D.charH G.char_transaction_date_sep)
			 (write <$> 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
		 _  -> write (D.space :: d, transaction_comments) <> D.eol) <>
		TreeMap.foldr_with_Path
		 (\path -> flip $
			foldr (\value -> (<>) (D.spaces 2 <>
			write (Transaction_Tag (Tag (Tag_Path path) value)) <> D.eol)))
		 D.empty tags <>
		D.catV (write . (ctx',) <$> Compose transaction_postings)
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
         Writable d (Context_Write, Map Date [Transaction]) where
	write (ctx, txns) =
		let ctx' = ctx{context_write_width_acct_amt =
			foldr (max . w_Transaction ctx) 0 $ Compose txns} in
		fromMaybe D.empty $
		foldl (\mdoc txn -> Just $
			write (ctx', txn) <>
			case mdoc of
			 Nothing  -> D.eol
			 Just doc -> D.eol <> D.eol <> doc
		 ) Nothing (Compose txns)
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
         Writable d Transaction_Tag where
	write (Transaction_Tag (Tag (Tag_Path path) (Tag_Data value))) =
		D.catH (
			(:) (D.yellower $ D.charH G.char_tag_prefix) $
			L.intersperse
			 (D.yellower $ D.charH G.char_tag_sep)
			 (D.bold . D.textH . unName <$> NonNull.toNullable path)) <>
		if Text.null value
		then D.empty
		else D.yellower (D.charH G.char_tag_data_prefix) <> D.textH value
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writable d (ctx, j)) =>
         Writable d (ctx, Journal j) where
	write (ctx, jnl) = write (ctx, journal_content jnl)
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writable d (ctx, j)) =>
         Writable d (ctx, Journals j) where
	write (ctx, Journals js) =
		Map.foldl
		 (\doc j@Journal{journal_file=PathFile jf} ->
			doc <>
			write (Comment $ Text.pack jf) <> D.eol <>
			D.eol <> write (ctx, j)
		 ) D.empty js
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
         Writable d Chart where
	write =
		TreeMap.foldl_with_Path
		 (\doc acct (Account_Tags (Tags ca)) ->
			doc <>
			write (H.to acct :: Account) <> D.eol <>
			TreeMap.foldl_with_Path
			 (\doc' tp tvs ->
				doc' <>
				foldl'
				 (\doc'' tv ->
					doc'' <> D.spaces 2 <>
					write (Account_Tag (Tag (Tag_Path tp) tv)) <>
					D.eol)
				 D.empty
				 tvs)
			 D.empty
			 ca
		 ) D.empty .
		chart_accounts
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
         Writable d Terms where
	write (ts::Terms) =
		Map.foldl (\doc t -> doc <> D.text t <> D.eol) D.empty ts
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writable d (Context_Write, j)) =>
         Writable d (Context_Write, Compta src ss j) where
	write (ctx, Compta
	 { compta_journals      = js
	 , compta_chart         = c@Chart{chart_accounts=ca}
	 , compta_style_amounts = amts
	 , compta_terms         = terms
	 }) =
		(if null terms then D.empty else (write terms <> D.eol)) <>
		(if TreeMap.null ca then D.empty else (write c <> D.eol)) <>
		write (ctx{context_write_amounts = context_write_amounts ctx <> amts}, js)
instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
         Writable (IO d) SourcePos where
	write (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 =
			L.take (intFrom $ (l - ll) + 1 + size_ctx) $
			L.drop (intFrom $ ll-1) ls
		let ns = show <$> L.take (L.length qs) [ll..]
		let max_len_n = maximum $ 0 : (L.length <$> ns)
		let ns' = (<$> ns) $ \n ->
			L.replicate (max_len_n - L.length n) ' ' <> n
		let quote =
			D.catV $
			L.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)
			 ) (L.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'

-- | Return the width of given 'Postings',
-- considering only 'Account's and 'Amount's (not indentation, 'Comment's, nor 'Posting_Tag's).
w_Transaction :: Context_Write -> Transaction -> Int
-- w_Postings ctx = MT.ofoldr (max . widthWrite ctx) 0
w_Transaction 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 ->
				widthWrite a + S.maybe 0 widthWrite sa
			 _ -> widthWrite 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
					widthWrite amt)
				 1 amts in
		w_Acct + w_Amt
	 ) 0 .
	transaction_postings