{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Hcompta.Format.JCC.Write
 ( module Hcompta.Format.JCC.Write
 , module Hcompta.Format.JCC.Date.Write
 ) where

import           Data.Bool
import           Data.Char (isSpace)
import qualified Data.Foldable
import           Data.Foldable (Foldable(..))
import           Data.Functor (Functor(..), (<$>))
import qualified Data.Functor.Compose
import           Data.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)
import           Data.Monoid (Monoid(..))
import           Data.Ord (Ord(..))
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import           Prelude (($), (.), Bounded(..), Int, IO, Num(..), flip)
import           System.IO (Handle)

import qualified Hcompta.Account as Account
import           Hcompta.Account ( Account_Anchor(..)
                                 , Account_Tag(..)
                                 , Account_Tags(..)
                                 )
import qualified Hcompta.Anchor as Anchor
import           Hcompta.Chart (Chart)
import qualified Hcompta.Chart as Chart
import qualified Hcompta.Format.JCC as JCC
import           Hcompta.Format.JCC
                  ( Account
                  , Comment
                  , Journal(..)
                  , Posting(..)
                  , Transaction(..)
                  , Quantity
                  , Unit(..)
                  )
import qualified Hcompta.Format.JCC.Amount as Amount
import qualified Hcompta.Format.JCC.Amount.Write as Amount.Write
import qualified Hcompta.Format.JCC.Read as Read
-- import           Hcompta.Lib.Consable (Consable(..))
import           Hcompta.Lib.Leijen (Doc, (<>))
import qualified Hcompta.Lib.Leijen as W
import qualified Hcompta.Lib.TreeMap as TreeMap
import qualified Hcompta.Tag as Tag
import           Hcompta.Tag (Tags(..))
import           Hcompta.Anchor (Anchors(..))
import           Hcompta.Transaction ( Transaction_Anchor(..)
                                     , Transaction_Anchors(..)
                                     , Transaction_Tag(..)
                                     , Transaction_Tags(..) )

import           Hcompta.Format.JCC.Date.Write

-- * Write 'Comment'

comment :: Comment -> Doc
comment com =
	W.cyan $ do
		W.char Read.comment_begin
		<> (case Text.uncons com of
		 Just (c, _) | not $ Data.Char.isSpace c -> W.space
		 _ -> W.empty)
		<> W.strict_text com

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

-- * Write 'Account'

account :: Account -> Doc
account acct =
	W.align $ W.hcat $
		NonEmpty.toList $
		fmap (sep <>) $
		(NonEmpty.map account_section acct)
	where sep = W.bold $ W.dullblack $ W.char Read.account_section_sep

account_section :: Account.Account_Section Account -> Doc
account_section = W.strict_text

-- ** Measure 'Account'

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

-- ** Write 'Account_Anchor'

account_anchor :: Account_Anchor -> Doc
account_anchor (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

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

-- ** Write 'Account_Tag'

account_tag :: Account_Tag -> Doc
account_tag (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'

amounts :: Amount.Styles -> Map Unit Quantity -> Doc
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) <>
		(Amount.Write.amount $
		Amount.style styles $
		JCC.Amount unit qty))
	 W.empty

-- ** Measure 'Amount's

amounts_length :: Amount.Styles -> Map Unit Quantity -> Int
amounts_length styles amts =
	if Map.null amts
	then 0
	else
		Map.foldrWithKey
		 (\unit qty -> (3 +) . (+)
			 (Amount.Write.amount_length $
				Amount.style styles $
				JCC.Amount unit qty))
		 (-3) amts

-- * Write 'Posting'

posting :: Amount.Styles -> Posting_Lengths -> Posting -> Doc
posting styles max_posting_length
 Posting
 { posting_account
 , posting_account_anchor
 , posting_amounts
 , posting_comments=cmts
 -- , posting_dates
 -- , posting_tags
 } =
	W.string "  " <> do
		let (doc_acct, len_acct) =
			case posting_account_anchor of
			 Nothing ->
				( account        posting_account
				, account_length posting_account )
			 Just (a, sa) ->
				( account_anchor        a <> maybe W.empty account sa
				, account_anchor_length a + maybe 0 account_length sa )
		case Map.null posting_amounts of
		 True -> doc_acct
		 False ->
			let len_amts = amounts_length styles posting_amounts in
			doc_acct <>
			W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <>
			amounts styles posting_amounts
	<> (case cmts of
	 []  -> W.empty
	 [c] -> W.space <> comment c
	 _   -> W.line <> do comments (W.text "   ") cmts)

-- ** Measure 'Posting'

type Posting_Lengths = (Int)

postings_lengths
 :: Amount.Styles
 -> Map Account [Posting]
 -> Posting_Lengths
 -> Posting_Lengths
postings_lengths styles ps pl =
	Data.Foldable.foldr
	 (\p ->
		let len_acct =
			case posting_account_anchor p of
			 Nothing -> account_length $ posting_account p
			 Just (a, sa) ->
				account_anchor_length a +
				maybe 0 account_length sa in
		max
		 ( len_acct
		 + amounts_length styles (posting_amounts p) )
	 ) pl
	 (Data.Functor.Compose.Compose ps)

-- * Write 'Transaction'

transaction :: Amount.Styles -> Transaction -> Doc
transaction styles t = transaction_with_lengths styles (transaction_lengths styles t 0) t

transactions :: Foldable ts => Amount.Styles -> ts Transaction -> Doc
transactions styles ts = do
	let transaction_lengths_ =
		Data.Foldable.foldr (transaction_lengths styles) 0 ts
	Data.Foldable.foldr
	 (\t doc ->
		transaction_with_lengths styles transaction_lengths_ t <>
		(if W.is_empty doc then W.empty else W.line <> doc)
	 )
	 W.empty
	 ts

transaction_with_lengths
 :: Amount.Styles
 -> Transaction_Lengths
 -> Transaction -> Doc
transaction_with_lengths
 styles
 posting_lengths_
 Transaction
 { transaction_comments
 , transaction_dates=(first_date, dates)
 , transaction_wording
 , transaction_postings
 , transaction_anchors=Transaction_Anchors (Anchors anchors)
 , transaction_tags=Transaction_Tags (Tags tags)
 } = do
	(W.hcat $
		Data.List.intersperse
		 (W.char Read.date_sep)
		 (date <$> (first_date:dates))) <> do
	(case transaction_wording of
	 "" -> W.empty
	 _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_wording)) <> do
	W.line <> do
	(case transaction_comments of
	 [] -> W.empty
	 _  -> comments W.space transaction_comments <> W.line) <> do
	Map.foldrWithKey
	 (\path () -> ((W.string "  " <>
		transaction_anchor (Transaction_Anchor path) <> W.line) <>))
	 W.empty anchors <> do
	Map.foldrWithKey
	 (\path -> flip $
		Data.List.foldr
		 (\value -> (<>) (W.string "  " <>
		transaction_tag (Transaction_Tag (path, value)) <> W.line)))
	 W.empty tags <> do
	W.intercalate W.line
	 (W.vsep . fmap (posting styles posting_lengths_))
	 transaction_postings <> W.line

-- ** Measure 'Transaction'

type Transaction_Lengths = Posting_Lengths

transaction_lengths
 :: Amount.Styles
 -> Transaction
 -> Posting_Lengths
 -> Posting_Lengths
transaction_lengths
 styles
 Transaction
 { transaction_postings
 } posting_lengths_ = do
	Data.List.foldl
	 (flip $ postings_lengths styles)
	 posting_lengths_
	 [ transaction_postings
	 ]

-- ** Write 'Transaction_Tag'

transaction_tag :: Transaction_Tag -> Doc
transaction_tag (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)
		 (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

transaction_tag_section :: Tag.Section -> Doc
transaction_tag_section = W.bold . W.strict_text

-- ** Write 'Transaction_Anchor'

transaction_anchor :: Transaction_Anchor -> Doc
transaction_anchor (Transaction_Anchor path) =
	W.hcat $
		(:) (op $ W.char Read.transaction_anchor_prefix) $
		NonEmpty.toList $
		NonEmpty.intersperse
		 (op $ W.char Read.transaction_anchor_sep)
		 (transaction_anchor_section <$> path)
	where
		op = W.bold . W.yellow

transaction_anchor_section :: Anchor.Section -> Doc
transaction_anchor_section = W.bold . W.strict_text

-- * Write 'Journal'

journal ::
 ( Foldable ts
 , Monoid (ts Transaction)
 ) => Journal (ts Transaction) -> Doc
journal Journal{ journal_content, journal_amount_styles } =
	transactions journal_amount_styles journal_content

-- * Write 'Chart'

chart :: Chart Account -> Doc
chart =
	TreeMap.foldl_with_Path
	 (\doc acct (Account_Tags (Tags ca)) ->
		doc <>
		account acct <> W.line <>
		Map.foldlWithKey
		 (\dd tn tvs ->
			dd <>
			foldl'
			 (\ddd tv ->
				ddd <> W.string "  " <> account_tag (Account_Tag (tn, tv)) <> W.line)
			 W.empty
			 tvs
		 )
		 W.empty
		 ca
	 ) W.empty .
	Chart.chart_accounts

-- * Rendering

data Style
 =   Style
 { style_align :: Bool
 , style_color :: Bool
 }
style :: Style
style =
	Style
	 { style_align = True
	 , style_color = True
	 }

show :: Style -> Doc -> TL.Text
show Style{style_color, style_align} =
	W.displayT .
	if style_align
	then W.renderPretty style_color 1.0 maxBound
	else W.renderCompact style_color

put :: Style -> Doc -> Handle -> IO ()
put Style{style_color, style_align} doc handle =
	W.displayIO handle $
		if style_align
		then W.renderPretty style_color 1.0 maxBound doc
		else W.renderCompact style_color doc