cli/Hcompta/CLI/Command/Balance.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Hcompta.CLI.Command.Balance where
   4
   5 import           Control.Monad.IO.Class (liftIO)
   6 import           Control.Monad.Trans.Except (runExceptT)
   7 import qualified Data.Either
   8 import qualified Data.Foldable
   9 import qualified Data.List
  10 import qualified Data.Map.Strict as Data.Map
  11 import qualified Data.Text.Lazy as TL
  12 import           System.Console.GetOpt
  13                  ( ArgDescr(..)
  14                  , OptDescr(..)
  15                  , usageInfo
  16                  )
  17 import           System.Environment as Env (getProgName)
  18 import           System.Exit (exitWith, ExitCode(..))
  19 import qualified System.IO as IO
  20 import           Text.Show.Pretty (ppShow) -- TODO: may be not necessary
  21
  22 import qualified Hcompta.Calc.Balance as Balance
  23 import qualified Hcompta.CLI.Args as Args
  24 import qualified Hcompta.CLI.Context as Context
  25 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  26 import qualified Hcompta.CLI.Lib.Shakespeare.Leijen as I18N
  27 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
  28 import qualified Hcompta.CLI.Write as Write
  29 import qualified Hcompta.Format.Ledger as Ledger
  30 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  31 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  32 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  33 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
  34 import qualified Hcompta.Lib.Leijen as W
  35 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  36 import qualified Hcompta.Model.Amount as Amount
  37 import           Hcompta.Model.Amount (Amount, Unit)
  38
  39 data Ctx
  40  =   Ctx
  41  { ctx_input     :: [FilePath]
  42  , ctx_redundant :: Bool
  43  } deriving (Eq, Show)
  44
  45 nil :: Ctx
  46 nil =
  47         Ctx
  48          { ctx_input     = []
  49          , ctx_redundant = False
  50          }
  51
  52 usage :: IO String
  53 usage = do
  54         bin <- Env.getProgName
  55         return $ unlines $
  56                 [ "SYNTAX "
  57                 , "  "++bin++" balance [option..]"
  58                 , ""
  59                 , usageInfo "OPTIONS" options
  60                 ]
  61
  62 options :: Args.Options Ctx
  63 options =
  64         [ Option "h" ["help"]
  65          (NoArg (\_context _ctx -> do
  66                 usage >>= IO.hPutStr IO.stderr
  67                 exitWith ExitSuccess))
  68          "show this help"
  69         , Option "i" ["input"]
  70          (ReqArg (\s _context ctx -> do
  71                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  72          "read data from given file, can be use multiple times"
  73         , Option "" ["redundant"]
  74          (OptArg (\arg context ctx -> do
  75                 redundant <- case arg of
  76                  Nothing    -> return $ True
  77                  Just "yes" -> return $ True
  78                  Just "no"  -> return $ False
  79                  Just _     -> Write.fatal context $
  80                         W.text "--redundant option expects \"yes\", or \"no\" as value"
  81                 return $ ctx{ctx_redundant=redundant})
  82           "[yes|no]")
  83          "also print accounts with zero amount or the same amounts than its ascending account"
  84         ]
  85
  86 run :: Context.Context -> [String] -> IO ()
  87 run context args = do
  88         (ctx, _) <- Args.parse context usage options (nil, args)
  89         koks <- do
  90                 CLI.Ledger.paths context $ ctx_input ctx
  91                 >>= do mapM $ \path -> do
  92                         liftIO $ runExceptT $
  93                                 Ledger.Read.file path
  94                         >>= \x -> case x of
  95                          Left  ko -> return $ Left (path, ko)
  96                          Right ok -> return $ Right ok
  97                 >>= return . Data.Either.partitionEithers
  98         case koks of
  99          (kos@(_:_), _oks) ->
 100                 (flip mapM_) kos $ \(_path, ko) -> do
 101                         Write.debug context $ ppShow $ ko
 102                         Write.fatal context $ toDoc context ko
 103          ([], journals) -> do
 104                 let balance =
 105                         Data.List.foldr
 106                          (Ledger.Journal.fold
 107                                  (flip (Data.Foldable.foldr
 108                                          (flip (Data.Foldable.foldr
 109                                                  ( flip Balance.union
 110                                                  . Ledger.transaction_postings_balance))))
 111                                  . Ledger.journal_transactions))
 112                          Balance.balance
 113                          journals
 114                 let expanded = Balance.expanded $ Balance.balance_by_account balance
 115                 style_color <- Write.with_color context IO.stdout
 116                 Ledger.Write.put Ledger.Write.Style
 117                  { Ledger.Write.style_align = True
 118                  , Ledger.Write.style_color
 119                  } IO.stdout $ do
 120                         toDoc () $
 121                                 let title = TL.toStrict . W.displayT . W.renderCompact False .
 122                                         I18N.renderMessage Context.App (Context.langs context) in
 123                                 zipWith id
 124                                 [ Table.column (title Write.I18N_Balance_debit)  Table.Align_Right
 125                                 , Table.column (title Write.I18N_Balance_credit) Table.Align_Right
 126                                 , Table.column (title Write.I18N_Balance_total)  Table.Align_Right
 127                                 , Table.column (title Write.I18N_Account)        Table.Align_Left
 128                                 ] $
 129                                 flip (write_by_accounts ctx) expanded $
 130                                 zipWith (:)
 131                                         [ Table.Cell_Line '=' 0
 132                                         , Table.Cell_Line '=' 0
 133                                         , Table.Cell_Line '=' 0
 134                                         , Table.Cell_Line ' ' 0
 135                                         ] $
 136                                 write_by_amounts (repeat []) $
 137                                         Data.Map.map
 138                                          Balance.unit_sum_amount
 139                                          (Balance.balance_by_unit balance)
 140 write_by_accounts
 141  :: Ctx
 142  -> [[Table.Cell]]
 143  -> Balance.Expanded Amount Unit
 144  -> [[Table.Cell]]
 145 write_by_accounts ctx =
 146         let posting_type = Ledger.Posting_Type_Regular in
 147         Lib.TreeMap.foldr_with_Path_and_Node
 148          (\account node balance rows -> do
 149                 let descendants = Lib.TreeMap.nodes
 150                          (Lib.TreeMap.node_descendants node)
 151                 let is_worth =
 152                         ctx_redundant ctx
 153                         || Data.Map.size
 154                                  (Data.Map.filter
 155                                          (not . Amount.is_zero)
 156                                          (Balance.exclusive balance)) > 0
 157                         || Data.Map.size
 158                                  (Data.Map.filter
 159                                          ( maybe False (not . Amount.are_zero . Balance.amount_sum_balance . Balance.inclusive)
 160                                          . Lib.TreeMap.node_value )
 161                                          descendants) > 1
 162                 case is_worth of
 163                  False -> rows
 164                  True ->
 165                         Data.List.foldr
 166                          (\(amount_positive, amount_negative, amount) ->
 167                                 zipWith (:)
 168                                         [ Table.cell
 169                                          { Table.cell_content = maybe W.empty Ledger.Write.amount  amount_positive
 170                                          , Table.cell_width   = maybe 0 Ledger.Write.amount_length amount_positive
 171                                          }
 172                                         , Table.cell
 173                                          { Table.cell_content = maybe W.empty Ledger.Write.amount  amount_negative
 174                                          , Table.cell_width   = maybe 0 Ledger.Write.amount_length amount_negative
 175                                          }
 176                                         , Table.cell
 177                                          { Table.cell_content = Ledger.Write.amount        $ amount
 178                                          , Table.cell_width   = Ledger.Write.amount_length $ amount
 179                                          }
 180                                         , Table.cell
 181                                          { Table.cell_content = Ledger.Write.account        posting_type account
 182                                          , Table.cell_width   = Ledger.Write.account_length posting_type account
 183                                          }
 184                                         ]
 185                          )
 186                          rows $
 187                         let bal = Balance.inclusive balance in
 188                         Data.Map.foldrWithKey
 189                          (\unit amount acc ->
 190                                 ( Data.Map.lookup unit $ Balance.amount_sum_positive bal
 191                                 , Data.Map.lookup unit $ Balance.amount_sum_negative bal
 192                                 , amount
 193                                 ) : acc
 194                          ) [] $ Balance.amount_sum_balance bal
 195          )
 196
 197 write_by_amounts
 198  :: [[Table.Cell]]
 199  -> Data.Map.Map Unit (Balance.Amount_Sum Amount ())
 200  -> [[Table.Cell]]
 201 write_by_amounts =
 202         Data.Map.foldr
 203          (\amount_sum ->
 204                 zipWith (:)
 205                         [ let amt = Data.Map.lookup () $ Balance.amount_sum_positive amount_sum in
 206                                 Table.cell
 207                                  { Table.cell_content = maybe W.empty Ledger.Write.amount  amt
 208                                  , Table.cell_width   = maybe 0 Ledger.Write.amount_length amt
 209                                  }
 210                         , let amt = Data.Map.lookup () $ Balance.amount_sum_negative amount_sum in
 211                                 Table.cell
 212                                  { Table.cell_content = maybe W.empty Ledger.Write.amount  amt
 213                                  , Table.cell_width   = maybe 0 Ledger.Write.amount_length amt
 214                                  }
 215                         , let amt = Data.Map.lookup () $ Balance.amount_sum_balance amount_sum in
 216                                 Table.cell
 217                                  { Table.cell_content = maybe W.empty Ledger.Write.amount  amt
 218                                  , Table.cell_width   = maybe 0 Ledger.Write.amount_length amt
 219                                  }
 220                         , Table.cell
 221                                  { Table.cell_content = W.empty
 222                                  , Table.cell_width   = 0
 223                                  }
 224                         ]
 225          )