{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# 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 (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 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.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.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'
--- * Printing 'Account'
-
-account :: Posting.Type -> Account -> Doc
+account :: Posting_Type -> Account -> Doc
account type_ =
case type_ of
- Posting.Type_Regular -> account_
- Posting.Type_Virtual -> \acct ->
+ 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 ->
+ 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
W.align $ W.hcat $
Data.List.NonEmpty.toList $
Data.List.NonEmpty.intersperse
- (W.bold $ W.dullblack $ W.char Read.account_name_sep)
+ (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'
+-- ** Measure 'Account'
-account_length :: Posting.Type -> Account -> Int
+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.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
+ 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 =
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'
-
-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
+-- * 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 amounts of
+ 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 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 amounts
+ Amount.Write.amount posting_amounts
<> (case cmts of
[] -> W.empty
[c] -> W.space <> comment c
- _ -> W.line <> do comments (W.text "\t\t") cmts)
+ _ -> W.line <> do comments (W.text "\t ") cmts)
-status :: Transaction.Status -> Doc
+status :: Ledger.Status -> Doc
status = \x -> case x of
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 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
- { 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
+ 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
+ (case transaction_comments_before of
[] -> W.empty
- _ -> comments (W.text "\t") comments_before <> W.line) <> do
+ _ -> 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
+ (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 description of
+ (case transaction_description of
"" -> W.empty
- _ -> W.space <> (W.dullmagenta $ W.strict_text description)) <> do
+ _ -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
W.line <> do
- (case comments_after of
+ (case transaction_comments_after of
[] -> W.empty
- _ -> comments (W.text "\t") comments_after <> W.line) <> do
+ _ -> 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_)))
- (Posting.by_signs_and_account ps))
- [ (Posting.Type_Regular, postings)
- , (Posting.Type_Virtual, virtual_postings)
- , (Posting.Type_Virtual_Balanced, balanced_virtual_postings)
+ (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 :: Transaction.Code -> Doc
+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
- { Transaction.postings
- , Transaction.virtual_postings
- , Transaction.balanced_virtual_postings
+ 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)
+ [ (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
- { 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
+journal Journal { journal_transactions } =
+ transactions (Data.Functor.Compose.Compose 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
sourcephile / git / comptalang.git / blobdiff