cli/Hcompta/CLI/Command/Balance.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE TupleSections #-}
   5 module Hcompta.CLI.Command.Balance where
   6
   7 import           Prelude hiding (foldr)
   8 -- import           Control.Monad ((>=>))
   9 import           Control.Applicative ((<$>))
  10 import           Control.Monad.IO.Class (liftIO)
  11 import           Control.Monad.Trans.Except (runExceptT)
  12 import qualified Data.Either
  13 import qualified Data.Foldable
  14 import           Data.Foldable (foldr)
  15 import qualified Data.List
  16 import qualified Data.Map.Strict as Data.Map
  17 -- import           Data.Map.Strict (Map)
  18 import qualified Data.Text.Lazy as TL
  19 import           System.Console.GetOpt
  20                  ( ArgDescr(..)
  21                  , OptDescr(..)
  22                  , usageInfo
  23                  )
  24 import           System.Environment as Env (getProgName)
  25 import           System.Exit (exitWith, ExitCode(..))
  26 import qualified System.IO as IO
  27 -- import           Text.Show.Pretty (ppShow)
  28
  29 import qualified Hcompta.Calc.Balance as Balance
  30 import qualified Hcompta.CLI.Args as Args
  31 import qualified Hcompta.CLI.Context as Context
  32 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  33 import qualified Hcompta.CLI.Lang as Lang
  34 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
  35 import qualified Hcompta.CLI.Write as Write
  36 import qualified Hcompta.Format.Ledger as Ledger
  37 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  38 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  39 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  40 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
  41 -- import qualified Hcompta.Lib.Foldable as Lib.Foldable
  42 import qualified Hcompta.Lib.Leijen as W
  43 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  44 -- import qualified Hcompta.Model.Account as Account
  45 import           Hcompta.Model.Account (Account)
  46 import qualified Hcompta.Model.Amount as Amount
  47 import           Hcompta.Model.Amount (Amount)
  48 import           Hcompta.Model.Amount.Unit (Unit)
  49 import qualified Hcompta.Model.Filter as Filter
  50 import qualified Hcompta.Model.Filter.Read as Filter.Read
  51
  52 data Ctx
  53  =   Ctx
  54  { ctx_input              :: [FilePath]
  55  , ctx_redundant          :: Bool
  56  , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
  57  , ctx_posting_filter     :: Filter.Test_Bool (Filter.Test_Posting     Ledger.Posting)
  58  } deriving (Show)
  59
  60 nil :: Ctx
  61 nil =
  62         Ctx
  63          { ctx_input              = []
  64          , ctx_redundant          = False
  65          , ctx_transaction_filter = Filter.Any
  66          , ctx_posting_filter     = Filter.Any
  67          }
  68
  69 usage :: IO String
  70 usage = do
  71         bin <- Env.getProgName
  72         return $ unlines $
  73                 [ "SYNTAX "
  74                 , "  "++bin++" balance [option..]"
  75                 , ""
  76                 , usageInfo "OPTIONS" options
  77                 ]
  78
  79 options :: Args.Options Ctx
  80 options =
  81         [ Option "h" ["help"]
  82          (NoArg (\_context _ctx -> do
  83                 usage >>= IO.hPutStr IO.stderr
  84                 exitWith ExitSuccess))
  85          "show this help"
  86         , Option "i" ["input"]
  87          (ReqArg (\s _context ctx -> do
  88                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  89          "read data from given file, can be use multiple times"
  90         , Option "t" ["transaction-filter"]
  91          (ReqArg (\s context ctx -> do
  92                 ctx_transaction_filter <- do
  93                         case Filter.Read.read Filter.Read.test_transaction s of
  94                          Left  ko -> Write.fatal context $ ko
  95                          Right ok -> return ok
  96                 return $ ctx{ctx_transaction_filter}) "FILTER")
  97          "filter on posting"
  98         , Option "p" ["posting-filter"]
  99          (ReqArg (\s context ctx -> do
 100                 ctx_posting_filter <- do
 101                         case Filter.Read.read Filter.Read.test_posting s of
 102                          Left  ko -> Write.fatal context $ ko
 103                          Right ok -> return ok
 104                 return $ ctx{ctx_posting_filter}) "FILTER")
 105          "filter on balance"
 106         , Option "" ["redundant"]
 107          (OptArg (\arg context ctx -> do
 108                 redundant <- case arg of
 109                  Nothing    -> return $ True
 110                  Just "yes" -> return $ True
 111                  Just "no"  -> return $ False
 112                  Just _     -> Write.fatal context $
 113                         W.text "--redundant option expects \"yes\", or \"no\" as value"
 114                 return $ ctx{ctx_redundant=redundant})
 115           "[yes|no]")
 116          "also print accounts with zero amount or the same amounts than its ascending account"
 117         ]
 118
 119 run :: Context.Context -> [String] -> IO ()
 120 run context args = do
 121         (ctx, text_filters) <- Args.parse context usage options (nil, args)
 122         read_journals <- do
 123                 CLI.Ledger.paths context $ ctx_input ctx
 124                 >>= do
 125                         mapM $ \path -> do
 126                                 liftIO $ runExceptT $ Ledger.Read.file path
 127                                 >>= \x -> case x of
 128                                  Left  ko -> return $ Left (path, ko)
 129                                  Right ok -> return $ Right ok
 130                 >>= return . Data.Either.partitionEithers
 131         case read_journals of
 132          (errs@(_:_), _journals) ->
 133                 (flip mapM_) errs $ \(_path, err) -> do
 134                         Write.fatal context $ err
 135          ([], journals) -> do
 136                 (balance_filter::
 137                  Filter.Test_Bool (Filter.Test_Balance
 138                          (Account, Balance.Amount_Sum Amount))) <-
 139                         foldr Filter.And Filter.Any <$> do
 140                         (flip mapM) text_filters $ \s ->
 141                                 case Filter.Read.read Filter.Read.test_balance s of
 142                                  Left  ko -> Write.fatal context $ ko
 143                                  Right ok -> return ok
 144                 Write.debug context $ "balance_filter: " ++ show balance_filter
 145                 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
 146                 Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
 147                 let (balance_by_account::Balance.Balance_by_Account (Balance.Amount_Sum Amount) Amount.Unit) =
 148                         foldr
 149                          (Ledger.Journal.fold
 150                                  (flip (foldr
 151                                          (flip (foldr
 152                                                  (\tr ->
 153                                                         case Filter.test (ctx_transaction_filter ctx) tr of
 154                                                          False -> id
 155                                                          True ->
 156                                                                 let filter_postings =
 157                                                                         Data.Foldable.concatMap $
 158                                                                         Data.List.filter $
 159                                                                         (Filter.test (ctx_posting_filter ctx)) in
 160                                                                 let balance =
 161                                                                         flip (foldr Balance.by_account) .
 162                                                                         map (\p ->
 163                                                                                 ( Ledger.posting_account p
 164                                                                                 , Data.Map.map Balance.amount_sum (Ledger.posting_amounts p)
 165                                                                                 )
 166                                                                          ) .
 167                                                                         filter_postings in
 168                                                                 balance (Ledger.transaction_postings tr) .
 169                                                                 balance (Ledger.transaction_virtual_postings tr) .
 170                                                                 balance (Ledger.transaction_balanced_virtual_postings tr)
 171                                                  ))))
 172                                  . Ledger.journal_transactions))
 173                          (Balance.balance_by_account Balance.nil)
 174                          journals
 175                 let balance_expanded =
 176                         Lib.TreeMap.filter_with_Path (\acct ->
 177                                 Data.Foldable.any
 178                                  (Filter.test balance_filter . (acct,)) .
 179                                 Balance.inclusive) $
 180                         Balance.expanded balance_by_account
 181                 style_color <- Write.with_color context IO.stdout
 182                 Ledger.Write.put Ledger.Write.Style
 183                  { Ledger.Write.style_align = True
 184                  , Ledger.Write.style_color
 185                  } IO.stdout $ do
 186                         toDoc () $
 187                                 let title = TL.toStrict . W.displayT . W.renderCompact False .
 188                                         toDoc (Context.lang context) in
 189                                 zipWith id
 190                                 [ Table.column (title Lang.Message_Balance_debit)  Table.Align_Right
 191                                 , Table.column (title Lang.Message_Balance_credit) Table.Align_Right
 192                                 , Table.column (title Lang.Message_Balance_total)  Table.Align_Right
 193                                 , Table.column (title Lang.Message_Account)        Table.Align_Left
 194                                 ] $
 195                                 flip (write_by_accounts ctx) balance_expanded $
 196                                 zipWith (:)
 197                                         [ Table.Cell_Line '=' 0
 198                                         , Table.Cell_Line '=' 0
 199                                         , Table.Cell_Line '=' 0
 200                                         , Table.Cell_Line ' ' 0
 201                                         ] $
 202                                 write_by_amounts (repeat []) $
 203                                         Data.Map.map Balance.unit_sum_amount $
 204                                                 Balance.by_unit_of_expanded
 205                                                  balance_expanded
 206                                                  (Balance.balance_by_unit Balance.nil)
 207
 208 write_by_accounts
 209  :: Ctx
 210  -> [[Table.Cell]]
 211  -> Balance.Expanded (Balance.Amount_Sum Amount)
 212  -> [[Table.Cell]]
 213 write_by_accounts ctx =
 214         let posting_type = Ledger.Posting_Type_Regular in
 215         Lib.TreeMap.foldr_with_Path_and_Node
 216          (\account node balance rows -> do
 217                 let descendants = Lib.TreeMap.nodes
 218                          (Lib.TreeMap.node_descendants node)
 219                 let is_worth =
 220                         ctx_redundant ctx
 221                         -- NOTE: worth if no descendant
 222                         -- but account inclusive
 223                         -- has at least a non-zero amount
 224                         || (Data.Map.null descendants && not
 225                                  (Data.Map.null
 226                                  (Data.Map.filter
 227                                          (not . Amount.is_zero . Balance.amount_sum_balance)
 228                                          (Balance.inclusive balance))))
 229                         -- NOTE: worth if account exclusive
 230                         -- has at least a non-zero amount
 231                         || not (Data.Map.null
 232                                  (Data.Map.filter
 233                                          (not . Amount.is_zero . Balance.amount_sum_balance)
 234                                          (Balance.exclusive balance)))
 235                         -- NOTE: worth if account has at least more than
 236                         -- one descendant account whose inclusive
 237                         -- has at least a non-zero amount
 238                         || Data.Map.size
 239                                  (Data.Map.filter
 240                                          ( maybe False
 241                                                  ( not . Data.Foldable.all
 242                                                          ( Amount.is_zero
 243                                                          . Balance.amount_sum_balance )
 244                                                  . Balance.inclusive )
 245                                          . Lib.TreeMap.node_value )
 246                                          descendants) > 1
 247                 case is_worth of
 248                  False -> rows
 249                  True ->
 250                         foldr
 251                          (\(amount_positive, amount_negative, amount) ->
 252                                 zipWith (:)
 253                                         [ Table.cell
 254                                          { Table.cell_content = maybe W.empty Ledger.Write.amount  amount_positive
 255                                          , Table.cell_width   = maybe 0 Ledger.Write.amount_length amount_positive
 256                                          }
 257                                         , Table.cell
 258                                          { Table.cell_content = maybe W.empty Ledger.Write.amount  amount_negative
 259                                          , Table.cell_width   = maybe 0 Ledger.Write.amount_length amount_negative
 260                                          }
 261                                         , Table.cell
 262                                          { Table.cell_content = Ledger.Write.amount        $ amount
 263                                          , Table.cell_width   = Ledger.Write.amount_length $ amount
 264                                          }
 265                                         , Table.cell
 266                                          { Table.cell_content = Ledger.Write.account        posting_type account
 267                                          , Table.cell_width   = Ledger.Write.account_length posting_type account
 268                                          }
 269                                         ]
 270                          )
 271                          rows $
 272                         let bal = Balance.inclusive balance in
 273                         Data.Map.foldrWithKey
 274                          (\unit amount acc ->
 275                                 ( maybe Nothing Balance.amount_sum_positive $ Data.Map.lookup unit $ bal
 276                                 , maybe Nothing Balance.amount_sum_negative $ Data.Map.lookup unit $ bal
 277                                 , Balance.amount_sum_balance amount
 278                                 ) : acc
 279                          ) [] $ bal
 280          )
 281
 282 write_by_amounts
 283  :: [[Table.Cell]]
 284  -> Data.Map.Map Unit (Balance.Amount_Sum Amount)
 285  -> [[Table.Cell]]
 286 write_by_amounts =
 287         foldr
 288          (\amount_sum ->
 289                 zipWith (:)
 290                         [ let amt = Balance.amount_sum_positive amount_sum in
 291                                 Table.cell
 292                                  { Table.cell_content = maybe W.empty Ledger.Write.amount  amt
 293                                  , Table.cell_width   = maybe 0 Ledger.Write.amount_length amt
 294                                  }
 295                         , let amt = Balance.amount_sum_negative amount_sum in
 296                                 Table.cell
 297                                  { Table.cell_content = maybe W.empty Ledger.Write.amount  amt
 298                                  , Table.cell_width   = maybe 0 Ledger.Write.amount_length amt
 299                                  }
 300                         , let amt = Balance.amount_sum_balance amount_sum in
 301                                 Table.cell
 302                                  { Table.cell_content = Ledger.Write.amount  amt
 303                                  , Table.cell_width   = Ledger.Write.amount_length amt
 304                                  }
 305                         , Table.cell
 306                                  { Table.cell_content = W.empty
 307                                  , Table.cell_width   = 0
 308                                  }
 309                         ]
 310          )