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

import           Control.Applicative ((<$>), (<*))
-- import           Control.Arrow ((***))
import           Data.Decimal (DecimalRaw(..))
import qualified Data.Char (isSpace)
import           Data.Fixed (showFixed)
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           Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as TL
import qualified Data.Text as Text
import qualified Data.Time.Calendar  as Time (toGregorian)
import qualified Data.Time.LocalTime as Time
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           GHC.Exts (Int(..))
import           GHC.Integer.Logarithms (integerLogBase#)

import qualified Hcompta.Account as Account
import           Hcompta.Account (Account)
import qualified Hcompta.Amount as Amount
import           Hcompta.Amount (Amount)
import qualified Hcompta.Amount.Quantity as Quantity
import           Hcompta.Amount.Quantity (Quantity)
import qualified Hcompta.Amount.Style as Amount.Style
import qualified Hcompta.Amount.Unit as Unit
import           Hcompta.Amount.Unit (Unit)
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 as Date
import           Hcompta.Date (Date)
-- import           Hcompta.Format.Ledger.Journal as Journal
import qualified Hcompta.Format.Ledger.Read as Read
import qualified Hcompta.Lib.Parsec as R


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

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

-- * Printing 'Amount'

amount :: Amount -> Doc
amount Amount.Amount
 { Amount.quantity=qty
 , Amount.style = sty@(Amount.Style.Style
	 { Amount.Style.unit_side
	 , Amount.Style.unit_spaced
	 })
 , Amount.unit=unit_
 } = do
	case unit_side of
	 Just Amount.Style.Side_Left ->
		(unit unit_)
		<> (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
	 _ -> W.empty
	<> quantity sty qty
	<> case unit_side of
	 (Just Amount.Style.Side_Right) ->
		(case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
		<> unit unit_
	 Nothing ->
		(case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
		<> unit unit_
	 _ -> W.empty

unit :: Unit -> Doc
unit = W.yellow . W.strict_text . Unit.text

quantity :: Amount.Style -> Quantity -> Doc
quantity Amount.Style.Style
 { Amount.Style.fractioning
 , Amount.Style.grouping_integral
 , Amount.Style.grouping_fractional
 , Amount.Style.precision
 } qty = do
	let Decimal e n = Quantity.round precision qty
	let num = Prelude.show $ abs $ n
	let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
	case e == 0 || precision == 0 of
	 True  -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num)
	 False -> do
		let num_len = length num
		let padded =
			Data.List.concat
			 [ replicate (fromIntegral e + 1 - num_len) '0'
			 , num
			 , replicate (fromIntegral precision - fromIntegral e) '0'
			 ]
		let (int, frac) = Data.List.splitAt (max 1 (num_len - fromIntegral precision)) padded
		let default_fractioning =
			Data.List.head $
			del_grouping_sep grouping_integral $
			del_grouping_sep grouping_fractional $
			['.', ',']
		sign <> do
		W.bold $ W.blue $ do
			W.text (TL.pack $ maybe id (\g -> reverse . group g . reverse) grouping_integral $ int) <> do
			(W.yellow $ W.char (fromMaybe default_fractioning fractioning)) <> do
			W.text (TL.pack $ maybe id group grouping_fractional frac)
	where
		group :: Amount.Style.Grouping -> [Char] -> [Char]
		group (Amount.Style.Grouping sep sizes_) =
			Data.List.concat . reverse .
			Data.List.map reverse . fst .
			Data.List.foldl
			 (flip (\digit -> \x -> case x of
				 ([], sizes) -> ([[digit]], sizes)
				 (digits:groups, []) -> ((digit:digits):groups, [])
				 (digits:groups, curr_sizes@(size:sizes)) ->
					if length digits < size
					then (      (digit:digits):groups, curr_sizes)
					else ([digit]:[sep]:digits:groups, if sizes == [] then curr_sizes else sizes)
			 ))
			 ([], sizes_)
		del_grouping_sep grouping =
			case grouping of
			 Just (Amount.Style.Grouping sep _) -> Data.List.delete sep
			 _ -> id

-- ** Mesuring 'Amount'

amount_length :: Amount -> Int
amount_length Amount.Amount
 { Amount.quantity = qty
 , Amount.style = sty@(Amount.Style.Style
	 { Amount.Style.unit_spaced
	 })
 , Amount.unit = unit_
 } = do
	Unit.length unit_
	+ (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 })
	+ quantity_length sty qty

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

quantity_length :: Amount.Style -> Quantity -> Int
quantity_length Amount.Style.Style
 { Amount.Style.grouping_integral
 , Amount.Style.grouping_fractional
 , Amount.Style.precision
 } qty =
	let Decimal e n = Quantity.round precision 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 precision) in
	let frac_len = max 0 (padded_len - int_len) in
	( sign_len
	+ fractioning_len
	+ padded_len
	+ maybe 0 (group int_len)  grouping_integral
	+ maybe 0 (group frac_len) grouping_fractional
	)
	where
		group :: Int -> Amount.Style.Grouping -> Int
		group num_len (Amount.Style.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

-- * Printing 'Date'

date :: Date -> Doc
date utc = do
	let (y, mo, d) = Time.toGregorian day
	(if y == 0 then W.empty else W.integer y <> sep '/') <> do
	int2 mo <> do
	sep '/' <> int2 d <> do
	(case tod of
	 Time.TimeOfDay 0 0 0 -> W.empty
	 Time.TimeOfDay h m s ->
		W.space <> int2 h <> do
		sep ':' <> int2 m <> do
		(case s of
		 0 -> W.empty
		 _ -> sep ':' <> do
			(if s < 10 then W.char '0' else W.empty) <> do
			W.strict_text $ Text.pack $ showFixed True s)) <> do
	(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
		Time.ZonedTime
		 (Time.LocalTime day tod)
		 tz@(Time.TimeZone tz_min _ tz_name) =
			Time.utcToZonedTime Time.utc utc
		int2 :: Int -> Doc
		int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
		sep :: Char -> Doc
		sep = W.bold . W.dullblack . W.char

-- * Printing '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)

-- * Printing '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)

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

-- ** Mesuring '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)

-- * Printing '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 (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 ')'

-- ** Mesuring '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)
	 ]

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