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)
  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.I18N 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 $ show $ 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                                                  (\tr ->
 110                                                         Balance.union
 111                                                          (Data.Foldable.foldr Balance.postings
 112                                                                  (Ledger.transaction_balanced_virtual_postings_balance tr)
 113                                                                  (Ledger.transaction_virtual_postings tr)) .
 114                                                         Balance.union (Ledger.transaction_postings_balance tr)
 115                                                  ))))
 116                                  . Ledger.journal_transactions))
 117                          Balance.nil
 118                          journals
 119                 let expanded = Balance.expanded $ Balance.balance_by_account balance
 120                 style_color <- Write.with_color context IO.stdout
 121                 Ledger.Write.put Ledger.Write.Style
 122                  { Ledger.Write.style_align = True
 123                  , Ledger.Write.style_color
 124                  } IO.stdout $ do
 125                         toDoc () $
 126                                 let title = TL.toStrict . W.displayT . W.renderCompact False .
 127                                         I18N.render (Context.langs context) in
 128                                 zipWith id
 129                                 [ Table.column (title I18N.Message_Balance_debit)  Table.Align_Right
 130                                 , Table.column (title I18N.Message_Balance_credit) Table.Align_Right
 131                                 , Table.column (title I18N.Message_Balance_total)  Table.Align_Right
 132                                 , Table.column (title I18N.Message_Account)        Table.Align_Left
 133                                 ] $
 134                                 flip (write_by_accounts ctx) expanded $
 135                                 zipWith (:)
 136                                         [ Table.Cell_Line '=' 0
 137                                         , Table.Cell_Line '=' 0
 138                                         , Table.Cell_Line '=' 0
 139                                         , Table.Cell_Line ' ' 0
 140                                         ] $
 141                                 write_by_amounts (repeat []) $
 142                                         Data.Map.map
 143                                          Balance.unit_sum_amount
 144                                          (Balance.balance_by_unit balance)
 145 write_by_accounts
 146  :: Ctx
 147  -> [[Table.Cell]]
 148  -> Balance.Expanded Amount
 149  -> [[Table.Cell]]
 150 write_by_accounts ctx =
 151         let posting_type = Ledger.Posting_Type_Regular in
 152         Lib.TreeMap.foldr_with_Path_and_Node
 153          (\account node balance rows -> do
 154                 let descendants = Lib.TreeMap.nodes
 155                          (Lib.TreeMap.node_descendants node)
 156                 let is_worth =
 157                         ctx_redundant ctx
 158                         || Data.Map.size
 159                                  (Data.Map.filter
 160                                          (not . Amount.is_zero)
 161                                          (Balance.exclusive balance)) > 0
 162                         || Data.Map.size
 163                                  (Data.Map.filter
 164                                          ( maybe False (not . Amount.are_zero . Balance.amount_sum_balance . Balance.inclusive)
 165                                          . Lib.TreeMap.node_value )
 166                                          descendants) > 1
 167                 case is_worth of
 168                  False -> rows
 169                  True ->
 170                         Data.List.foldr
 171                          (\(amount_positive, amount_negative, amount) ->
 172                                 zipWith (:)
 173                                         [ Table.cell
 174                                          { Table.cell_content = maybe W.empty Ledger.Write.amount  amount_positive
 175                                          , Table.cell_width   = maybe 0 Ledger.Write.amount_length amount_positive
 176                                          }
 177                                         , Table.cell
 178                                          { Table.cell_content = maybe W.empty Ledger.Write.amount  amount_negative
 179                                          , Table.cell_width   = maybe 0 Ledger.Write.amount_length amount_negative
 180                                          }
 181                                         , Table.cell
 182                                          { Table.cell_content = Ledger.Write.amount        $ amount
 183                                          , Table.cell_width   = Ledger.Write.amount_length $ amount
 184                                          }
 185                                         , Table.cell
 186                                          { Table.cell_content = Ledger.Write.account        posting_type account
 187                                          , Table.cell_width   = Ledger.Write.account_length posting_type account
 188                                          }
 189                                         ]
 190                          )
 191                          rows $
 192                         let bal = Balance.inclusive balance in
 193                         Data.Map.foldrWithKey
 194                          (\unit amount acc ->
 195                                 ( Data.Map.lookup unit $ Balance.amount_sum_positive bal
 196                                 , Data.Map.lookup unit $ Balance.amount_sum_negative bal
 197                                 , amount
 198                                 ) : acc
 199                          ) [] $ Balance.amount_sum_balance bal
 200          )
 201
 202 write_by_amounts
 203  :: [[Table.Cell]]
 204  -> Data.Map.Map Unit (Balance.Amount_Sum Amount ())
 205  -> [[Table.Cell]]
 206 write_by_amounts =
 207         Data.Map.foldr
 208          (\amount_sum ->
 209                 zipWith (:)
 210                         [ let amt = Data.Map.lookup () $ Balance.amount_sum_positive 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_negative 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                         , let amt = Data.Map.lookup () $ Balance.amount_sum_balance amount_sum in
 221                                 Table.cell
 222                                  { Table.cell_content = maybe W.empty Ledger.Write.amount  amt
 223                                  , Table.cell_width   = maybe 0 Ledger.Write.amount_length amt
 224                                  }
 225                         , Table.cell
 226                                  { Table.cell_content = W.empty
 227                                  , Table.cell_width   = 0
 228                                  }
 229                         ]
 230          )