]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Journal.hs
Polissage : hlint.
[comptalang.git] / cli / Hcompta / CLI / Command / Journal.hs
1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# LANGUAGE TupleSections #-}
5 module Hcompta.CLI.Command.Journal where
6
7 import Control.Monad ({-foldM,-} liftM, forM_)
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 System.Console.GetOpt
13 ( ArgDescr(..)
14 , OptDescr(..)
15 , usageInfo )
16 import Data.Monoid ((<>))
17 import Prelude hiding (foldr)
18 import System.Environment as Env (getProgName)
19 import System.Exit (exitSuccess)
20 import qualified System.IO as IO
21
22 import qualified Hcompta.CLI.Args as Args
23 import qualified Hcompta.CLI.Context as Context
24 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
25 import qualified Hcompta.CLI.Write as Write
26 -- import qualified Hcompta.Date as Date
27 import qualified Hcompta.Filter as Filter
28 import qualified Hcompta.Filter.Read as Filter.Read
29 -- import qualified Hcompta.Filter.Reduce as Filter.Reduce
30 import qualified Hcompta.Format.Ledger as Ledger
31 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
32 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
33 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
34 import qualified Hcompta.Lib.Leijen as W
35 import qualified Hcompta.Journal as Journal
36
37 data Ctx
38 = Ctx
39 { ctx_input :: [FilePath]
40 , ctx_align :: Bool
41 , ctx_reduce_date :: Bool
42 , ctx_filter_transaction :: Filter.Simplified
43 (Filter.Filter_Bool
44 (Filter.Filter_Transaction
45 Ledger.Transaction))
46 } deriving (Show)
47
48 nil :: Ctx
49 nil =
50 Ctx
51 { ctx_input = []
52 , ctx_align = True
53 , ctx_reduce_date = True
54 , ctx_filter_transaction = mempty
55 }
56
57 usage :: IO String
58 usage = do
59 bin <- Env.getProgName
60 let pad = replicate (length bin) ' '
61 return $unlines $
62 [ "SYNTAX "
63 , " "++bin++" journal [-i JOURNAL_FILE]"
64 , " "++pad++" [-t TRANSACTION_FILTER]"
65 , " "++pad++" [JOURNAL_FILE] [...]"
66 , ""
67 , usageInfo "OPTIONS" options
68 ]
69
70 options :: Args.Options Ctx
71 options =
72 [ Option "h" ["help"]
73 (NoArg (\_context _ctx -> do
74 usage >>= IO.hPutStr IO.stderr
75 exitSuccess))
76 "show this help"
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"
81 , Option "" ["align"]
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})
90 "[yes|no]")
91 "align output"
92 {- NOTE: not used so far.
93 , Option "" ["reduce-date"]
94 (OptArg (\arg context ctx -> do
95 ctx_reduce_date <- case arg of
96 Nothing -> return $ True
97 Just "yes" -> return $ True
98 Just "no" -> return $ False
99 Just _ -> Write.fatal context $
100 W.text "--reduce-date option expects \"yes\", or \"no\" as value"
101 return $ ctx{ctx_reduce_date})
102 "[yes|no]")
103 "use advanced date reducer to speed up filtering"
104 -}
105 , Option "t" ["transaction-filter"]
106 (ReqArg (\s context ctx -> do
107 ctx_filter_transaction <-
108 liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
109 liftIO $ Filter.Read.read Filter.Read.filter_transaction s
110 >>= \f -> case f of
111 Left ko -> Write.fatal context $ ko
112 Right ok -> return ok
113 return $ ctx{ctx_filter_transaction}) "FILTER")
114 "filter at transaction level, multiple uses are merged with a logical AND"
115 ]
116
117 run :: Context.Context -> [String] -> IO ()
118 run context args = do
119 (ctx, inputs) <- Args.parse context usage options (nil, args)
120 read_journals <-
121 liftM Data.Either.partitionEithers $ do
122 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
123 >>= do
124 mapM $ \path -> do
125 liftIO $ runExceptT $ Ledger.Read.file
126 (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
127 path
128 >>= \x -> case x of
129 Left ko -> return $ Left (path, ko)
130 Right ok -> return $ Right ok
131 case read_journals of
132 (errs@(_:_), _journals) ->
133 forM_ errs $ \(_path, err) -> do
134 Write.fatal context $ err
135 ([], journals) -> do
136 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
137 {- NOTE: not used so far
138 let reducer_date =
139 if ctx_reduce_date ctx
140 then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
141 else mempty
142 Write.debug context $ "filter: transaction: reducer: " ++ show reducer_date
143 -}
144 style_color <- Write.with_color context IO.stdout
145 let sty = Ledger.Write.Style
146 { Ledger.Write.style_align = ctx_align ctx
147 , Ledger.Write.style_color
148 }
149 let journal = ledger_journal ctx journals
150 Ledger.Write.put sty IO.stdout $ do
151 Ledger.Write.transactions journal
152
153 ledger_journal
154 :: Ctx
155 -> [ Ledger.Journal (Journal.Journal Ledger.Transaction) ]
156 -> Journal.Journal Ledger.Transaction
157 ledger_journal _ctx =
158 Data.Foldable.foldl'
159 (flip $ Ledger.Journal.fold
160 (\Ledger.Journal{Ledger.journal_transactions=j} ->
161 mappend j))
162 mempty