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