{-# LANGUAGE FlexibleContexts #-}
{-# 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.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 (LocalTime(..), TimeOfDay(..), TimeZone(..), timeZoneOffsetString, ZonedTime(..))
import qualified Hcompta.Lib.Leijen as W
import           Hcompta.Lib.Leijen (Doc, (<>))
import           System.IO (Handle)
import qualified Text.Parsec as R
import           Text.Parsec (Stream, ParsecT)

import qualified Hcompta.Model.Account as Account
import           Hcompta.Model.Account (Account)
import qualified Hcompta.Model.Amount as Amount
import           Hcompta.Model.Amount (Amount)
import qualified Hcompta.Model.Amount.Quantity as Quantity
import           Hcompta.Model.Amount.Quantity (Quantity)
import qualified Hcompta.Model.Amount.Style as Style
import           Hcompta.Model.Amount.Style (Style)
-- import qualified Hcompta.Model.Amount.Unit as Unit
import           Hcompta.Model.Amount.Unit (Unit)
import qualified Hcompta.Model.Transaction as Transaction
import           Hcompta.Model.Transaction (Comment, Tag, Transaction)
import qualified Hcompta.Model.Transaction.Posting as Posting
import           Hcompta.Model.Transaction (Posting)
import qualified Hcompta.Model.Journal as Journal
import           Hcompta.Model.Journal (Journal)
-- import qualified Hcompta.Model.Transaction.Tag as Tag
-- import           Hcompta.Model.Transaction (Tag)
-- import qualified Hcompta.Model.Date as Date
import           Hcompta.Model.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 = style@(Style.Style
	 { Style.unit_side
	 , Style.unit_spaced
	 })
 , Amount.unit=unit_
 } = do
	case unit_side of
	 Just Style.Side_Left ->
		(unit unit_)
		<> (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
	 _ -> W.empty
	<> quantity style qty
	<> case unit_side of
	 (Just 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

quantity :: Style -> Quantity -> Doc
quantity Style.Style
 { Style.fractioning
 , Style.grouping_integral
 , Style.grouping_fractional
 , 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 :: Style.Grouping -> [Char] -> [Char]
		group (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 (Style.Grouping sep _) -> Data.List.delete sep
			 _ -> id

-- ** Mesuring 'Amount'

amount_length :: Amount -> Int
amount_length Amount.Amount
 { Amount.quantity=qty
 , Amount.style = style@(Style.Style
	 { Style.unit_spaced
	 })
 , Amount.unit=unit_
 } = do
	Text.length unit_
	+ (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 })
	+ quantity_length style 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 :: Style -> Quantity -> Int
quantity_length Style.Style
 { Style.grouping_integral
 , Style.grouping_fractional
 , 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 +) $ truncate $ logBase 10 $ (fromIntegral (abs n)::Double) 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 -> Style.Grouping -> Int
		group num_len (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 (Time.ZonedTime
 (Time.LocalTime day tod)
 tz@(Time.TimeZone tz_min _ tz_name)) = 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
		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_account_length
 , max_amount_length
 )
 type_
 Posting.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 amounts of
		 True -> account type_ acct
		 False ->
			W.fill (max_account_length + 2)
			 (account type_ acct) <> do
			W.fill (max 0
			 ( max_amount_length
			 - (fromIntegral $ amounts_length amounts) )) W.empty <> do
			W.intercalate
			 (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
			 amount amounts
	<> (case cmts of
	 [] -> W.empty
	 [c] -> W.space <> comment c
	 _ -> W.line <> do comments (W.text "\t\t") cmts)

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

-- ** Mesuring 'Posting'

type Posting_Lengths = (Int, Int)

nil_Posting_Lengths :: Posting_Lengths
nil_Posting_Lengths = (0, 0)

postings_lengths :: Posting.Type -> Posting.By_Account -> Posting_Lengths -> Posting_Lengths
postings_lengths type_ =
	flip $ Data.Map.foldl $ Data.List.foldl $
	flip $ \p ->
	(max (account_length type_ (Posting.account p)))
	***
	(max (amounts_length (Posting.amounts p)))

-- * Printing 'Transaction'

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

transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
transaction_with_lengths
 posting_lengths_
 Transaction.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 comments_before of
	 [] -> W.empty
	 _  -> comments (W.text "\t") 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 description of
	 "" -> W.empty
	 _  -> W.space <> (W.dullmagenta $ W.strict_text description)) <> do
	W.line <> do
	(case comments_after of
	 [] -> W.empty
	 _  -> comments (W.text "\t") 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_)))
		 (Posting.by_signs_and_account ps))
	 [ (Posting.Type_Regular, postings)
	 , (Posting.Type_Virtual, virtual_postings)
	 , (Posting.Type_Virtual_Balanced, balanced_virtual_postings)
	 ]

code :: Transaction.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

nil_Transaction_Lengths :: Posting_Lengths
nil_Transaction_Lengths = nil_Posting_Lengths

transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
transaction_lengths
 Transaction.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, postings)
	 , (Posting.Type_Virtual, virtual_postings)
	 , (Posting.Type_Virtual_Balanced, balanced_virtual_postings)
	 ]

-- * Printing 'Journal'

journal :: Journal -> Doc
journal Journal.Journal
 { Journal.transactions
 } = do
	let transaction_lengths_ =
		Data.Map.foldl
		 (Data.List.foldl (flip transaction_lengths))
		 nil_Transaction_Lengths
		 transactions
	Data.Map.foldl
	 (Data.List.foldl (\doc t ->
		(if W.is_empty doc then W.empty else doc <> W.line)
			<> transaction_with_lengths transaction_lengths_ t <> W.line
		))
	 W.empty
	 transactions

-- * Rendering

show :: Bool -> Doc -> TL.Text
show with_color = W.displayT . W.renderPretty with_color 1.0 maxBound

put :: Bool -> Handle -> Doc -> IO ()
put with_color handle = W.displayIO handle . W.renderPretty with_color 1.0 maxBound