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