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