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