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                 Data.Foldable.foldl
 116                  (\(len, plus) 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.foldl_with_Path_and_Node
 127          (\doc account node amounts ->
 128                 if Data.Map.null (Balance.exclusive amounts) &&
 129                         Data.Map.size (Lib.TreeMap.nodes (Lib.TreeMap.node_descendants node)) == 1
 130                 then doc
 131                 else
 132                         doc <> Data.Map.foldl
 133                          (\doc_ amount ->
 134                                 doc_ <>
 135                                 (if W.is_empty doc_
 136                                 then do
 137                                         W.fill (max_amount_length - Ledger.Write.amount_length amount) W.empty <> do
 138                                         Ledger.Write.amount amount <> do
 139                                         W.space <> W.space <> do
 140                                         Ledger.Write.account Posting.Type_Regular account
 141                                 else do
 142                                         (W.bold $ W.dullblack $ W.text "+" <> W.space) <> do
 143                                         W.fill (max_amount_length - Ledger.Write.amount_length amount - 2) W.empty <> do
 144                                         Ledger.Write.amount amount) <> do
 145                                 W.line
 146                          ) W.empty (Balance.inclusive amounts)
 147          )
 148          W.empty accounts
 149
 150 write_amounts :: Int -> Amount.By_Unit -> W.Doc
 151 write_amounts max_amount_length_ amounts = do
 152         let max_amount_length =
 153                 Data.Map.foldr
 154                  (max . Ledger.Write.amount_length)
 155                  max_amount_length_ amounts
 156         (if Data.Map.size amounts > 1
 157                 then W.space <> W.space
 158                 else W.empty) <> do
 159         W.intercalate
 160          (W.line <> (W.bold $ W.dullblack $ W.text "+") <> W.space)
 161          (\amount ->
 162                 let len =
 163                         max_amount_length
 164                         - Ledger.Write.amount_length amount
 165                         - (if Data.Map.size amounts > 1 then 2 else 0) in
 166                 W.fill len W.empty <> do
 167                 Ledger.Write.amount amount)
 168          amounts <> do
 169         (if Data.Map.null amounts then W.empty else W.line)