1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# LANGUAGE TupleSections #-}
5 module Hcompta.CLI.Command.GL where
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
25 import System.Environment as Env (getProgName)
26 import System.Exit (exitWith, ExitCode(..))
27 import qualified System.IO as IO
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
56 { ctx_input :: [FilePath]
57 , ctx_filter_transaction :: Filter.Simplified
59 (Filter.Filter_Transaction
61 , ctx_filter_posting :: Filter.Simplified
63 (Filter.Filter_Posting
65 , ctx_filter_gl :: Filter.Simplified
71 , Amount.Sum Amount )))
72 , ctx_reduce_date :: Bool
78 { ctx_filter_gl = mempty
79 , ctx_filter_posting = mempty
80 , ctx_filter_transaction = mempty
82 , ctx_reduce_date = True
87 bin <- Env.getProgName
91 , " [-t TRANSACTION_FILTER]"
92 , " [-p POSTING_FILTER]"
94 , " JOURNAL_FILE [...]"
96 , usageInfo "OPTIONS" options
99 options :: Args.Options Ctx
101 [ Option "g" ["filter-gl"]
102 (ReqArg (\s context ctx -> do
104 liftM (\t -> (<>) (ctx_filter_gl ctx)
105 (Filter.simplify t (Nothing::Maybe ( Account
108 , Amount.Sum Amount )))) $
109 liftIO $ Filter.Read.read Filter.Read.filter_gl s
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
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
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))
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})
156 "use advanced date reducer to speed up filtering"
159 run :: Context.Context -> [String] -> IO ()
160 run context args = do
161 (ctx, inputs) <- Args.parse context usage options (nil, args)
163 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
166 liftIO $ runExceptT $ Ledger.Read.file path
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
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
185 TL.toStrict . W.displayT .
186 W.renderCompact False .
187 toDoc (Context.lang context) in
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
198 write_gl gl (repeat [])
203 -> GL Ledger.Transaction
204 ledger_gl ctx journals =
206 if ctx_reduce_date ctx
207 then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
211 (flip $ Ledger.Journal.fold
212 (\Ledger.Journal{Ledger.journal_transactions=ts} ->
213 flip (Data.Foldable.foldl'
215 case Filter.test (ctx_filter_transaction ctx) t of
219 t{ Ledger.transaction_postings =
221 (Data.Foldable.foldMap
223 Data.Map.foldrWithKey
224 (\u a -> (:) p{Ledger.posting_amounts=Data.Map.singleton u a})
226 (Ledger.posting_amounts p)
230 (\ps -> case Data.List.filter
231 (Filter.test $ ctx_filter_posting ctx) ps of
234 (Ledger.transaction_postings t)
236 ))) $ Compose $ Compose $
237 case Filter.simplified reducer_date of
239 let (ts_reduced, _date_sieve) = Filter.Reduce.map_date reducer ts
248 Lib.TreeMap.map_Maybe_with_Path
249 (\acct expanded_lines ->
250 case Data.Map.mapMaybeWithKey
252 case Data.Foldable.foldMap
254 { GL.gl_line_transaction = _t
255 , GL.gl_line_posting = p
258 if Filter.test (ctx_filter_gl ctx)
261 , Amount.sum $ snd $ Data.Map.elemAt 0 $ Ledger.posting_amounts p
262 , snd . Data.Map.elemAt 0 <$> s
264 then Data.Sequence.singleton line
265 else Data.Sequence.empty
267 m | Data.Sequence.null m -> Nothing
270 (GL.inclusive expanded_lines) of
271 m | Data.Map.null m -> Nothing
277 :: GL Ledger.Transaction
281 flip (Lib.TreeMap.foldr_with_Path
283 flip $ Data.Map.foldrWithKey
285 flip (Data.Foldable.foldr
287 { GL.gl_line_transaction = t
288 , GL.gl_line_posting = p
291 flip (Data.Map.foldrWithKey
293 let ptype = Ledger.Posting_Type_Regular
294 let descr = Ledger.transaction_description t
297 { Table.cell_content = Ledger.Write.account ptype acct
298 , Table.cell_width = Ledger.Write.account_length ptype acct
301 { Table.cell_content = Date.Write.date date
302 , Table.cell_width = Date.Write.date_length date
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)
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)
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)
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)
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)
325 { Table.cell_content = toDoc () descr
326 , Table.cell_width = Text.length descr
330 (Ledger.posting_amounts p)