{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Hcompta.CLI.Command.Balance where import Control.Applicative ((<*), Const(..)) import Control.Arrow (first) import Control.Monad (Monad(..), forM_, liftM, mapM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (runExceptT) import Data.Bool import Data.Either (Either(..), partitionEithers) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..), any) import Data.Functor (Functor(..), (<$>)) import Data.List ((++), repeat) import qualified Data.Map.Strict as Data.Map import Data.Maybe (Maybe(..), maybe) import Data.Monoid (Monoid(..), (<>)) import Data.Ord (Ord(..), Ordering(..)) import qualified Data.Strict.Maybe as Strict import Data.String (String) import Data.Tuple (fst, snd) import qualified Data.Time.Clock as Time import Prelude (($), (.), FilePath, IO, Num(..), const, id, flip, unlines, zipWith) import qualified Text.Parsec import Text.Show (Show(..)) import System.Console.GetOpt ( ArgDescr(..) , OptDescr(..) , usageInfo ) import System.Environment as Env (getProgName) import System.Exit (exitSuccess) import qualified System.IO as IO import Hcompta.Account (Account) import qualified Hcompta.Account as Account import qualified Hcompta.Account.Read as Account.Read import Hcompta.Amount (Amount) import qualified Hcompta.Amount as Amount import Hcompta.Amount.Unit (Unit) import qualified Hcompta.Amount.Write as Amount.Write import qualified Hcompta.Balance as Balance import Hcompta.Chart (Chart) import qualified Hcompta.Chart as Chart import qualified Hcompta.CLI.Args as Args import qualified Hcompta.CLI.Context as C 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.Date as Date import qualified Hcompta.Filter as Filter import qualified Hcompta.Filter.Read as Filter.Read 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 Hcompta.Lib.Leijen (toDoc, ToDoc(..)) import qualified Hcompta.Lib.Leijen as W import Hcompta.Lib.TreeMap (TreeMap) import qualified Hcompta.Lib.TreeMap as TreeMap import qualified Hcompta.Posting as Posting import qualified Hcompta.Tag as Tag data Ctx = Ctx { ctx_filter_balance :: Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Balance ((Account, Tag.Tags), Amount.Sum Amount))) , ctx_filter_posting :: Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Posting (Chart, Ledger.Posting))) , ctx_filter_transaction :: Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Transaction (Chart, Ledger.Transaction))) , ctx_heritage :: Bool , ctx_input :: [FilePath] , ctx_output :: [(Write.Mode, FilePath)] , ctx_reduce_date :: Bool , ctx_redundant :: Bool , ctx_total_by_unit :: Bool , ctx_format_output :: Format_Output , ctx_account_equilibrium :: (Account, Account) } deriving (Show) data Format_Output = Format_Output_Table | Format_Output_Transaction Lang.Exercise_OC deriving (Eq, Show) nil :: C.Context -> Ctx nil c = Ctx { ctx_filter_balance = mempty , ctx_filter_posting = mempty , ctx_filter_transaction = mempty , ctx_heritage = True , ctx_input = [] , ctx_output = [] , ctx_reduce_date = True , ctx_redundant = False , ctx_total_by_unit = True , ctx_format_output = Format_Output_Table , ctx_account_equilibrium = let e = C.translate c Lang.Account_Equilibrium in (e, e) } usage :: C.Context -> IO String usage c = do bin <- Env.getProgName return $ unlines $ [ C.translate c Lang.Section_Description , " "++C.translate c Lang.Help_Command_Balance , "" , C.translate c Lang.Section_Syntax , " "++bin++" balance ["++C.translate c Lang.Type_Option++"] [...]"++ " ["++C.translate c Lang.Type_File_Journal++"] [...]" , "" , usageInfo (C.translate c Lang.Section_Options) (options c) ] options :: C.Context -> Args.Options Ctx options c = [ Option "b" ["filter-balance"] (ReqArg (\s ctx -> do ctx_filter_balance <- liftM ((ctx_filter_balance ctx <>) . Filter.simplify) $ liftIO $ Filter.Read.read Filter.Read.filter_balance s >>= \f -> case f of Left ko -> Write.fatal c ko Right ok -> return ok return $ ctx{ctx_filter_balance}) $ C.translate c Lang.Type_Filter_Balance) $ C.translate c Lang.Help_Option_Filter_Balance , Option "p" ["filter-posting"] (ReqArg (\s ctx -> do ctx_filter_posting <- liftM ((ctx_filter_posting ctx <>) . Filter.simplify) $ liftIO $ Filter.Read.read Filter.Read.filter_posting s >>= \f -> case f of Left ko -> Write.fatal c ko Right ok -> return ok return $ ctx{ctx_filter_posting}) $ C.translate c Lang.Type_Filter_Posting) $ C.translate c Lang.Help_Option_Filter_Posting , Option "t" ["filter-transaction"] (ReqArg (\s ctx -> do ctx_filter_transaction <- liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $ liftIO $ Filter.Read.read Filter.Read.filter_transaction s >>= \f -> case f of Left ko -> Write.fatal c ko Right ok -> return ok return $ ctx{ctx_filter_transaction}) $ C.translate c Lang.Type_Filter_Transaction) $ C.translate c Lang.Help_Option_Filter_Transaction , Option "h" ["help"] (NoArg (\_ctx -> do usage c >>= IO.hPutStr IO.stderr exitSuccess)) $ C.translate c Lang.Help_Option_Help , Option "i" ["input"] (ReqArg (\s ctx -> do return $ ctx{ctx_input=s:ctx_input ctx}) $ C.translate c Lang.Type_File_Journal) $ C.translate c Lang.Help_Option_Input , Option "o" ["output"] (ReqArg (\s ctx -> do return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $ C.translate c Lang.Type_File) $ C.translate c Lang.Help_Option_Output , Option "O" ["overwrite"] (ReqArg (\s ctx -> do return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $ C.translate c Lang.Type_File) $ C.translate c Lang.Help_Option_Overwrite {- NOTE: not used so far. , Option "" ["reduce-date"] (OptArg (\arg ctx -> do ctx_reduce_date <- case arg of Nothing -> return $ True Just "yes" -> return $ True Just "no" -> return $ False Just _ -> Write.fatal c $ W.text "--reduce-date option expects \"yes\", or \"no\" as value" return $ ctx{ctx_reduce_date}) "[yes|no]") "use advanced date reducer to speed up filtering" -} , Option "" ["redundant"] (OptArg (\arg ctx -> do ctx_redundant <- case arg of Nothing -> return $ True Just "yes" -> return $ True Just "no" -> return $ False Just _ -> Write.fatal c Lang.Error_Option_Balance_Redundant return $ ctx{ctx_redundant}) "[no|yes]") $ C.translate c Lang.Help_Option_Balance_Redundant , Option "" ["heritage"] (OptArg (\arg ctx -> do ctx_heritage <- case arg of Nothing -> return $ True Just "yes" -> return $ True Just "no" -> return $ False Just _ -> Write.fatal c Lang.Error_Option_Balance_Heritage return $ ctx{ctx_heritage}) "[yes|no]") $ C.translate c Lang.Help_Option_Balance_Heritage , Option "" ["total"] (OptArg (\arg ctx -> do ctx_total_by_unit <- case arg of Nothing -> return $ True Just "yes" -> return $ True Just "no" -> return $ False Just _ -> Write.fatal c Lang.Error_Option_Balance_Total return $ ctx{ctx_total_by_unit}) "[yes|no]") $ C.translate c Lang.Help_Option_Balance_Total , Option "f" ["format"] (ReqArg (\arg ctx -> do ctx_format_output <- case arg of "table" -> return $ Format_Output_Table "open" -> return $ Format_Output_Transaction Lang.Exercise_Opening "close" -> return $ Format_Output_Transaction Lang.Exercise_Closing _ -> Write.fatal c Lang.Error_Option_Balance_Format return $ ctx{ctx_format_output}) "[table|close|open]") $ C.translate c Lang.Help_Option_Balance_Format , Option "" ["eq"] (ReqArg (\arg ctx -> do ctx_account_equilibrium <- fmap (\e -> (e, e)) $ case Text.Parsec.runParser (Account.Read.account <* Text.Parsec.eof) () "" arg of Right acct -> return acct _ -> Write.fatal c Lang.Error_Option_Equilibrium return $ ctx{ctx_account_equilibrium}) $ C.translate c Lang.Type_Account) $ C.translate c Lang.Help_Option_Equilibrium , Option "" ["eq-credit"] (ReqArg (\arg ctx -> do ctx_account_equilibrium <- fmap (\e -> (fst $ ctx_account_equilibrium ctx, e)) $ case Text.Parsec.runParser (Account.Read.account <* Text.Parsec.eof) () "" arg of Right acct -> return acct _ -> Write.fatal c Lang.Error_Option_Equilibrium_Credit return $ ctx{ctx_account_equilibrium}) $ C.translate c Lang.Type_Account) $ C.translate c Lang.Help_Option_Equilibrium_Credit , Option "" ["eq-debit"] (ReqArg (\arg ctx -> do ctx_account_equilibrium <- fmap (\e -> (e, snd $ ctx_account_equilibrium ctx)) $ case Text.Parsec.runParser (Account.Read.account <* Text.Parsec.eof) () "" arg of Right acct -> return acct _ -> Write.fatal c Lang.Error_Option_Equilibrium_Debit return $ ctx{ctx_account_equilibrium}) $ C.translate c Lang.Type_Account) $ C.translate c Lang.Help_Option_Equilibrium_Debit ] run :: C.Context -> [String] -> IO () run c args = do (ctx, inputs) <- first (\x -> case ctx_output x of [] -> x{ctx_output=[(Write.Mode_Append, "-")]} _ -> x) <$> Args.parse c usage options (nil c, args) read_journals <- liftM Data.Either.partitionEithers $ do CLI.Ledger.paths c $ ctx_input ctx ++ inputs >>= do mapM $ \path -> do liftIO $ runExceptT $ Ledger.Read.file (Ledger.Read.context ( ctx_filter_transaction ctx , ctx_filter_posting ctx ) Ledger.journal) path >>= \x -> case x of Left ko -> return $ Left (path, ko) Right ok -> return $ Right ok case read_journals of (errs@(_:_), _journals) -> forM_ errs $ \(_path, err) -> do Write.fatal c $ err ([], journals) -> do Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx) Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx) Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx) let lang = C.lang c case ctx_format_output ctx of Format_Output_Transaction oc -> do now <- liftM (\d -> d{Time.utctDayTime=0}) $ Date.now let sty = Write.style { Write.style_pretty = True -- ctx_align ctx } Write.write c sty (ctx_output ctx) $ do Ledger.Write.transactions $ do let (chart, bal) = ledger_balance_by_account ctx journals let balance_by_account = ledger_balance_by_account_filter ctx (chart, bal) let Balance.Balance_by_Unit balance_by_unit = ledger_balance_by_unit ctx balance_by_account let equilibrium_postings = Data.Map.foldlWithKey (\acc unit bu -> let amt = (case oc of Lang.Exercise_Closing -> id Lang.Exercise_Opening -> negate) $ Amount.sum_balance $ Balance.unit_sum_amount bu in case Amount.sign amt of LT -> (Ledger.posting $ snd $ ctx_account_equilibrium ctx) { Ledger.posting_amounts = Data.Map.singleton unit amt , Ledger.posting_comments = [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ] }:acc EQ -> acc GT -> (Ledger.posting $ fst $ ctx_account_equilibrium ctx) { Ledger.posting_amounts = Data.Map.singleton unit amt , Ledger.posting_comments = [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ] }:acc ) mempty balance_by_unit [Ledger.transaction { Ledger.transaction_description= Lang.translate lang (Lang.Description_Exercise oc) , Ledger.transaction_dates=(now, []) , Ledger.transaction_postings= Data.Map.unionWith mappend (Ledger.posting_by_Account equilibrium_postings) (TreeMap.flatten_with_Path (\posting_account (Balance.Account_Sum amount_by_unit) -> [(Ledger.posting posting_account) { Ledger.posting_amounts = flip fmap amount_by_unit $ (case oc of Lang.Exercise_Closing -> negate Lang.Exercise_Opening -> id) . Amount.sum_balance } ] ) balance_by_account ) }] Format_Output_Table -> do let ( table_balance_by_account , Balance.Balance_by_Unit balance_by_unit ) = let (ch, bal) = ledger_balance_by_account ctx journals in if ctx_heritage ctx then let balance_filtered = ledger_balance_by_account_expanded ctx ch bal in ( table_by_account ctx Balance.inclusive balance_filtered , ledger_balance_by_unit_expanded ctx balance_filtered ) else let balance_filtered = ledger_balance_by_account_filter ctx (ch, bal) in ( table_by_account ctx id balance_filtered , ledger_balance_by_unit ctx balance_filtered ) let sty = Write.style { Write.style_pretty = True } Write.write c sty (ctx_output ctx) $ do toDoc () $ do zipWith id [ Table.column (Lang.translate lang Lang.Title_Debit) Table.Align_Right , Table.column (Lang.translate lang Lang.Title_Credit) Table.Align_Right , Table.column (Lang.translate lang Lang.Title_Balance) Table.Align_Right , Table.column (Lang.translate lang Lang.Title_Account) Table.Align_Left ] $ do table_balance_by_account $ do case ctx_total_by_unit ctx of False -> repeat [] True -> do zipWith (:) [ Table.Cell_Line '=' 0 , Table.Cell_Line '=' 0 , Table.Cell_Line '=' 0 , Table.Cell_Line ' ' 0 ] $ do flip table_by_unit (repeat []) $ Data.Map.map Balance.unit_sum_amount balance_by_unit ledger_balance_by_account :: Ctx -> [ Ledger.Journal (Const (Balance.Balance_by_Account (Amount.Sum Amount)) (Chart, Ledger.Transaction)) ] -> (Chart, Balance.Balance_by_Account (Amount.Sum Amount)) ledger_balance_by_account _ctx = Data.Foldable.foldl' (flip (\j -> flip mappend $ (Ledger.journal_chart j,) $ Ledger.Journal.fold (\Ledger.Journal { Ledger.journal_sections=Const b } -> mappend b ) j mempty )) mempty ledger_balance_by_account_filter :: Ctx -> (Chart, Balance.Balance_by_Account (Amount.Sum Amount)) -> Balance.Balance_by_Account (Amount.Sum Amount) ledger_balance_by_account_filter ctx (chart, balance) = case Filter.simplified $ ctx_filter_balance ctx of Right True -> if ctx_redundant ctx then balance else TreeMap.filter_with_Path_and_Node (const . is_worth) balance Right False -> mempty Left flt -> TreeMap.filter_with_Path_and_Node (\node acct bal -> (is_worth node bal &&) $ Data.Foldable.any (Filter.test flt . ((acct, Chart.account_tags acct chart),)) $ Balance.get_Account_Sum bal) balance where is_worth node bal = let _descendants = TreeMap.nodes (TreeMap.node_descendants node) in ctx_redundant ctx -- NOTE: worth if no descendant -- but Account's exclusive -- has at least a non-zero Amount || Data.Foldable.any (not . Amount.is_zero . Amount.sum_balance) (Balance.get_Account_Sum bal) ledger_balance_by_account_expanded :: Ctx -> Chart -> Balance.Balance_by_Account (Amount.Sum Amount) -> Balance.Expanded (Amount.Sum Amount) ledger_balance_by_account_expanded ctx chart = case Filter.simplified $ ctx_filter_balance ctx of Right True -> if ctx_redundant ctx then id else TreeMap.filter_with_Path_and_Node (const . is_worth) Right False -> const mempty Left flt -> TreeMap.filter_with_Path_and_Node (\node acct bal -> (is_worth node bal &&) $ Data.Foldable.any (Filter.test flt . ((acct, Chart.account_tags acct chart),)) $ Balance.get_Account_Sum $ Balance.inclusive bal) . Balance.expanded where is_worth node bal = let descendants = TreeMap.nodes (TreeMap.node_descendants node) in ctx_redundant ctx -- NOTE: worth if no descendant -- but Account's inclusive -- has at least a non-zero Amount || (Data.Map.null descendants && Data.Foldable.any (not . Amount.is_zero . Amount.sum_balance) (Balance.get_Account_Sum $ Balance.inclusive bal)) -- NOTE: worth if Account's exclusive -- has at least a non-zero Amount || (Data.Foldable.any (not . Amount.is_zero . Amount.sum_balance) (Balance.get_Account_Sum $ Balance.exclusive bal)) -- 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 ( Strict.maybe False ( Data.Foldable.any (not . Amount.is_zero . Amount.sum_balance) . Balance.get_Account_Sum . Balance.inclusive ) . TreeMap.node_value ) descendants ) > 1 ledger_balance_by_unit :: Ctx -> Balance.Balance_by_Account (Amount.Sum Amount) -> Balance.Balance_by_Unit (Amount.Sum Amount) ledger_balance_by_unit _ctx = flip Balance.by_unit_of_by_account mempty ledger_balance_by_unit_expanded :: Ctx -> Balance.Expanded (Amount.Sum Amount) -> Balance.Balance_by_Unit (Amount.Sum Amount) ledger_balance_by_unit_expanded _ctx = flip Balance.by_unit_of_expanded mempty table_by_account :: Ctx -> (amount -> Balance.Account_Sum (Amount.Sum Amount)) -> TreeMap Account.Account_Section amount -> [[Table.Cell]] -> [[Table.Cell]] table_by_account _ctx get_Account_Sum = let posting_type = Posting.Posting_Type_Regular in flip $ TreeMap.foldr_with_Path (\account balance rows -> foldr (\(amount_positive, amount_negative, amount) -> zipWith (:) [ Table.cell { Table.cell_content = maybe W.empty Amount.Write.amount amount_positive , Table.cell_width = maybe 0 Amount.Write.amount_length amount_positive } , Table.cell { Table.cell_content = maybe W.empty Amount.Write.amount amount_negative , Table.cell_width = maybe 0 Amount.Write.amount_length amount_negative } , Table.cell { Table.cell_content = Amount.Write.amount $ amount , Table.cell_width = Amount.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.get_Account_Sum $ get_Account_Sum balance in Data.Map.foldrWithKey (\unit amount acc -> ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal , Amount.sum_balance amount ) : acc ) [] $ bal ) table_by_unit :: Data.Map.Map Unit (Amount.Sum Amount) -> [[Table.Cell]] -> [[Table.Cell]] table_by_unit = flip $ foldr (\amount_sum -> zipWith (:) [ let amt = Amount.sum_positive amount_sum in Table.cell { Table.cell_content = maybe W.empty Amount.Write.amount amt , Table.cell_width = maybe 0 Amount.Write.amount_length amt } , let amt = Amount.sum_negative amount_sum in Table.cell { Table.cell_content = maybe W.empty Amount.Write.amount amt , Table.cell_width = maybe 0 Amount.Write.amount_length amt } , let amt = Amount.sum_balance amount_sum in Table.cell { Table.cell_content = Amount.Write.amount amt , Table.cell_width = Amount.Write.amount_length amt } , Table.cell { Table.cell_content = W.empty , Table.cell_width = 0 } ] )