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