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