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           Control.Applicative (Const(..))
  10 import           Prelude hiding (foldr)
  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                 , "  [-i JOURNAL_FILE]"
  89                 , "  [-b BALANCE_FILTER]"
  90                 , "  [-p POSTING_FILTER]"
  91                 , "  [-t TRANSACTION_FILTER]"
  92                 , "  [JOURNAL_FILE] [...]"
  93                 , ""
  94                 , usageInfo "OPTIONS" options
  95                 ]
  96
  97 options :: Args.Options Ctx
  98 options =
  99         [ Option "b" ["filter-balance"]
 100          (ReqArg (\s context ctx -> do
 101                 ctx_filter_balance <-
 102                         liftM ((ctx_filter_balance ctx <>) . Filter.simplify) $
 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 ((ctx_filter_posting ctx <>) . Filter.simplify) $
 113                         liftIO $ Filter.Read.read Filter.Read.filter_posting s
 114                         >>= \f -> case f of
 115                          Left  ko -> Write.fatal context $ ko
 116                          Right ok -> return ok
 117                 return $ ctx{ctx_filter_posting}) "FILTER")
 118          "filter at posting level, multiple uses are merged with a logical AND"
 119         , Option "t" ["filter-transaction"]
 120          (ReqArg (\s context ctx -> do
 121                 ctx_filter_transaction <-
 122                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
 123                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
 124                         >>= \f -> case f of
 125                          Left  ko -> Write.fatal context $ ko
 126                          Right ok -> return ok
 127                 return $ ctx{ctx_filter_transaction}) "FILTER")
 128          "filter at transaction level, multiple uses are merged with a logical AND"
 129         , Option "h" ["help"]
 130          (NoArg (\_context _ctx -> do
 131                 usage >>= IO.hPutStr IO.stderr
 132                 exitWith ExitSuccess))
 133          "show this help"
 134         , Option "i" ["input"]
 135          (ReqArg (\s _context ctx -> do
 136                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
 137          "read data from given file, multiple uses merge the data as would a concatenation do"
 138         {- NOTE: not used so far.
 139         , Option "" ["reduce-date"]
 140          (OptArg (\arg context ctx -> do
 141                 ctx_reduce_date <- case arg of
 142                  Nothing    -> return $ True
 143                  Just "yes" -> return $ True
 144                  Just "no"  -> return $ False
 145                  Just _     -> Write.fatal context $
 146                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 147                 return $ ctx{ctx_reduce_date})
 148           "[yes|no]")
 149          "use advanced date reducer to speed up filtering"
 150         -}
 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 ( ctx_filter_transaction ctx
 173                                                       , ctx_filter_posting     ctx )
 174                                                       Ledger.journal)
 175                                  path
 176                                 >>= \x -> case x of
 177                                  Left  ko -> return $ Left (path, ko)
 178                                  Right ok -> return $ Right ok
 179                 >>= return . Data.Either.partitionEithers
 180         case read_journals of
 181          (errs@(_:_), _journals) ->
 182                 (flip mapM_) errs $ \(_path, err) -> do
 183                         Write.fatal context $ err
 184          ([], journals) -> do
 185                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 186                 Write.debug context $ "filter: posting: " ++ show (ctx_filter_posting ctx)
 187                 Write.debug context $ "filter: balance: " ++ show (ctx_filter_balance ctx)
 188                 let (balance_by_account, Balance.Balance_by_Unit balance_by_unit) =
 189                         ledger_balances ctx journals
 190                 style_color <- Write.with_color context IO.stdout
 191                 W.displayIO IO.stdout $
 192                  W.renderPretty style_color 1.0 maxBound $ do
 193                         toDoc () $
 194                                 let title =
 195                                         TL.toStrict . W.displayT .
 196                                         W.renderCompact False .
 197                                         toDoc (Context.lang context) in
 198                                 zipWith id
 199                                 [ Table.column (title Lang.Message_Debit)   Table.Align_Right
 200                                 , Table.column (title Lang.Message_Credit)  Table.Align_Right
 201                                 , Table.column (title Lang.Message_Balance) Table.Align_Right
 202                                 , Table.column (title Lang.Message_Account) Table.Align_Left
 203                                 ] $
 204                                 write_by_accounts ctx balance_by_account $
 205                                 zipWith (:)
 206                                         [ Table.Cell_Line '=' 0
 207                                         , Table.Cell_Line '=' 0
 208                                         , Table.Cell_Line '=' 0
 209                                         , Table.Cell_Line ' ' 0
 210                                         ] $
 211                                 flip write_by_amounts (repeat []) $
 212                                         Data.Map.map
 213                                          Balance.unit_sum_amount
 214                                          balance_by_unit
 215
 216 ledger_balances
 217  :: Ctx
 218  -> [ Ledger.Journal (Const (Balance.Balance_by_Account (Amount.Sum Amount)) Ledger.Transaction) ]
 219  -> ( Balance.Expanded        (Amount.Sum Amount)
 220     , Balance.Balance_by_Unit (Amount.Sum Amount) )
 221 ledger_balances ctx journals =
 222         let balance_by_account =
 223                 Data.Foldable.foldl'
 224                  (flip $ Ledger.Journal.fold
 225                          (\Ledger.Journal{Ledger.journal_transactions=Const b} ->
 226                                 mappend b))
 227                  mempty journals in
 228         let balance_expanded =
 229                 Lib.TreeMap.filter_with_Path_and_Node
 230                  (\node acct balance ->
 231                         let descendants = Lib.TreeMap.nodes
 232                                  (Lib.TreeMap.node_descendants node) in
 233                         let is_worth =
 234                                 ctx_redundant ctx
 235                                 -- NOTE: worth if no descendant
 236                                 -- but account inclusive
 237                                 -- has at least a non-zero amount
 238                                 || (Data.Map.null descendants && not
 239                                          (Data.Map.null
 240                                          (Data.Map.filter
 241                                                  (not . Amount.is_zero . Amount.sum_balance)
 242                                                  (Balance.get_Account_Sum $ Balance.inclusive balance))))
 243                                 -- NOTE: worth if account exclusive
 244                                 -- has at least a non-zero amount
 245                                 || not (Data.Map.null
 246                                          (Data.Map.filter
 247                                                  (not . Amount.is_zero . Amount.sum_balance)
 248                                                  (Balance.get_Account_Sum $ Balance.exclusive balance)))
 249                                 -- NOTE: worth if account has at least more than
 250                                 -- one descendant account whose inclusive
 251                                 -- has at least a non-zero amount
 252                                 || Data.Map.size
 253                                          (Data.Map.filter
 254                                                  ( Strict.maybe False
 255                                                          ( not . Data.Foldable.all
 256                                                                  ( Amount.is_zero
 257                                                                  . Amount.sum_balance )
 258                                                          . Balance.get_Account_Sum
 259                                                          . Balance.inclusive )
 260                                                  . Lib.TreeMap.node_value )
 261                                                  descendants) > 1
 262                         in
 263                         if is_worth
 264                         then
 265                                 Data.Foldable.any
 266                                  (Filter.test (ctx_filter_balance ctx) . (acct,)) $
 267                                 Balance.get_Account_Sum $
 268                                 Balance.inclusive balance
 269                         else False
 270                  ) $
 271                 Balance.expanded balance_by_account in
 272         let balance_by_unit =
 273                 Balance.by_unit_of_expanded
 274                  balance_expanded
 275                  mempty in
 276         ( balance_expanded
 277         , balance_by_unit
 278         )
 279
 280 write_by_accounts
 281  :: Ctx
 282  -> Balance.Expanded (Amount.Sum Amount)
 283  -> [[Table.Cell]]
 284  -> [[Table.Cell]]
 285 write_by_accounts _ctx =
 286         let posting_type = Ledger.Posting_Type_Regular in
 287         flip $ Lib.TreeMap.foldr_with_Path
 288          (\account balance rows ->
 289                 foldr
 290                  (\(amount_positive, amount_negative, amount) ->
 291                         zipWith (:)
 292                                 [ Table.cell
 293                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_positive
 294                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_positive
 295                                  }
 296                                 , Table.cell
 297                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_negative
 298                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_negative
 299                                  }
 300                                 , Table.cell
 301                                  { Table.cell_content = Amount.Write.amount        $ amount
 302                                  , Table.cell_width   = Amount.Write.amount_length $ amount
 303                                  }
 304                                 , Table.cell
 305                                  { Table.cell_content = Ledger.Write.account        posting_type account
 306                                  , Table.cell_width   = Ledger.Write.account_length posting_type account
 307                                  }
 308                                 ]
 309                  )
 310                  rows $
 311                 let bal = Balance.get_Account_Sum $ Balance.inclusive balance in
 312                 Data.Map.foldrWithKey
 313                  (\unit amount acc ->
 314                         ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
 315                         , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
 316                         , Amount.sum_balance amount
 317                         ) : acc
 318                  ) [] $ bal
 319          )
 320
 321 write_by_amounts
 322  :: Data.Map.Map Unit (Amount.Sum Amount)
 323  -> [[Table.Cell]]
 324  -> [[Table.Cell]]
 325 write_by_amounts =
 326         flip $ foldr
 327          (\amount_sum ->
 328                 zipWith (:)
 329                         [ let amt = Amount.sum_positive amount_sum in
 330                                 Table.cell
 331                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 332                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 333                                  }
 334                         , let amt = Amount.sum_negative amount_sum in
 335                                 Table.cell
 336                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 337                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 338                                  }
 339                         , let amt = Amount.sum_balance amount_sum in
 340                                 Table.cell
 341                                  { Table.cell_content = Amount.Write.amount        amt
 342                                  , Table.cell_width   = Amount.Write.amount_length amt
 343                                  }
 344                         , Table.cell
 345                                  { Table.cell_content = W.empty
 346                                  , Table.cell_width   = 0
 347                                  }
 348                         ]
 349          )