cli/Hcompta/CLI/Command/Balance.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE TupleSections #-}
   4 module Hcompta.CLI.Command.Balance where
   5
   6 import           Control.Monad.IO.Class (liftIO)
   7 import           Control.Monad.Trans.Except (runExceptT)
   8 import qualified Data.Either
   9 -- import qualified Data.Foldable
  10 import qualified Data.List
  11 import qualified Data.Map
  12 import qualified Data.Text.Lazy as TL
  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)
  22
  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.Write as Write
  27 import qualified Hcompta.Calc.Balance as Balance
  28 import qualified Hcompta.Format.Ledger.Journal
  29 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  30 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  31 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
  32 import qualified Hcompta.Lib.Leijen as W
  33 import           Hcompta.Lib.Leijen ((<>))
  34 import qualified Hcompta.Model.Amount as Amount
  35 import qualified Hcompta.Model.Transaction.Posting as Posting
  36 -- import qualified Hcompta.Format.Ledger.Write
  37
  38 data Ctx
  39  =   Ctx
  40  { ctx_input :: [FilePath]
  41  } deriving (Eq, Show)
  42
  43 nil :: Ctx
  44 nil =
  45         Ctx
  46          { ctx_input = []
  47          }
  48
  49 usage :: IO String
  50 usage = do
  51         bin <- Env.getProgName
  52         return $ unlines $
  53                 [ "SYNTAX "
  54                 , "  "++bin++" balance [option..]"
  55                 , ""
  56                 , usageInfo "OPTIONS" options
  57                 ]
  58
  59 options :: Args.Options Ctx
  60 options =
  61         [ Option "h" ["help"]
  62          (NoArg (\_ctx -> do
  63                 usage >>= IO.hPutStr IO.stderr
  64                 exitWith ExitSuccess))
  65          "show this help"
  66         , Option "i" ["input"]
  67          (ReqArg (\s ctx -> do
  68                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  69          "read data from given file, can be use multiple times"
  70         ]
  71
  72 run :: Context.Context -> [String] -> IO ()
  73 run context args = do
  74         (ctx, _) <- Args.parse context usage options (nil, args)
  75         CLI.Ledger.paths context $ ctx_input ctx
  76         >>= do mapM $ \path -> do
  77                 liftIO $ runExceptT $
  78                         Ledger.Read.file path
  79                 >>= \x -> case x of
  80                  Left  ko -> return $ Left (path, ko)
  81                  Right ok -> return $ Right ok
  82         >>= return . Data.Either.partitionEithers
  83         >>= \x -> case x of
  84          (kos@(_:_), _oks) ->
  85                 (flip mapM_) kos $ \(_path, ko) ->
  86                         Write.fatal context $ ko
  87          ([], journals) -> do
  88                 CLI.Ledger.equilibre context journals
  89                 let balance =
  90                         Data.List.foldl
  91                          (\b j -> Balance.journal_with_virtual
  92                                  (Hcompta.Format.Ledger.Journal.to_Model j) b)
  93                          Balance.nil
  94                          journals
  95                 Write.debug context $ ppShow $ balance
  96                 Write.debug context $ ppShow $
  97                         Lib.TreeMap.flatten (const ()) (Balance.by_account balance)
  98                 let expanded = Balance.expand $ Balance.by_account balance
  99                 Write.debug context $ ppShow $ expanded
 100                 with_color <- Write.with_color context IO.stdout
 101                 Ledger.Write.put with_color IO.stdout $ do
 102                         let (max_amount_length, accounts) = write_accounts expanded
 103                         accounts <> do
 104                         (W.bold $ W.dullblack $
 105                                 W.text (TL.pack $ replicate max_amount_length '-') <>
 106                                 (if max_amount_length <= 0 then W.empty else W.line)) <> do
 107                         write_amounts max_amount_length $
 108                                 Data.Map.map Balance.amount $
 109                                 (Balance.by_unit balance)
 110
 111 write_accounts :: Balance.Expanded -> (Int, W.Doc)
 112 write_accounts accounts = do
 113         let max_amount_length =
 114                 uncurry (+) $
 115                 Lib.TreeMap.foldlWithKey
 116                  (\(len, plus) _k amounts ->
 117                         ( Data.Map.foldr
 118                                  (max . Ledger.Write.amount_length)
 119                                  len (Balance.inclusive amounts)
 120                         , if Data.Map.size (Balance.inclusive amounts) > 1
 121                                 then 2
 122                                 else plus
 123                         ))
 124                  (0, 0) accounts
 125         (max_amount_length,) $ do
 126         Lib.TreeMap.foldlWithKey
 127          (\doc account amounts ->
 128                 if Data.Map.null $ Balance.exclusive amounts
 129                 then doc
 130                 else
 131                         doc <> Data.Map.foldl
 132                          (\doc_ amount ->
 133                                 doc_ <>
 134                                 (if W.is_empty doc_
 135                                 then do
 136                                         W.fill (max_amount_length - Ledger.Write.amount_length amount) W.empty <> do
 137                                         Ledger.Write.amount amount <> do
 138                                         W.space <> W.space <> do
 139                                         Ledger.Write.account Posting.Type_Regular account
 140                                 else do
 141                                         (W.bold $ W.dullblack $ W.text "+" <> W.space) <> do
 142                                         W.fill (max_amount_length - Ledger.Write.amount_length amount - 2) W.empty <> do
 143                                         Ledger.Write.amount amount) <> do
 144                                 W.line
 145                          ) W.empty (Balance.inclusive amounts)
 146          )
 147          W.empty accounts
 148
 149 write_amounts :: Int -> Amount.By_Unit -> W.Doc
 150 write_amounts max_amount_length_ amounts = do
 151         let max_amount_length =
 152                 Data.Map.foldr
 153                  (max . Ledger.Write.amount_length)
 154                  max_amount_length_ amounts
 155         (if Data.Map.size amounts > 1
 156                 then W.space <> W.space
 157                 else W.empty) <> do
 158         W.intercalate
 159          (W.line <> (W.bold $ W.dullblack $ W.text "+") <> W.space)
 160          (\amount ->
 161                 let len =
 162                         max_amount_length
 163                         - Ledger.Write.amount_length amount
 164                         - (if Data.Map.size amounts > 1 then 2 else 0) in
 165                 W.fill len W.empty <> do
 166                 Ledger.Write.amount amount)
 167          amounts <> do
 168         (if Data.Map.null amounts then W.empty else W.line)