cli/Hcompta/CLI/Command/Stats.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE TupleSections #-}
   6 module Hcompta.CLI.Command.Stats where
   7
   8 import           Control.Monad (Monad(..), forM_, liftM, mapM)
   9 import           Control.Monad.IO.Class (liftIO)
  10 import           Control.Monad.Trans.Except (runExceptT)
  11 import           Data.Either (Either(..), partitionEithers)
  12 import           Data.Foldable (Foldable(..))
  13 import           Data.List ((++))
  14 import qualified Data.Map.Strict as Data.Map
  15 import           Data.Maybe (Maybe(..))
  16 import           Data.Monoid (Monoid(..), (<>))
  17 import           Data.Text (Text)
  18 import           Data.String (String)
  19 import           Prelude (($), (.), Bounded(..), FilePath, IO, Num(..), flip, unlines)
  20 import           Text.Show (Show(..))
  21 import           System.Console.GetOpt
  22                  ( ArgDescr(..)
  23                  , OptDescr(..)
  24                  , usageInfo )
  25 import           System.Environment as Env (getProgName)
  26 import           System.Exit (exitSuccess)
  27 import qualified System.IO as IO
  28
  29 import qualified Hcompta.Amount.Unit as Amount.Unit
  30 import           Hcompta.Chart (Chart)
  31 import qualified Hcompta.CLI.Args as Args
  32 import qualified Hcompta.CLI.Context as C
  33 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  34 import qualified Hcompta.CLI.Lang as Lang
  35 import qualified Hcompta.CLI.Write as Write
  36 -- import qualified Hcompta.Date as Date
  37 import qualified Hcompta.Filter as Filter
  38 import qualified Hcompta.Filter.Read as Filter.Read
  39 import qualified Hcompta.Format.Ledger as Ledger
  40 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  41 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  42 import qualified Hcompta.Lib.Interval as Interval
  43 import qualified Hcompta.Lib.Leijen as W
  44 import qualified Hcompta.Stats as Stats
  45
  46 data Ctx
  47  =   Ctx
  48  { ctx_input              :: [FilePath]
  49  , ctx_filter_transaction :: Filter.Simplified
  50                              (Filter.Filter_Bool
  51                              (Filter.Filter_Transaction
  52                              (Chart, Ledger.Transaction)))
  53  } deriving (Show)
  54
  55 nil :: Ctx
  56 nil =
  57         Ctx
  58          { ctx_input = []
  59          , ctx_filter_transaction = mempty
  60          }
  61
  62 usage :: C.Context -> IO String
  63 usage c = do
  64         bin <- Env.getProgName
  65         return $ unlines $
  66                 [ C.translate c Lang.Section_Description
  67                 , "  "++C.translate c Lang.Help_Command_Stats
  68                 , ""
  69                 , C.translate c Lang.Section_Syntax
  70                 , "  "++bin++" stats ["++C.translate c Lang.Type_Option++"] [...]"++
  71                                    " ["++C.translate c Lang.Type_File_Journal++"] [...]"
  72                 , ""
  73                 , usageInfo (C.translate c Lang.Section_Options) (options c)
  74                 ]
  75
  76 options :: C.Context -> Args.Options Ctx
  77 options c =
  78         [ Option "h" ["help"]
  79          (NoArg (\_ctx -> do
  80                 usage c >>= IO.hPutStr IO.stderr
  81                 exitSuccess)) $
  82                 C.translate c Lang.Help_Option_Help
  83         , Option "i" ["input"]
  84          (ReqArg (\s ctx -> do
  85                 return $ ctx{ctx_input=s:ctx_input ctx}) $
  86                 C.translate c Lang.Type_File_Journal) $
  87                 C.translate c Lang.Help_Option_Input
  88         , Option "t" ["transaction-filter"]
  89          (ReqArg (\s ctx -> do
  90                 ctx_filter_transaction <-
  91                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
  92                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
  93                         >>= \f -> case f of
  94                          Left  ko -> Write.fatal c $ ko
  95                          Right ok -> do
  96                                 Write.debug c $ "filter: transaction: " ++ show ok
  97                                 return ok
  98                 return $ ctx{ctx_filter_transaction}) $
  99                 C.translate c Lang.Type_Filter_Transaction) $
 100                 C.translate c Lang.Help_Option_Filter_Transaction
 101         ]
 102
 103 run :: C.Context -> [String] -> IO ()
 104 run context args = do
 105         (ctx, inputs) <- Args.parse context usage options (nil, args)
 106         read_journals <-
 107                 liftM Data.Either.partitionEithers $ do
 108                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 109                 >>= do
 110                         mapM $ \path -> do
 111                                 liftIO $ runExceptT $ Ledger.Read.file
 112                                  (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
 113                                  path
 114                                 >>= \x -> case x of
 115                                  Left  ko -> return $ Left (path, ko)
 116                                  Right ok -> return $ Right ok
 117         case read_journals of
 118          (errs@(_:_), _journals) ->
 119                 forM_ errs $ \(_path, err) -> do
 120                         Write.fatal context $ err
 121          ([], journals) -> do
 122                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 123                 let (files, stats) = ledger_stats ctx journals
 124                 style_color <- Write.with_color context IO.stdout
 125                 W.displayIO IO.stdout $ do
 126                 W.renderPretty style_color 1.0 maxBound $ do
 127                 doc_stats context ctx (files, stats)
 128
 129 ledger_stats
 130  :: Ctx
 131  -> [ Ledger.Journal (Stats.Stats (Chart, Ledger.Transaction)) ]
 132  -> ([FilePath], Stats.Stats (Chart, Ledger.Transaction))
 133 ledger_stats _ctx =
 134         Data.Foldable.foldl'
 135          (flip (\j ->
 136                 flip mappend $
 137                 Ledger.Journal.fold
 138                  (\Ledger.Journal
 139                          { Ledger.journal_sections=s
 140                          , Ledger.journal_file=f
 141                          } -> mappend ([f], s)
 142                  ) j mempty
 143          ))
 144          mempty
 145
 146 doc_stats
 147  :: C.Context
 148  -> Ctx
 149  -> ([FilePath], Stats.Stats (Chart, Ledger.Transaction))
 150  -> W.Doc
 151 doc_stats c _ctx (files, stats) =
 152         let lang = C.lang c in
 153         h Lang.Header_Accounts <>
 154         (W.toDoc () $ Data.Map.size $ Stats.stats_accounts stats) <>
 155                 (let depth = Stats.stats_accounts_depths stats in
 156                 W.line <> h Lang.Header_Accounts_Depth <>
 157                 W.toDoc () (Interval.limit $ Interval.low  depth) <>
 158                 (W.bold $ W.dullyellow "..") <>
 159                 W.toDoc () (Interval.limit $ Interval.high depth)) <>
 160         W.line <>
 161         h Lang.Header_Transactions <>
 162         (W.toDoc () $ Stats.stats_transactions stats) <>
 163                 (case Stats.stats_transactions_span stats of
 164                  Nothing -> W.empty
 165                  Just date ->
 166                         W.line <> h Lang.Header_Transactions_Date <>
 167                         W.toDoc lang (Interval.limit $ Interval.low  date) <>
 168                         (W.bold $ W.dullyellow "..") <>
 169                         W.toDoc lang (Interval.limit $ Interval.high date)) <>
 170         W.line <>
 171         h Lang.Header_Units <>
 172         (W.toDoc () (Data.Map.size $
 173                 Data.Map.delete Amount.Unit.nil $
 174                 Stats.stats_units stats)) <> W.line <>
 175         h Lang.Header_Journals <>
 176         W.toDoc () (length $ files) <> W.line <>
 177         h Lang.Header_Tags <>
 178                 ((W.toDoc () (Data.Foldable.foldr
 179                  (flip $ Data.Foldable.foldr (+)) 0 $
 180                 Stats.stats_tags stats)) <>
 181                 W.line <>
 182                 h Lang.Header_Tags_Distinct <>
 183                 W.toDoc () (Data.Map.size $ Stats.stats_tags stats)) <>
 184         W.line
 185         where
 186                 h :: Lang.Translate t [Text] => t -> W.Doc
 187                 h t =
 188                         foldMap
 189                          (\s -> (W.bold $ W.dullblack (W.toDoc () s)) <> (W.bold $ W.dullyellow ":"))
 190                          (C.translate c t::[Text])