cli/Hcompta/CLI/Command/Stats.hs

   1 {-# LANGUAGE ExistentialQuantification #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE NamedFieldPuns #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE Rank2Types #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TupleSections #-}
  10 {-# LANGUAGE TypeFamilies #-}
  11 {-# OPTIONS_GHC -fno-warn-orphans #-}
  12 module Hcompta.CLI.Command.Stats where
  13
  14 import           Control.Applicative (Const(..))
  15 import           Control.Arrow ((+++))
  16 import           Control.Monad (Monad(..), liftM, mapM)
  17 import           Control.Monad.IO.Class (liftIO)
  18 import           Data.Bool (Bool(..))
  19 import           Data.Either (Either(..), partitionEithers)
  20 import           Data.Foldable (Foldable(..))
  21 import           Data.Function (($), (.), on)
  22 import           Data.Functor ((<$>))
  23 import           Data.List ((++))
  24 import qualified Data.List as List
  25 import qualified Data.Map.Strict as Map
  26 import           Data.Maybe (Maybe(..))
  27 import           Data.Monoid (Monoid(..), (<>))
  28 import           Data.Text (Text)
  29 import           Data.String (String)
  30 import           Prelude (Bounded(..), Num(..), flip, unlines)
  31 import           System.Console.GetOpt
  32                  ( ArgDescr(..)
  33                  , OptDescr(..)
  34                  , usageInfo )
  35 import           System.Environment as Env (getProgName)
  36 import           System.Exit (exitSuccess)
  37 import qualified System.IO as IO
  38 import           System.IO (FilePath, IO)
  39
  40 import qualified Hcompta.Unit as Unit
  41 import qualified Hcompta.CLI.Args as Args
  42 import qualified Hcompta.CLI.Context as C
  43 import qualified Hcompta.CLI.Env as CLI.Env
  44 import           Hcompta.CLI.Format.JCC ()
  45 import           Hcompta.CLI.Format.Ledger ()
  46 import           Hcompta.CLI.Format (Format(..), Formats)
  47 import qualified Hcompta.CLI.Format as Format
  48 import qualified Hcompta.CLI.Lang as Lang
  49 import qualified Hcompta.CLI.Write as Write
  50 import qualified Hcompta.Posting as Posting
  51 import qualified Hcompta.Filter as Filter
  52 import qualified Hcompta.Filter.Read as Filter.Read
  53 import qualified Hcompta.Filter.Amount as Filter.Amount
  54 import qualified Hcompta.Format.JCC as JCC
  55 import qualified Hcompta.Format.Ledger as Ledger
  56 import qualified Hcompta.Lib.Interval as Interval
  57 import qualified Hcompta.Lib.Parsec as R
  58 import qualified Hcompta.Lib.Leijen as W
  59 import qualified Hcompta.Stats as Stats
  60
  61 data Context
  62  =   Context
  63  { ctx_input              :: [FilePath]
  64  , ctx_input_format       :: Formats
  65  , ctx_filter_transaction :: forall t.
  66                              ( Filter.Transaction t
  67                              , Filter.Amount_Quantity
  68                                (Posting.Posting_Amount
  69                                (Filter.Transaction_Posting t))
  70                                ~ Filter.Amount.Quantity
  71                              ) => Journal_Filter t
  72  , ctx_output_format      :: Maybe Formats
  73  }
  74
  75 context :: Context
  76 context =
  77         Context
  78          { ctx_input = []
  79          , ctx_input_format       = mempty
  80          , ctx_filter_transaction = Filter.Simplified $ Right True
  81          , ctx_output_format      = Nothing
  82          }
  83
  84 usage :: C.Context -> IO String
  85 usage c = do
  86         bin <- Env.getProgName
  87         return $ unlines $
  88                 [ C.translate c Lang.Section_Description
  89                 , "  "++C.translate c Lang.Help_Command_Stats
  90                 , ""
  91                 , C.translate c Lang.Section_Syntax
  92                 , "  "++bin++" stats ["++C.translate c Lang.Type_Option++"] [...]"++
  93                                    " ["++C.translate c Lang.Type_File_Journal++"] [...]"
  94                 , ""
  95                 , usageInfo (C.translate c Lang.Section_Options) (options c)
  96                 ]
  97
  98 options :: C.Context -> Args.Options Context
  99 options c =
 100         [ Option "h" ["help"]
 101          (NoArg (\_ctx -> do
 102                 usage c >>= IO.hPutStr IO.stderr
 103                 exitSuccess)) $
 104                 C.translate c Lang.Help_Option_Help
 105         , Option "i" ["input"]
 106          (ReqArg (\s ctx -> do
 107                 return $ ctx{ctx_input=s:ctx_input ctx}) $
 108                 C.translate c Lang.Type_File_Journal) $
 109                 C.translate c Lang.Help_Option_Input
 110         , Option "if" ["input-format"]
 111          (OptArg (\arg ctx -> do
 112                 ctx_input_format <- case arg of
 113                  Nothing       -> return $ Format_JCC ()
 114                  Just "jcc"    -> return $ Format_JCC ()
 115                  Just "ledger" -> return $ Format_Ledger ()
 116                  Just _        -> Write.fatal c $
 117                         W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
 118                 return $ ctx{ctx_input_format})
 119           "[jcc|ledger]")
 120           "input format"
 121         , Option "of" ["output-format"]
 122          (OptArg (\arg ctx -> do
 123                 ctx_output_format <- case arg of
 124                  Nothing       -> return $ Just $ Format_JCC ()
 125                  Just "jcc"    -> return $ Just $ Format_JCC ()
 126                  Just "ledger" -> return $ Just $ Format_Ledger ()
 127                  Just _        -> Write.fatal c $
 128                         W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
 129                 return $ ctx{ctx_output_format})
 130           "[jcc|ledger]")
 131           "input format"
 132         , Option "t" ["filter-transaction"]
 133          (ReqArg (\s ctx -> do
 134                 filter <-
 135                         R.runParserT_with_Error
 136                          Filter.Read.filter_transaction
 137                          Filter.Read.context "" s
 138                 case filter of
 139                  Left ko -> Write.fatal c ko
 140                  Right flt ->
 141                         return $
 142                                 ctx{ctx_filter_transaction =
 143                                         Filter.and (ctx_filter_transaction ctx) $
 144                                         (Filter.simplify $
 145                                                 Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
 146                                  }) $
 147                 C.translate c Lang.Type_Filter_Transaction) $
 148                 C.translate c Lang.Help_Option_Filter_Transaction
 149         ]
 150
 151 run :: C.Context -> [String] -> IO ()
 152 run c args = do
 153         (ctx, inputs) <- Args.parse c usage options (context, args)
 154         input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
 155         read_journals <- mapM (liftIO . journal_read ctx) input_paths
 156         case partitionEithers read_journals of
 157          (errs@(_:_), _journals) -> Write.fatals c errs
 158          ([], (journals::[Forall_Stats])) -> do
 159                 with_color <- Write.with_color c IO.stdout
 160                 W.displayIO IO.stdout $
 161                         W.renderPretty with_color 1.0 maxBound $
 162                         stats_write c ctx $
 163                         (Const::x -> Const x ()) $
 164                         mconcat $ Format.journal_flatten <$>
 165                                 case ctx_output_format ctx of
 166                                  Nothing -> journals
 167                                  Just f -> Format.journal_empty f:journals
 168
 169 -- * Type 'Format_Journal'
 170
 171 type Format_Journal
 172  = Format
 173    (   JCC.Journal Stats_JCC)
 174    (Ledger.Journal Stats_Ledger)
 175
 176 type Stats_JCC    = Stats.Stats (   JCC.Charted    JCC.Transaction)
 177 type Stats_Ledger = Stats.Stats (Ledger.Charted Ledger.Transaction)
 178
 179 -- * Class 'Stats'
 180
 181 class Stats j m where
 182         stats_write :: C.Context -> Context -> j m -> W.Doc
 183 instance
 184  ( Stats.Transaction t
 185  , t ~ (Format.Journal_Charted j) (Format.Journal_Transaction j)
 186  , Stats.Posting_Unit (Stats.Transaction_Posting t) ~ Format.Journal_Unit j
 187  , Unit.Unit (Format.Journal_Unit j)
 188  , Format.Journal_Content j
 189  , Format.Journal_Files j
 190  ) => Stats j (Stats.Stats t) where
 191         stats_write c _ctx j =
 192                 let stats = Format.journal_content j in
 193                 render
 194                 [ (Lang.Header_Accounts,) . W.toDoc () $
 195                         Map.size $ Stats.stats_accounts stats
 196                 , (Lang.Header_Accounts_Depth,) $
 197                         let depth = Stats.stats_accounts_depths stats in
 198                         W.toDoc () (Interval.limit $ Interval.low  depth) <>
 199                         (W.bold $ W.dullyellow "..") <>
 200                         W.toDoc () (Interval.limit $ Interval.high depth)
 201                 , (Lang.Header_Transactions,) . W.toDoc () $
 202                         Stats.stats_transactions stats
 203                 , (Lang.Header_Transactions_Date,) $
 204                         case Stats.stats_transactions_span stats of
 205                          Nothing -> W.empty
 206                          Just date ->
 207                                 W.toDoc () (Interval.limit $ Interval.low date) <>
 208                                 (W.bold $ W.dullyellow "..") <>
 209                                 W.toDoc () (Interval.limit $ Interval.high date)
 210                 , (Lang.Header_Units,) . W.toDoc () $
 211                         Map.size $ Map.delete Unit.unit_empty $
 212                         Stats.stats_units stats
 213                 , (Lang.Header_Journals,) . W.toDoc () $
 214                         List.length $ Format.journal_files j
 215                 , (Lang.Header_Tags,) . W.toDoc () $
 216                         W.toDoc () (foldr (flip $ foldr (+)) 0 $
 217                                 Stats.stats_tags stats)
 218                 , (Lang.Header_Tags_Distinct,) . W.toDoc () $
 219                         Map.size $ Stats.stats_tags stats
 220                 ]
 221                 where
 222                         render :: Lang.Translate h [Text] => [(h, W.Doc)] -> W.Doc
 223                         render =
 224                                 foldMap $ \(h, x) ->
 225                                         W.hcat
 226                                          [ W.bold $ flip foldMap
 227                                                  (C.translate c h::[Text]) $ \s ->
 228                                                         W.dullblack (W.toDoc () s) <> W.dullyellow ":"
 229                                          , W.toDoc () x
 230                                          , W.line ]
 231
 232 instance Format.Journal (JCC.Journal Stats_JCC) where
 233         type Journal_Format   (JCC.Journal Stats_JCC) = Format_Journal
 234         journal_format = Format_JCC
 235
 236 instance Format.Journal (Ledger.Journal Stats_Ledger) where
 237         type Journal_Format   (Ledger.Journal Stats_Ledger) = Format_Journal
 238         journal_format = Format_Ledger
 239
 240 -- * Type 'Forall_Stats'
 241
 242 data Forall_Stats
 243  = forall j m. ( Stats j m
 244                , Format.Journal (j m)
 245                , Format.Journal_Content j
 246                , Format.Journal_Files j
 247                , Format.Journal_Read j
 248                , Format.Journal_Monoid (j m)
 249                , Format.Journal_Format (j m) ~ Format_Journal )
 250  => Forall_Stats (j m)
 251
 252 instance Format.Journal Forall_Stats where
 253         type Journal_Format   Forall_Stats = Format_Journal
 254         journal_format  (Forall_Stats j) = Format.journal_format j
 255 instance Format.Journal_Empty Forall_Stats where
 256         journal_empty f =
 257                 case f of
 258                  Format_JCC    () -> Forall_Stats (mempty::JCC.Journal    Stats_JCC)
 259                  Format_Ledger () -> Forall_Stats (mempty::Ledger.Journal Stats_Ledger)
 260
 261 instance Format.Journal_Monoid Forall_Stats where
 262         journal_flatten (Forall_Stats j) = Forall_Stats $ Format.journal_flatten j
 263         journal_fold f  (Forall_Stats j) = Format.journal_fold (f . Forall_Stats) j
 264 instance Stats (Const Forall_Stats) () where
 265         stats_write c ctx (Const (Forall_Stats j)) = stats_write c ctx j
 266 instance Monoid Forall_Stats where
 267         mempty = Forall_Stats (mempty::JCC.Journal Stats_JCC)
 268         mappend x y =
 269                 case (mappend `on` Format.journal_format) x y of
 270                  Format_JCC    j -> Forall_Stats j
 271                  Format_Ledger j -> Forall_Stats j
 272         mconcat js =
 273                 case js of
 274                  [] -> mempty
 275                  j:jn -> foldl' mappend j jn
 276
 277 type Journal_Filter transaction
 278  = Filter.Simplified
 279    (Filter.Filter_Bool
 280    (Filter.Filter_Transaction transaction))
 281 type Journal_Read_Cons txn
 282  = txn -> Filter.Filtered (Journal_Filter txn) txn
 283
 284 journal_read
 285  :: Context -> FilePath
 286  -> IO (Either (Format.Message W.Doc) Forall_Stats)
 287 journal_read ctx =
 288         case ctx_input_format ctx of
 289          Format_JCC () ->
 290                 let wrap (j::JCC.Journal Stats_JCC) = Forall_Stats j in
 291                 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
 292                          = Filter.Filtered (ctx_filter_transaction ctx) in
 293                 liftM ((+++) Format.Message wrap) .
 294                 Format.journal_read cons
 295          Format_Ledger () ->
 296                 let wrap (j::Ledger.Journal Stats_Ledger) = Forall_Stats j in
 297                 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
 298                          = Filter.Filtered (ctx_filter_transaction ctx) in
 299                 liftM ((+++) Format.Message wrap) .
 300                 Format.journal_read cons