cli/Hcompta/CLI/Command/Balance.hs

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