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