]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Stats.hs
Correction : rétro support de GHC 7.6.3 (Debian/jessie).
[comptalang.git] / 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 ((++), length)
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])