1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# LANGUAGE TupleSections #-}
5 module Hcompta.CLI.Command.Journal where
7 -- import Control.Applicative ((<$>))
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 Data.Foldable ()
13 import Data.Functor.Compose (Compose(..))
14 import qualified Data.List
15 import qualified Data.Map.Strict as Data.Map
16 import System.Console.GetOpt
20 import Data.Monoid ((<>))
21 import Prelude hiding (foldr)
22 import System.Environment as Env (getProgName)
23 import System.Exit (exitWith, ExitCode(..))
24 import qualified System.IO as IO
26 import qualified Hcompta.CLI.Args as Args
27 import qualified Hcompta.CLI.Context as Context
28 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
29 import qualified Hcompta.CLI.Write as Write
30 import qualified Hcompta.Filter as Filter
31 import qualified Hcompta.Filter.Read as Filter.Read
32 import qualified Hcompta.Filter.Reduce as Filter.Reduce
33 import qualified Hcompta.Format.Ledger as Ledger
34 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
35 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
36 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
37 import qualified Hcompta.Lib.Leijen as W
38 import qualified Hcompta.Lib.Interval as Interval
42 { ctx_input :: [FilePath]
44 , ctx_date_reducer :: Bool
45 , ctx_transaction_filter :: Filter.Simplified
47 (Filter.Test_Transaction
56 , ctx_date_reducer = True
57 , ctx_transaction_filter = mempty
62 bin <- Env.getProgName
65 , " "++bin++" journal"
66 , " [-t TRANSACTION_FILTER]"
67 , " JOURNAL_FILE [...]"
69 , usageInfo "OPTIONS" options
72 options :: Args.Options Ctx
75 (NoArg (\_context _ctx -> do
76 usage >>= IO.hPutStr IO.stderr
77 exitWith ExitSuccess))
79 , Option "i" ["input"]
80 (ReqArg (\s _context ctx -> do
81 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
82 "read data from given file, multiple uses merge the data as would a concatenation do"
84 (OptArg (\arg context ctx -> do
85 ctx_align <- case arg of
86 Nothing -> return $ True
87 Just "yes" -> return $ True
88 Just "no" -> return $ False
89 Just _ -> Write.fatal context $
90 W.text "--align option expects \"yes\", or \"no\" as value"
91 return $ ctx{ctx_align})
94 , Option "" ["date-reducer"]
95 (OptArg (\arg context ctx -> do
96 ctx_date_reducer <- case arg of
97 Nothing -> return $ True
98 Just "yes" -> return $ True
99 Just "no" -> return $ False
100 Just _ -> Write.fatal context $
101 W.text "--date-reducer option expects \"yes\", or \"no\" as value"
102 return $ ctx{ctx_date_reducer})
104 "use advanced date reducer to speed up filtering"
105 , Option "t" ["transaction-filter"]
106 (ReqArg (\s context ctx -> do
107 ctx_transaction_filter <-
108 liftM (\t -> (<>) (ctx_transaction_filter ctx)
109 (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
110 liftIO $ Filter.Read.read Filter.Read.test_transaction s
112 Left ko -> Write.fatal context $ ko
113 Right ok -> return ok
114 return $ ctx{ctx_transaction_filter}) "FILTER")
115 "filter at transaction level, multiple uses are merged with a logical AND"
118 run :: Context.Context -> [String] -> IO ()
119 run context args = do
120 (ctx, inputs) <- Args.parse context usage options (nil, args)
122 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
125 liftIO $ runExceptT $ Ledger.Read.file path
127 Left ko -> return $ Left (path, ko)
128 Right ok -> return $ Right ok
129 >>= return . Data.Either.partitionEithers
130 case read_journals of
131 (errs@(_:_), _journals) ->
132 (flip mapM_) errs $ \(_path, err) -> do
133 Write.fatal context $ err
135 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
137 if ctx_date_reducer ctx
138 then Filter.Reduce.bool_date <$> ctx_transaction_filter ctx
140 Write.debug context $ "transaction_filter: date_reducer: " ++ show date_reducer
141 style_color <- Write.with_color context IO.stdout
142 let sty = Ledger.Write.Style
143 { Ledger.Write.style_align = ctx_align ctx
144 , Ledger.Write.style_color
148 (flip (Ledger.Journal.foldM
150 let ts = Ledger.journal_transactions j
152 case Filter.simplified $ ctx_transaction_filter ctx of
153 Right True -> return $ ts:[]
154 Right False -> return $ []
160 case Data.List.filter (Filter.test flt) lt of
164 case Filter.simplified date_reducer of
166 let (ts_reduced, date_sieve) = Filter.Reduce.map_date reducer ts
167 Write.debug context $ "transaction_filter: date_sieve: "
168 ++ "journal=" ++ (show $ Ledger.journal_file j)
169 ++ ": " ++ show (Interval.Pretty date_sieve)
171 Right True -> return $ ts:[]
172 Right False -> return $ []
174 Data.Map.unionsWith (++) (j_ts:ts_filtered)
178 Ledger.Write.put sty IO.stdout $ do
179 Ledger.Write.transactions (Compose transactions)