cli/Hcompta/CLI/Command/Stats.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE TupleSections #-}
   5 module Hcompta.CLI.Command.Stats where
   6
   7 import           Control.Monad (liftM, forM_)
   8 import           Control.Monad.IO.Class (liftIO)
   9 import           Control.Monad.Trans.Except (runExceptT)
  10 import qualified Data.Either
  11 import qualified Data.Foldable
  12 import qualified Data.Map.Strict as Data.Map
  13 import           Data.Monoid ((<>))
  14 import           System.Console.GetOpt
  15                  ( ArgDescr(..)
  16                  , OptDescr(..)
  17                  , usageInfo )
  18 import           System.Environment as Env (getProgName)
  19 import           System.Exit (exitSuccess)
  20 import qualified System.IO as IO
  21
  22 import qualified Hcompta.CLI.Args as Args
  23 import qualified Hcompta.CLI.Context as Context
  24 import           Hcompta.CLI.Context (Context)
  25 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  26 import qualified Hcompta.CLI.Lang as Lang
  27 import qualified Hcompta.CLI.Write as Write
  28 -- import qualified Hcompta.Date as Date
  29 import qualified Hcompta.Amount.Unit as Amount.Unit
  30 import qualified Hcompta.Filter as Filter
  31 import qualified Hcompta.Filter.Read as Filter.Read
  32 -- import qualified Hcompta.Filter.Reduce as Filter.Reduce
  33 import qualified Hcompta.Format.Ledger as Ledger
  34 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  35 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  36 -- import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  37 import qualified Hcompta.Lib.Interval as Interval
  38 import qualified Hcompta.Lib.Leijen as W
  39 import qualified Hcompta.Stats as Stats
  40
  41 data Ctx
  42  =   Ctx
  43  { ctx_input              :: [FilePath]
  44  , ctx_filter_transaction :: Filter.Simplified
  45                              (Filter.Filter_Bool
  46                              (Filter.Filter_Transaction
  47                              Ledger.Transaction))
  48  } deriving (Show)
  49
  50 nil :: Ctx
  51 nil =
  52         Ctx
  53          { ctx_input = []
  54          , ctx_filter_transaction = mempty
  55          }
  56
  57 usage :: IO String
  58 usage = do
  59         bin <- Env.getProgName
  60         let pad = replicate (length bin) ' '
  61         return $unlines $
  62                 [ "SYNTAX "
  63                 , "  "++bin++" stats [-i JOURNAL_FILE]"
  64                 , "  "++pad++"       [-t TRANSACTION_FILTER]"
  65                 , "  "++pad++"       [JOURNAL_FILE] [...]"
  66                 , ""
  67                 , usageInfo "OPTIONS" options
  68                 ]
  69
  70 options :: Args.Options Ctx
  71 options =
  72         [ Option "h" ["help"]
  73          (NoArg (\_context _ctx -> do
  74                 usage >>= IO.hPutStr IO.stderr
  75                 exitSuccess))
  76          "show this help"
  77         , Option "i" ["input"]
  78          (ReqArg (\s _context ctx -> do
  79                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  80          "read data from given file, multiple uses merge the data as would a concatenation do"
  81         , Option "t" ["transaction-filter"]
  82          (ReqArg (\s context ctx -> do
  83                 ctx_filter_transaction <-
  84                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
  85                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
  86                         >>= \f -> case f of
  87                          Left  ko -> Write.fatal context $ ko
  88                          Right ok -> do
  89                                 Write.debug context $ "filter: transaction: " ++ show ok
  90                                 return ok
  91                 return $ ctx{ctx_filter_transaction}) "FILTER")
  92          "filter at transaction level, multiple uses are merged with a logical AND"
  93         ]
  94
  95 run :: Context.Context -> [String] -> IO ()
  96 run context args = do
  97         (ctx, inputs) <- Args.parse context usage options (nil, args)
  98         read_journals <-
  99                 liftM Data.Either.partitionEithers $ do
 100                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 101                 >>= do
 102                         mapM $ \path -> do
 103                                 liftIO $ runExceptT $ Ledger.Read.file
 104                                  (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
 105                                  path
 106                                 >>= \x -> case x of
 107                                  Left  ko -> return $ Left (path, ko)
 108                                  Right ok -> return $ Right ok
 109         case read_journals of
 110          (errs@(_:_), _journals) ->
 111                 forM_ errs $ \(_path, err) -> do
 112                         Write.fatal context $ err
 113          ([], journals) -> do
 114                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 115                 let (files, stats) = ledger_stats ctx journals
 116                 style_color <- Write.with_color context IO.stdout
 117                 W.displayIO IO.stdout $ do
 118                 W.renderPretty style_color 1.0 maxBound $ do
 119                 doc_stats context ctx (files, stats)
 120
 121 ledger_stats
 122  :: Ctx
 123  -> [ Ledger.Journal (Stats.Stats Ledger.Transaction) ]
 124  -> ([FilePath], Stats.Stats Ledger.Transaction)
 125 ledger_stats _ctx =
 126         Data.Foldable.foldl'
 127          (flip $ Ledger.Journal.fold
 128                  (\Ledger.Journal
 129                          { Ledger.journal_transactions=s
 130                          , Ledger.journal_file=f
 131                          } -> mappend ([f], s)))
 132          mempty
 133
 134 doc_stats
 135  :: Context
 136  -> Ctx
 137  -> ([FilePath], Stats.Stats Ledger.Transaction)
 138  -> W.Doc
 139 doc_stats context _ctx (files, stats) =
 140         let lang = Context.lang context in
 141         W.toDoc lang Lang.Message_Accounts <> " (" <>
 142         (W.toDoc () $ Data.Map.size $ Stats.stats_accounts stats) <> ")" <>
 143                 W.nest 2 (
 144                         let depth = Stats.stats_accounts_depths stats in
 145                         W.line <> W.toDoc lang Lang.Message_Depths <>
 146                         " (" <>
 147                         W.toDoc () (Interval.limit $ Interval.low  depth) <>
 148                         ".." <>
 149                         W.toDoc () (Interval.limit $ Interval.high depth) <>
 150                         ")"
 151                  ) <> W.line <>
 152         W.toDoc lang Lang.Message_Transactions <> " (" <> (W.toDoc () $ Stats.stats_transactions stats) <> ")" <>
 153                 W.nest 2 (
 154                         case Stats.stats_transactions_span stats of
 155                          Nothing -> W.empty
 156                          Just date ->
 157                                 W.line <> "Dates" <>
 158                                 " (" <>
 159                                 W.toDoc () (Interval.limit $ Interval.low  date) <>
 160                                 ".." <>
 161                                 W.toDoc () (Interval.limit $ Interval.high date) <>
 162                                 ")"
 163                  ) <> W.line <>
 164         W.toDoc lang Lang.Message_Units <> " (" <>
 165                 (W.toDoc () (Data.Map.size $ Data.Map.delete Amount.Unit.nil $ Stats.stats_units stats)) <> ")" <> W.line <>
 166         W.toDoc lang Lang.Message_Journals <> " (" <> (W.toDoc () (length $ files)) <> ")" <> W.line <>
 167         W.toDoc lang Lang.Message_Tags <> " (" <>
 168                 (W.toDoc () (foldr (flip $ foldr (+)) 0 $ Stats.stats_tags stats)) <>
 169                 ")" <>
 170         W.nest 2 ( W.line <>
 171                 "Distincts" <> " (" <> (W.toDoc () (Data.Map.size $ Stats.stats_tags stats)) <> ")"
 172          ) <> W.line