1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# LANGUAGE TupleSections #-}
5 module Hcompta.CLI.Command.Journal where
7 import Control.Applicative (Const(..))
8 import Control.Monad ({-foldM,-} liftM)
9 import Control.Monad.IO.Class (liftIO)
10 import Control.Monad.Trans.Except (runExceptT)
11 import qualified Data.Either
12 import qualified Data.Foldable
13 import System.Console.GetOpt
17 import Data.Monoid ((<>))
18 import Prelude hiding (foldr)
19 import System.Environment as Env (getProgName)
20 import System.Exit (exitWith, ExitCode(..))
21 import qualified System.IO as IO
23 import qualified Hcompta.CLI.Args as Args
24 import qualified Hcompta.CLI.Context as Context
25 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
26 import qualified Hcompta.CLI.Write as Write
27 import qualified Hcompta.Date as Date
28 import qualified Hcompta.Filter as Filter
29 import qualified Hcompta.Filter.Read as Filter.Read
30 import qualified Hcompta.Filter.Reduce as Filter.Reduce
31 import qualified Hcompta.Format.Ledger as Ledger
32 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
33 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
34 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
35 import qualified Hcompta.Lib.Leijen as W
36 import qualified Hcompta.Journal as Journal
40 { ctx_input :: [FilePath]
42 , ctx_reduce_date :: Bool
43 , ctx_filter_transaction :: Filter.Simplified
45 (Filter.Filter_Transaction
54 , ctx_reduce_date = True
55 , ctx_filter_transaction = mempty
60 bin <- Env.getProgName
63 , " "++bin++" journal"
64 , " [-t TRANSACTION_FILTER]"
65 , " JOURNAL_FILE [...]"
67 , usageInfo "OPTIONS" options
70 options :: Args.Options Ctx
73 (NoArg (\_context _ctx -> do
74 usage >>= IO.hPutStr IO.stderr
75 exitWith ExitSuccess))
77 , Option "i" ["input"]
78 (ReqArg (\s _context ctx -> do
79 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
80 "read data from given file, multiple uses merge the data as would a concatenation do"
82 (OptArg (\arg context ctx -> do
83 ctx_align <- case arg of
84 Nothing -> return $ True
85 Just "yes" -> return $ True
86 Just "no" -> return $ False
87 Just _ -> Write.fatal context $
88 W.text "--align option expects \"yes\", or \"no\" as value"
89 return $ ctx{ctx_align})
92 , Option "" ["reduce-date"]
93 (OptArg (\arg context ctx -> do
94 ctx_reduce_date <- case arg of
95 Nothing -> return $ True
96 Just "yes" -> return $ True
97 Just "no" -> return $ False
98 Just _ -> Write.fatal context $
99 W.text "--reduce-date option expects \"yes\", or \"no\" as value"
100 return $ ctx{ctx_reduce_date})
102 "use advanced date reducer to speed up filtering"
103 , Option "t" ["transaction-filter"]
104 (ReqArg (\s context ctx -> do
105 ctx_filter_transaction <-
106 liftM (\t -> (<>) (ctx_filter_transaction ctx)
107 (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
108 liftIO $ Filter.Read.read Filter.Read.filter_transaction s
110 Left ko -> Write.fatal context $ ko
111 Right ok -> return ok
112 return $ ctx{ctx_filter_transaction}) "FILTER")
113 "filter at transaction level, multiple uses are merged with a logical AND"
116 run :: Context.Context -> [String] -> IO ()
117 run context args = do
118 (ctx, inputs) <- Args.parse context usage options (nil, args)
119 (read_journals, read_bench) <- Date.bench $ do
120 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
123 liftIO $ runExceptT $ Ledger.Read.file
124 (Ledger.Read.context $ Ledger.journal
125 { Ledger.journal_transactions=Const
127 , ctx_filter_transaction ctx
131 Left ko -> return $ Left (path, ko)
132 Right ok -> return $ Right ok
133 >>= return . Data.Either.partitionEithers
134 Write.debug context $ "benchmark: input:" ++ show read_bench
135 case read_journals of
136 (errs@(_:_), _journals) ->
137 (flip mapM_) errs $ \(_path, err) -> do
138 Write.fatal context $ err
140 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
142 if ctx_reduce_date ctx
143 then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
145 Write.debug context $ "filter: transaction: reducer: " ++ show reducer_date
146 style_color <- Write.with_color context IO.stdout
147 let sty = Ledger.Write.Style
148 { Ledger.Write.style_align = ctx_align ctx
149 , Ledger.Write.style_color
151 let journal = ledger_journal ctx journals
152 Ledger.Write.put sty IO.stdout $ do
153 Ledger.Write.transactions journal
157 -> [Ledger.Journal (Const
158 ( Journal.Journal Ledger.Transaction
159 , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Transaction Ledger.Transaction))
163 -> Journal.Journal Ledger.Transaction
164 ledger_journal _ctx journals =
166 (flip $ Ledger.Journal.fold
167 (\Ledger.Journal{Ledger.journal_transactions=Const (j, _)} ->