]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/GL.hs
Renommage : Filter.Test_* -> Filter.Filter_*.
[comptalang.git] / cli / Hcompta / CLI / Command / GL.hs
1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# LANGUAGE TupleSections #-}
5 module Hcompta.CLI.Command.GL where
6
7 import Control.Monad (liftM)
8 import Control.Monad.IO.Class (liftIO)
9 import Control.Monad.Trans.Except (runExceptT)
10 import qualified Data.Either
11 import qualified Data.Foldable
12 import Data.Functor.Compose (Compose(..))
13 import qualified Data.List
14 import qualified Data.Map.Strict as Data.Map
15 import Data.Monoid ((<>))
16 import qualified Data.Sequence
17 import qualified Data.Text as Text
18 import qualified Data.Text.Lazy as TL
19 import Prelude hiding (foldr)
20 import System.Console.GetOpt
21 ( ArgDescr(..)
22 , OptDescr(..)
23 , usageInfo
24 )
25 import System.Environment as Env (getProgName)
26 import System.Exit (exitWith, ExitCode(..))
27 import qualified System.IO as IO
28
29 import Hcompta.Account (Account)
30 import Hcompta.Amount (Amount)
31 import qualified Hcompta.Amount as Amount
32 import qualified Hcompta.Amount.Write as Amount.Write
33 import qualified Hcompta.CLI.Args as Args
34 import qualified Hcompta.CLI.Context as Context
35 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
36 import qualified Hcompta.CLI.Lang as Lang
37 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
38 import qualified Hcompta.CLI.Write as Write
39 import Hcompta.Date (Date)
40 import qualified Hcompta.Date.Write as Date.Write
41 import qualified Hcompta.Filter as Filter
42 import qualified Hcompta.Filter.Read as Filter.Read
43 import qualified Hcompta.Filter.Reduce as Filter.Reduce
44 import qualified Hcompta.Format.Ledger as Ledger
45 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
46 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
47 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
48 import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
49 import qualified Hcompta.Lib.Leijen as W
50 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
51 import Hcompta.GL (GL(..))
52 import qualified Hcompta.GL as GL
53
54 data Ctx
55 = Ctx
56 { ctx_input :: [FilePath]
57 , ctx_filter_transaction :: Filter.Simplified
58 (Filter.Filter_Bool
59 (Filter.Filter_Transaction
60 Ledger.Transaction))
61 , ctx_filter_posting :: Filter.Simplified
62 (Filter.Filter_Bool
63 (Filter.Filter_Posting
64 Ledger.Posting))
65 , ctx_filter_gl :: Filter.Simplified
66 (Filter.Filter_Bool
67 (Filter.Filter_GL
68 ( Account
69 , Date
70 , Amount.Sum Amount
71 , Amount.Sum Amount )))
72 , ctx_reduce_date :: Bool
73 } deriving (Show)
74
75 nil :: Ctx
76 nil =
77 Ctx
78 { ctx_filter_gl = mempty
79 , ctx_filter_posting = mempty
80 , ctx_filter_transaction = mempty
81 , ctx_input = []
82 , ctx_reduce_date = True
83 }
84
85 usage :: IO String
86 usage = do
87 bin <- Env.getProgName
88 return $ unlines $
89 [ "SYNTAX "
90 , " "++bin++" gl"
91 , " [-t TRANSACTION_FILTER]"
92 , " [-p POSTING_FILTER]"
93 , " [-g GL_FILTER]"
94 , " JOURNAL_FILE [...]"
95 , ""
96 , usageInfo "OPTIONS" options
97 ]
98
99 options :: Args.Options Ctx
100 options =
101 [ Option "g" ["filter-gl"]
102 (ReqArg (\s context ctx -> do
103 ctx_filter_gl <-
104 liftM (\t -> (<>) (ctx_filter_gl ctx)
105 (Filter.simplify t (Nothing::Maybe ( Account
106 , Date
107 , Amount.Sum Amount
108 , Amount.Sum Amount )))) $
109 liftIO $ Filter.Read.read Filter.Read.filter_gl s
110 >>= \f -> case f of
111 Left ko -> Write.fatal context $ ko
112 Right ok -> return ok
113 return $ ctx{ctx_filter_gl}) "FILTER")
114 "filter at general ledger level, multiple uses are merged with a logical AND"
115 , Option "p" ["filter-posting"]
116 (ReqArg (\s context ctx -> do
117 ctx_filter_posting <-
118 liftM (\t -> (<>) (ctx_filter_posting ctx)
119 (Filter.simplify t (Nothing::Maybe Ledger.Posting))) $
120 liftIO $ Filter.Read.read Filter.Read.filter_posting s
121 >>= \f -> case f of
122 Left ko -> Write.fatal context $ ko
123 Right ok -> return ok
124 return $ ctx{ctx_filter_posting}) "FILTER")
125 "filter at posting level, multiple uses are merged with a logical AND"
126 , Option "t" ["filter-transaction"]
127 (ReqArg (\s context ctx -> do
128 ctx_filter_transaction <-
129 liftM (\t -> (<>) (ctx_filter_transaction ctx)
130 (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
131 liftIO $ Filter.Read.read Filter.Read.filter_transaction s
132 >>= \f -> case f of
133 Left ko -> Write.fatal context $ ko
134 Right ok -> return ok
135 return $ ctx{ctx_filter_transaction}) "FILTER")
136 "filter at transaction level, multiple uses are merged with a logical AND"
137 , Option "h" ["help"]
138 (NoArg (\_context _ctx -> do
139 usage >>= IO.hPutStr IO.stderr
140 exitWith ExitSuccess))
141 "show this help"
142 , Option "i" ["input"]
143 (ReqArg (\s _context ctx -> do
144 return $ ctx{ctx_input=s:ctx_input ctx}) "JOURNAL_FILE")
145 "read data from given file, multiple uses merge the data as would a concatenation do"
146 , Option "" ["reduce-date"]
147 (OptArg (\arg context ctx -> do
148 ctx_reduce_date <- case arg of
149 Nothing -> return $ True
150 Just "yes" -> return $ True
151 Just "no" -> return $ False
152 Just _ -> Write.fatal context $
153 W.text "--reduce-date option expects \"yes\", or \"no\" as value"
154 return $ ctx{ctx_reduce_date})
155 "[yes|no]")
156 "use advanced date reducer to speed up filtering"
157 ]
158
159 run :: Context.Context -> [String] -> IO ()
160 run context args = do
161 (ctx, inputs) <- Args.parse context usage options (nil, args)
162 read_journals <- do
163 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
164 >>= do
165 mapM $ \path -> do
166 liftIO $ runExceptT $ Ledger.Read.file path
167 >>= \x -> case x of
168 Left ko -> return $ Left (path, ko)
169 Right ok -> return $ Right ok
170 >>= return . Data.Either.partitionEithers
171 case read_journals of
172 (errs@(_:_), _journals) ->
173 (flip mapM_) errs $ \(_path, err) -> do
174 Write.fatal context $ err
175 ([], journals) -> do
176 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
177 Write.debug context $ "filter: posting: " ++ show (ctx_filter_posting ctx)
178 Write.debug context $ "filter: gl: " ++ show (ctx_filter_gl ctx)
179 let gl = ledger_gl ctx journals
180 style_color <- Write.with_color context IO.stdout
181 W.displayIO IO.stdout $
182 W.renderPretty style_color 1.0 maxBound $ do
183 toDoc () $
184 let title =
185 TL.toStrict . W.displayT .
186 W.renderCompact False .
187 toDoc (Context.lang context) in
188 zipWith id
189 [ Table.column (title Lang.Message_Account) Table.Align_Left
190 , Table.column (title Lang.Message_Date) Table.Align_Left
191 , Table.column (title Lang.Message_Debit) Table.Align_Right
192 , Table.column (title Lang.Message_Credit) Table.Align_Right
193 , Table.column (title Lang.Message_Running_debit) Table.Align_Right
194 , Table.column (title Lang.Message_Running_credit) Table.Align_Right
195 , Table.column (title Lang.Message_Running_balance) Table.Align_Right
196 , Table.column (title Lang.Message_Description) Table.Align_Left
197 ] $
198 write_gl gl (repeat [])
199
200 ledger_gl
201 :: Ctx
202 -> [Ledger.Journal]
203 -> GL Ledger.Transaction
204 ledger_gl ctx journals =
205 let reducer_date =
206 if ctx_reduce_date ctx
207 then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
208 else mempty in
209 let gl =
210 Data.Foldable.foldl'
211 (flip $ Ledger.Journal.fold
212 (\Ledger.Journal{Ledger.journal_transactions=ts} ->
213 flip (Data.Foldable.foldl'
214 (flip $ (\t ->
215 case Filter.test (ctx_filter_transaction ctx) t of
216 False -> id
217 True ->
218 GL.general_ledger
219 t{ Ledger.transaction_postings =
220 Data.Map.map
221 (Data.Foldable.foldMap
222 (\p ->
223 Data.Map.foldrWithKey
224 (\u a -> (:) p{Ledger.posting_amounts=Data.Map.singleton u a})
225 []
226 (Ledger.posting_amounts p)
227 )
228 ) $
229 Data.Map.mapMaybe
230 (\ps -> case Data.List.filter
231 (Filter.test $ ctx_filter_posting ctx) ps of
232 [] -> Nothing
233 x -> Just x)
234 (Ledger.transaction_postings t)
235 }
236 ))) $ Compose $ Compose $
237 case Filter.simplified reducer_date of
238 Left reducer -> do
239 let (ts_reduced, _date_sieve) = Filter.Reduce.map_date reducer ts
240 ts_reduced
241 Right True -> ts:[]
242 Right False -> []
243 )
244 )
245 GL.nil
246 journals in
247 GL.GL $
248 Lib.TreeMap.map_Maybe_with_Path
249 (\acct expanded_lines ->
250 case Data.Map.mapMaybeWithKey
251 (\date seq_lines ->
252 case Data.Foldable.foldMap
253 (\line@GL.GL_Line
254 { GL.gl_line_transaction = _t
255 , GL.gl_line_posting = p
256 , GL.gl_line_sum = s
257 } ->
258 if Filter.test (ctx_filter_gl ctx)
259 ( acct
260 , date
261 , Amount.sum $ snd $ Data.Map.elemAt 0 $ Ledger.posting_amounts p
262 , snd . Data.Map.elemAt 0 <$> s
263 )
264 then Data.Sequence.singleton line
265 else Data.Sequence.empty
266 ) seq_lines of
267 m | Data.Sequence.null m -> Nothing
268 m -> Just m
269 )
270 (GL.inclusive expanded_lines) of
271 m | Data.Map.null m -> Nothing
272 m -> Just m
273 ) $
274 GL.expanded gl
275
276 write_gl
277 :: GL Ledger.Transaction
278 -> [[Table.Cell]]
279 -> [[Table.Cell]]
280 write_gl (GL gl) =
281 flip (Lib.TreeMap.foldr_with_Path
282 (\acct ->
283 flip $ Data.Map.foldrWithKey
284 (\date ->
285 flip (Data.Foldable.foldr
286 (\GL.GL_Line
287 { GL.gl_line_transaction = t
288 , GL.gl_line_posting = p
289 , GL.gl_line_sum = s
290 } ->
291 flip (Data.Map.foldrWithKey
292 (\unit amt -> do
293 let ptype = Ledger.Posting_Type_Regular
294 let descr = Ledger.transaction_description t
295 zipWith (:)
296 [ Table.cell
297 { Table.cell_content = Ledger.Write.account ptype acct
298 , Table.cell_width = Ledger.Write.account_length ptype acct
299 }
300 , Table.cell
301 { Table.cell_content = Date.Write.date date
302 , Table.cell_width = Date.Write.date_length date
303 }
304 , Table.cell
305 { Table.cell_content = maybe W.empty Amount.Write.amount (Amount.sumable_positive amt)
306 , Table.cell_width = maybe 0 Amount.Write.amount_length (Amount.sumable_positive amt)
307 }
308 , Table.cell
309 { Table.cell_content = maybe W.empty Amount.Write.amount (Amount.sumable_negative amt)
310 , Table.cell_width = maybe 0 Amount.Write.amount_length (Amount.sumable_negative amt)
311 }
312 , Table.cell
313 { Table.cell_content = maybe W.empty Amount.Write.amount (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
314 , Table.cell_width = maybe 0 Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
315 }
316 , Table.cell
317 { Table.cell_content = maybe W.empty Amount.Write.amount (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
318 , Table.cell_width = maybe 0 Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
319 }
320 , Table.cell
321 { Table.cell_content = maybe W.empty Amount.Write.amount (Data.Map.lookup unit $ Amount.sum_balance s)
322 , Table.cell_width = maybe 0 Amount.Write.amount_length (Data.Map.lookup unit $ Amount.sum_balance s)
323 }
324 , Table.cell
325 { Table.cell_content = toDoc () descr
326 , Table.cell_width = Text.length descr
327 }
328 ]
329 ))
330 (Ledger.posting_amounts p)
331 ))
332 )
333 ))
334 gl