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