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
9 import Control.Applicative (Const(..))
10 import Control.Monad (liftM)
11 import Control.Monad.IO.Class (liftIO)
12 import Control.Monad.Trans.Except (runExceptT)
13 import qualified Data.Either
14 import qualified Data.Foldable
15 import qualified Data.Map.Strict as Data.Map
16 import Data.Monoid ((<>))
17 import qualified Data.Sequence
18 import qualified Data.Strict.Maybe as Strict
19 import qualified Data.Text as Text
20 import qualified Data.Text.Lazy as TL
21 import Prelude hiding (foldr)
22 import System.Console.GetOpt
27 import System.Environment as Env (getProgName)
28 import System.Exit (exitWith, ExitCode(..))
29 import qualified System.IO as IO
31 import Hcompta.Account (Account)
32 import Hcompta.Amount (Amount)
33 import qualified Hcompta.Amount as Amount
34 import qualified Hcompta.Amount.Write as Amount.Write
35 import qualified Hcompta.CLI.Args as Args
36 import qualified Hcompta.CLI.Context as Context
37 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
38 import qualified Hcompta.CLI.Lang as Lang
39 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
40 import qualified Hcompta.CLI.Write as Write
41 import Hcompta.Date (Date)
42 import qualified Hcompta.Date.Write as Date.Write
43 import qualified Hcompta.Filter as Filter
44 import qualified Hcompta.Filter.Read as Filter.Read
45 import qualified Hcompta.Format.Ledger as Ledger
46 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
47 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
48 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
49 import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
50 import qualified Hcompta.Lib.Leijen as W
51 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
52 import Hcompta.GL (GL(..))
53 import qualified Hcompta.GL as GL
57 { ctx_input :: [FilePath]
58 , ctx_filter_transaction :: Filter.Simplified
60 (Filter.Filter_Transaction
62 , ctx_filter_posting :: Filter.Simplified
64 (Filter.Filter_Posting
66 , ctx_filter_gl :: Filter.Simplified
72 , Amount.Sum Amount )))
73 , ctx_reduce_date :: Bool
79 { ctx_filter_gl = mempty
80 , ctx_filter_posting = mempty
81 , ctx_filter_transaction = mempty
83 , ctx_reduce_date = True
88 bin <- Env.getProgName
92 , " [-t TRANSACTION_FILTER]"
93 , " [-p POSTING_FILTER]"
95 , " JOURNAL_FILE [...]"
97 , usageInfo "OPTIONS" options
100 options :: Args.Options Ctx
102 [ Option "g" ["filter-gl"]
103 (ReqArg (\s context ctx -> do
105 liftM (\t -> (<>) (ctx_filter_gl ctx)
106 (Filter.simplify t (Nothing::Maybe ( Account
109 , Amount.Sum Amount )))) $
110 liftIO $ Filter.Read.read Filter.Read.filter_gl s
112 Left ko -> Write.fatal context $ ko
113 Right ok -> return ok
114 return $ ctx{ctx_filter_gl}) "FILTER")
115 "filter at general ledger level, multiple uses are merged with a logical AND"
116 , Option "p" ["filter-posting"]
117 (ReqArg (\s context ctx -> do
118 ctx_filter_posting <-
119 liftM (\t -> (<>) (ctx_filter_posting ctx)
120 (Filter.simplify t (Nothing::Maybe Ledger.Posting))) $
121 liftIO $ Filter.Read.read Filter.Read.filter_posting s
123 Left ko -> Write.fatal context $ ko
124 Right ok -> return ok
125 return $ ctx{ctx_filter_posting}) "FILTER")
126 "filter at posting level, multiple uses are merged with a logical AND"
127 , Option "t" ["filter-transaction"]
128 (ReqArg (\s context ctx -> do
129 ctx_filter_transaction <-
130 liftM (\t -> (<>) (ctx_filter_transaction ctx)
131 (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
132 liftIO $ Filter.Read.read Filter.Read.filter_transaction s
134 Left ko -> Write.fatal context $ ko
135 Right ok -> return ok
136 return $ ctx{ctx_filter_transaction}) "FILTER")
137 "filter at transaction level, multiple uses are merged with a logical AND"
138 , Option "h" ["help"]
139 (NoArg (\_context _ctx -> do
140 usage >>= IO.hPutStr IO.stderr
141 exitWith ExitSuccess))
143 , Option "i" ["input"]
144 (ReqArg (\s _context ctx -> do
145 return $ ctx{ctx_input=s:ctx_input ctx}) "JOURNAL_FILE")
146 "read data from given file, multiple uses merge the data as would a concatenation do"
147 , Option "" ["reduce-date"]
148 (OptArg (\arg context ctx -> do
149 ctx_reduce_date <- case arg of
150 Nothing -> return $ True
151 Just "yes" -> return $ True
152 Just "no" -> return $ False
153 Just _ -> Write.fatal context $
154 W.text "--reduce-date option expects \"yes\", or \"no\" as value"
155 return $ ctx{ctx_reduce_date})
157 "use advanced date reducer to speed up filtering"
160 run :: Context.Context -> [String] -> IO ()
161 run context args = do
162 (ctx, inputs) <- Args.parse context usage options (nil, args)
164 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
167 liftIO $ runExceptT $ Ledger.Read.file
168 (Ledger.Read.context $ Ledger.journal
169 { Ledger.journal_transactions=Const
171 , ctx_filter_transaction ctx
172 , ctx_filter_posting ctx
176 Left ko -> return $ Left (path, ko)
177 Right ok -> return $ Right ok
178 >>= return . Data.Either.partitionEithers
179 case read_journals of
180 (errs@(_:_), _journals) ->
181 (flip mapM_) errs $ \(_path, err) -> do
182 Write.fatal context $ err
184 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
185 Write.debug context $ "filter: posting: " ++ show (ctx_filter_posting ctx)
186 Write.debug context $ "filter: gl: " ++ show (ctx_filter_gl ctx)
187 let gl = ledger_gl ctx journals
188 style_color <- Write.with_color context IO.stdout
189 W.displayIO IO.stdout $
190 W.renderPretty style_color 1.0 maxBound $ do
193 TL.toStrict . W.displayT .
194 W.renderCompact False .
195 toDoc (Context.lang context) in
197 [ Table.column (title Lang.Message_Account) Table.Align_Left
198 , Table.column (title Lang.Message_Date) Table.Align_Left
199 , Table.column (title Lang.Message_Debit) Table.Align_Right
200 , Table.column (title Lang.Message_Credit) Table.Align_Right
201 , Table.column (title Lang.Message_Running_debit) Table.Align_Right
202 , Table.column (title Lang.Message_Running_credit) Table.Align_Right
203 , Table.column (title Lang.Message_Running_balance) Table.Align_Right
204 , Table.column (title Lang.Message_Description) Table.Align_Left
206 write_gl gl (repeat [])
210 -> [Ledger.Journal (Const
211 ( GL.GL Ledger.Transaction
212 , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Transaction Ledger.Transaction))
213 , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Posting Ledger.Posting))
217 -> GL Ledger.Transaction
218 ledger_gl ctx journals =
221 (flip $ Ledger.Journal.fold
222 (\Ledger.Journal{Ledger.journal_transactions=Const (g, _, _)} ->
226 Lib.TreeMap.map_Maybe_with_Path
227 (\acct expanded_lines ->
228 case Data.Map.mapMaybeWithKey
230 case Data.Foldable.foldMap
232 { GL.gl_line_transaction = _t
233 , GL.gl_line_posting = p
236 if Filter.test (ctx_filter_gl ctx)
239 , Amount.sum $ snd $ Data.Map.elemAt 0 $ Ledger.posting_amounts p
240 , snd . Data.Map.elemAt 0 <$> s
242 then Data.Sequence.singleton line
243 else Data.Sequence.empty
245 m | Data.Sequence.null m -> Nothing
248 (GL.inclusive expanded_lines) of
249 m | Data.Map.null m -> Strict.Nothing
255 :: GL Ledger.Transaction
259 flip (Lib.TreeMap.foldr_with_Path
261 flip $ Data.Map.foldrWithKey
263 flip (Data.Foldable.foldr
265 { GL.gl_line_transaction = t
266 , GL.gl_line_posting = p
269 flip (Data.Map.foldrWithKey
271 let ptype = Ledger.Posting_Type_Regular
272 let descr = Ledger.transaction_description t
275 { Table.cell_content = Ledger.Write.account ptype acct
276 , Table.cell_width = Ledger.Write.account_length ptype acct
279 { Table.cell_content = Date.Write.date date
280 , Table.cell_width = Date.Write.date_length date
283 { Table.cell_content = maybe W.empty Amount.Write.amount (Amount.sumable_positive amt)
284 , Table.cell_width = maybe 0 Amount.Write.amount_length (Amount.sumable_positive amt)
287 { Table.cell_content = maybe W.empty Amount.Write.amount (Amount.sumable_negative amt)
288 , Table.cell_width = maybe 0 Amount.Write.amount_length (Amount.sumable_negative amt)
291 { Table.cell_content = maybe W.empty Amount.Write.amount (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
292 , Table.cell_width = maybe 0 Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
295 { Table.cell_content = maybe W.empty Amount.Write.amount (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
296 , Table.cell_width = maybe 0 Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
299 { Table.cell_content = maybe W.empty Amount.Write.amount (Data.Map.lookup unit $ Amount.sum_balance s)
300 , Table.cell_width = maybe 0 Amount.Write.amount_length (Data.Map.lookup unit $ Amount.sum_balance s)
303 { Table.cell_content = toDoc () descr
304 , Table.cell_width = Text.length descr
308 (Ledger.posting_amounts p)