cli/Hcompta/CLI/Command/Balance.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE TupleSections #-}
   5 module Hcompta.CLI.Command.Balance where
   6
   7 import           Prelude hiding (foldr)
   8 -- import           Control.Monad ((>=>))
   9 import           Control.Monad.IO.Class (liftIO)
  10 import           Control.Monad.Trans.Except (runExceptT)
  11 import qualified Data.Either
  12 import qualified Data.Foldable
  13 import           Data.Foldable (foldr)
  14 import qualified Data.List
  15 import qualified Data.Map.Strict as Data.Map
  16 import qualified Data.Text.Lazy as TL
  17 import           System.Console.GetOpt
  18                  ( ArgDescr(..)
  19                  , OptDescr(..)
  20                  , usageInfo
  21                  )
  22 import           System.Environment as Env (getProgName)
  23 import           System.Exit (exitWith, ExitCode(..))
  24 import qualified System.IO as IO
  25
  26 import           Hcompta.Account (Account)
  27 import           Hcompta.Amount (Amount)
  28 import qualified Hcompta.Amount as Amount
  29 import qualified Hcompta.Amount.Write as Amount.Write
  30 import           Hcompta.Amount.Unit (Unit)
  31 import qualified Hcompta.Balance as Balance
  32 import qualified Hcompta.CLI.Args as Args
  33 import qualified Hcompta.CLI.Context as Context
  34 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  35 import qualified Hcompta.CLI.Lang as Lang
  36 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
  37 import qualified Hcompta.CLI.Write as Write
  38 import qualified Hcompta.Filter as Filter
  39 import qualified Hcompta.Filter.Read as Filter.Read
  40 import qualified Hcompta.Format.Ledger as Ledger
  41 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  42 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  43 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  44 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  45 import qualified Hcompta.Lib.Leijen as W
  46 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
  47
  48 data Ctx
  49  =   Ctx
  50  { ctx_input              :: [FilePath]
  51  , ctx_redundant          :: Bool
  52  , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
  53  , ctx_posting_filter     :: Filter.Test_Bool (Filter.Test_Posting     Ledger.Posting)
  54  , ctx_balance_filter     :: Filter.Test_Bool (Filter.Test_Balance     (Account, Amount.Sum Amount))
  55  } deriving (Show)
  56
  57 nil :: Ctx
  58 nil =
  59         Ctx
  60          { ctx_input              = []
  61          , ctx_redundant          = False
  62          , ctx_transaction_filter = Filter.Any
  63          , ctx_posting_filter     = Filter.Any
  64          , ctx_balance_filter     = Filter.Any
  65          }
  66
  67 usage :: IO String
  68 usage = do
  69         bin <- Env.getProgName
  70         return $ unlines $
  71                 [ "SYNTAX "
  72                 , "  "++bin++" balance"
  73                 , " [-t TRANSACTION_FILTER]"
  74                 , " [-p POSTING_FILTER]"
  75                 , " [-b BALANCE_FILTER]"
  76                 , " JOURNAL_FILE [...]"
  77                 , ""
  78                 , usageInfo "OPTIONS" options
  79                 ]
  80
  81 options :: Args.Options Ctx
  82 options =
  83         [ Option "b" ["balance-filter"]
  84          (ReqArg (\s context ctx -> do
  85                 ctx_balance_filter <-
  86                         fmap (Filter.And $ ctx_balance_filter ctx) $
  87                                 liftIO $ Filter.Read.read Filter.Read.test_balance s
  88                                 >>= \f -> case f of
  89                                  Left  ko -> Write.fatal context $ ko
  90                                  Right ok -> return ok
  91                 return $ ctx{ctx_balance_filter}) "FILTER")
  92          "filter at balance level, multiple uses are merged with a logical AND"
  93         , Option "h" ["help"]
  94          (NoArg (\_context _ctx -> do
  95                 usage >>= IO.hPutStr IO.stderr
  96                 exitWith ExitSuccess))
  97          "show this help"
  98         , Option "i" ["input"]
  99          (ReqArg (\s _context ctx -> do
 100                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
 101          "read data from given file, multiple uses merge the data as would a concatenation do"
 102         , Option "p" ["posting-filter"]
 103          (ReqArg (\s context ctx -> do
 104                 ctx_posting_filter <-
 105                         fmap (Filter.And $ ctx_posting_filter ctx) $
 106                         liftIO $ Filter.Read.read Filter.Read.test_posting s
 107                         >>= \f -> case f of
 108                          Left  ko -> Write.fatal context $ ko
 109                          Right ok -> return ok
 110                 return $ ctx{ctx_posting_filter}) "FILTER")
 111          "filter at posting level, multiple uses are merged with a logical AND"
 112         , Option "" ["redundant"]
 113          (OptArg (\arg context ctx -> do
 114                 ctx_redundant <- case arg of
 115                  Nothing    -> return $ True
 116                  Just "yes" -> return $ True
 117                  Just "no"  -> return $ False
 118                  Just _     -> Write.fatal context $
 119                         W.text "--redundant option expects \"yes\", or \"no\" as value"
 120                 return $ ctx{ctx_redundant})
 121           "[yes|no]")
 122          "also print accounts with zero amount or the same amounts than its ascending account"
 123         , Option "t" ["transaction-filter"]
 124          (ReqArg (\s context ctx -> do
 125                 ctx_transaction_filter <-
 126                         fmap (Filter.And $ ctx_transaction_filter ctx) $
 127                         liftIO $ Filter.Read.read Filter.Read.test_transaction s
 128                         >>= \f -> case f of
 129                          Left  ko -> Write.fatal context $ ko
 130                          Right ok -> return ok
 131                 return $ ctx{ctx_transaction_filter}) "FILTER")
 132          "filter at transaction level, multiple uses are merged with a logical AND"
 133         ]
 134
 135 run :: Context.Context -> [String] -> IO ()
 136 run context args = do
 137         (ctx, inputs) <- Args.parse context usage options (nil, args)
 138         read_journals <- do
 139                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 140                 >>= do
 141                         mapM $ \path -> do
 142                                 liftIO $ runExceptT $ Ledger.Read.file path
 143                                 >>= \x -> case x of
 144                                  Left  ko -> return $ Left (path, ko)
 145                                  Right ok -> return $ Right ok
 146                 >>= return . Data.Either.partitionEithers
 147         case read_journals of
 148          (errs@(_:_), _journals) ->
 149                 (flip mapM_) errs $ \(_path, err) -> do
 150                         Write.fatal context $ err
 151          ([], journals) -> do
 152                 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
 153                 Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
 154                 Write.debug context $ "balance_filter: " ++ show (ctx_balance_filter ctx)
 155                 let (balance_by_account, balance_by_unit) =
 156                         ledger_balances ctx journals
 157                 style_color <- Write.with_color context IO.stdout
 158                 W.displayIO IO.stdout $
 159                  W.renderPretty style_color 1.0 maxBound $ do
 160                         toDoc () $
 161                                 let title =
 162                                         TL.toStrict . W.displayT .
 163                                         W.renderCompact False .
 164                                         toDoc (Context.lang context) in
 165                                 zipWith id
 166                                 [ Table.column (title Lang.Message_Debit)   Table.Align_Right
 167                                 , Table.column (title Lang.Message_Credit)  Table.Align_Right
 168                                 , Table.column (title Lang.Message_Balance) Table.Align_Right
 169                                 , Table.column (title Lang.Message_Account) Table.Align_Left
 170                                 ] $
 171                                 write_by_accounts ctx balance_by_account $
 172                                 zipWith (:)
 173                                         [ Table.Cell_Line '=' 0
 174                                         , Table.Cell_Line '=' 0
 175                                         , Table.Cell_Line '=' 0
 176                                         , Table.Cell_Line ' ' 0
 177                                         ] $
 178                                 flip write_by_amounts (repeat []) $
 179                                         Data.Map.map
 180                                          Balance.unit_sum_amount
 181                                          balance_by_unit
 182
 183 ledger_balances
 184  :: Ctx
 185  -> [Ledger.Journal]
 186  -> ( Balance.Expanded (Amount.Sum Amount)
 187     , Balance.Balance_by_Unit (Amount.Sum Amount) Unit )
 188 ledger_balances ctx journals =
 189         let balance_by_account =
 190                 foldr
 191                  (Ledger.Journal.fold
 192                          (flip (foldr
 193                                  (flip (foldr
 194                                          (\tr ->
 195                                                 case Filter.test (ctx_transaction_filter ctx) tr of
 196                                                  False -> id
 197                                                  True ->
 198                                                         let filter_postings =
 199                                                                 Data.Foldable.concatMap $
 200                                                                 Data.List.filter $
 201                                                                 (Filter.test $ ctx_posting_filter ctx) in
 202                                                         let balance =
 203                                                                 flip (foldr Balance.by_account) .
 204                                                                 map (\p ->
 205                                                                         ( Ledger.posting_account p
 206                                                                         , Data.Map.map Amount.sum (Ledger.posting_amounts p)
 207                                                                         )
 208                                                                  ) .
 209                                                                 filter_postings in
 210                                                         balance (Ledger.transaction_postings tr) .
 211                                                         balance (Ledger.transaction_virtual_postings tr) .
 212                                                         balance (Ledger.transaction_balanced_virtual_postings tr)
 213                                          ))))
 214                          . Ledger.journal_transactions))
 215                  (Balance.balance_by_account Balance.nil)
 216                  journals in
 217         let balance_expanded =
 218                 Lib.TreeMap.filter_with_Path_and_Node
 219                  (\node acct balance ->
 220                         let descendants = Lib.TreeMap.nodes
 221                                  (Lib.TreeMap.node_descendants node) in
 222                         let is_worth =
 223                                 ctx_redundant ctx
 224                                 -- NOTE: worth if no descendant
 225                                 -- but account inclusive
 226                                 -- has at least a non-zero amount
 227                                 || (Data.Map.null descendants && not
 228                                          (Data.Map.null
 229                                          (Data.Map.filter
 230                                                  (not . Amount.is_zero . Amount.sum_balance)
 231                                                  (Balance.inclusive balance))))
 232                                 -- NOTE: worth if account exclusive
 233                                 -- has at least a non-zero amount
 234                                 || not (Data.Map.null
 235                                          (Data.Map.filter
 236                                                  (not . Amount.is_zero . Amount.sum_balance)
 237                                                  (Balance.exclusive balance)))
 238                                 -- NOTE: worth if account has at least more than
 239                                 -- one descendant account whose inclusive
 240                                 -- has at least a non-zero amount
 241                                 || Data.Map.size
 242                                          (Data.Map.filter
 243                                                  ( maybe False
 244                                                          ( not . Data.Foldable.all
 245                                                                  ( Amount.is_zero
 246                                                                  . Amount.sum_balance )
 247                                                          . Balance.inclusive )
 248                                                  . Lib.TreeMap.node_value )
 249                                                  descendants) > 1
 250                         in
 251                         if is_worth
 252                         then
 253                                 Data.Foldable.any
 254                                  (Filter.test (ctx_balance_filter ctx) . (acct,)) $
 255                                 Balance.inclusive balance
 256                         else False
 257                  ) $
 258                 Balance.expanded balance_by_account in
 259         let balance_by_unit =
 260                 Balance.by_unit_of_expanded
 261                  balance_expanded
 262                  (Balance.balance_by_unit Balance.nil) in
 263         ( balance_expanded
 264         , balance_by_unit
 265         )
 266
 267 write_by_accounts
 268  :: Ctx
 269  -> Balance.Expanded (Amount.Sum Amount)
 270  -> [[Table.Cell]]
 271  -> [[Table.Cell]]
 272 write_by_accounts _ctx =
 273         let posting_type = Ledger.Posting_Type_Regular in
 274         flip $ Lib.TreeMap.foldr_with_Path
 275          (\account balance rows ->
 276                 foldr
 277                  (\(amount_positive, amount_negative, amount) ->
 278                         zipWith (:)
 279                                 [ Table.cell
 280                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_positive
 281                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_positive
 282                                  }
 283                                 , Table.cell
 284                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_negative
 285                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_negative
 286                                  }
 287                                 , Table.cell
 288                                  { Table.cell_content = Amount.Write.amount        $ amount
 289                                  , Table.cell_width   = Amount.Write.amount_length $ amount
 290                                  }
 291                                 , Table.cell
 292                                  { Table.cell_content = Ledger.Write.account        posting_type account
 293                                  , Table.cell_width   = Ledger.Write.account_length posting_type account
 294                                  }
 295                                 ]
 296                  )
 297                  rows $
 298                 let bal = Balance.inclusive balance in
 299                 Data.Map.foldrWithKey
 300                  (\unit amount acc ->
 301                         ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
 302                         , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
 303                         , Amount.sum_balance amount
 304                         ) : acc
 305                  ) [] $ bal
 306          )
 307
 308 write_by_amounts
 309  :: Data.Map.Map Unit (Amount.Sum Amount)
 310  -> [[Table.Cell]]
 311  -> [[Table.Cell]]
 312 write_by_amounts =
 313         flip $ foldr
 314          (\amount_sum ->
 315                 zipWith (:)
 316                         [ let amt = Amount.sum_positive amount_sum in
 317                                 Table.cell
 318                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 319                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 320                                  }
 321                         , let amt = Amount.sum_negative amount_sum in
 322                                 Table.cell
 323                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 324                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 325                                  }
 326                         , let amt = Amount.sum_balance amount_sum in
 327                                 Table.cell
 328                                  { Table.cell_content = Amount.Write.amount        amt
 329                                  , Table.cell_width   = Amount.Write.amount_length amt
 330                                  }
 331                         , Table.cell
 332                                  { Table.cell_content = W.empty
 333                                  , Table.cell_width   = 0
 334                                  }
 335                         ]
 336          )