{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Hcompta.CLI.Command.Balance where
+import Prelude hiding (foldr)
+-- import Control.Monad ((>=>))
+import Control.Applicative ((<$>))
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (runExceptT)
import qualified Data.Either
import qualified Data.Foldable
+import Data.Foldable (foldr)
import qualified Data.List
-import qualified Data.Map
+import qualified Data.Map.Strict as Data.Map
+-- import Data.Map.Strict (Map)
import qualified Data.Text.Lazy as TL
import System.Console.GetOpt
( ArgDescr(..)
import System.Environment as Env (getProgName)
import System.Exit (exitWith, ExitCode(..))
import qualified System.IO as IO
-import Text.Show.Pretty (ppShow) -- TODO: may be not necessary
+-- import Text.Show.Pretty (ppShow)
+import qualified Hcompta.Balance as Balance
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.Lang as Lang
+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.Journal
+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.Foldable as Lib.Foldable
import qualified Hcompta.Lib.Leijen as W
-import Hcompta.Lib.Leijen ((<>))
-import qualified Hcompta.Model.Amount as Amount
-import qualified Hcompta.Model.Transaction.Posting as Posting
--- import qualified Hcompta.Format.Ledger.Write
+import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
+-- import qualified Hcompta.Account as Account
+import Hcompta.Account (Account)
+import qualified Hcompta.Amount as Amount
+import Hcompta.Amount (Amount)
+import Hcompta.Amount.Unit (Unit)
+import qualified Hcompta.Filter as Filter
+import qualified Hcompta.Filter.Read as Filter.Read
data Ctx
= Ctx
- { ctx_input :: [FilePath]
- , ctx_redundant :: Bool
- } deriving (Eq, Show)
+ { ctx_input :: [FilePath]
+ , ctx_redundant :: Bool
+ , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
+ , ctx_posting_filter :: Filter.Test_Bool (Filter.Test_Posting Ledger.Posting)
+ } deriving (Show)
nil :: Ctx
nil =
Ctx
- { ctx_input = []
- , ctx_redundant = False
+ { ctx_input = []
+ , ctx_redundant = False
+ , ctx_transaction_filter = Filter.Any
+ , ctx_posting_filter = Filter.Any
}
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 "t" ["transaction-filter"]
+ (ReqArg (\s context ctx -> do
+ ctx_transaction_filter <-
+ liftIO $ Filter.Read.read Filter.Read.test_transaction s
+ >>= \f -> case f of
+ Left ko -> Write.fatal context $ ko
+ Right ok -> return ok
+ return $ ctx{ctx_transaction_filter}) "FILTER")
+ "filter on posting"
+ , Option "p" ["posting-filter"]
+ (ReqArg (\s context ctx -> do
+ ctx_posting_filter <-
+ liftIO $ Filter.Read.read Filter.Read.test_posting s
+ >>= \f -> case f of
+ Left ko -> Write.fatal context $ ko
+ Right ok -> return ok
+ return $ ctx{ctx_posting_filter}) "FILTER")
+ "filter on balance"
, Option "" ["redundant"]
(OptArg (\arg context ctx -> do
redundant <- case arg of
Nothing -> return $ True
Just "yes" -> return $ True
Just "no" -> return $ False
- Just _ -> Write.fatal context
- "--redundant option expects \"yes\", or \"no\" as value"
+ Just _ -> Write.fatal context $
+ W.text "--redundant option expects \"yes\", or \"no\" as value"
return $ ctx{ctx_redundant=redundant})
"[yes|no]")
"also print accounts with zero amount or the same amounts than its ascending account"
run :: Context.Context -> [String] -> IO ()
run context args = do
- (ctx, _) <- Args.parse context usage options (nil, args)
- koks <- do
+ (ctx, text_filters) <- Args.parse context usage options (nil, args)
+ read_journals <- 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
+ >>= 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
- case koks of
- (kos@(_:_), _oks) ->
- (flip mapM_) kos $ \(_path, ko) ->
- Write.fatal context $ ko
+ case read_journals of
+ (errs@(_:_), _journals) ->
+ (flip mapM_) errs $ \(_path, err) -> do
+ Write.fatal context $ err
([], journals) -> do
- let balance =
- Data.List.foldl
- (\b j -> Balance.journal_with_virtual
- (Hcompta.Format.Ledger.Journal.to_Model j) b)
- Balance.nil
+ balance_filter <-
+ foldr Filter.And Filter.Any <$> do
+ (flip mapM) text_filters $ \s ->
+ liftIO $ Filter.Read.read Filter.Read.test_balance s
+ >>= \f -> case f of
+ Left ko -> Write.fatal context $ ko
+ Right ok -> return ok
+ Write.debug context $ "balance_filter: " ++ show balance_filter
+ Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
+ Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
+ let (balance_by_account, balance_by_unit) =
+ ledger_balances
+ (ctx_transaction_filter ctx)
+ (ctx_posting_filter ctx)
+ balance_filter
journals
- Write.debug context $ ppShow $ balance
- Write.debug context $ ppShow $
- Lib.TreeMap.flatten (const ()) (Balance.by_account balance)
- let expanded = Balance.expanded $ 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.amount $
- (Balance.by_unit balance)
+ style_color <- Write.with_color context IO.stdout
+ W.displayIO IO.stdout $
+ W.renderPretty style_color 1.0 maxBound $ do
+ toDoc () $
+ let title =
+ TL.toStrict . W.displayT .
+ W.renderCompact False .
+ toDoc (Context.lang context) in
+ zipWith id
+ [ Table.column (title Lang.Message_Balance_debit) Table.Align_Right
+ , Table.column (title Lang.Message_Balance_credit) Table.Align_Right
+ , Table.column (title Lang.Message_Balance_total) Table.Align_Right
+ , Table.column (title Lang.Message_Account) Table.Align_Left
+ ] $
+ flip (write_by_accounts ctx) balance_by_account $
+ zipWith (:)
+ [ Table.Cell_Line '=' 0
+ , Table.Cell_Line '=' 0
+ , Table.Cell_Line '=' 0
+ , Table.Cell_Line ' ' 0
+ ] $
+ write_by_amounts (repeat []) $
+ Data.Map.map
+ Balance.unit_sum_amount
+ balance_by_unit
-write_accounts :: Ctx -> Balance.Expanded -> (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 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)
+ledger_balances
+ :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
+ -> Filter.Test_Bool (Filter.Test_Posting Ledger.Posting)
+ -> Filter.Test_Bool (Filter.Test_Balance (Account, Balance.Amount_Sum Amount))
+ -> [Ledger.Journal]
+ -> ( Balance.Expanded (Balance.Amount_Sum Amount)
+ , Balance.Balance_by_Unit (Balance.Amount_Sum Amount) Unit )
+ledger_balances
+ transaction_filter
+ posting_filter
+ balance_filter
+ journals =
+ let balance_by_account =
+ foldr
+ (Ledger.Journal.fold
+ (flip (foldr
+ (flip (foldr
+ (\tr ->
+ case Filter.test transaction_filter tr of
+ False -> id
+ True ->
+ let filter_postings =
+ Data.Foldable.concatMap $
+ Data.List.filter $
+ (Filter.test posting_filter) in
+ let balance =
+ flip (foldr Balance.by_account) .
+ map (\p ->
+ ( Ledger.posting_account p
+ , Data.Map.map Balance.amount_sum (Ledger.posting_amounts p)
+ )
+ ) .
+ filter_postings in
+ balance (Ledger.transaction_postings tr) .
+ balance (Ledger.transaction_virtual_postings tr) .
+ balance (Ledger.transaction_balanced_virtual_postings tr)
+ ))))
+ . Ledger.journal_transactions))
+ (Balance.balance_by_account Balance.nil)
+ journals in
+ let balance_expanded =
+ Lib.TreeMap.filter_with_Path (\acct ->
+ Data.Foldable.any
+ (Filter.test balance_filter . (acct,)) .
+ Balance.inclusive) $
+ Balance.expanded balance_by_account in
+ let balance_by_unit =
+ Balance.by_unit_of_expanded
+ balance_expanded
+ (Balance.balance_by_unit Balance.nil) in
+ ( balance_expanded
+ , balance_by_unit
+ )
+
+write_by_accounts
+ :: Ctx
+ -> [[Table.Cell]]
+ -> Balance.Expanded (Balance.Amount_Sum Amount)
+ -> [[Table.Cell]]
+write_by_accounts ctx =
+ let posting_type = Ledger.Posting_Type_Regular in
+ Lib.TreeMap.foldr_with_Path_and_Node
+ (\account node balance rows -> do
+ let descendants = Lib.TreeMap.nodes
+ (Lib.TreeMap.node_descendants node)
+ let is_worth =
+ ctx_redundant ctx
+ -- NOTE: worth if no descendant
+ -- but account inclusive
+ -- has at least a non-zero amount
+ || (Data.Map.null descendants && not
+ (Data.Map.null
+ (Data.Map.filter
+ (not . Amount.is_zero . Balance.amount_sum_balance)
+ (Balance.inclusive balance))))
+ -- NOTE: worth if account exclusive
+ -- has at least a non-zero amount
+ || not (Data.Map.null
+ (Data.Map.filter
+ (not . Amount.is_zero . Balance.amount_sum_balance)
+ (Balance.exclusive balance)))
+ -- NOTE: worth if account has at least more than
+ -- one descendant account whose inclusive
+ -- has at least a non-zero amount
+ || Data.Map.size
+ (Data.Map.filter
+ ( maybe False
+ ( not . Data.Foldable.all
+ ( Amount.is_zero
+ . Balance.amount_sum_balance )
+ . Balance.inclusive )
+ . Lib.TreeMap.node_value )
+ descendants) > 1
+ case is_worth of
+ False -> rows
+ True ->
+ foldr
+ (\(amount_positive, amount_negative, amount) ->
+ zipWith (:)
+ [ Table.cell
+ { Table.cell_content = maybe W.empty Ledger.Write.amount amount_positive
+ , Table.cell_width = maybe 0 Ledger.Write.amount_length amount_positive
+ }
+ , Table.cell
+ { Table.cell_content = maybe W.empty Ledger.Write.amount amount_negative
+ , Table.cell_width = maybe 0 Ledger.Write.amount_length amount_negative
+ }
+ , 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 $
+ let bal = Balance.inclusive balance in
+ Data.Map.foldrWithKey
+ (\unit amount acc ->
+ ( maybe Nothing Balance.amount_sum_positive $ Data.Map.lookup unit $ bal
+ , maybe Nothing Balance.amount_sum_negative $ Data.Map.lookup unit $ bal
+ , Balance.amount_sum_balance amount
+ ) : acc
+ ) [] $ bal
)
- W.empty accounts
-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)
- (\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)
+write_by_amounts
+ :: [[Table.Cell]]
+ -> Data.Map.Map Unit (Balance.Amount_Sum Amount)
+ -> [[Table.Cell]]
+write_by_amounts =
+ foldr
+ (\amount_sum ->
+ zipWith (:)
+ [ let amt = Balance.amount_sum_positive amount_sum in
+ Table.cell
+ { Table.cell_content = maybe W.empty Ledger.Write.amount amt
+ , Table.cell_width = maybe 0 Ledger.Write.amount_length amt
+ }
+ , let amt = Balance.amount_sum_negative amount_sum in
+ Table.cell
+ { Table.cell_content = maybe W.empty Ledger.Write.amount amt
+ , Table.cell_width = maybe 0 Ledger.Write.amount_length amt
+ }
+ , let amt = Balance.amount_sum_balance amount_sum in
+ Table.cell
+ { Table.cell_content = Ledger.Write.amount amt
+ , Table.cell_width = Ledger.Write.amount_length amt
+ }
+ , Table.cell
+ { Table.cell_content = W.empty
+ , Table.cell_width = 0
+ }
+ ]
+ )
sourcephile / git / comptalang.git / blobdiff