{-# 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 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 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 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
+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.Model.Account as Account
import Hcompta.Model.Account (Account)
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 qualified Hcompta.Model.Amount.Style as Amount.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.Format.Ledger as Ledger
+import Hcompta.Format.Ledger
+ ( Comment
+ , Journal(..)
+ , Posting(..), Posting_by_Account, Posting_Type(..)
+ , Tag
+ , Transaction(..)
+ )
-- import qualified Hcompta.Model.Date as Date
import Hcompta.Model.Date (Date)
-- import Hcompta.Format.Ledger.Journal as Journal
-- * 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
-- ** Mesuring '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
+ 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.style = sty@(Amount.Style.Style
+ { Amount.Style.unit_side
+ , Amount.Style.unit_spaced
})
, Amount.unit=unit_
} = do
case unit_side of
- Just Style.Side_Left ->
+ Just Amount.Style.Side_Left ->
(unit unit_)
<> (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
_ -> W.empty
- <> quantity style qty
+ <> quantity sty qty
<> case unit_side of
- (Just Style.Side_Right) ->
+ (Just Amount.Style.Side_Right) ->
(case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty })
<> unit unit_
Nothing ->
_ -> 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
+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
(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_) =
+ group :: Amount.Style.Grouping -> [Char] -> [Char]
+ group (Amount.Style.Grouping sep sizes_) =
Data.List.concat . reverse .
Data.List.map reverse . fst .
Data.List.foldl
([], sizes_)
del_grouping_sep grouping =
case grouping of
- Just (Style.Grouping sep _) -> Data.List.delete sep
+ 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 = style@(Style.Style
- { Style.unit_spaced
+ { Amount.quantity = qty
+ , Amount.style = sty@(Amount.Style.Style
+ { Amount.Style.unit_spaced
})
- , Amount.unit=unit_
+ , Amount.unit = unit_
} = do
- Text.length unit_
+ Unit.length unit_
+ (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 })
- + quantity_length style qty
+ + quantity_length sty qty
amounts_length :: Amount.By_Unit -> Int
amounts_length amts =
(\n -> (3 +) . (+) (amount_length n))
(-3) amts
-quantity_length :: Style -> Quantity -> Int
-quantity_length Style.Style
- { Style.grouping_integral
- , Style.grouping_fractional
- , Style.precision
+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 +) $ truncate $ logBase 10 $ (fromIntegral (abs n)::Double) 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
+ maybe 0 (group frac_len) grouping_fractional
)
where
- group :: Int -> Style.Grouping -> Int
- group num_len (Style.Grouping _sep sizes_) =
+ 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_
-- * Printing 'Date'
date :: Date -> Doc
-date (Time.ZonedTime
- (Time.LocalTime day tod)
- tz@(Time.TimeZone tz_min _ tz_name)) = do
+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
_ | 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
-- * 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
+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 posting_amounts
<> (case cmts of
[] -> W.empty
[c] -> W.space <> comment c
_ -> 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'
-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)))
+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 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.space comments_before <> W.line) <> do
+ _ -> comments W.space transaction_comments_before <> W.line) <> do
(W.hcat $
Data.List.intersperse
(W.char Read.date_sep)
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.space 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 ')'
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'
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