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