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 '-') <> W.line <> do
 106                         write_amounts max_amount_length $
 107                                 Data.Map.map Balance.amount $
 108                                 (Balance.by_unit balance)
 109
 110 write_accounts :: Balance.Expanded -> (Int, W.Doc)
 111 write_accounts accounts = do
 112         let max_amount_length =
 113                 uncurry (+) $
 114                 Lib.TreeMap.foldlWithKey
 115                  (\(len, plus) _k amounts ->
 116                         ( Data.Map.foldr
 117                                  (max . Ledger.Write.amount_length)
 118                                  len (Balance.inclusive amounts)
 119                         , if Data.Map.size (Balance.inclusive amounts) > 1
 120                                 then 2
 121                                 else plus
 122                         ))
 123                  (0, 0) accounts
 124         (max_amount_length,) $ do
 125         Lib.TreeMap.foldlWithKey
 126          (\doc account amounts ->
 127                 if Data.Map.null $ Balance.exclusive amounts
 128                 then doc
 129                 else
 130                         doc <> Data.Map.foldl
 131                          (\doc_ amount ->
 132                                 doc_ <>
 133                                 (if W.is_empty doc_
 134                                 then do
 135                                         W.fill (max_amount_length - Ledger.Write.amount_length amount) W.empty <> do
 136                                         Ledger.Write.amount amount <> do
 137                                         W.space <> do
 138                                         Ledger.Write.account Posting.Type_Regular account
 139                                 else do
 140                                         (W.text "+" <> W.space) <> do
 141                                         W.fill (max_amount_length - Ledger.Write.amount_length amount - 2) W.empty <> do
 142                                         Ledger.Write.amount amount) <> do
 143                                 W.line
 144                          ) W.empty (Balance.inclusive amounts)
 145          )
 146          W.empty accounts
 147
 148 write_amounts :: Int -> Amount.By_Unit -> W.Doc
 149 write_amounts max_amount_length_ amounts = do
 150         let max_amount_length =
 151                 Data.Map.foldr
 152                  (max . Ledger.Write.amount_length)
 153                  max_amount_length_ amounts
 154         (if Data.Map.size amounts > 1
 155                 then W.space <> W.space
 156                 else W.empty) <> do
 157         W.intercalate
 158          (W.line <> W.text "+" <> W.space)
 159          (\amount ->
 160                 let len =
 161                         max_amount_length
 162                         - Ledger.Write.amount_length amount
 163                         - (if Data.Map.size amounts > 1 then 2 else 0) in
 164                 W.fill len W.empty <> do
 165                 Ledger.Write.amount amount)
 166          amounts <> do
 167         W.line