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 qualified Hcompta.Balance as Balance
  30 import qualified Hcompta.CLI.Args as Args
  31 import qualified Hcompta.CLI.Context as Context
  32 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  33 import qualified Hcompta.CLI.Lang as Lang
  34 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
  35 import qualified Hcompta.CLI.Write as Write
  36 import qualified Hcompta.Format.Ledger as Ledger
  37 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  38 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  39 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  40 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
  41 -- import qualified Hcompta.Lib.Foldable as Lib.Foldable
  42 import qualified Hcompta.Lib.Leijen as W
  43 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  44 -- import qualified Hcompta.Account as Account
  45 import           Hcompta.Account (Account)
  46 import qualified Hcompta.Amount as Amount
  47 import           Hcompta.Amount (Amount)
  48 import           Hcompta.Amount.Unit (Unit)
  49 import qualified Hcompta.Filter as Filter
  50 import qualified Hcompta.Filter.Read as Filter.Read
  51
  52 data Ctx
  53  =   Ctx
  54  { ctx_input              :: [FilePath]
  55  , ctx_redundant          :: Bool
  56  , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
  57  , ctx_posting_filter     :: Filter.Test_Bool (Filter.Test_Posting     Ledger.Posting)
  58  } deriving (Show)
  59
  60 nil :: Ctx
  61 nil =
  62         Ctx
  63          { ctx_input              = []
  64          , ctx_redundant          = False
  65          , ctx_transaction_filter = Filter.Any
  66          , ctx_posting_filter     = Filter.Any
  67          }
  68
  69 usage :: IO String
  70 usage = do
  71         bin <- Env.getProgName
  72         return $ unlines $
  73                 [ "SYNTAX "
  74                 , "  "++bin++" balance [option..]"
  75                 , ""
  76                 , usageInfo "OPTIONS" options
  77                 ]
  78
  79 options :: Args.Options Ctx
  80 options =
  81         [ Option "h" ["help"]
  82          (NoArg (\_context _ctx -> do
  83                 usage >>= IO.hPutStr IO.stderr
  84                 exitWith ExitSuccess))
  85          "show this help"
  86         , Option "i" ["input"]
  87          (ReqArg (\s _context ctx -> do
  88                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  89          "read data from given file, can be use multiple times"
  90         , Option "t" ["transaction-filter"]
  91          (ReqArg (\s context ctx -> do
  92                 ctx_transaction_filter <-
  93                         liftIO $ Filter.Read.read Filter.Read.test_transaction s
  94                         >>= \f -> case f of
  95                          Left  ko -> Write.fatal context $ ko
  96                          Right ok -> return ok
  97                 return $ ctx{ctx_transaction_filter}) "FILTER")
  98          "filter on posting"
  99         , Option "p" ["posting-filter"]
 100          (ReqArg (\s context ctx -> do
 101                 ctx_posting_filter <-
 102                         liftIO $ Filter.Read.read Filter.Read.test_posting s
 103                         >>= \f -> case f of
 104                          Left  ko -> Write.fatal 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 $ err
 137          ([], journals) -> do
 138                 balance_filter <-
 139                         foldr Filter.And Filter.Any <$> do
 140                         (flip mapM) text_filters $ \s ->
 141                                 liftIO $ Filter.Read.read Filter.Read.test_balance s
 142                                 >>= \f -> case f of
 143                                  Left  ko -> Write.fatal context $ ko
 144                                  Right ok -> return ok
 145                 Write.debug context $ "balance_filter: " ++ show balance_filter
 146                 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
 147                 Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
 148                 let (balance_by_account, balance_by_unit) =
 149                         ledger_balances
 150                          (ctx_transaction_filter ctx)
 151                          (ctx_posting_filter ctx)
 152                          balance_filter
 153                          journals
 154                 style_color <- Write.with_color context IO.stdout
 155                 W.displayIO IO.stdout $
 156                  W.renderPretty style_color 1.0 maxBound $ do
 157                         toDoc () $
 158                                 let title =
 159                                         TL.toStrict . W.displayT .
 160                                         W.renderCompact False .
 161                                         toDoc (Context.lang context) in
 162                                 zipWith id
 163                                 [ Table.column (title Lang.Message_Balance_debit)  Table.Align_Right
 164                                 , Table.column (title Lang.Message_Balance_credit) Table.Align_Right
 165                                 , Table.column (title Lang.Message_Balance_total)  Table.Align_Right
 166                                 , Table.column (title Lang.Message_Account)        Table.Align_Left
 167                                 ] $
 168                                 flip (write_by_accounts ctx) balance_by_account $
 169                                 zipWith (:)
 170                                         [ Table.Cell_Line '=' 0
 171                                         , Table.Cell_Line '=' 0
 172                                         , Table.Cell_Line '=' 0
 173                                         , Table.Cell_Line ' ' 0
 174                                         ] $
 175                                 write_by_amounts (repeat []) $
 176                                         Data.Map.map
 177                                          Balance.unit_sum_amount
 178                                          balance_by_unit
 179
 180 ledger_balances
 181  :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
 182  -> Filter.Test_Bool (Filter.Test_Posting     Ledger.Posting)
 183  -> Filter.Test_Bool (Filter.Test_Balance     (Account, Balance.Amount_Sum Amount))
 184  -> [Ledger.Journal]
 185  -> ( Balance.Expanded (Balance.Amount_Sum Amount)
 186     , Balance.Balance_by_Unit (Balance.Amount_Sum Amount) Unit )
 187 ledger_balances
 188  transaction_filter
 189  posting_filter
 190  balance_filter
 191  journals =
 192         let balance_by_account =
 193                 foldr
 194                  (Ledger.Journal.fold
 195                          (flip (foldr
 196                                  (flip (foldr
 197                                          (\tr ->
 198                                                 case Filter.test transaction_filter tr of
 199                                                  False -> id
 200                                                  True ->
 201                                                         let filter_postings =
 202                                                                 Data.Foldable.concatMap $
 203                                                                 Data.List.filter $
 204                                                                 (Filter.test posting_filter) in
 205                                                         let balance =
 206                                                                 flip (foldr Balance.by_account) .
 207                                                                 map (\p ->
 208                                                                         ( Ledger.posting_account p
 209                                                                         , Data.Map.map Balance.amount_sum (Ledger.posting_amounts p)
 210                                                                         )
 211                                                                  ) .
 212                                                                 filter_postings in
 213                                                         balance (Ledger.transaction_postings tr) .
 214                                                         balance (Ledger.transaction_virtual_postings tr) .
 215                                                         balance (Ledger.transaction_balanced_virtual_postings tr)
 216                                          ))))
 217                          . Ledger.journal_transactions))
 218                  (Balance.balance_by_account Balance.nil)
 219                  journals in
 220         let balance_expanded =
 221                 Lib.TreeMap.filter_with_Path (\acct ->
 222                         Data.Foldable.any
 223                          (Filter.test balance_filter . (acct,)) .
 224                         Balance.inclusive) $
 225                 Balance.expanded balance_by_account in
 226         let balance_by_unit =
 227                 Balance.by_unit_of_expanded
 228                  balance_expanded
 229                  (Balance.balance_by_unit Balance.nil) in
 230         ( balance_expanded
 231         , balance_by_unit
 232         )
 233
 234 write_by_accounts
 235  :: Ctx
 236  -> [[Table.Cell]]
 237  -> Balance.Expanded (Balance.Amount_Sum Amount)
 238  -> [[Table.Cell]]
 239 write_by_accounts ctx =
 240         let posting_type = Ledger.Posting_Type_Regular in
 241         Lib.TreeMap.foldr_with_Path_and_Node
 242          (\account node balance rows -> do
 243                 let descendants = Lib.TreeMap.nodes
 244                          (Lib.TreeMap.node_descendants node)
 245                 let is_worth =
 246                         ctx_redundant ctx
 247                         -- NOTE: worth if no descendant
 248                         -- but account inclusive
 249                         -- has at least a non-zero amount
 250                         || (Data.Map.null descendants && not
 251                                  (Data.Map.null
 252                                  (Data.Map.filter
 253                                          (not . Amount.is_zero . Balance.amount_sum_balance)
 254                                          (Balance.inclusive balance))))
 255                         -- NOTE: worth if account exclusive
 256                         -- has at least a non-zero amount
 257                         || not (Data.Map.null
 258                                  (Data.Map.filter
 259                                          (not . Amount.is_zero . Balance.amount_sum_balance)
 260                                          (Balance.exclusive balance)))
 261                         -- NOTE: worth if account has at least more than
 262                         -- one descendant account whose inclusive
 263                         -- has at least a non-zero amount
 264                         || Data.Map.size
 265                                  (Data.Map.filter
 266                                          ( maybe False
 267                                                  ( not . Data.Foldable.all
 268                                                          ( Amount.is_zero
 269                                                          . Balance.amount_sum_balance )
 270                                                  . Balance.inclusive )
 271                                          . Lib.TreeMap.node_value )
 272                                          descendants) > 1
 273                 case is_worth of
 274                  False -> rows
 275                  True ->
 276                         foldr
 277                          (\(amount_positive, amount_negative, amount) ->
 278                                 zipWith (:)
 279                                         [ Table.cell
 280                                          { Table.cell_content = maybe W.empty Ledger.Write.amount  amount_positive
 281                                          , Table.cell_width   = maybe 0 Ledger.Write.amount_length amount_positive
 282                                          }
 283                                         , Table.cell
 284                                          { Table.cell_content = maybe W.empty Ledger.Write.amount  amount_negative
 285                                          , Table.cell_width   = maybe 0 Ledger.Write.amount_length amount_negative
 286                                          }
 287                                         , Table.cell
 288                                          { Table.cell_content = Ledger.Write.amount        $ amount
 289                                          , Table.cell_width   = Ledger.Write.amount_length $ amount
 290                                          }
 291                                         , Table.cell
 292                                          { Table.cell_content = Ledger.Write.account        posting_type account
 293                                          , Table.cell_width   = Ledger.Write.account_length posting_type account
 294                                          }
 295                                         ]
 296                          )
 297                          rows $
 298                         let bal = Balance.inclusive balance in
 299                         Data.Map.foldrWithKey
 300                          (\unit amount acc ->
 301                                 ( maybe Nothing Balance.amount_sum_positive $ Data.Map.lookup unit $ bal
 302                                 , maybe Nothing Balance.amount_sum_negative $ Data.Map.lookup unit $ bal
 303                                 , Balance.amount_sum_balance amount
 304                                 ) : acc
 305                          ) [] $ bal
 306          )
 307
 308 write_by_amounts
 309  :: [[Table.Cell]]
 310  -> Data.Map.Map Unit (Balance.Amount_Sum Amount)
 311  -> [[Table.Cell]]
 312 write_by_amounts =
 313         foldr
 314          (\amount_sum ->
 315                 zipWith (:)
 316                         [ let amt = Balance.amount_sum_positive amount_sum in
 317                                 Table.cell
 318                                  { Table.cell_content = maybe W.empty Ledger.Write.amount  amt
 319                                  , Table.cell_width   = maybe 0 Ledger.Write.amount_length amt
 320                                  }
 321                         , let amt = Balance.amount_sum_negative amount_sum in
 322                                 Table.cell
 323                                  { Table.cell_content = maybe W.empty Ledger.Write.amount  amt
 324                                  , Table.cell_width   = maybe 0 Ledger.Write.amount_length amt
 325                                  }
 326                         , let amt = Balance.amount_sum_balance amount_sum in
 327                                 Table.cell
 328                                  { Table.cell_content = Ledger.Write.amount  amt
 329                                  , Table.cell_width   = Ledger.Write.amount_length amt
 330                                  }
 331                         , Table.cell
 332                                  { Table.cell_content = W.empty
 333                                  , Table.cell_width   = 0
 334                                  }
 335                         ]
 336          )