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