{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
module Hcompta.Format.Ledger.Write where
-import Control.Applicative ((<$>), (<*))
-import Control.Arrow ((***))
-import Data.Decimal (DecimalRaw(..))
+-- import Control.Applicative ((<$>), (<*))
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 (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 hiding (satisfy, char)
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.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
, Tag
, Transaction(..)
)
--- import qualified Hcompta.Model.Date as Date
-import Hcompta.Model.Date (Date)
--- import Hcompta.Format.Ledger.Journal as Journal
+import qualified Hcompta.Date.Write as Date.Write
import qualified Hcompta.Format.Ledger.Read as Read
+-- import Hcompta.Lib.Consable (Consable(..))
import qualified Hcompta.Lib.Parsec as R
-
--- * Printing 'Account'
+-- * Write 'Account'
account :: Posting_Type -> Account -> Doc
account type_ =
account_name :: Account.Name -> Doc
account_name = W.strict_text
--- ** Mesuring 'Account'
+-- ** Measure 'Account'
account_length :: Posting_Type -> Account -> Int
account_length type_ acct =
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 . Unit.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
- Unit.length unit_
- + (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 })
- + quantity_length style qty
+-- ** Measure 'Amount's
amounts_length :: Amount.By_Unit -> Int
amounts_length amts =
then 0
else
Data.Map.foldr
- (\n -> (3 +) . (+) (amount_length n))
+ (\n -> (3 +) . (+) (Amount.Write.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'
+-- * Write 'Comment'
comment :: Comment -> Doc
comment com =
Data.List.intersperse W.line .
Data.List.map (\c -> prefix <> comment c)
--- * Printing 'Tag'
+-- * Write 'Tag'
tag :: Tag -> Doc
tag (n, v) =
<> W.char Read.tag_value_sep
<> (W.dullred $ W.strict_text v)
--- * Printing 'Posting'
+-- * Write 'Posting'
posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
-posting
- ( max_account_length
- , max_amount_length
- )
- type_
+posting max_posting_length type_
Posting
{ posting_account=acct
, posting_amounts
case Data.Map.null posting_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 posting_amounts) )) W.empty <> do
+ 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
+ Amount.Write.amount posting_amounts
<> (case cmts of
[] -> W.empty
[c] -> W.space <> comment c
True -> W.char '!'
False -> W.empty
--- ** Mesuring 'Posting'
+-- ** Measure 'Posting'
-type Posting_Lengths = (Int, Int)
+type Posting_Lengths = (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_ ps pl =
+ Data.Foldable.foldr
+ (\p ->
+ max
+ ( account_length type_ (posting_account p)
+ + amounts_length (posting_amounts p) )
+ ) pl
+ (Data.Functor.Compose.Compose ps)
-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'
+-- * Write 'Transaction'
transaction :: Transaction -> Doc
-transaction t = transaction_with_lengths (transaction_lengths t nil_Transaction_Lengths) t
+transaction t = transaction_with_lengths (transaction_lengths t 0) t
+
+transactions :: Foldable ts => ts 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 <>
+ (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
(W.hcat $
Data.List.intersperse
(W.char Read.date_sep)
- (Data.List.map date (first_date:dates))) <> do
+ (Data.List.map Date.Write.date (first_date:dates))) <> do
(case status_ of
True -> W.space <> status status_
False -> W.empty) <> 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)
- ]
+ W.vsep
+ (fmap
+ (\(type_, ps) ->
+ (W.intercalate W.line
+ (W.vsep . fmap (posting posting_lengths_ type_))
+ )
+ (ps)
+ )
+ [ (Posting_Type_Regular , transaction_postings)
+ , (Posting_Type_Virtual , transaction_virtual_postings)
+ , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
+ ]
+ ) <> W.line
code :: Ledger.Code -> Doc
code = \x -> case x of
"" -> W.empty
t -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
--- ** Mesuring 'Transaction'
+-- ** Measure '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_balanced_virtual_postings
} posting_lengths_ = do
Data.List.foldl
- (flip (\(type_, ps) -> postings_lengths type_ ps))
+ (flip (uncurry postings_lengths))
posting_lengths_
[ (Posting_Type_Regular, transaction_postings)
, (Posting_Type_Virtual, transaction_virtual_postings)
, (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
]
--- * Printing 'Journal'
+-- * Write 'Journal'
-journal :: Journal -> Doc
-journal Journal
- { journal_transactions
- } = do
- let transaction_lengths_ =
- Data.Map.foldr
- (flip (Data.List.foldr transaction_lengths))
- nil_Transaction_Lengths
- journal_transactions
- Data.Foldable.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
- journal_transactions
+journal ::
+ ( Foldable ts
+ , Monoid (ts Transaction)
+ ) => Journal (ts Transaction) -> Doc
+journal Journal{ journal_transactions } =
+ transactions journal_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
+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