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 qualified Data.Time.Clock as Time
  22 import           System.Console.GetOpt
  23                  ( ArgDescr(..)
  24                  , OptDescr(..)
  25                  , usageInfo
  26                  )
  27 import           System.Environment as Env (getProgName)
  28 import           System.Exit (exitSuccess)
  29 import qualified System.IO as IO
  30 import qualified Text.Parsec
  31
  32 import           Hcompta.Account (Account)
  33 import qualified Hcompta.Account as Account
  34 import qualified Hcompta.Account.Read as Account.Read
  35 import           Hcompta.Amount (Amount)
  36 import qualified Hcompta.Amount as Amount
  37 import qualified Hcompta.Amount.Write as Amount.Write
  38 import           Hcompta.Amount.Unit (Unit)
  39 import qualified Hcompta.Balance as Balance
  40 import qualified Hcompta.CLI.Args as Args
  41 import           Hcompta.CLI.Context (Context)
  42 import qualified Hcompta.CLI.Context as Context
  43 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  44 import qualified Hcompta.CLI.Lang as Lang
  45 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
  46 import qualified Hcompta.CLI.Write as Write
  47 import qualified Hcompta.Date as Date
  48 import qualified Hcompta.Filter as Filter
  49 import qualified Hcompta.Filter.Read as Filter.Read
  50 import qualified Hcompta.Format.Ledger as Ledger
  51 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  52 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  53 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  54 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  55 import qualified Hcompta.Lib.Leijen as W
  56 import           Hcompta.Lib.TreeMap (TreeMap)
  57 import qualified Hcompta.Lib.TreeMap as TreeMap
  58 import qualified Hcompta.Posting as Posting
  59
  60 data Ctx
  61  =   Ctx
  62  { ctx_filter_balance      :: Filter.Simplified
  63                               (Filter.Filter_Bool
  64                               (Filter.Filter_Balance
  65                               (Account, Amount.Sum Amount)))
  66  , ctx_filter_posting      :: Filter.Simplified
  67                               (Filter.Filter_Bool
  68                               (Filter.Filter_Posting
  69                               Ledger.Posting))
  70  , ctx_filter_transaction  :: Filter.Simplified
  71                               (Filter.Filter_Bool
  72                               (Filter.Filter_Transaction
  73                               Ledger.Transaction))
  74  , ctx_heritage            :: Bool
  75  , ctx_input               :: [FilePath]
  76  , ctx_reduce_date         :: Bool
  77  , ctx_redundant           :: Bool
  78  , ctx_total_by_unit       :: Bool
  79  , ctx_format_output       :: Format_Output
  80  , ctx_account_equilibrium :: Account
  81  } deriving (Show)
  82
  83 data Format_Output
  84  =   Format_Output_Table
  85  |   Format_Output_Transaction { negate_transaction :: Bool }
  86  deriving (Eq, Show)
  87
  88 nil :: Context -> Ctx
  89 nil context =
  90         Ctx
  91          { ctx_filter_balance      = mempty
  92          , ctx_filter_posting      = mempty
  93          , ctx_filter_transaction  = mempty
  94          , ctx_heritage            = True
  95          , ctx_input               = []
  96          , ctx_reduce_date         = True
  97          , ctx_redundant           = False
  98          , ctx_total_by_unit       = True
  99          , ctx_format_output       = Format_Output_Table
 100          , ctx_account_equilibrium = Account.account
 101                  (TL.toStrict $ W.displayT $ W.renderOneLine False $
 102                         toDoc (Context.lang context) Lang.Message_Equilibrium)
 103                  []
 104          }
 105
 106 usage :: IO String
 107 usage = do
 108         bin <- Env.getProgName
 109         let pad = replicate (length bin) ' '
 110         return $ unlines $
 111                 [ "SYNTAX "
 112                 , "  "++bin++" balance [-i JOURNAL_FILE]"
 113                 , "  "++pad++"         [-b BALANCE_FILTER]"
 114                 , "  "++pad++"         [-p POSTING_FILTER]"
 115                 , "  "++pad++"         [-t TRANSACTION_FILTER]"
 116                 , "  "++pad++"         [JOURNAL_FILE] [...]"
 117                 , ""
 118                 , usageInfo "OPTIONS" options
 119                 ]
 120
 121 options :: Args.Options Ctx
 122 options =
 123         [ Option "b" ["filter-balance"]
 124          (ReqArg (\s context ctx -> do
 125                 ctx_filter_balance <-
 126                         liftM ((ctx_filter_balance ctx <>) . Filter.simplify) $
 127                                 liftIO $ Filter.Read.read Filter.Read.filter_balance s
 128                                 >>= \f -> case f of
 129                                  Left  ko -> Write.fatal context $ ko
 130                                  Right ok -> return ok
 131                 return $ ctx{ctx_filter_balance}) "FILTER")
 132          "filter at balance level, multiple uses are merged with a logical AND"
 133         , Option "p" ["filter-posting"]
 134          (ReqArg (\s context ctx -> do
 135                 ctx_filter_posting <-
 136                         liftM ((ctx_filter_posting ctx <>) . Filter.simplify) $
 137                         liftIO $ Filter.Read.read Filter.Read.filter_posting s
 138                         >>= \f -> case f of
 139                          Left  ko -> Write.fatal context $ ko
 140                          Right ok -> return ok
 141                 return $ ctx{ctx_filter_posting}) "FILTER")
 142          "filter at posting level, multiple uses are merged with a logical AND"
 143         , Option "t" ["filter-transaction"]
 144          (ReqArg (\s context ctx -> do
 145                 ctx_filter_transaction <-
 146                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
 147                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
 148                         >>= \f -> case f of
 149                          Left  ko -> Write.fatal context $ ko
 150                          Right ok -> return ok
 151                 return $ ctx{ctx_filter_transaction}) "FILTER")
 152          "filter at transaction level, multiple uses are merged with a logical AND"
 153         , Option "h" ["help"]
 154          (NoArg (\_context _ctx -> do
 155                 usage >>= IO.hPutStr IO.stderr
 156                 exitSuccess))
 157          "show this help"
 158         , Option "i" ["input"]
 159          (ReqArg (\s _context ctx -> do
 160                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
 161          "read data from given file, multiple uses merge the data as would a concatenation do"
 162         {- NOTE: not used so far.
 163         , Option "" ["reduce-date"]
 164          (OptArg (\arg context ctx -> do
 165                 ctx_reduce_date <- case arg of
 166                  Nothing    -> return $ True
 167                  Just "yes" -> return $ True
 168                  Just "no"  -> return $ False
 169                  Just _     -> Write.fatal context $
 170                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 171                 return $ ctx{ctx_reduce_date})
 172           "[yes|no]")
 173          "use advanced date reducer to speed up filtering"
 174         -}
 175         , Option "" ["redundant"]
 176          (OptArg (\arg context ctx -> do
 177                 ctx_redundant <- case arg of
 178                  Nothing    -> return $ True
 179                  Just "yes" -> return $ True
 180                  Just "no"  -> return $ False
 181                  Just _     -> Write.fatal context $
 182                         W.text "--redundant option expects \"yes\", or \"no\" as value"
 183                 return $ ctx{ctx_redundant})
 184           "[yes|no]")
 185          "also print accounts with zero amount or the same amounts than its ascending account"
 186         , Option "" ["heritage"]
 187          (OptArg (\arg context ctx -> do
 188                 ctx_heritage <- case arg of
 189                  Nothing    -> return $ True
 190                  Just "yes" -> return $ True
 191                  Just "no"  -> return $ False
 192                  Just _     -> Write.fatal context $
 193                         W.text "--heritage option expects \"yes\", or \"no\" as value"
 194                 return $ ctx{ctx_heritage})
 195           "[yes|no]")
 196          "propagate amounts to ascending accounts"
 197         , Option "" ["total"]
 198          (OptArg (\arg context ctx -> do
 199                 ctx_total_by_unit <- case arg of
 200                  Nothing    -> return $ True
 201                  Just "yes" -> return $ True
 202                  Just "no"  -> return $ False
 203                  Just _     -> Write.fatal context $
 204                         W.text "--total option expects \"yes\", or \"no\" as value"
 205                 return $ ctx{ctx_total_by_unit})
 206           "[yes|no]")
 207          "calculate totals by unit"
 208         , Option "f" ["format"]
 209          (ReqArg (\arg context ctx -> do
 210                 ctx_format_output <- case arg of
 211                  "table" -> return $ Format_Output_Table
 212                  "open"  -> return $ Format_Output_Transaction False
 213                  "close" -> return $ Format_Output_Transaction True
 214                  _       -> Write.fatal context $
 215                         W.text "--format option expects \"close\", \"open\", or \"table\" as value"
 216                 return $ ctx{ctx_format_output})
 217           "[close|open|table]")
 218          "select output format"
 219         , Option "" ["equilibrium"]
 220          (ReqArg (\arg context ctx -> do
 221                 ctx_account_equilibrium <-
 222                         case Text.Parsec.runParser
 223                                  (Account.Read.account <* Text.Parsec.eof)
 224                                  () "" arg of
 225                          Right acct -> return acct
 226                          _          -> Write.fatal context $
 227                                 W.text "--equilibrium option expects a valid account name"
 228                 return $ ctx{ctx_account_equilibrium})
 229           "ACCOUNT")
 230          "specify account equilibrating a close or open balance"
 231         ]
 232
 233 run :: Context.Context -> [String] -> IO ()
 234 run context args = do
 235         (ctx, inputs) <- Args.parse context usage options (nil context, args)
 236         read_journals <-
 237                 liftM Data.Either.partitionEithers $ do
 238                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 239                 >>= do
 240                         mapM $ \path -> do
 241                                 liftIO $ runExceptT $ Ledger.Read.file
 242                                  (Ledger.Read.context ( ctx_filter_transaction ctx
 243                                                       , ctx_filter_posting     ctx )
 244                                                       Ledger.journal)
 245                                  path
 246                                 >>= \x -> case x of
 247                                  Left  ko -> return $ Left (path, ko)
 248                                  Right ok -> return $ Right ok
 249         case read_journals of
 250          (errs@(_:_), _journals) ->
 251                 forM_ errs $ \(_path, err) -> do
 252                         Write.fatal context $ err
 253          ([], journals) -> do
 254                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 255                 Write.debug context $ "filter: posting: " ++ show (ctx_filter_posting ctx)
 256                 Write.debug context $ "filter: balance: " ++ show (ctx_filter_balance ctx)
 257                 style_color <- Write.with_color context IO.stdout
 258                 case ctx_format_output ctx of
 259                  Format_Output_Transaction nt -> do
 260                         let balance_by_account =
 261                                 ledger_balance_by_account_filter ctx $
 262                                 ledger_balance_by_account ctx journals
 263                         let Balance.Balance_by_Unit balance_by_unit =
 264                                 ledger_balance_by_unit ctx $
 265                                 ledger_balance_by_account_filter ctx balance_by_account
 266                         let posting_equilibrium =
 267                                 (Ledger.posting $ ctx_account_equilibrium ctx)
 268                                  { Ledger.posting_amounts =
 269                                         flip Data.Map.map balance_by_unit $
 270                                                 (if nt then id else negate)
 271                                                 . Amount.sum_balance
 272                                                 . Balance.unit_sum_amount
 273                                  , Ledger.posting_comments=
 274                                          [ TL.toStrict $ W.displayT $ W.renderOneLine False $
 275                                                 toDoc (Context.lang context) $
 276                                                 Lang.Message_Equilibrium_posting
 277                                          ]
 278                                  }
 279                         now <- liftM (\d -> d{Time.utctDayTime=0}) $ Date.now
 280                         let transaction =
 281                                 Ledger.transaction
 282                                  { Ledger.transaction_description=
 283                                         TL.toStrict $ W.displayT $ W.renderOneLine False $
 284                                         toDoc (Context.lang context) $
 285                                         Lang.Message_Balance_Description nt
 286                                  , Ledger.transaction_dates=(now, [])
 287                                  , Ledger.transaction_postings=
 288                                         (if null $ Ledger.posting_amounts posting_equilibrium
 289                                         then id
 290                                         else
 291                                                 Data.Map.insertWith (++)
 292                                                  (ctx_account_equilibrium ctx)
 293                                                  [posting_equilibrium]) $
 294                                         TreeMap.flatten_with_Path
 295                                          (\posting_account (Balance.Account_Sum amount_by_unit) ->
 296                                                 [(Ledger.posting posting_account)
 297                                                  { Ledger.posting_amounts =
 298                                                         flip fmap amount_by_unit $
 299                                                                 (if nt then negate else id)
 300                                                                 . Amount.sum_balance
 301                                                  }
 302                                                 ]
 303                                          )
 304                                          balance_by_account
 305                                  }
 306                         let sty = Ledger.Write.Style
 307                                  { Ledger.Write.style_align = True -- ctx_align ctx
 308                                  , Ledger.Write.style_color
 309                                  }
 310                         Ledger.Write.put sty IO.stdout $ do
 311                         Ledger.Write.transaction transaction
 312                  Format_Output_Table -> do
 313                         let ( table_balance_by_account
 314                                   , Balance.Balance_by_Unit balance_by_unit
 315                                   ) =
 316                                 case ledger_balance_by_account ctx journals of
 317                                  b | ctx_heritage ctx ->
 318                                         let bb = ledger_balance_by_account_expanded ctx b in
 319                                         ( table_by_account ctx Balance.inclusive bb
 320                                         , ledger_balance_by_unit_expanded ctx bb
 321                                         )
 322                                  b ->
 323                                         let bb = ledger_balance_by_account_filter ctx b in
 324                                         ( table_by_account ctx id bb
 325                                         , ledger_balance_by_unit ctx bb
 326                                         )
 327                         W.displayIO IO.stdout $ do
 328                         W.renderPretty style_color 1.0 maxBound $ do
 329                         toDoc () $ do
 330                         let title =
 331                                 TL.toStrict . W.displayT .
 332                                 W.renderCompact False .
 333                                 toDoc (Context.lang context)
 334                         zipWith id
 335                          [ Table.column (title Lang.Message_Debit)   Table.Align_Right
 336                          , Table.column (title Lang.Message_Credit)  Table.Align_Right
 337                          , Table.column (title Lang.Message_Balance) Table.Align_Right
 338                          , Table.column (title Lang.Message_Account) Table.Align_Left
 339                          ] $ do
 340                                 table_balance_by_account $ do
 341                                 case ctx_total_by_unit ctx of
 342                                  False -> repeat []
 343                                  True -> do
 344                                         zipWith (:)
 345                                          [ Table.Cell_Line '=' 0
 346                                          , Table.Cell_Line '=' 0
 347                                          , Table.Cell_Line '=' 0
 348                                          , Table.Cell_Line ' ' 0
 349                                          ] $ do
 350                                         flip table_by_unit (repeat []) $
 351                                                 Data.Map.map
 352                                                  Balance.unit_sum_amount
 353                                                  balance_by_unit
 354
 355 ledger_balance_by_account
 356  :: Ctx
 357  -> [ Ledger.Journal (Const (Balance.Balance_by_Account (Amount.Sum Amount)) Ledger.Transaction) ]
 358  -> Balance.Balance_by_Account (Amount.Sum Amount)
 359 ledger_balance_by_account _ctx =
 360         Data.Foldable.foldl'
 361          (flip $ Ledger.Journal.fold
 362                  (\Ledger.Journal{Ledger.journal_transactions=Const b} ->
 363                         mappend b))
 364          mempty
 365
 366 ledger_balance_by_account_filter
 367  :: Ctx
 368  -> Balance.Balance_by_Account (Amount.Sum Amount)
 369  -> Balance.Balance_by_Account (Amount.Sum Amount)
 370 ledger_balance_by_account_filter ctx =
 371         case Filter.simplified $ ctx_filter_balance ctx of
 372          Right True -> id
 373          Right False -> const mempty
 374          Left flt ->
 375                 TreeMap.filter_with_Path $ \acct ->
 376                         Data.Foldable.any (Filter.test flt . (acct,)) .
 377                         Balance.get_Account_Sum
 378
 379 ledger_balance_by_account_expanded
 380  :: Ctx
 381  -> Balance.Balance_by_Account (Amount.Sum Amount)
 382  -> Balance.Expanded           (Amount.Sum Amount)
 383 ledger_balance_by_account_expanded ctx =
 384         case Filter.simplified $ ctx_filter_balance ctx of
 385          Right True  -> id
 386          Right False -> const mempty
 387          Left flt ->
 388                 TreeMap.filter_with_Path_and_Node
 389                  (\node acct balance ->
 390                         let descendants = TreeMap.nodes
 391                                  (TreeMap.node_descendants node) in
 392                         let is_worth =
 393                                 ctx_redundant ctx
 394                                 -- NOTE: worth if no descendant
 395                                 -- but Account's inclusive
 396                                 -- has at least a non-zero Amount
 397                                 || (Data.Map.null descendants &&
 398                                          (Data.Foldable.any
 399                                                  (not . Amount.is_zero . Amount.sum_balance)
 400                                                  (Balance.get_Account_Sum $ Balance.inclusive balance)))
 401                                 -- NOTE: worth if Account's exclusive
 402                                 -- has at least a non-zero Amount
 403                                 || (Data.Foldable.any
 404                                          (not . Amount.is_zero . Amount.sum_balance)
 405                                          (Balance.get_Account_Sum $ Balance.exclusive balance))
 406                                 -- NOTE: worth if Account has at least more than
 407                                 -- one descendant Account whose inclusive
 408                                 -- has at least a non-zero Amount
 409                                 || Data.Map.size
 410                                          ( Data.Map.filter
 411                                                  ( Strict.maybe False
 412                                                          ( Data.Foldable.any
 413                                                                  (not . Amount.is_zero . Amount.sum_balance)
 414                                                          . Balance.get_Account_Sum
 415                                                          . Balance.inclusive )
 416                                                  . TreeMap.node_value )
 417                                                  descendants
 418                                          ) > 1
 419                         in
 420                         (&&) is_worth $
 421                         Data.Foldable.any (Filter.test flt . (acct,)) $
 422                                 Balance.get_Account_Sum $
 423                                 Balance.inclusive balance
 424                  )
 425         . Balance.expanded
 426
 427 ledger_balance_by_unit
 428  :: Ctx
 429  -> Balance.Balance_by_Account (Amount.Sum Amount)
 430  -> Balance.Balance_by_Unit    (Amount.Sum Amount)
 431 ledger_balance_by_unit _ctx =
 432         flip Balance.by_unit_of_by_account mempty
 433
 434 ledger_balance_by_unit_expanded
 435  :: Ctx
 436  -> Balance.Expanded        (Amount.Sum Amount)
 437  -> Balance.Balance_by_Unit (Amount.Sum Amount)
 438 ledger_balance_by_unit_expanded _ctx =
 439         flip Balance.by_unit_of_expanded mempty
 440
 441 table_by_account
 442  :: Ctx
 443  -> (amount -> Balance.Account_Sum (Amount.Sum Amount))
 444  -> TreeMap Account.Name amount
 445  -> [[Table.Cell]]
 446  -> [[Table.Cell]]
 447 table_by_account _ctx get_Account_Sum =
 448         let posting_type = Posting.Posting_Type_Regular in
 449         flip $ TreeMap.foldr_with_Path
 450          (\account balance rows ->
 451                 foldr
 452                  (\(amount_positive, amount_negative, amount) ->
 453                         zipWith (:)
 454                                 [ Table.cell
 455                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_positive
 456                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_positive
 457                                  }
 458                                 , Table.cell
 459                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_negative
 460                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_negative
 461                                  }
 462                                 , Table.cell
 463                                  { Table.cell_content = Amount.Write.amount        $ amount
 464                                  , Table.cell_width   = Amount.Write.amount_length $ amount
 465                                  }
 466                                 , Table.cell
 467                                  { Table.cell_content = Ledger.Write.account        posting_type account
 468                                  , Table.cell_width   = Ledger.Write.account_length posting_type account
 469                                  }
 470                                 ]
 471                  )
 472                  rows $
 473                 let bal = Balance.get_Account_Sum $ get_Account_Sum balance in
 474                 Data.Map.foldrWithKey
 475                  (\unit amount acc ->
 476                         ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
 477                         , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
 478                         , Amount.sum_balance amount
 479                         ) : acc
 480                  ) [] $ bal
 481          )
 482
 483 table_by_unit
 484  :: Data.Map.Map Unit (Amount.Sum Amount)
 485  -> [[Table.Cell]]
 486  -> [[Table.Cell]]
 487 table_by_unit =
 488         flip $ foldr
 489          (\amount_sum ->
 490                 zipWith (:)
 491                         [ let amt = Amount.sum_positive amount_sum in
 492                                 Table.cell
 493                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 494                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 495                                  }
 496                         , let amt = Amount.sum_negative amount_sum in
 497                                 Table.cell
 498                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 499                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 500                                  }
 501                         , let amt = Amount.sum_balance amount_sum in
 502                                 Table.cell
 503                                  { Table.cell_content = Amount.Write.amount        amt
 504                                  , Table.cell_width   = Amount.Write.amount_length amt
 505                                  }
 506                         , Table.cell
 507                                  { Table.cell_content = W.empty
 508                                  , Table.cell_width   = 0
 509                                  }
 510                         ]
 511          )