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.Calc.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.Model.Account as Account
  45 import           Hcompta.Model.Account (Account)
  46 import qualified Hcompta.Model.Amount as Amount
  47 import           Hcompta.Model.Amount (Amount)
  48 import           Hcompta.Model.Amount.Unit (Unit)
  49 import qualified Hcompta.Model.Filter as Filter
  50 import qualified Hcompta.Model.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                  Filter.Test_Bool (Filter.Test_Balance
 140                          (Account, Balance.Amount_Sum Amount))) <-
 141                         foldr Filter.And Filter.Any <$> do
 142                         (flip mapM) text_filters $ \s ->
 143                                 liftIO $ Filter.Read.read Filter.Read.test_balance s
 144                                 >>= \f -> case f of
 145                                  Left  ko -> Write.fatal context $ ko
 146                                  Right ok -> return ok
 147                 Write.debug context $ "balance_filter: " ++ show balance_filter
 148                 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
 149                 Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
 150                 let (balance_by_account::Balance.Balance_by_Account (Balance.Amount_Sum Amount) Amount.Unit) =
 151                         foldr
 152                          (Ledger.Journal.fold
 153                                  (flip (foldr
 154                                          (flip (foldr
 155                                                  (\tr ->
 156                                                         case Filter.test (ctx_transaction_filter ctx) tr of
 157                                                          False -> id
 158                                                          True ->
 159                                                                 let filter_postings =
 160                                                                         Data.Foldable.concatMap $
 161                                                                         Data.List.filter $
 162                                                                         (Filter.test (ctx_posting_filter ctx)) in
 163                                                                 let balance =
 164                                                                         flip (foldr Balance.by_account) .
 165                                                                         map (\p ->
 166                                                                                 ( Ledger.posting_account p
 167                                                                                 , Data.Map.map Balance.amount_sum (Ledger.posting_amounts p)
 168                                                                                 )
 169                                                                          ) .
 170                                                                         filter_postings in
 171                                                                 balance (Ledger.transaction_postings tr) .
 172                                                                 balance (Ledger.transaction_virtual_postings tr) .
 173                                                                 balance (Ledger.transaction_balanced_virtual_postings tr)
 174                                                  ))))
 175                                  . Ledger.journal_transactions))
 176                          (Balance.balance_by_account Balance.nil)
 177                          journals
 178                 let balance_expanded =
 179                         Lib.TreeMap.filter_with_Path (\acct ->
 180                                 Data.Foldable.any
 181                                  (Filter.test balance_filter . (acct,)) .
 182                                 Balance.inclusive) $
 183                         Balance.expanded balance_by_account
 184                 style_color <- Write.with_color context IO.stdout
 185                 Ledger.Write.put Ledger.Write.Style
 186                  { Ledger.Write.style_align = True
 187                  , Ledger.Write.style_color
 188                  } IO.stdout $ do
 189                         toDoc () $
 190                                 let title = TL.toStrict . W.displayT . W.renderCompact False .
 191                                         toDoc (Context.lang context) in
 192                                 zipWith id
 193                                 [ Table.column (title Lang.Message_Balance_debit)  Table.Align_Right
 194                                 , Table.column (title Lang.Message_Balance_credit) Table.Align_Right
 195                                 , Table.column (title Lang.Message_Balance_total)  Table.Align_Right
 196                                 , Table.column (title Lang.Message_Account)        Table.Align_Left
 197                                 ] $
 198                                 flip (write_by_accounts ctx) balance_expanded $
 199                                 zipWith (:)
 200                                         [ Table.Cell_Line '=' 0
 201                                         , Table.Cell_Line '=' 0
 202                                         , Table.Cell_Line '=' 0
 203                                         , Table.Cell_Line ' ' 0
 204                                         ] $
 205                                 write_by_amounts (repeat []) $
 206                                         Data.Map.map Balance.unit_sum_amount $
 207                                                 Balance.by_unit_of_expanded
 208                                                  balance_expanded
 209                                                  (Balance.balance_by_unit Balance.nil)
 210
 211 write_by_accounts
 212  :: Ctx
 213  -> [[Table.Cell]]
 214  -> Balance.Expanded (Balance.Amount_Sum Amount)
 215  -> [[Table.Cell]]
 216 write_by_accounts ctx =
 217         let posting_type = Ledger.Posting_Type_Regular in
 218         Lib.TreeMap.foldr_with_Path_and_Node
 219          (\account node balance rows -> do
 220                 let descendants = Lib.TreeMap.nodes
 221                          (Lib.TreeMap.node_descendants node)
 222                 let is_worth =
 223                         ctx_redundant ctx
 224                         -- NOTE: worth if no descendant
 225                         -- but account inclusive
 226                         -- has at least a non-zero amount
 227                         || (Data.Map.null descendants && not
 228                                  (Data.Map.null
 229                                  (Data.Map.filter
 230                                          (not . Amount.is_zero . Balance.amount_sum_balance)
 231                                          (Balance.inclusive balance))))
 232                         -- NOTE: worth if account exclusive
 233                         -- has at least a non-zero amount
 234                         || not (Data.Map.null
 235                                  (Data.Map.filter
 236                                          (not . Amount.is_zero . Balance.amount_sum_balance)
 237                                          (Balance.exclusive balance)))
 238                         -- NOTE: worth if account has at least more than
 239                         -- one descendant account whose inclusive
 240                         -- has at least a non-zero amount
 241                         || Data.Map.size
 242                                  (Data.Map.filter
 243                                          ( maybe False
 244                                                  ( not . Data.Foldable.all
 245                                                          ( Amount.is_zero
 246                                                          . Balance.amount_sum_balance )
 247                                                  . Balance.inclusive )
 248                                          . Lib.TreeMap.node_value )
 249                                          descendants) > 1
 250                 case is_worth of
 251                  False -> rows
 252                  True ->
 253                         foldr
 254                          (\(amount_positive, amount_negative, amount) ->
 255                                 zipWith (:)
 256                                         [ Table.cell
 257                                          { Table.cell_content = maybe W.empty Ledger.Write.amount  amount_positive
 258                                          , Table.cell_width   = maybe 0 Ledger.Write.amount_length amount_positive
 259                                          }
 260                                         , Table.cell
 261                                          { Table.cell_content = maybe W.empty Ledger.Write.amount  amount_negative
 262                                          , Table.cell_width   = maybe 0 Ledger.Write.amount_length amount_negative
 263                                          }
 264                                         , Table.cell
 265                                          { Table.cell_content = Ledger.Write.amount        $ amount
 266                                          , Table.cell_width   = Ledger.Write.amount_length $ amount
 267                                          }
 268                                         , Table.cell
 269                                          { Table.cell_content = Ledger.Write.account        posting_type account
 270                                          , Table.cell_width   = Ledger.Write.account_length posting_type account
 271                                          }
 272                                         ]
 273                          )
 274                          rows $
 275                         let bal = Balance.inclusive balance in
 276                         Data.Map.foldrWithKey
 277                          (\unit amount acc ->
 278                                 ( maybe Nothing Balance.amount_sum_positive $ Data.Map.lookup unit $ bal
 279                                 , maybe Nothing Balance.amount_sum_negative $ Data.Map.lookup unit $ bal
 280                                 , Balance.amount_sum_balance amount
 281                                 ) : acc
 282                          ) [] $ bal
 283          )
 284
 285 write_by_amounts
 286  :: [[Table.Cell]]
 287  -> Data.Map.Map Unit (Balance.Amount_Sum Amount)
 288  -> [[Table.Cell]]
 289 write_by_amounts =
 290         foldr
 291          (\amount_sum ->
 292                 zipWith (:)
 293                         [ let amt = Balance.amount_sum_positive amount_sum in
 294                                 Table.cell
 295                                  { Table.cell_content = maybe W.empty Ledger.Write.amount  amt
 296                                  , Table.cell_width   = maybe 0 Ledger.Write.amount_length amt
 297                                  }
 298                         , let amt = Balance.amount_sum_negative amount_sum in
 299                                 Table.cell
 300                                  { Table.cell_content = maybe W.empty Ledger.Write.amount  amt
 301                                  , Table.cell_width   = maybe 0 Ledger.Write.amount_length amt
 302                                  }
 303                         , let amt = Balance.amount_sum_balance amount_sum in
 304                                 Table.cell
 305                                  { Table.cell_content = Ledger.Write.amount  amt
 306                                  , Table.cell_width   = Ledger.Write.amount_length amt
 307                                  }
 308                         , Table.cell
 309                                  { Table.cell_content = W.empty
 310                                  , Table.cell_width   = 0
 311                                  }
 312                         ]
 313          )