{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hcompta.Format.Ledger.Write where

-- import           Control.Applicative ((<$>), (<*))
import qualified Data.Char (isSpace)
import qualified Data.Functor.Compose
import qualified Data.Foldable
-- import           Data.Foldable (Foldable)
import qualified Data.List
import qualified Data.List.NonEmpty
import qualified Data.Map.Strict as Data.Map
import qualified Data.Text.Lazy as TL
import qualified Data.Text as Text
import qualified Hcompta.Lib.Leijen as W
import           Hcompta.Lib.Leijen (Doc, (<>))
import           System.IO (Handle)
import qualified Text.Parsec as R hiding (satisfy, char)
import           Text.Parsec (Stream, ParsecT)

import qualified Hcompta.Account as Account
import           Hcompta.Account (Account)
import qualified Hcompta.Amount as Amount
import qualified Hcompta.Amount.Write as Amount.Write
import qualified Hcompta.Format.Ledger as Ledger
import           Hcompta.Format.Ledger
                  ( Comment
                  , Journal(..)
                  , Posting(..), Posting_by_Account, Posting_Type(..)
                  , Tag
                  , Transaction(..)
                  )
import qualified Hcompta.Date.Write as Date.Write
import qualified Hcompta.Format.Ledger.Read as Read
import qualified Hcompta.Lib.Parsec as R

-- * Write 'Account'

account :: Posting_Type -> Account -> Doc
account type_ =
	case type_ of
	 Posting_Type_Regular -> account_
	 Posting_Type_Virtual -> \acct ->
		W.char Read.posting_type_virtual_begin <> do
		account_ acct <> do
		W.char Read.posting_type_virtual_end
	 Posting_Type_Virtual_Balanced -> \acct ->
		W.char Read.posting_type_virtual_balanced_begin <> do
		account_ acct <> do
		W.char Read.posting_type_virtual_balanced_end
	where
		account_ :: Account -> Doc
		account_ acct =
			W.align $ W.hcat $
				Data.List.NonEmpty.toList $
				Data.List.NonEmpty.intersperse
				 (W.bold $ W.yellow $ W.char Read.account_name_sep)
				 (Data.List.NonEmpty.map account_name acct)

account_name :: Account.Name -> Doc
account_name = W.strict_text

-- ** Measure 'Account'

account_length :: Posting_Type -> Account -> Int
account_length type_ acct =
	Data.Foldable.foldl
	 (\acc -> (1 +) . (acc +) . Text.length)
	 (- 1) acct +
	case type_ of
	 Posting_Type_Regular -> 0
	 Posting_Type_Virtual -> 2
	 Posting_Type_Virtual_Balanced -> 2

-- ** Measure 'Amount's

amounts_length :: Amount.By_Unit -> Int
amounts_length amts =
	if Data.Map.null amts
	then 0
	else
		Data.Map.foldr
		 (\n -> (3 +) . (+) (Amount.Write.amount_length n))
		 (-3) amts

-- * 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)
		<> do W.if_color colorize (W.strict_text com)
	where
		colorize :: Doc
		colorize =
			case R.runParser (do
				pre <- R.many $ R.try $ do
					ns <- R.many $ R.satisfy (\c -> c /= Read.tag_value_sep && not (Data.Char.isSpace c))
					sh <- R.space_horizontal
					return (ns ++ [sh])
				((W.text $ TL.pack $ concat pre) <>) <$> tags <* R.eof)
			 () "" com of
			 Left _ -> W.strict_text com
			 Right doc -> doc
		tags :: Stream s m Char => ParsecT s u m Doc
		tags = do
			x <- tag_
			xs <- W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_)))
			return $ x <> xs
			where
				tag_sep :: Stream s m Char => ParsecT s u m Doc
				tag_sep = do
					s <- R.char Read.tag_sep
					sh <- R.many R.space_horizontal
					return $
						do W.bold $ W.dullblack $ W.char s
						<> do W.text $ TL.pack sh
				tag_ :: Stream s m Char => ParsecT s u m Doc
				tag_ = do
					n <- Read.tag_name
					s <- R.char Read.tag_value_sep
					v <- Read.tag_value
					return $
						(W.yellow $ W.strict_text n)
						<> (W.bold $ W.dullblack $ W.char s)
						<> (W.red $ W.strict_text v)

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

-- * Write 'Tag'

tag :: Tag -> Doc
tag (n, v) =
	(W.dullyellow $ W.strict_text n)
	<> W.char Read.tag_value_sep
	<> (W.dullred $ W.strict_text v)

-- * Write 'Posting'

posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
posting max_posting_length type_
 Posting
 { posting_account=acct
 , posting_amounts
 , posting_comments=cmts
 -- , posting_dates
 , posting_status=status_
 -- , posting_tags
 } =
	W.char '\t' <> do
	status status_ <> do
		case Data.Map.null posting_amounts of
		 True -> account type_ acct
		 False ->
			let len_acct = account_length type_ acct in
			let len_amts = amounts_length posting_amounts in
			account type_ acct <> do
			W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <> do
			W.intercalate
			 (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
			 Amount.Write.amount posting_amounts
	<> (case cmts of
	 [] -> W.empty
	 [c] -> W.space <> comment c
	 _ -> W.line <> do comments (W.text "\t ") cmts)

status :: Ledger.Status -> Doc
status = \x -> case x of
	 True  -> W.char '!'
	 False -> W.empty

-- ** Measure 'Posting'

type Posting_Lengths = (Int)

postings_lengths
 :: Posting_Type
 -> Posting_by_Account
 -> Posting_Lengths
 -> Posting_Lengths
postings_lengths type_ ps pl =
	Data.Foldable.foldr
	 (\p ->
		max
		 ( account_length type_ (posting_account p)
		 + amounts_length       (posting_amounts p) )
	 ) pl
	 (Data.Functor.Compose.Compose ps)

-- * Write 'Transaction'

transaction :: Transaction -> Doc
transaction t = transaction_with_lengths (transaction_lengths t 0) t

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

transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
transaction_with_lengths
 posting_lengths_
 Transaction
 { transaction_code=code_
 , transaction_comments_before
 , transaction_comments_after
 , transaction_dates=(first_date, dates)
 , transaction_description
 , transaction_postings
 , transaction_virtual_postings
 , transaction_balanced_virtual_postings
 , transaction_status=status_
 -- , transaction_tags
 } = do
	(case transaction_comments_before of
	 [] -> W.empty
	 _  -> comments W.space transaction_comments_before <> W.line) <> do
	(W.hcat $
		Data.List.intersperse
		 (W.char Read.date_sep)
		 (Data.List.map Date.Write.date (first_date:dates))) <> do
	(case status_ of
	 True -> W.space <> status status_
	 False -> W.empty) <> do
	code code_ <> do
	(case transaction_description of
	 "" -> W.empty
	 _  -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
	W.line <> do
	(case transaction_comments_after of
	 [] -> W.empty
	 _  -> comments W.space transaction_comments_after <> W.line) <> do
	W.vsep $ Data.List.map
	 (\(type_, ps) ->
		W.intercalate W.line
		 (W.intercalate W.line
			 (W.vsep . Data.List.map
				 (posting posting_lengths_ type_)))
		 (Ledger.posting_by_Signs_and_Account ps))
	 [ (Posting_Type_Regular, transaction_postings)
	 , (Posting_Type_Virtual, transaction_virtual_postings)
	 , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
	 ]

code :: Ledger.Code -> Doc
code = \x -> case x of
	 "" -> W.empty
	 t  -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'

-- ** Measure 'Transaction'

type Transaction_Lengths = Posting_Lengths

transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
transaction_lengths
 Transaction
 { transaction_postings
 , transaction_virtual_postings
 , transaction_balanced_virtual_postings
 } posting_lengths_ = do
	Data.List.foldl
	 (flip (\(type_, ps) -> postings_lengths type_ ps))
	 posting_lengths_
	 [ (Posting_Type_Regular, transaction_postings)
	 , (Posting_Type_Virtual, transaction_virtual_postings)
	 , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
	 ]

-- * Write 'Journal'

journal :: Journal -> Doc
journal Journal { journal_transactions } =
	transactions (Data.Functor.Compose.Compose journal_transactions)

-- * 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 -> Handle -> Doc -> IO ()
put Style{style_color, style_align} handle =
	W.displayIO handle .
	if style_align
	then W.renderPretty style_color 1.0 maxBound
	else W.renderCompact style_color