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.Applicative ((<$>))
  10 import           Control.Monad.IO.Class (liftIO)
  11 import           Control.Monad.Trans.Except (runExceptT)
  12 import qualified Data.Either
  13 import qualified Data.Foldable
  14 import           Data.Foldable (foldr)
  15 import qualified Data.List
  16 import qualified Data.Map.Strict as Data.Map
  17 -- import           Data.Map.Strict (Map)
  18 import qualified Data.Text.Lazy as TL
  19 import           System.Console.GetOpt
  20                  ( ArgDescr(..)
  21                  , OptDescr(..)
  22                  , usageInfo
  23                  )
  24 import           System.Environment as Env (getProgName)
  25 import           System.Exit (exitWith, ExitCode(..))
  26 import qualified System.IO as IO
  27 -- import           Text.Show.Pretty (ppShow)
  28
  29 import           Hcompta.Account (Account)
  30 import           Hcompta.Amount (Amount)
  31 import qualified Hcompta.Amount as Amount
  32 import qualified Hcompta.Amount.Write as Amount.Write
  33 import           Hcompta.Amount.Unit (Unit)
  34 import qualified Hcompta.Balance as Balance
  35 import qualified Hcompta.CLI.Args as Args
  36 import qualified Hcompta.CLI.Context as Context
  37 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  38 import qualified Hcompta.CLI.Lang as Lang
  39 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
  40 import qualified Hcompta.CLI.Write as Write
  41 import qualified Hcompta.Filter as Filter
  42 import qualified Hcompta.Filter.Read as Filter.Read
  43 import qualified Hcompta.Format.Ledger as Ledger
  44 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  45 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  46 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  47 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  48 import qualified Hcompta.Lib.Leijen as W
  49 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
  50
  51 data Ctx
  52  =   Ctx
  53  { ctx_input              :: [FilePath]
  54  , ctx_redundant          :: Bool
  55  , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
  56  , ctx_posting_filter     :: Filter.Test_Bool (Filter.Test_Posting     Ledger.Posting)
  57  } deriving (Show)
  58
  59 nil :: Ctx
  60 nil =
  61         Ctx
  62          { ctx_input              = []
  63          , ctx_redundant          = False
  64          , ctx_transaction_filter = Filter.Any
  65          , ctx_posting_filter     = Filter.Any
  66          }
  67
  68 usage :: IO String
  69 usage = do
  70         bin <- Env.getProgName
  71         return $ unlines $
  72                 [ "SYNTAX "
  73                 , "  "++bin++" balance [option..]"
  74                 , ""
  75                 , usageInfo "OPTIONS" options
  76                 ]
  77
  78 options :: Args.Options Ctx
  79 options =
  80         [ Option "h" ["help"]
  81          (NoArg (\_context _ctx -> do
  82                 usage >>= IO.hPutStr IO.stderr
  83                 exitWith ExitSuccess))
  84          "show this help"
  85         , Option "i" ["input"]
  86          (ReqArg (\s _context ctx -> do
  87                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  88          "read data from given file, can be use multiple times"
  89         , Option "p" ["posting-filter"]
  90          (ReqArg (\s context ctx -> do
  91                 ctx_posting_filter <-
  92                         liftIO $ Filter.Read.read Filter.Read.test_posting s
  93                         >>= \f -> case f of
  94                          Left  ko -> Write.fatal context $ ko
  95                          Right ok -> return ok
  96                 return $ ctx{ctx_posting_filter}) "FILTER")
  97          "filter at posting level"
  98         , Option "" ["redundant"]
  99          (OptArg (\arg context ctx -> do
 100                 ctx_redundant <- case arg of
 101                  Nothing    -> return $ True
 102                  Just "yes" -> return $ True
 103                  Just "no"  -> return $ False
 104                  Just _     -> Write.fatal context $
 105                         W.text "--redundant option expects \"yes\", or \"no\" as value"
 106                 return $ ctx{ctx_redundant})
 107           "[yes|no]")
 108          "also print accounts with zero amount or the same amounts than its ascending account"
 109         , Option "t" ["transaction-filter"]
 110          (ReqArg (\s context ctx -> do
 111                 ctx_transaction_filter <-
 112                         liftIO $ Filter.Read.read Filter.Read.test_transaction s
 113                         >>= \f -> case f of
 114                          Left  ko -> Write.fatal context $ ko
 115                          Right ok -> return ok
 116                 return $ ctx{ctx_transaction_filter}) "FILTER")
 117          "filter at transaction level"
 118         ]
 119
 120 run :: Context.Context -> [String] -> IO ()
 121 run context args = do
 122         (ctx, text_filters) <- Args.parse context usage options (nil, args)
 123         read_journals <- do
 124                 CLI.Ledger.paths context $ ctx_input ctx
 125                 >>= do
 126                         mapM $ \path -> do
 127                                 liftIO $ runExceptT $ Ledger.Read.file path
 128                                 >>= \x -> case x of
 129                                  Left  ko -> return $ Left (path, ko)
 130                                  Right ok -> return $ Right ok
 131                 >>= return . Data.Either.partitionEithers
 132         case read_journals of
 133          (errs@(_:_), _journals) ->
 134                 (flip mapM_) errs $ \(_path, err) -> do
 135                         Write.fatal context $ err
 136          ([], journals) -> do
 137                 balance_filter <-
 138                         foldr Filter.And Filter.Any <$> do
 139                         (flip mapM) text_filters $ \s ->
 140                                 liftIO $ Filter.Read.read Filter.Read.test_balance s
 141                                 >>= \f -> case f of
 142                                  Left  ko -> Write.fatal context $ ko
 143                                  Right ok -> return ok
 144                 Write.debug context $ "balance_filter: " ++ show balance_filter
 145                 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
 146                 Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
 147                 let (balance_by_account, balance_by_unit) =
 148                         ledger_balances
 149                          (ctx_transaction_filter ctx)
 150                          (ctx_posting_filter ctx)
 151                          balance_filter
 152                          journals
 153                 style_color <- Write.with_color context IO.stdout
 154                 W.displayIO IO.stdout $
 155                  W.renderPretty style_color 1.0 maxBound $ do
 156                         toDoc () $
 157                                 let title =
 158                                         TL.toStrict . W.displayT .
 159                                         W.renderCompact False .
 160                                         toDoc (Context.lang context) in
 161                                 zipWith id
 162                                 [ Table.column (title Lang.Message_Debit)   Table.Align_Right
 163                                 , Table.column (title Lang.Message_Credit)  Table.Align_Right
 164                                 , Table.column (title Lang.Message_Balance) Table.Align_Right
 165                                 , Table.column (title Lang.Message_Account) Table.Align_Left
 166                                 ] $
 167                                 write_by_accounts ctx balance_by_account $
 168                                 zipWith (:)
 169                                         [ Table.Cell_Line '=' 0
 170                                         , Table.Cell_Line '=' 0
 171                                         , Table.Cell_Line '=' 0
 172                                         , Table.Cell_Line ' ' 0
 173                                         ] $
 174                                 flip write_by_amounts (repeat []) $
 175                                         Data.Map.map
 176                                          Balance.unit_sum_amount
 177                                          balance_by_unit
 178
 179 ledger_balances
 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  transaction_filter
 188  posting_filter
 189  balance_filter
 190  journals =
 191         let balance_by_account =
 192                 foldr
 193                  (Ledger.Journal.fold
 194                          (flip (foldr
 195                                  (flip (foldr
 196                                          (\tr ->
 197                                                 case Filter.test transaction_filter tr of
 198                                                  False -> id
 199                                                  True ->
 200                                                         let filter_postings =
 201                                                                 Data.Foldable.concatMap $
 202                                                                 Data.List.filter $
 203                                                                 (Filter.test posting_filter) in
 204                                                         let balance =
 205                                                                 flip (foldr Balance.by_account) .
 206                                                                 map (\p ->
 207                                                                         ( Ledger.posting_account p
 208                                                                         , Data.Map.map Amount.sum (Ledger.posting_amounts p)
 209                                                                         )
 210                                                                  ) .
 211                                                                 filter_postings in
 212                                                         balance (Ledger.transaction_postings tr) .
 213                                                         balance (Ledger.transaction_virtual_postings tr) .
 214                                                         balance (Ledger.transaction_balanced_virtual_postings tr)
 215                                          ))))
 216                          . Ledger.journal_transactions))
 217                  (Balance.balance_by_account Balance.nil)
 218                  journals in
 219         let balance_expanded =
 220                 Lib.TreeMap.filter_with_Path (\acct ->
 221                         Data.Foldable.any
 222                          (Filter.test balance_filter . (acct,)) .
 223                         Balance.inclusive) $
 224                 Balance.expanded balance_by_account in
 225         let balance_by_unit =
 226                 Balance.by_unit_of_expanded
 227                  balance_expanded
 228                  (Balance.balance_by_unit Balance.nil) in
 229         ( balance_expanded
 230         , balance_by_unit
 231         )
 232
 233 write_by_accounts
 234  :: Ctx
 235  -> Balance.Expanded (Amount.Sum Amount)
 236  -> [[Table.Cell]]
 237  -> [[Table.Cell]]
 238 write_by_accounts ctx =
 239         let posting_type = Ledger.Posting_Type_Regular in
 240         flip $ Lib.TreeMap.foldr_with_Path_and_Node
 241          (\account node balance rows -> do
 242                 let descendants = Lib.TreeMap.nodes
 243                          (Lib.TreeMap.node_descendants node)
 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.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.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                                          ( maybe False
 266                                                  ( not . Data.Foldable.all
 267                                                          ( Amount.is_zero
 268                                                          . Amount.sum_balance )
 269                                                  . Balance.inclusive )
 270                                          . Lib.TreeMap.node_value )
 271                                          descendants) > 1
 272                 case is_worth of
 273                  False -> rows
 274                  True ->
 275                         foldr
 276                          (\(amount_positive, amount_negative, amount) ->
 277                                 zipWith (:)
 278                                         [ Table.cell
 279                                          { Table.cell_content = maybe W.empty Amount.Write.amount  amount_positive
 280                                          , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_positive
 281                                          }
 282                                         , Table.cell
 283                                          { Table.cell_content = maybe W.empty Amount.Write.amount  amount_negative
 284                                          , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_negative
 285                                          }
 286                                         , Table.cell
 287                                          { Table.cell_content = Amount.Write.amount        $ amount
 288                                          , Table.cell_width   = Amount.Write.amount_length $ amount
 289                                          }
 290                                         , Table.cell
 291                                          { Table.cell_content = Ledger.Write.account        posting_type account
 292                                          , Table.cell_width   = Ledger.Write.account_length posting_type account
 293                                          }
 294                                         ]
 295                          )
 296                          rows $
 297                         let bal = Balance.inclusive balance in
 298                         Data.Map.foldrWithKey
 299                          (\unit amount acc ->
 300                                 ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
 301                                 , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
 302                                 , Amount.sum_balance amount
 303                                 ) : acc
 304                          ) [] $ bal
 305          )
 306
 307 write_by_amounts
 308  :: Data.Map.Map Unit (Amount.Sum Amount)
 309  -> [[Table.Cell]]
 310  -> [[Table.Cell]]
 311 write_by_amounts =
 312         flip $ foldr
 313          (\amount_sum ->
 314                 zipWith (:)
 315                         [ let amt = Amount.sum_positive amount_sum in
 316                                 Table.cell
 317                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 318                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 319                                  }
 320                         , let amt = Amount.sum_negative amount_sum in
 321                                 Table.cell
 322                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 323                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 324                                  }
 325                         , let amt = Amount.sum_balance amount_sum in
 326                                 Table.cell
 327                                  { Table.cell_content = Amount.Write.amount        amt
 328                                  , Table.cell_width   = Amount.Write.amount_length amt
 329                                  }
 330                         , Table.cell
 331                                  { Table.cell_content = W.empty
 332                                  , Table.cell_width   = 0
 333                                  }
 334                         ]
 335          )