{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Hcompta.CLI.Command.Balance where import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (runExceptT) import qualified Data.Either import qualified Data.Foldable import qualified Data.List import qualified Data.Map import qualified Data.Text.Lazy as TL import System.Console.GetOpt ( ArgDescr(..) , OptDescr(..) , usageInfo ) import System.Environment as Env (getProgName) import System.Exit (exitWith, ExitCode(..)) import qualified System.IO as IO import Text.Show.Pretty (ppShow) 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.Calc.Balance as Balance import qualified Hcompta.Format.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 ((<>)) import qualified Hcompta.Model.Amount as Amount import qualified Hcompta.Model.Transaction.Posting as Posting -- import qualified Hcompta.Format.Ledger.Write data Ctx = Ctx { ctx_input :: [FilePath] , ctx_redundant :: Bool } deriving (Eq, Show) nil :: Ctx nil = Ctx { ctx_input = [] , ctx_redundant = False } usage :: IO String usage = do bin <- Env.getProgName return $ unlines $ [ "SYNTAX " , " "++bin++" balance [option..]" , "" , usageInfo "OPTIONS" options ] options :: Args.Options Ctx options = [ Option "h" ["help"] (NoArg (\_context _ctx -> do usage >>= IO.hPutStr IO.stderr exitWith ExitSuccess)) "show this help" , Option "i" ["input"] (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 "" ["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" 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 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 case koks of (kos@(_:_), _oks) -> (flip mapM_) kos $ \(_path, ko) -> Write.fatal context $ ko ([], journals) -> do CLI.Ledger.equilibre context journals let balance = Data.List.foldl (\b j -> Balance.journal_with_virtual (Hcompta.Format.Ledger.Journal.to_Model j) b) Balance.nil journals Write.debug context $ ppShow $ balance Write.debug context $ ppShow $ Lib.TreeMap.flatten (const ()) (Balance.by_account balance) let expanded = Balance.expand $ 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) 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.null (Balance.exclusive amounts) || Data.Map.size (Data.Map.filter ( maybe False (not . Amount.are_zero . Balance.inclusive) . Lib.TreeMap.node_content ) 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) ) 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)