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, forM_)
  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 (exitSuccess)
  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         let pad = replicate (length bin) ' '
  86         return $ unlines $
  87                 [ "SYNTAX "
  88                 , "  "++bin++" balance [-i JOURNAL_FILE]"
  89                 , "  "++pad++"         [-b BALANCE_FILTER]"
  90                 , "  "++pad++"         [-p POSTING_FILTER]"
  91                 , "  "++pad++"         [-t TRANSACTION_FILTER]"
  92                 , "  "++pad++"         [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                 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 <-
 168                 liftM Data.Either.partitionEithers $ 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 ( ctx_filter_transaction ctx
 174                                                       , ctx_filter_posting     ctx )
 175                                                       Ledger.journal)
 176                                  path
 177                                 >>= \x -> case x of
 178                                  Left  ko -> return $ Left (path, ko)
 179                                  Right ok -> return $ Right ok
 180         case read_journals of
 181          (errs@(_:_), _journals) ->
 182                 forM_ 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                         (&&) is_worth $
 264                         Data.Foldable.any
 265                                  (Filter.test (ctx_filter_balance ctx) . (acct,)) $
 266                                 Balance.get_Account_Sum $
 267                                 Balance.inclusive balance
 268                  ) $
 269                 Balance.expanded balance_by_account in
 270         let balance_by_unit =
 271                 Balance.by_unit_of_expanded
 272                  balance_expanded
 273                  mempty in
 274         ( balance_expanded
 275         , balance_by_unit
 276         )
 277
 278 write_by_accounts
 279  :: Ctx
 280  -> Balance.Expanded (Amount.Sum Amount)
 281  -> [[Table.Cell]]
 282  -> [[Table.Cell]]
 283 write_by_accounts _ctx =
 284         let posting_type = Ledger.Posting_Type_Regular in
 285         flip $ Lib.TreeMap.foldr_with_Path
 286          (\account balance rows ->
 287                 foldr
 288                  (\(amount_positive, amount_negative, amount) ->
 289                         zipWith (:)
 290                                 [ Table.cell
 291                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_positive
 292                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_positive
 293                                  }
 294                                 , Table.cell
 295                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_negative
 296                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_negative
 297                                  }
 298                                 , Table.cell
 299                                  { Table.cell_content = Amount.Write.amount        $ amount
 300                                  , Table.cell_width   = Amount.Write.amount_length $ amount
 301                                  }
 302                                 , Table.cell
 303                                  { Table.cell_content = Ledger.Write.account        posting_type account
 304                                  , Table.cell_width   = Ledger.Write.account_length posting_type account
 305                                  }
 306                                 ]
 307                  )
 308                  rows $
 309                 let bal = Balance.get_Account_Sum $ Balance.inclusive balance in
 310                 Data.Map.foldrWithKey
 311                  (\unit amount acc ->
 312                         ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
 313                         , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
 314                         , Amount.sum_balance amount
 315                         ) : acc
 316                  ) [] $ bal
 317          )
 318
 319 write_by_amounts
 320  :: Data.Map.Map Unit (Amount.Sum Amount)
 321  -> [[Table.Cell]]
 322  -> [[Table.Cell]]
 323 write_by_amounts =
 324         flip $ foldr
 325          (\amount_sum ->
 326                 zipWith (:)
 327                         [ let amt = Amount.sum_positive amount_sum in
 328                                 Table.cell
 329                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 330                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 331                                  }
 332                         , let amt = Amount.sum_negative amount_sum in
 333                                 Table.cell
 334                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 335                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 336                                  }
 337                         , let amt = Amount.sum_balance amount_sum in
 338                                 Table.cell
 339                                  { Table.cell_content = Amount.Write.amount        amt
 340                                  , Table.cell_width   = Amount.Write.amount_length amt
 341                                  }
 342                         , Table.cell
 343                                  { Table.cell_content = W.empty
 344                                  , Table.cell_width   = 0
 345                                  }
 346                         ]
 347          )