+{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.CLI.Command.Stats where
-import Control.Monad (Monad(..), forM_, liftM, mapM)
+import Control.Applicative (Const(..))
+import Control.Arrow ((+++))
+import Control.Monad (Monad(..), liftM, mapM)
import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (runExceptT)
+import Data.Bool (Bool(..))
import Data.Either (Either(..), partitionEithers)
import Data.Foldable (Foldable(..))
+import Data.Function (($), (.), on)
+import Data.Functor ((<$>))
import Data.List ((++))
-import qualified Data.Map.Strict as Data.Map
+import qualified Data.List as List
+import qualified Data.Map.Strict as Map
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..), (<>))
import Data.Text (Text)
import Data.String (String)
-import Prelude (($), (.), Bounded(..), FilePath, IO, Num(..), flip, unlines)
-import Text.Show (Show(..))
+import Prelude (Bounded(..), Num(..), flip, unlines)
import System.Console.GetOpt
( ArgDescr(..)
, OptDescr(..)
import System.Environment as Env (getProgName)
import System.Exit (exitSuccess)
import qualified System.IO as IO
+import System.IO (FilePath, IO)
import qualified Hcompta.Unit as Unit
import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
+import qualified Hcompta.CLI.Env as CLI.Env
+import Hcompta.CLI.Format.JCC ()
+import Hcompta.CLI.Format.Ledger ()
+import Hcompta.CLI.Format (Format(..), Formats)
+import qualified Hcompta.CLI.Format as Format
import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Write as Write
--- import qualified Hcompta.Date as Date
+import qualified Hcompta.Posting as Posting
import qualified Hcompta.Filter as Filter
import qualified Hcompta.Filter.Read as Filter.Read
+import qualified Hcompta.Filter.Amount as Filter.Amount
+import qualified Hcompta.Format.JCC as JCC
import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
-import qualified Hcompta.Format.Ledger.Read as Ledger.Read
import qualified Hcompta.Lib.Interval as Interval
+import qualified Hcompta.Lib.Parsec as R
import qualified Hcompta.Lib.Leijen as W
import qualified Hcompta.Stats as Stats
-data Ctx
- = Ctx
+data Context
+ = Context
{ ctx_input :: [FilePath]
- , ctx_filter_transaction :: Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Transaction
- (Ledger.Chart_With Ledger.Transaction)))
- } deriving (Show)
-
-nil :: Ctx
-nil =
- Ctx
+ , ctx_input_format :: Formats
+ , ctx_filter_transaction :: forall t.
+ ( Filter.Transaction t
+ , Filter.Amount_Quantity
+ (Posting.Posting_Amount
+ (Filter.Transaction_Posting t))
+ ~ Filter.Amount.Quantity
+ ) => Journal_Filter t
+ , ctx_output_format :: Maybe Formats
+ }
+
+context :: Context
+context =
+ Context
{ ctx_input = []
- , ctx_filter_transaction = mempty
+ , ctx_input_format = mempty
+ , ctx_filter_transaction = Filter.Simplified $ Right True
+ , ctx_output_format = Nothing
}
usage :: C.Context -> IO String
, usageInfo (C.translate c Lang.Section_Options) (options c)
]
-options :: C.Context -> Args.Options Ctx
+options :: C.Context -> Args.Options Context
options c =
[ Option "h" ["help"]
(NoArg (\_ctx -> do
return $ ctx{ctx_input=s:ctx_input ctx}) $
C.translate c Lang.Type_File_Journal) $
C.translate c Lang.Help_Option_Input
- , Option "t" ["transaction-filter"]
+ , Option "if" ["input-format"]
+ (OptArg (\arg ctx -> do
+ ctx_input_format <- case arg of
+ Nothing -> return $ Format_JCC ()
+ Just "jcc" -> return $ Format_JCC ()
+ Just "ledger" -> return $ Format_Ledger ()
+ Just _ -> Write.fatal c $
+ W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
+ return $ ctx{ctx_input_format})
+ "[jcc|ledger]")
+ "input format"
+ , Option "of" ["output-format"]
+ (OptArg (\arg ctx -> do
+ ctx_output_format <- case arg of
+ Nothing -> return $ Just $ Format_JCC ()
+ Just "jcc" -> return $ Just $ Format_JCC ()
+ Just "ledger" -> return $ Just $ Format_Ledger ()
+ Just _ -> Write.fatal c $
+ W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
+ return $ ctx{ctx_output_format})
+ "[jcc|ledger]")
+ "input format"
+ , Option "t" ["filter-transaction"]
(ReqArg (\s ctx -> do
- ctx_filter_transaction <-
- liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
- liftIO $ Filter.Read.read Filter.Read.filter_transaction s
- >>= \f -> case f of
- Left ko -> Write.fatal c $ ko
- Right ok -> do
- Write.debug c $ "filter: transaction: " ++ show ok
- return ok
- return $ ctx{ctx_filter_transaction}) $
+ filter <-
+ R.runParserT_with_Error
+ Filter.Read.filter_transaction
+ Filter.Read.context "" s
+ case filter of
+ Left ko -> Write.fatal c ko
+ Right flt ->
+ return $
+ ctx{ctx_filter_transaction =
+ Filter.and (ctx_filter_transaction ctx) $
+ (Filter.simplify $
+ Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
+ }) $
C.translate c Lang.Type_Filter_Transaction) $
C.translate c Lang.Help_Option_Filter_Transaction
]
run :: C.Context -> [String] -> IO ()
-run context args = do
- (ctx, inputs) <- Args.parse context usage options (nil, args)
- read_journals <-
- liftM Data.Either.partitionEithers $ do
- CLI.Ledger.paths context $ ctx_input ctx ++ inputs
- >>= do
- mapM $ \path -> do
- liftIO $ runExceptT $ Ledger.Read.file
- (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
- path
- >>= \x -> case x of
- Left ko -> return $ Left (path, ko)
- Right ok -> return $ Right ok
- case read_journals of
- (errs@(_:_), _journals) ->
- forM_ errs $ \(_path, err) -> do
- Write.fatal context $ err
- ([], journals) -> do
- Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
- let (files, stats) = ledger_stats ctx journals
- style_color <- Write.with_color context IO.stdout
- W.displayIO IO.stdout $ do
- W.renderPretty style_color 1.0 maxBound $ do
- doc_stats context ctx (files, stats)
-
-ledger_stats
- :: Ctx
- -> [ Ledger.Journal (Stats.Stats (Ledger.Chart_With Ledger.Transaction)) ]
- -> ([FilePath], Stats.Stats (Ledger.Chart_With Ledger.Transaction))
-ledger_stats _ctx =
- Data.Foldable.foldl'
- (flip (\j ->
- flip mappend $
- Ledger.Journal.fold
- (\Ledger.Journal
- { Ledger.journal_sections=s
- , Ledger.journal_file=f
- } -> mappend ([f], s)
- ) j mempty
- ))
- mempty
-
-doc_stats
- :: C.Context
- -> Ctx
- -> ([FilePath], Stats.Stats (Ledger.Chart_With Ledger.Transaction))
- -> W.Doc
-doc_stats c _ctx (files, stats) =
- let lang = C.lang c in
- h Lang.Header_Accounts <>
- (W.toDoc () $ Data.Map.size $ Stats.stats_accounts stats) <>
- (let depth = Stats.stats_accounts_depths stats in
- W.line <> h Lang.Header_Accounts_Depth <>
- W.toDoc () (Interval.limit $ Interval.low depth) <>
- (W.bold $ W.dullyellow "..") <>
- W.toDoc () (Interval.limit $ Interval.high depth)) <>
- W.line <>
- h Lang.Header_Transactions <>
- (W.toDoc () $ Stats.stats_transactions stats) <>
- (case Stats.stats_transactions_span stats of
- Nothing -> W.empty
- Just date ->
- W.line <> h Lang.Header_Transactions_Date <>
- W.toDoc lang (Interval.limit $ Interval.low date) <>
+run c args = do
+ (ctx, inputs) <- Args.parse c usage options (context, args)
+ input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
+ read_journals <- mapM (liftIO . journal_read ctx) input_paths
+ case partitionEithers read_journals of
+ (errs@(_:_), _journals) -> Write.fatals c errs
+ ([], (journals::[Forall_Stats])) -> do
+ with_color <- Write.with_color c IO.stdout
+ W.displayIO IO.stdout $
+ W.renderPretty with_color 1.0 maxBound $
+ stats_write c ctx $
+ (Const::x -> Const x ()) $
+ mconcat $ Format.journal_flatten <$>
+ case ctx_output_format ctx of
+ Nothing -> journals
+ Just f -> Format.journal_empty f:journals
+
+-- * Type 'Format_Journal'
+
+type Format_Journal
+ = Format
+ ( JCC.Journal Stats_JCC)
+ (Ledger.Journal Stats_Ledger)
+
+type Stats_JCC = Stats.Stats ( JCC.Charted JCC.Transaction)
+type Stats_Ledger = Stats.Stats (Ledger.Charted Ledger.Transaction)
+
+-- * Class 'Stats'
+
+class Stats j m where
+ stats_write :: C.Context -> Context -> j m -> W.Doc
+instance
+ ( Stats.Transaction t
+ , t ~ (Format.Journal_Charted j) (Format.Journal_Transaction j)
+ , Stats.Posting_Unit (Stats.Transaction_Posting t) ~ Format.Journal_Unit j
+ , Unit.Unit (Format.Journal_Unit j)
+ , Format.Journal_Content j
+ , Format.Journal_Files j
+ ) => Stats j (Stats.Stats t) where
+ stats_write c _ctx j =
+ let stats = Format.journal_content j in
+ render
+ [ (Lang.Header_Accounts,) . W.toDoc () $
+ Map.size $ Stats.stats_accounts stats
+ , (Lang.Header_Accounts_Depth,) $
+ let depth = Stats.stats_accounts_depths stats in
+ W.toDoc () (Interval.limit $ Interval.low depth) <>
(W.bold $ W.dullyellow "..") <>
- W.toDoc lang (Interval.limit $ Interval.high date)) <>
- W.line <>
- h Lang.Header_Units <>
- (W.toDoc () (Data.Map.size $
- Data.Map.delete Unit.unit_empty $
- Stats.stats_units stats)) <> W.line <>
- h Lang.Header_Journals <>
- W.toDoc () (length $ files) <> W.line <>
- h Lang.Header_Tags <>
- ((W.toDoc () (Data.Foldable.foldr
- (flip $ Data.Foldable.foldr (+)) 0 $
- Stats.stats_tags stats)) <>
- W.line <>
- h Lang.Header_Tags_Distinct <>
- W.toDoc () (Data.Map.size $ Stats.stats_tags stats)) <>
- W.line
- where
- h :: Lang.Translate t [Text] => t -> W.Doc
- h t =
- foldMap
- (\s -> (W.bold $ W.dullblack (W.toDoc () s)) <> (W.bold $ W.dullyellow ":"))
- (C.translate c t::[Text])
+ W.toDoc () (Interval.limit $ Interval.high depth)
+ , (Lang.Header_Transactions,) . W.toDoc () $
+ Stats.stats_transactions stats
+ , (Lang.Header_Transactions_Date,) $
+ case Stats.stats_transactions_span stats of
+ Nothing -> W.empty
+ Just date ->
+ W.toDoc () (Interval.limit $ Interval.low date) <>
+ (W.bold $ W.dullyellow "..") <>
+ W.toDoc () (Interval.limit $ Interval.high date)
+ , (Lang.Header_Units,) . W.toDoc () $
+ Map.size $ Map.delete Unit.unit_empty $
+ Stats.stats_units stats
+ , (Lang.Header_Journals,) . W.toDoc () $
+ List.length $ Format.journal_files j
+ , (Lang.Header_Tags,) . W.toDoc () $
+ W.toDoc () (foldr (flip $ foldr (+)) 0 $
+ Stats.stats_tags stats)
+ , (Lang.Header_Tags_Distinct,) . W.toDoc () $
+ Map.size $ Stats.stats_tags stats
+ ]
+ where
+ render :: Lang.Translate h [Text] => [(h, W.Doc)] -> W.Doc
+ render =
+ foldMap $ \(h, x) ->
+ W.hcat
+ [ W.bold $ flip foldMap
+ (C.translate c h::[Text]) $ \s ->
+ W.dullblack (W.toDoc () s) <> W.dullyellow ":"
+ , W.toDoc () x
+ , W.line ]
+
+instance Format.Journal (JCC.Journal Stats_JCC) where
+ type Journal_Format (JCC.Journal Stats_JCC) = Format_Journal
+ journal_format = Format_JCC
+
+instance Format.Journal (Ledger.Journal Stats_Ledger) where
+ type Journal_Format (Ledger.Journal Stats_Ledger) = Format_Journal
+ journal_format = Format_Ledger
+
+-- * Type 'Forall_Stats'
+
+data Forall_Stats
+ = forall j m. ( Stats j m
+ , Format.Journal (j m)
+ , Format.Journal_Content j
+ , Format.Journal_Files j
+ , Format.Journal_Read j
+ , Format.Journal_Monoid (j m)
+ , Format.Journal_Format (j m) ~ Format_Journal )
+ => Forall_Stats (j m)
+
+instance Format.Journal Forall_Stats where
+ type Journal_Format Forall_Stats = Format_Journal
+ journal_format (Forall_Stats j) = Format.journal_format j
+instance Format.Journal_Empty Forall_Stats where
+ journal_empty f =
+ case f of
+ Format_JCC () -> Forall_Stats (mempty::JCC.Journal Stats_JCC)
+ Format_Ledger () -> Forall_Stats (mempty::Ledger.Journal Stats_Ledger)
+
+instance Format.Journal_Monoid Forall_Stats where
+ journal_flatten (Forall_Stats j) = Forall_Stats $ Format.journal_flatten j
+ journal_fold f (Forall_Stats j) = Format.journal_fold (f . Forall_Stats) j
+instance Stats (Const Forall_Stats) () where
+ stats_write c ctx (Const (Forall_Stats j)) = stats_write c ctx j
+instance Monoid Forall_Stats where
+ mempty = Forall_Stats (mempty::JCC.Journal Stats_JCC)
+ mappend x y =
+ case (mappend `on` Format.journal_format) x y of
+ Format_JCC j -> Forall_Stats j
+ Format_Ledger j -> Forall_Stats j
+ mconcat js =
+ case js of
+ [] -> mempty
+ j:jn -> foldl' mappend j jn
+
+type Journal_Filter transaction
+ = Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_Transaction transaction))
+type Journal_Read_Cons txn
+ = txn -> Filter.Filtered (Journal_Filter txn) txn
+
+journal_read
+ :: Context -> FilePath
+ -> IO (Either (Format.Message W.Doc) Forall_Stats)
+journal_read ctx =
+ case ctx_input_format ctx of
+ Format_JCC () ->
+ let wrap (j::JCC.Journal Stats_JCC) = Forall_Stats j in
+ let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
+ = Filter.Filtered (ctx_filter_transaction ctx) in
+ liftM ((+++) Format.Message wrap) .
+ Format.journal_read cons
+ Format_Ledger () ->
+ let wrap (j::Ledger.Journal Stats_Ledger) = Forall_Stats j in
+ let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
+ = Filter.Filtered (ctx_filter_transaction ctx) in
+ liftM ((+++) Format.Message wrap) .
+ Format.journal_read cons
sourcephile / git / comptalang.git / blobdiff