1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# LANGUAGE TupleSections #-}
5 module Hcompta.CLI.Command.Balance where
7 import Control.Monad.IO.Class (liftIO)
8 import Control.Monad.Trans.Except (runExceptT)
9 import qualified Data.Either
10 import qualified Data.Foldable
11 import qualified Data.List
12 import qualified Data.Map
13 import qualified Data.Text.Lazy as TL
14 import System.Console.GetOpt
19 import System.Environment as Env (getProgName)
20 import System.Exit (exitWith, ExitCode(..))
21 import qualified System.IO as IO
22 import Text.Show.Pretty (ppShow) -- TODO: may be not necessary
24 import qualified Hcompta.CLI.Args as Args
25 import qualified Hcompta.CLI.Context as Context
26 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
27 import qualified Hcompta.CLI.Write as Write
28 import qualified Hcompta.Calc.Balance as Balance
29 import qualified Hcompta.Format.Ledger as Ledger
30 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
31 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
32 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
33 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
34 import qualified Hcompta.Lib.Leijen as W
35 import Hcompta.Lib.Leijen ((<>))
36 import qualified Hcompta.Model.Amount as Amount
37 import Hcompta.Model.Amount (Amount, Unit)
38 -- import qualified Hcompta.Format.Ledger.Write
42 { ctx_input :: [FilePath]
43 , ctx_redundant :: Bool
50 , ctx_redundant = False
55 bin <- Env.getProgName
58 , " "++bin++" balance [option..]"
60 , usageInfo "OPTIONS" options
63 options :: Args.Options Ctx
66 (NoArg (\_context _ctx -> do
67 usage >>= IO.hPutStr IO.stderr
68 exitWith ExitSuccess))
70 , Option "i" ["input"]
71 (ReqArg (\s _context ctx -> do
72 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
73 "read data from given file, can be use multiple times"
74 , Option "" ["redundant"]
75 (OptArg (\arg context ctx -> do
76 redundant <- case arg of
77 Nothing -> return $ True
78 Just "yes" -> return $ True
79 Just "no" -> return $ False
80 Just _ -> Write.fatal context
81 "--redundant option expects \"yes\", or \"no\" as value"
82 return $ ctx{ctx_redundant=redundant})
84 "also print accounts with zero amount or the same amounts than its ascending account"
87 run :: Context.Context -> [String] -> IO ()
89 (ctx, _) <- Args.parse context usage options (nil, args)
91 CLI.Ledger.paths context $ ctx_input ctx
92 >>= do mapM $ \path -> do
96 Left ko -> return $ Left (path, ko)
97 Right ok -> return $ Right ok
98 >>= return . Data.Either.partitionEithers
101 (flip mapM_) kos $ \(_path, ko) ->
102 Write.fatal context $ show ko
107 (flip (Data.Foldable.foldr
108 (flip (Data.Foldable.foldr
109 (flip (Data.Foldable.foldr Balance.postings)
110 . Ledger.transaction_postings))))
111 . Ledger.journal_transactions))
114 Write.debug context $ ppShow $ balance
115 Write.debug context $ ppShow $
116 Lib.TreeMap.flatten (const ()) (Balance.balance_by_account balance)
117 let expanded = Balance.expanded $ Balance.balance_by_account balance
118 Write.debug context $ ppShow $ expanded
119 with_color <- Write.with_color context IO.stdout
120 Ledger.Write.put with_color IO.stdout $ do
121 let (max_amount_length, accounts) = write_accounts ctx expanded
123 (if W.is_empty accounts
125 else (W.bold $ W.dullblack $
126 W.text (TL.pack $ replicate max_amount_length '-') <>
127 (if max_amount_length <= 0 then W.empty else W.line))) <> do
128 write_amounts max_amount_length $
129 Data.Map.map Balance.unit_sum_amount $
130 (Balance.balance_by_unit balance)
132 write_accounts :: Ctx -> Balance.Expanded Amount Unit -> (Int, W.Doc)
133 write_accounts ctx accounts = do
134 let max_amount_length =
137 (\(len, plus) Balance.Account_Sum_Expanded{Balance.inclusive=amounts} ->
138 let amounts_ = (if ctx_redundant ctx then amounts else Data.Map.filter (not . Amount.is_zero) amounts) in
139 ( Data.Map.foldr (max . Ledger.Write.amount_length) len amounts
140 , (if Data.Map.size amounts_ > 1
141 then 2 -- NOTE: length "+ "
146 (max_amount_length,) $ do
147 Lib.TreeMap.foldl_with_Path_and_Node
148 (\doc account node amounts ->
149 let descendants = Lib.TreeMap.nodes (Lib.TreeMap.node_descendants node) in
150 if not (ctx_redundant ctx) && (
153 (not . Amount.is_zero)
154 (Balance.exclusive amounts)) == 0 &&
157 ( maybe False (not . Amount.are_zero . Balance.inclusive)
158 . Lib.TreeMap.node_value
163 doc <> Data.Map.foldl
165 if not (ctx_redundant ctx) && Amount.is_zero amount
171 W.fill (max_amount_length - Ledger.Write.amount_length amount) W.empty <> do
172 Ledger.Write.amount amount <> do
173 W.space <> W.space <> do
174 Ledger.Write.account Ledger.Posting_Type_Regular account
176 (W.bold $ W.dullblack $ W.text "+" <> W.space) <> do
177 W.fill (max_amount_length - Ledger.Write.amount_length amount - 2) W.empty <> do
178 Ledger.Write.amount amount) <> do
180 ) W.empty (Balance.inclusive amounts)
184 write_amounts :: Int -> Amount.By_Unit -> W.Doc
185 write_amounts max_amount_length_ amounts = do
186 let max_amount_length =
188 (max . Ledger.Write.amount_length)
189 max_amount_length_ amounts
190 (if Data.Map.size amounts > 1
191 then W.space <> W.space
194 (W.line <> (W.bold $ W.dullblack $ W.text "+") <> W.space)
198 - Ledger.Write.amount_length amount
199 - (if Data.Map.size amounts > 1
200 then 2 -- NOTE: length "+ "
202 W.fill len W.empty <> do
203 Ledger.Write.amount amount)
205 (if Data.Map.null amounts then W.empty else W.line)