]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Stats.hs
Refactor hcompta-lib.
[comptalang.git] / 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