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 (liftM)
   9 import           Control.Monad.IO.Class (liftIO)
  10 import           Control.Monad.Trans.Except (runExceptT)
  11 import qualified Data.Either
  12 import qualified Data.Foldable
  13 import           Data.Foldable (foldr)
  14 import           Data.Functor.Compose (Compose(..))
  15 import qualified Data.List
  16 import qualified Data.Map.Strict as Data.Map
  17 import           Data.Monoid ((<>))
  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
  28 import           Hcompta.Account (Account)
  29 import           Hcompta.Amount (Amount)
  30 import qualified Hcompta.Amount as Amount
  31 import qualified Hcompta.Amount.Write as Amount.Write
  32 import           Hcompta.Amount.Unit (Unit)
  33 import qualified Hcompta.Balance as Balance
  34 import qualified Hcompta.CLI.Args as Args
  35 import qualified Hcompta.CLI.Context as Context
  36 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  37 import qualified Hcompta.CLI.Lang as Lang
  38 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
  39 import qualified Hcompta.CLI.Write as Write
  40 import qualified Hcompta.Filter as Filter
  41 import qualified Hcompta.Filter.Reduce as Filter.Reduce
  42 import qualified Hcompta.Filter.Read as Filter.Read
  43 import qualified Hcompta.Format.Ledger as Ledger
  44 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  45 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  46 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  47 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  48 import qualified Hcompta.Lib.Leijen as W
  49 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
  50
  51 data Ctx
  52  =   Ctx
  53  { ctx_filter_balance     :: Filter.Simplified
  54                              (Filter.Filter_Bool
  55                              (Filter.Filter_Balance
  56                              (Account, Amount.Sum Amount)))
  57  , ctx_filter_posting     :: Filter.Simplified
  58                              (Filter.Filter_Bool
  59                              (Filter.Filter_Posting
  60                              Ledger.Posting))
  61  , ctx_filter_transaction :: Filter.Simplified
  62                              (Filter.Filter_Bool
  63                              (Filter.Filter_Transaction
  64                              Ledger.Transaction))
  65  , ctx_input              :: [FilePath]
  66  , ctx_reduce_date        :: Bool
  67  , ctx_redundant          :: Bool
  68  } deriving (Show)
  69
  70 nil :: Ctx
  71 nil =
  72         Ctx
  73          { ctx_filter_balance     = mempty
  74          , ctx_filter_posting     = mempty
  75          , ctx_filter_transaction = mempty
  76          , ctx_input              = []
  77          , ctx_reduce_date        = True
  78          , ctx_redundant          = False
  79          }
  80
  81 usage :: IO String
  82 usage = do
  83         bin <- Env.getProgName
  84         return $ unlines $
  85                 [ "SYNTAX "
  86                 , "  "++bin++" balance"
  87                 , " [-t TRANSACTION_FILTER]"
  88                 , " [-p POSTING_FILTER]"
  89                 , " [-b BALANCE_FILTER]"
  90                 , " JOURNAL_FILE [...]"
  91                 , ""
  92                 , usageInfo "OPTIONS" options
  93                 ]
  94
  95 options :: Args.Options Ctx
  96 options =
  97         [ Option "b" ["filter-balance"]
  98          (ReqArg (\s context ctx -> do
  99                 ctx_filter_balance <-
 100                         liftM (\t -> (<>) (ctx_filter_balance ctx)
 101                          (Filter.simplify t (Nothing::Maybe (Account, Amount.Sum Amount)))) $
 102                                 liftIO $ Filter.Read.read Filter.Read.filter_balance s
 103                                 >>= \f -> case f of
 104                                  Left  ko -> Write.fatal context $ ko
 105                                  Right ok -> return ok
 106                 return $ ctx{ctx_filter_balance}) "FILTER")
 107          "filter at balance level, multiple uses are merged with a logical AND"
 108         , Option "p" ["filter-posting"]
 109          (ReqArg (\s context ctx -> do
 110                 ctx_filter_posting <-
 111                         liftM (\t -> (<>) (ctx_filter_posting ctx)
 112                          (Filter.simplify t (Nothing::Maybe Ledger.Posting))) $
 113                         liftIO $ Filter.Read.read Filter.Read.filter_posting s
 114                         >>= \f -> case f of
 115                          Left  ko -> Write.fatal context $ ko
 116                          Right ok -> return ok
 117                 return $ ctx{ctx_filter_posting}) "FILTER")
 118          "filter at posting level, multiple uses are merged with a logical AND"
 119         , Option "t" ["filter-transaction"]
 120          (ReqArg (\s context ctx -> do
 121                 ctx_filter_transaction <-
 122                         liftM (\t -> (<>) (ctx_filter_transaction ctx)
 123                          (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
 124                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
 125                         >>= \f -> case f of
 126                          Left  ko -> Write.fatal context $ ko
 127                          Right ok -> return ok
 128                 return $ ctx{ctx_filter_transaction}) "FILTER")
 129          "filter at transaction level, multiple uses are merged with a logical AND"
 130         , Option "h" ["help"]
 131          (NoArg (\_context _ctx -> do
 132                 usage >>= IO.hPutStr IO.stderr
 133                 exitWith ExitSuccess))
 134          "show this help"
 135         , Option "i" ["input"]
 136          (ReqArg (\s _context ctx -> do
 137                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
 138          "read data from given file, multiple uses merge the data as would a concatenation do"
 139         , Option "" ["reduce-date"]
 140          (OptArg (\arg context ctx -> do
 141                 ctx_reduce_date <- case arg of
 142                  Nothing    -> return $ True
 143                  Just "yes" -> return $ True
 144                  Just "no"  -> return $ False
 145                  Just _     -> Write.fatal context $
 146                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 147                 return $ ctx{ctx_reduce_date})
 148           "[yes|no]")
 149          "use advanced date reducer to speed up filtering"
 150         , Option "" ["redundant"]
 151          (OptArg (\arg context ctx -> do
 152                 ctx_redundant <- case arg of
 153                  Nothing    -> return $ True
 154                  Just "yes" -> return $ True
 155                  Just "no"  -> return $ False
 156                  Just _     -> Write.fatal context $
 157                         W.text "--redundant option expects \"yes\", or \"no\" as value"
 158                 return $ ctx{ctx_redundant})
 159           "[yes|no]")
 160          "also print accounts with zero amount or the same amounts than its ascending account"
 161         ]
 162
 163 run :: Context.Context -> [String] -> IO ()
 164 run context args = do
 165         (ctx, inputs) <- Args.parse context usage options (nil, args)
 166         read_journals <- do
 167                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 168                 >>= do
 169                         mapM $ \path -> do
 170                                 liftIO $ runExceptT $ Ledger.Read.file path
 171                                 >>= \x -> case x of
 172                                  Left  ko -> return $ Left (path, ko)
 173                                  Right ok -> return $ Right ok
 174                 >>= return . Data.Either.partitionEithers
 175         case read_journals of
 176          (errs@(_:_), _journals) ->
 177                 (flip mapM_) errs $ \(_path, err) -> do
 178                         Write.fatal context $ err
 179          ([], journals) -> do
 180                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 181                 Write.debug context $ "filter: posting: " ++ show (ctx_filter_posting ctx)
 182                 Write.debug context $ "filter: balance: " ++ show (ctx_filter_balance ctx)
 183                 let (balance_by_account, balance_by_unit) =
 184                         ledger_balances ctx journals
 185                 style_color <- Write.with_color context IO.stdout
 186                 W.displayIO IO.stdout $
 187                  W.renderPretty style_color 1.0 maxBound $ do
 188                         toDoc () $
 189                                 let title =
 190                                         TL.toStrict . W.displayT .
 191                                         W.renderCompact False .
 192                                         toDoc (Context.lang context) in
 193                                 zipWith id
 194                                 [ Table.column (title Lang.Message_Debit)   Table.Align_Right
 195                                 , Table.column (title Lang.Message_Credit)  Table.Align_Right
 196                                 , Table.column (title Lang.Message_Balance) Table.Align_Right
 197                                 , Table.column (title Lang.Message_Account) Table.Align_Left
 198                                 ] $
 199                                 write_by_accounts ctx balance_by_account $
 200                                 zipWith (:)
 201                                         [ Table.Cell_Line '=' 0
 202                                         , Table.Cell_Line '=' 0
 203                                         , Table.Cell_Line '=' 0
 204                                         , Table.Cell_Line ' ' 0
 205                                         ] $
 206                                 flip write_by_amounts (repeat []) $
 207                                         Data.Map.map
 208                                          Balance.unit_sum_amount
 209                                          balance_by_unit
 210
 211 ledger_balances
 212  :: Ctx
 213  -> [Ledger.Journal]
 214  -> ( Balance.Expanded (Amount.Sum Amount)
 215     , Balance.Balance_by_Unit (Amount.Sum Amount) Unit )
 216 ledger_balances ctx journals =
 217         let reducer_date =
 218                 if ctx_reduce_date ctx
 219                 then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
 220                 else mempty in
 221         let balance_by_account =
 222                 foldr
 223                  (Ledger.Journal.fold
 224                          (\Ledger.Journal{Ledger.journal_transactions=ts} ->
 225                                 flip (foldr
 226                                  (\tr ->
 227                                         case Filter.test
 228                                          (Filter.simplify (ctx_filter_transaction ctx)
 229                                          (Nothing::Maybe Ledger.Transaction)) tr of
 230                                          False -> id
 231                                          True ->
 232                                                 let filter_postings =
 233                                                         Data.Foldable.concatMap $
 234                                                         Data.List.filter $
 235                                                         (Filter.test $ ctx_filter_posting ctx) in
 236                                                 let balance =
 237                                                         flip (foldr Balance.by_account) .
 238                                                         map (\p ->
 239                                                                 ( Ledger.posting_account p
 240                                                                 , Data.Map.map Amount.sum (Ledger.posting_amounts p)
 241                                                                 )) .
 242                                                         filter_postings in
 243                                                 balance (Ledger.transaction_postings tr) .
 244                                                 balance (Ledger.transaction_virtual_postings tr) .
 245                                                 balance (Ledger.transaction_balanced_virtual_postings tr)
 246                                  )) $ Compose $ Compose $
 247                                 case Filter.simplified reducer_date of
 248                                  Left reducer -> do
 249                                         let (ts_reduced, _date_sieve) = Filter.Reduce.map_date reducer ts
 250                                         ts_reduced
 251                                  Right True  -> ts:[]
 252                                  Right False -> []
 253                          )
 254                  )
 255                  (Balance.balance_by_account Balance.nil)
 256                  journals in
 257         let balance_expanded =
 258                 Lib.TreeMap.filter_with_Path_and_Node
 259                  (\node acct balance ->
 260                         let descendants = Lib.TreeMap.nodes
 261                                  (Lib.TreeMap.node_descendants node) in
 262                         let is_worth =
 263                                 ctx_redundant ctx
 264                                 -- NOTE: worth if no descendant
 265                                 -- but account inclusive
 266                                 -- has at least a non-zero amount
 267                                 || (Data.Map.null descendants && not
 268                                          (Data.Map.null
 269                                          (Data.Map.filter
 270                                                  (not . Amount.is_zero . Amount.sum_balance)
 271                                                  (Balance.inclusive balance))))
 272                                 -- NOTE: worth if account exclusive
 273                                 -- has at least a non-zero amount
 274                                 || not (Data.Map.null
 275                                          (Data.Map.filter
 276                                                  (not . Amount.is_zero . Amount.sum_balance)
 277                                                  (Balance.exclusive balance)))
 278                                 -- NOTE: worth if account has at least more than
 279                                 -- one descendant account whose inclusive
 280                                 -- has at least a non-zero amount
 281                                 || Data.Map.size
 282                                          (Data.Map.filter
 283                                                  ( maybe False
 284                                                          ( not . Data.Foldable.all
 285                                                                  ( Amount.is_zero
 286                                                                  . Amount.sum_balance )
 287                                                          . Balance.inclusive )
 288                                                  . Lib.TreeMap.node_value )
 289                                                  descendants) > 1
 290                         in
 291                         if is_worth
 292                         then
 293                                 Data.Foldable.any
 294                                  (Filter.test (ctx_filter_balance ctx) . (acct,)) $
 295                                 Balance.inclusive balance
 296                         else False
 297                  ) $
 298                 Balance.expanded balance_by_account in
 299         let balance_by_unit =
 300                 Balance.by_unit_of_expanded
 301                  balance_expanded
 302                  (Balance.balance_by_unit Balance.nil) in
 303         ( balance_expanded
 304         , balance_by_unit
 305         )
 306
 307 write_by_accounts
 308  :: Ctx
 309  -> Balance.Expanded (Amount.Sum Amount)
 310  -> [[Table.Cell]]
 311  -> [[Table.Cell]]
 312 write_by_accounts _ctx =
 313         let posting_type = Ledger.Posting_Type_Regular in
 314         flip $ Lib.TreeMap.foldr_with_Path
 315          (\account balance rows ->
 316                 foldr
 317                  (\(amount_positive, amount_negative, amount) ->
 318                         zipWith (:)
 319                                 [ Table.cell
 320                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_positive
 321                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_positive
 322                                  }
 323                                 , Table.cell
 324                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amount_negative
 325                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_negative
 326                                  }
 327                                 , Table.cell
 328                                  { Table.cell_content = Amount.Write.amount        $ amount
 329                                  , Table.cell_width   = Amount.Write.amount_length $ amount
 330                                  }
 331                                 , Table.cell
 332                                  { Table.cell_content = Ledger.Write.account        posting_type account
 333                                  , Table.cell_width   = Ledger.Write.account_length posting_type account
 334                                  }
 335                                 ]
 336                  )
 337                  rows $
 338                 let bal = Balance.inclusive balance in
 339                 Data.Map.foldrWithKey
 340                  (\unit amount acc ->
 341                         ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
 342                         , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
 343                         , Amount.sum_balance amount
 344                         ) : acc
 345                  ) [] $ bal
 346          )
 347
 348 write_by_amounts
 349  :: Data.Map.Map Unit (Amount.Sum Amount)
 350  -> [[Table.Cell]]
 351  -> [[Table.Cell]]
 352 write_by_amounts =
 353         flip $ foldr
 354          (\amount_sum ->
 355                 zipWith (:)
 356                         [ let amt = Amount.sum_positive amount_sum in
 357                                 Table.cell
 358                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 359                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 360                                  }
 361                         , let amt = Amount.sum_negative amount_sum in
 362                                 Table.cell
 363                                  { Table.cell_content = maybe W.empty Amount.Write.amount  amt
 364                                  , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
 365                                  }
 366                         , let amt = Amount.sum_balance amount_sum in
 367                                 Table.cell
 368                                  { Table.cell_content = Amount.Write.amount        amt
 369                                  , Table.cell_width   = Amount.Write.amount_length amt
 370                                  }
 371                         , Table.cell
 372                                  { Table.cell_content = W.empty
 373                                  , Table.cell_width   = 0
 374                                  }
 375                         ]
 376          )