{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
module Hcompta.CLI.Command.Balance where
import Control.Monad.IO.Class (liftIO)
import qualified Data.List
import qualified Data.Map
import qualified Data.Text.Lazy as TL
+import qualified Data.Text as Text
import System.Console.GetOpt
( ArgDescr(..)
, OptDescr(..)
import qualified System.IO as IO
import Text.Show.Pretty (ppShow) -- TODO: may be not necessary
+import qualified Hcompta.Calc.Balance as Balance
import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as Context
+import Hcompta.CLI.Context (Context)
import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
+import qualified Hcompta.CLI.Lib.Shakespeare.Leijen as I18N
+import qualified Hcompta.CLI.Lib.Leijen.Table as Table
import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Calc.Balance as Balance
import qualified Hcompta.Format.Ledger as Ledger
import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
import qualified Hcompta.Format.Ledger.Read as Ledger.Read
import qualified Hcompta.Format.Ledger.Write as Ledger.Write
import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
import qualified Hcompta.Lib.Leijen as W
-import Hcompta.Lib.Leijen ((<>), toDoc)
+import Hcompta.Lib.Leijen ((<>), toDoc, ToDoc(..))
import qualified Hcompta.Model.Amount as Amount
import Hcompta.Model.Amount (Amount, Unit)
--- import qualified Hcompta.Format.Ledger.Write
data Ctx
= Ctx
. Ledger.journal_transactions))
Balance.balance
journals
- Write.debug context $ ppShow $ balance
- Write.debug context $ ppShow $
- Lib.TreeMap.flatten (const ()) (Balance.balance_by_account balance)
let expanded = Balance.expanded $ Balance.balance_by_account balance
- Write.debug context $ ppShow $ expanded
- with_color <- Write.with_color context IO.stdout
- Ledger.Write.put with_color IO.stdout $ do
- let (max_amount_length, accounts) = write_accounts ctx expanded
- accounts <> do
- (if W.is_empty accounts
- then W.empty
- else (W.bold $ W.dullblack $
- W.text (TL.pack $ replicate max_amount_length '-') <>
- (if max_amount_length <= 0 then W.empty else W.line))) <> do
- write_amounts max_amount_length $
- Data.Map.map Balance.unit_sum_amount $
- (Balance.balance_by_unit balance)
+ let by_accounts_columns = write_by_accounts context ctx expanded
+ style_color <- Write.with_color context IO.stdout
+ Ledger.Write.put Ledger.Write.Style
+ { Ledger.Write.style_align = True
+ , Ledger.Write.style_color
+ } IO.stdout $ do
+ toDoc () by_accounts_columns <> do
+ case by_accounts_columns of
+ [col_balance, _col_account] ->
+ (W.bold $ W.dullblack $ do
+ W.text (TL.pack $ replicate
+ (foldr ((+) . (2 +) . Table.column_width)
+ (length by_accounts_columns - 1)
+ by_accounts_columns) '=') <> W.line) <> do
+ toDoc () $ write_by_amounts (Table.column_width col_balance) $
+ Data.Map.map
+ Balance.unit_sum_amount
+ (Balance.balance_by_unit balance)
+ _ -> error "Oops, should not happen: Hcompta.CLI.Command.Balance"
-write_accounts :: Ctx -> Balance.Expanded Amount Unit -> (Int, W.Doc)
-write_accounts ctx accounts = do
- let max_amount_length =
- uncurry (+) $
- Data.Foldable.foldl
- (\(len, plus) Balance.Account_Sum_Expanded{Balance.inclusive=amounts} ->
- let amounts_ = (if ctx_redundant ctx then amounts else Data.Map.filter (not . Amount.is_zero) amounts) in
- ( Data.Map.foldr (max . Ledger.Write.amount_length) len amounts
- , (if Data.Map.size amounts_ > 1
- then 2 -- NOTE: length "+ "
- else plus)
- )
- )
- (0, 0) accounts
- (max_amount_length,) $ do
- Lib.TreeMap.foldl_with_Path_and_Node
- (\doc account node amounts ->
- let descendants = Lib.TreeMap.nodes (Lib.TreeMap.node_descendants node) in
- if not (ctx_redundant ctx) && (
- Data.Map.size
- (Data.Map.filter
- (not . Amount.is_zero)
- (Balance.exclusive amounts)) == 0 &&
- Data.Map.size
- (Data.Map.filter
- ( maybe False (not . Amount.are_zero . Balance.inclusive)
- . Lib.TreeMap.node_value
- ) descendants) == 1
- )
- then doc
- else
- doc <> Data.Map.foldl
- (\doc_ amount ->
- if not (ctx_redundant ctx) && Amount.is_zero amount
- then doc_
- else
- doc_ <>
- (if W.is_empty doc_
- then do
- W.fill (max_amount_length - Ledger.Write.amount_length amount) W.empty <> do
- Ledger.Write.amount amount <> do
- W.space <> W.space <> do
- Ledger.Write.account Ledger.Posting_Type_Regular account
- else do
- (W.bold $ W.dullblack $ W.text "+" <> W.space) <> do
- W.fill (max_amount_length - Ledger.Write.amount_length amount - 2) W.empty <> do
- Ledger.Write.amount amount) <> do
- W.line
- ) W.empty (Balance.inclusive amounts)
+write_by_accounts
+ :: Context -> Ctx
+ -> Balance.Expanded Amount Unit
+ -> [Table.Column]
+write_by_accounts context ctx =
+ let posting_type = Ledger.Posting_Type_Regular in
+ let title = TL.toStrict . W.displayT . W.renderCompact False .
+ I18N.renderMessage Context.App (Context.langs context) in
+ zipWith id
+ [ Table.column (title Write.I18N_Balance) Table.Align_Right
+ , Table.column (title Write.I18N_Account) Table.Align_Left
+ ] .
+ Lib.TreeMap.foldr_with_Path_and_Node
+ (\account node amounts rows -> do
+ let descendants = Lib.TreeMap.nodes
+ (Lib.TreeMap.node_descendants node)
+ let is_worth =
+ ctx_redundant ctx
+ || Data.Map.size
+ (Data.Map.filter
+ (not . Amount.is_zero)
+ (Balance.exclusive amounts)) > 0
+ || Data.Map.size
+ (Data.Map.filter
+ ( maybe False (not . Amount.are_zero . Balance.inclusive)
+ . Lib.TreeMap.node_value )
+ descendants) > 1
+ case is_worth of
+ False -> rows
+ True ->
+ Data.Map.foldr
+ (\amount ->
+ zipWith id
+ [ (:) Table.cell
+ { Table.cell_content = Ledger.Write.amount amount
+ , Table.cell_width = Ledger.Write.amount_length amount
+ }
+ , (:) Table.cell
+ { Table.cell_content = Ledger.Write.account posting_type account
+ , Table.cell_width = Ledger.Write.account_length posting_type account
+ }
+ ]
+ )
+ rows
+ (Balance.inclusive amounts)
)
- W.empty accounts
+ (repeat [])
-write_amounts :: Int -> Amount.By_Unit -> W.Doc
-write_amounts max_amount_length_ amounts = do
- let max_amount_length =
- Data.Map.foldr
- (max . Ledger.Write.amount_length)
- max_amount_length_ amounts
- (if Data.Map.size amounts > 1
- then W.space <> W.space
- else W.empty) <> do
- W.intercalate
- (W.line <> (W.bold $ W.dullblack $ W.text "+") <> W.space)
+write_by_amounts
+ :: Int
+ -> Amount.By_Unit
+ -> [Table.Column]
+write_by_amounts min_col_width =
+ zipWith id
+ [ (\col_content ->
+ let col = Table.column Text.empty Table.Align_Right col_content in
+ col{Table.column_width = max min_col_width $ Table.column_width col})
+ ] .
+ Data.Map.foldr
(\amount ->
- let len =
- max_amount_length
- - Ledger.Write.amount_length amount
- - (if Data.Map.size amounts > 1
- then 2 -- NOTE: length "+ "
- else 0) in
- W.fill len W.empty <> do
- Ledger.Write.amount amount)
- amounts <> do
- (if Data.Map.null amounts then W.empty else W.line)
+ zipWith id
+ [ (:) Table.cell
+ { Table.cell_content = Ledger.Write.amount amount
+ , Table.cell_width = Ledger.Write.amount_length amount
+ }
+ ]
+ )
+ (repeat [])
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
module Hcompta.CLI.Command.Print where
import Control.Arrow (first)
import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as Context
+import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
import qualified Hcompta.CLI.Write as Write
import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
import qualified Hcompta.Format.Ledger.Read as Ledger.Read
import qualified Hcompta.Format.Ledger.Write as Ledger.Write
-import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
+import qualified Hcompta.Lib.Leijen as W
data Ctx
= Ctx
{ ctx_input :: [FilePath]
+ , ctx_align :: Bool
} deriving (Eq, Show)
nil :: Ctx
nil =
Ctx
{ ctx_input = []
+ , ctx_align = True
}
usage :: IO String
(ReqArg (\s _context ctx -> do
return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
"read data from given file, can be use multiple times"
+ , Option "" ["align"]
+ (OptArg (\arg context ctx -> do
+ ctx_align <- case arg of
+ Nothing -> return $ True
+ Just "yes" -> return $ True
+ Just "no" -> return $ False
+ Just _ -> Write.fatal context $
+ W.text "--align option expects \"yes\", or \"no\" as value"
+ return $ ctx{ctx_align})
+ "[yes|no]")
+ "align output"
]
run :: Context.Context -> [String] -> IO ()
(ctx, _) <-
first (\ctx -> ctx{ctx_input=reverse $ ctx_input ctx}) <$>
Args.parse context usage options (nil, args)
- CLI.Ledger.paths context $ ctx_input ctx
- >>= do mapM $ \path -> do
- liftIO $ runExceptT $
- Ledger.Read.file path
+ do
+ CLI.Ledger.paths context $ ctx_input ctx
+ >>= do mapM $ \path -> do
+ liftIO $ runExceptT $
+ Ledger.Read.file path
+ >>= \x -> case x of
+ Left ko -> return $ Left (path, ko)
+ Right ok -> return $ Right ok
+ >>= return . Data.Either.partitionEithers
>>= \x -> case x of
- Left ko -> return $ Left (path, ko)
- Right ok -> return $ Right ok
- >>= return . Data.Either.partitionEithers
- >>= \x -> case x of
- (kos@(_:_), _oks) ->
- (flip mapM_) kos $ \(_path, ko) -> Write.fatal context ko
- ([], journals) -> do
- with_color <- Write.with_color context IO.stdout
- let journal = Ledger.Journal.flatten $ Ledger.Journal.unions journals
- Ledger.Write.put with_color IO.stdout $ do
- Ledger.Write.journal journal
+ (kos@(_:_), _oks) ->
+ (flip mapM_) kos $ \(_path, ko) -> Write.fatal context ko
+ ([], journals) -> do
+ style_color <- Write.with_color context IO.stdout
+ let sty = Ledger.Write.Style
+ { Ledger.Write.style_align = ctx_align ctx
+ , Ledger.Write.style_color
+ }
+ let journal = Ledger.Journal.flatten $ Ledger.Journal.unions journals
+ Ledger.Write.put sty IO.stdout $ do
+ Ledger.Write.journal journal
Ledger.Read.Error_year_or_day_is_missing ->
I18N.renderMessage Context.App langs $
Write.I18N_year_or_day_is_missing
- Ledger.Read.Error_invalid_day (y, m, d) ->
+ Ledger.Read.Error_invalid_date (y, m, d) ->
I18N.renderMessage Context.App langs $
- Write.I18N_invalid_day y m d
+ Write.I18N_invalid_date y m d
Ledger.Read.Error_invalid_time_of_day (h, m, s) ->
I18N.renderMessage Context.App langs $
Write.I18N_invalid_time_of_day h m s
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+module Hcompta.CLI.Lib.Leijen.Table where
+
+import qualified Data.List
+import Data.Maybe (fromMaybe)
+import qualified Data.Text.Lazy as TL
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+import qualified Hcompta.Lib.Leijen as W
+import Hcompta.Lib.Leijen ((<>), toDoc, ToDoc(..))
+
+-- * The 'Table' type
+
+type Table = [Column]
+
+-- * The 'Column' type
+
+data Column
+ = Column
+ { column_title :: Text
+ , column_width :: Int
+ , column_align :: Align
+ , column_rows :: [Cell]
+ }
+instance ToDoc m [Column] where
+ toDoc _m cols = do
+ let rows = Data.List.transpose $ map column_rows cols
+ let has_title = any (not . Text.null . column_title) cols
+ let titles =
+ W.intercalate (W.bold $ W.dullblack $ W.char '|')
+ (\col@Column{column_title} -> do
+ let cell_width = Text.length column_title
+ let under = W.bold $ W.dullblack $ W.char '_'
+ let cell_content = W.enclose under under $
+ W.hcat $ map
+ (\c -> case c of { ' ' -> under; _ -> W.char c })
+ (Text.unpack column_title)
+ let pad len = W.bold $ W.dullblack $
+ W.text $ TL.pack $ replicate len '_'
+ align (Just pad) col
+ Cell{cell_width, cell_content, cell_align=Just Align_Center}
+ ) cols
+ W.vsep (
+ (if has_title then (:) titles else id) $
+ map
+ ( W.intercalate (W.space <> do W.bold $ W.dullblack $ W.char '|') id
+ . map (W.space <>)
+ . zipWith toDoc cols
+ ) rows
+ ) <> do
+ (if null cols then W.empty else W.line)
+column :: Text -> Align -> [Cell] -> Column
+column column_title column_align column_rows =
+ Column
+ { column_title
+ , column_width = max (Text.length column_title) $
+ foldr (max . cell_width) 0 column_rows
+ , column_align
+ , column_rows
+ }
+
+-- ** The 'Align' type
+
+data Align
+ = Align_Left
+ | Align_Center
+ | Align_Right
+align :: Maybe (Int -> W.Doc) -> Column -> Cell -> W.Doc
+align filling
+ Column{column_width, column_align}
+ Cell{cell_width, cell_content, cell_align} =
+ let pad = column_width - cell_width in
+ let fill =
+ case filling of
+ Nothing -> \l -> W.fill l W.empty
+ Just f -> f in
+ case fromMaybe column_align cell_align of
+ Align_Left -> cell_content <> fill pad
+ Align_Center ->
+ let half = fromInteger $ quot (toInteger pad) 2 in
+ fill half <> cell_content <> fill (pad - half)
+ Align_Right -> fill pad <> cell_content
+
+-- * The 'Cell' type
+
+data Cell
+ = Cell
+ { cell_align :: Maybe Align
+ , cell_width :: Int
+ , cell_content :: W.Doc
+ }
+cell :: Cell
+cell =
+ Cell
+ { cell_width = 0
+ , cell_content = W.empty
+ , cell_align = Nothing
+ }
+instance ToDoc Column Cell where
+ toDoc = align Nothing
the_following_virtual_transaction_is_not_equilibrated_because: the following virtual transaction is not equilibrated, because:
unit_sums_up_to_the_non_null_amount unit@Unit amount@Amount: #{W.space}- unit #{unit} sums up to the non-null amount: #{amount}
year_or_day_is_missing: year or day is missing
-invalid_day year@Integer month@Int day@Int: invalid day (year #{year}, month #{month}, day #{day})
+invalid_date year@Integer month@Int day@Int: invalid date (year #{year}, month #{month}, day #{day})
invalid_time_of_day hour@Int month@Int second@Integer: invalid hour (hour #{hour}, minute #{month}, second #{second})
unexpect doc@W.Doc: is written: #{doc}
sysunexpect msg@String: sysunexpect: #{msg}
sysunexpect_end_of_input: unexpected end of input
unknown: unknown
or: or
+Balance: Balance
+Account: Account
ERROR: ERREUR
-no_ledger_file_given: aucun fichier indiqué, veuillez utiliser#{W.line} - soit le paramètre -i FICHIER,#{W.line} - soit la variable d’environnement LEDGER_FILE.
+no_ledger_file_given: aucun fichier indiqué, veuillez utiliser :#{W.line} - soit le paramètre -i FICHIER,#{W.line} - soit la variable d’environnement LEDGER_FILE.
at line@Int col@Int: (ligne #{line}, colonne #{col})
in_file path@FilePath line@Int col@Int: (ligne #{line}, colonne #{col}) dans : #{path}
failed_to_read_file path@FilePath: échec de la lecture du fichier : #{path}
the_following_virtual_transaction_is_not_equilibrated_because: la transaction virtuelle suivante n’est pas équilibrée, car :
unit_sums_up_to_the_non_null_amount unit@Unit amount@Amount: #{W.space}- l’unité #{unit} a le solde non-nul : #{amount}
year_or_day_is_missing: l’année ou le jour est manquant-e
-invalid_day year@Integer month@Int day@Int: jour incorrect (année #{year}, mois #{month}, jour #{day})
+invalid_date year@Integer month@Int day@Int: date incorrecte (année #{year}, mois #{month}, jour #{day})
invalid_time_of_day hour@Int month@Int second@Integer: heure incorrecte (heure #{hour}, minute #{month}, seconde #{second})
unexpect doc@W.Doc: trouve : #{doc}
sysunexpect msg@String: est écrit : #{msg}
sysunexpect_end_of_input: fin de fichier inattendue
unknown: inconnu
or: ou
+Balance: Solde
+Account: Compte
sourcephile / git / comptalang.git / commitdiff