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           Hcompta.Chart (Chart)
  29 import qualified Hcompta.CLI.Args as Args
  30 import           Hcompta.CLI.Context (Context)
  31 import qualified Hcompta.CLI.Context as Context
  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                              (Chart, 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 :: IO String
  62 usage = do
  63         bin <- Env.getProgName
  64         let pad = replicate (length bin) ' '
  65         return $unlines $
  66                 [ "SYNTAX "
  67                 , "  "++bin++" stats [-i FILE_JOURNAL]"
  68                 , "  "++pad++"       [-t FILTER_TRANSACTION]"
  69                 , "  "++pad++"       [FILE_JOURNAL] [...]"
  70                 , ""
  71                 , usageInfo "OPTIONS" options
  72                 ]
  73
  74 options :: Args.Options Ctx
  75 options =
  76         [ Option "h" ["help"]
  77          (NoArg (\_context _ctx -> do
  78                 usage >>= IO.hPutStr IO.stderr
  79                 exitSuccess))
  80          "show this help"
  81         , Option "i" ["input"]
  82          (ReqArg (\s _context ctx -> do
  83                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  84          "read data from given file, multiple uses merge the data as would a concatenation do"
  85         , Option "t" ["transaction-filter"]
  86          (ReqArg (\s context ctx -> do
  87                 ctx_filter_transaction <-
  88                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
  89                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
  90                         >>= \f -> case f of
  91                          Left  ko -> Write.fatal context $ ko
  92                          Right ok -> do
  93                                 Write.debug context $ "filter: transaction: " ++ show ok
  94                                 return ok
  95                 return $ ctx{ctx_filter_transaction}) "FILTER")
  96          "filter at transaction level, multiple uses are merged with a logical AND"
  97         ]
  98
  99 run :: Context.Context -> [String] -> IO ()
 100 run context args = do
 101         (ctx, inputs) <- Args.parse context usage options (nil, args)
 102         read_journals <-
 103                 liftM Data.Either.partitionEithers $ do
 104                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 105                 >>= do
 106                         mapM $ \path -> do
 107                                 liftIO $ runExceptT $ Ledger.Read.file
 108                                  (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
 109                                  path
 110                                 >>= \x -> case x of
 111                                  Left  ko -> return $ Left (path, ko)
 112                                  Right ok -> return $ Right ok
 113         case read_journals of
 114          (errs@(_:_), _journals) ->
 115                 forM_ errs $ \(_path, err) -> do
 116                         Write.fatal context $ err
 117          ([], journals) -> do
 118                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 119                 let (files, stats) = ledger_stats ctx journals
 120                 style_color <- Write.with_color context IO.stdout
 121                 W.displayIO IO.stdout $ do
 122                 W.renderPretty style_color 1.0 maxBound $ do
 123                 doc_stats context ctx (files, stats)
 124
 125 ledger_stats
 126  :: Ctx
 127  -> [ Ledger.Journal (Stats.Stats (Chart, Ledger.Transaction)) ]
 128  -> ([FilePath], Stats.Stats (Chart, Ledger.Transaction))
 129 ledger_stats _ctx =
 130         Data.Foldable.foldl'
 131          (flip (\j ->
 132                 flip mappend $
 133                 Ledger.Journal.fold
 134                  (\Ledger.Journal
 135                          { Ledger.journal_sections=s
 136                          , Ledger.journal_file=f
 137                          } -> mappend ([f], s)
 138                  ) j mempty
 139          ))
 140          mempty
 141
 142 doc_stats
 143  :: Context
 144  -> Ctx
 145  -> ([FilePath], Stats.Stats (Chart, Ledger.Transaction))
 146  -> W.Doc
 147 doc_stats context _ctx (files, stats) =
 148         let lang = Context.lang context in
 149         W.toDoc lang Lang.Message_Accounts <> " (" <>
 150         (W.toDoc () $ Data.Map.size $ Stats.stats_accounts stats) <> ")" <>
 151                 W.nest 2 (
 152                         let depth = Stats.stats_accounts_depths stats in
 153                         W.line <> W.toDoc lang Lang.Message_Depths <>
 154                         " (" <>
 155                         W.toDoc () (Interval.limit $ Interval.low  depth) <>
 156                         ".." <>
 157                         W.toDoc () (Interval.limit $ Interval.high depth) <>
 158                         ")"
 159                  ) <> W.line <>
 160         W.toDoc lang Lang.Message_Transactions <> " (" <> (W.toDoc () $ Stats.stats_transactions stats) <> ")" <>
 161                 W.nest 2 (
 162                         case Stats.stats_transactions_span stats of
 163                          Nothing -> W.empty
 164                          Just date ->
 165                                 W.line <> "Dates" <>
 166                                 " (" <>
 167                                 W.toDoc () (Interval.limit $ Interval.low  date) <>
 168                                 ".." <>
 169                                 W.toDoc () (Interval.limit $ Interval.high date) <>
 170                                 ")"
 171                  ) <> W.line <>
 172         W.toDoc lang Lang.Message_Units <> " (" <>
 173                 (W.toDoc () (Data.Map.size $ Data.Map.delete Amount.Unit.nil $ Stats.stats_units stats)) <> ")" <> W.line <>
 174         W.toDoc lang Lang.Message_Journals <> " (" <> (W.toDoc () (length $ files)) <> ")" <> W.line <>
 175         W.toDoc lang Lang.Message_Tags <> " (" <>
 176                 (W.toDoc () (Data.Foldable.foldr (flip $ Data.Foldable.foldr (+)) 0 $ Stats.stats_tags stats)) <>
 177                 ")" <>
 178         W.nest 2 ( W.line <>
 179                 "Distincts" <> " (" <> (W.toDoc () (Data.Map.size $ Stats.stats_tags stats)) <> ")"
 180          ) <> W.line