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