]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Journal.hs
Refactor hcompta-lib.
[comptalang.git] / cli / Hcompta / CLI / Command / Journal.hs
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE ExistentialQuantification #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE NamedFieldPuns #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE Rank2Types #-}
9 {-# LANGUAGE ScopedTypeVariables #-}
10 {-# LANGUAGE TupleSections #-}
11 {-# LANGUAGE TypeFamilies #-}
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
13 module Hcompta.CLI.Command.Journal where
14
15 import Control.Arrow ((+++))
16 import Control.Monad (Monad(..), liftM, mapM)
17 import Control.Monad.IO.Class (liftIO)
18 import Data.Bool
19 import Data.Either (Either(..), partitionEithers)
20 import Data.Foldable (Foldable(..))
21 import Data.Function (($), (.), on)
22 import Data.Functor (Functor(..), (<$>))
23 import Data.List ((++))
24 import Data.Maybe (Maybe(..))
25 import Data.Monoid (Monoid(..))
26 import Data.String (String)
27 import Prelude (Bounded(..), unlines)
28 import System.Console.GetOpt
29 ( ArgDescr(..)
30 , OptDescr(..)
31 , usageInfo )
32 import System.Environment as Env (getProgName)
33 import System.Exit (exitSuccess)
34 import qualified System.IO as IO
35 import System.IO (FilePath, IO)
36
37 import qualified Hcompta.CLI.Args as Args
38 import qualified Hcompta.CLI.Context as C
39 import qualified Hcompta.CLI.Env as CLI.Env
40 import qualified Hcompta.CLI.Format as Format
41 import Hcompta.CLI.Format.JCC ()
42 import Hcompta.CLI.Format.Ledger ()
43 import Hcompta.CLI.Format (Format(..), Formats)
44 import qualified Hcompta.CLI.Lang as Lang
45 import qualified Hcompta.CLI.Write as Write
46 import qualified Hcompta.Chart as Chart
47 import qualified Hcompta.Posting as Posting
48 import qualified Hcompta.Filter as Filter
49 import qualified Hcompta.Filter.Amount as Filter.Amount
50 import qualified Hcompta.Filter.Read as Filter.Read
51 import qualified Hcompta.Format.JCC as JCC
52 import qualified Hcompta.Format.JCC.Write as JCC.Write
53 import qualified Hcompta.Format.Ledger as Ledger
54 import qualified Hcompta.Format.Ledger.Write as Ledger
55 import qualified Hcompta.Journal as Journal
56 -- import Hcompta.Lib.Consable (Consable(..))
57 import qualified Hcompta.Lib.Leijen as W
58 import qualified Hcompta.Lib.Parsec as R
59
60 data Context
61 = Context
62 { ctx_input :: [FilePath]
63 , ctx_input_format :: Formats
64 , ctx_output :: [(Write.Mode, FilePath)]
65 , ctx_output_format :: Maybe Formats
66 , ctx_align :: Bool
67 , ctx_reduce_date :: Bool
68 , ctx_filter_transaction :: forall t.
69 ( Filter.Transaction t
70 , Filter.Amount_Quantity
71 (Posting.Posting_Amount
72 (Filter.Transaction_Posting t))
73 ~ Filter.Amount.Quantity
74 ) => Journal_Filter t
75 }
76
77 context :: Context
78 context =
79 Context
80 { ctx_input = []
81 , ctx_input_format = mempty
82 , ctx_output = []
83 , ctx_output_format = Nothing
84 , ctx_align = True
85 , ctx_reduce_date = True
86 , ctx_filter_transaction = Filter.Simplified $ Right True
87 }
88
89 usage :: C.Context -> IO String
90 usage c = do
91 bin <- Env.getProgName
92 return $ unlines $
93 [ C.translate c Lang.Section_Description
94 , " "++C.translate c Lang.Help_Command_Journal
95 , ""
96 , C.translate c Lang.Section_Syntax
97 , " "++bin++" journal ["++C.translate c Lang.Type_Option++"] [...]"++
98 " ["++C.translate c Lang.Type_File_Journal++"] [...]"
99 , ""
100 , usageInfo (C.translate c Lang.Section_Options) (options c)
101 ]
102
103 options :: C.Context -> Args.Options Context
104 options c =
105 [ Option "h" ["help"]
106 (NoArg (\_ctx -> do
107 usage c >>= IO.hPutStr IO.stderr
108 exitSuccess)) $
109 C.translate c Lang.Help_Option_Help
110 , Option "i" ["input"]
111 (ReqArg (\s ctx -> do
112 return $ ctx{ctx_input=s:ctx_input ctx}) $
113 C.translate c Lang.Type_File_Journal) $
114 C.translate c Lang.Help_Option_Input
115 , Option "if" ["input-format"]
116 (OptArg (\arg ctx -> do
117 ctx_input_format <- case arg of
118 Nothing -> return $ Format_JCC ()
119 Just "jcc" -> return $ Format_JCC ()
120 Just "ledger" -> return $ Format_Ledger ()
121 Just _ -> Write.fatal c $
122 W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
123 return $ ctx{ctx_input_format})
124 "[jcc|ledger]")
125 "input format"
126 , Option "o" ["output"]
127 (ReqArg (\s ctx -> do
128 return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
129 C.translate c Lang.Type_File) $
130 C.translate c Lang.Help_Option_Output
131 , Option "of" ["output-format"]
132 (OptArg (\arg ctx -> do
133 ctx_output_format <- case arg of
134 Nothing -> return $ Just $ Format_JCC ()
135 Just "jcc" -> return $ Just $ Format_JCC ()
136 Just "ledger" -> return $ Just $ Format_Ledger ()
137 Just _ -> Write.fatal c $
138 W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
139 return $ ctx{ctx_output_format})
140 "[jcc|ledger]")
141 "input format"
142 , Option "O" ["overwrite"]
143 (ReqArg (\s ctx -> do
144 return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
145 C.translate c Lang.Type_File) $
146 C.translate c Lang.Help_Option_Overwrite
147 , Option "" ["align"]
148 (OptArg (\arg ctx -> do
149 ctx_align <- case arg of
150 Nothing -> return $ True
151 Just "yes" -> return $ True
152 Just "no" -> return $ False
153 Just _ -> Write.fatal c $
154 W.text "--align option expects \"yes\", or \"no\" as value"
155 return $ ctx{ctx_align})
156 "[yes|no]")
157 "align output"
158 {- NOTE: not used so far.
159 , Option "" ["reduce-date"]
160 (OptArg (\arg ctx -> do
161 ctx_reduce_date <- case arg of
162 Nothing -> return $ True
163 Just "yes" -> return $ True
164 Just "no" -> return $ False
165 Just _ -> Write.fatal c $
166 W.text "--reduce-date option expects \"yes\", or \"no\" as value"
167 return $ ctx{ctx_reduce_date})
168 "[yes|no]")
169 "use advanced date reducer to speed up filtering"
170 -}
171 , Option "t" ["filter-transaction"]
172 (ReqArg (\s ctx -> do
173 filter <-
174 R.runParserT_with_Error
175 Filter.Read.filter_transaction
176 Filter.Read.context "" s
177 case filter of
178 Left ko -> Write.fatal c ko
179 Right flt ->
180 return $
181 ctx{ctx_filter_transaction =
182 Filter.and (ctx_filter_transaction ctx) $
183 (Filter.simplify $
184 Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
185 }) $
186 C.translate c Lang.Type_Filter_Transaction) $
187 C.translate c Lang.Help_Option_Filter_Transaction
188 ]
189
190 run :: C.Context -> [String] -> IO ()
191 run c args = do
192 (ctx, inputs) <- Args.parse c usage options (context, args)
193 input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
194 read_journals <- mapM (liftIO . journal_read ctx) input_paths
195 case partitionEithers read_journals of
196 (errs@(_:_), _journals) -> Write.fatals c errs
197 ([], (journals::[Forall_Journal])) -> do
198 with_color <- Write.with_color c IO.stdout
199 W.displayIO IO.stdout $
200 W.renderPretty with_color 1.0 maxBound $
201 journal_write $ mconcat $
202 Format.journal_flatten <$>
203 case ctx_output_format ctx of
204 Nothing -> journals
205 Just f -> Format.journal_empty f:journals
206
207 -- * Type 'Format_Journal'
208
209 type Format_Journal
210 = Format
211 ( JCC.Journal Journal_JCC)
212 (Ledger.Journal Journal_Ledger)
213
214 type Journal_JCC = Journal.Journal ( JCC.Charted JCC.Transaction)
215 type Journal_Ledger = Journal.Journal (Ledger.Charted Ledger.Transaction)
216
217 -- * Class 'Journal'
218
219 class Journal j where
220 journal_write :: j -> W.Doc
221
222 instance Format.Journal (JCC.Journal Journal_JCC) where
223 type Journal_Format (JCC.Journal Journal_JCC) = Format_Journal
224 journal_format = Format_JCC
225 instance Journal (JCC.Journal Journal_JCC) where
226 journal_write j =
227 JCC.Write.transactions (JCC.journal_amount_styles j) $
228 fmap Chart.charted $
229 JCC.journal_content j
230
231 instance Format.Journal (Ledger.Journal Journal_Ledger) where
232 type Journal_Format (Ledger.Journal Journal_Ledger) = Format_Journal
233 journal_format = Format_Ledger
234 instance Journal (Ledger.Journal Journal_Ledger) where
235 journal_write j =
236 Ledger.write_transactions (Ledger.journal_amount_styles j) $
237 fmap Chart.charted $
238 Ledger.journal_content j
239
240 -- * Type 'Forall_Journal'
241
242 data Forall_Journal
243 = forall j m. ( Journal (j m)
244 , Format.Journal (j m)
245 , Format.Journal_Read j
246 , Format.Journal_Monoid (j m)
247 , Format.Journal_Format (j m) ~ Format_Journal )
248 => Forall_Journal (j m)
249
250 instance Format.Journal Forall_Journal where
251 type Journal_Format Forall_Journal = Format_Journal
252 journal_format (Forall_Journal j) = Format.journal_format j
253 instance Format.Journal_Empty Forall_Journal where
254 journal_empty f =
255 case f of
256 Format_JCC () -> Forall_Journal (mempty::JCC.Journal Journal_JCC)
257 Format_Ledger () -> Forall_Journal (mempty::Ledger.Journal Journal_Ledger)
258
259 instance Format.Journal_Monoid Forall_Journal where
260 journal_flatten (Forall_Journal j) = Forall_Journal $ Format.journal_flatten j
261 journal_fold f (Forall_Journal j) = Format.journal_fold (f . Forall_Journal) j
262 instance Journal Forall_Journal where
263 journal_write (Forall_Journal j) = journal_write j
264 instance Monoid Forall_Journal where
265 mempty = Forall_Journal (mempty::JCC.Journal Journal_JCC)
266 mappend x y =
267 case (mappend `on` Format.journal_format) x y of
268 Format_JCC j -> Forall_Journal j
269 Format_Ledger j -> Forall_Journal j
270 mconcat js =
271 case js of
272 [] -> mempty
273 j:jn -> foldl' mappend j jn
274
275 type Journal_Filter transaction
276 = Filter.Simplified
277 (Filter.Filter_Bool
278 (Filter.Filter_Transaction transaction))
279 type Journal_Read_Cons txn
280 = txn -> Filter.Filtered (Journal_Filter txn) txn
281
282 journal_read
283 :: Context -> FilePath
284 -> IO (Either (Format.Message W.Doc) Forall_Journal)
285 journal_read ctx =
286 case ctx_input_format ctx of
287 Format_JCC () ->
288 let wrap (j::JCC.Journal Journal_JCC) = Forall_Journal j in
289 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
290 = Filter.Filtered (ctx_filter_transaction ctx) in
291 liftM ((+++) Format.Message wrap) .
292 Format.journal_read cons
293 Format_Ledger () ->
294 let wrap (j::Ledger.Journal Journal_Ledger) = Forall_Journal j in
295 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
296 = Filter.Filtered (ctx_filter_transaction ctx) in
297 liftM ((+++) Format.Message wrap) .
298 Format.journal_read cons