Ajout : profilage du code.

[comptalang.git] / cli / Hcompta / CLI / Command / Journal.hs

diff --git a/cli/Hcompta/CLI/Command/Journal.hs b/cli/Hcompta/CLI/Command/Journal.hs
index 639cd59c36698116a508e5d08474f6b07cdd82c4..f46ac74f51e884883605e3f28daf7675ea2755ed 100644 (file)
--- a/cli/Hcompta/CLI/Command/Journal.hs
+++ b/cli/Hcompta/CLI/Command/Journal.hs
@@ -27,6 +27,7 @@ import qualified Hcompta.CLI.Args as Args
 import qualified Hcompta.CLI.Context as Context
 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
 import qualified Hcompta.CLI.Write as Write
+import qualified Hcompta.Date as Date
 import qualified Hcompta.Filter as Filter
 import qualified Hcompta.Filter.Read as Filter.Read
 import qualified Hcompta.Filter.Reduce as Filter.Reduce
@@ -41,10 +42,10 @@ data Ctx
  =   Ctx
  { ctx_input              :: [FilePath]
  , ctx_align              :: Bool
- , ctx_date_reducer       :: Bool
- , ctx_transaction_filter :: Filter.Simplified
-                             (Filter.Test_Bool
-                             (Filter.Test_Transaction
+ , ctx_reduce_date        :: Bool
+ , ctx_filter_transaction :: Filter.Simplified
+                             (Filter.Filter_Bool
+                             (Filter.Filter_Transaction
                              Ledger.Transaction))
  } deriving (Show)
 
@@ -53,8 +54,8 @@ nil =
        Ctx
         { ctx_input = []
         , ctx_align = True
-        , ctx_date_reducer = True
-        , ctx_transaction_filter = mempty
+        , ctx_reduce_date = True
+        , ctx_filter_transaction = mempty
         }
 
 usage :: IO String
@@ -62,7 +63,9 @@ usage = do
        bin <- Env.getProgName
        return $unlines $
                [ "SYNTAX "
-               , "  "++bin++" journal [-t TRANSACTION_FILTER]"
+               , "  "++bin++" journal"
+               , " [-t TRANSACTION_FILTER]"
+               , " JOURNAL_FILE [...]"
                , ""
                , usageInfo "OPTIONS" options
                ]
@@ -89,35 +92,35 @@ options =
                return $ ctx{ctx_align})
          "[yes|no]")
         "align output"
-       , Option "" ["date-reducer"]
+       , Option "" ["reduce-date"]
         (OptArg (\arg context ctx -> do
-               ctx_date_reducer <- case arg of
+               ctx_reduce_date <- case arg of
                 Nothing    -> return $ True
                 Just "yes" -> return $ True
                 Just "no"  -> return $ False
                 Just _     -> Write.fatal context $
-                       W.text "--date-reducer option expects \"yes\", or \"no\" as value"
-               return $ ctx{ctx_date_reducer})
+                       W.text "--reduce-date option expects \"yes\", or \"no\" as value"
+               return $ ctx{ctx_reduce_date})
          "[yes|no]")
         "use advanced date reducer to speed up filtering"
        , Option "t" ["transaction-filter"]
         (ReqArg (\s context ctx -> do
-               ctx_transaction_filter <-
-                       liftM (\t -> (<>) (ctx_transaction_filter ctx)
+               ctx_filter_transaction <-
+                       liftM (\t -> (<>) (ctx_filter_transaction ctx)
                         (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
-                       liftIO $ Filter.Read.read Filter.Read.test_transaction s
+                       liftIO $ Filter.Read.read Filter.Read.filter_transaction s
                        >>= \f -> case f of
                         Left  ko -> Write.fatal context $ ko
                         Right ok -> return ok
-               return $ ctx{ctx_transaction_filter}) "FILTER")
+               return $ ctx{ctx_filter_transaction}) "FILTER")
         "filter at transaction level, multiple uses are merged with a logical AND"
        ]
 
 run :: Context.Context -> [String] -> IO ()
 run context args = do
-       (ctx, _args) <- Args.parse context usage options (nil, args)
-       read_journals <- do
-               CLI.Ledger.paths context $ ctx_input ctx
+       (ctx, inputs) <- Args.parse context usage options (nil, args)
+       (read_journals, read_bench) <- Date.bench $ do
+               CLI.Ledger.paths context $ ctx_input ctx ++ inputs
                >>= do
                        mapM $ \path -> do
                                liftIO $ runExceptT $ Ledger.Read.file path
@@ -125,17 +128,18 @@ run context args = do
                                 Left  ko -> return $ Left (path, ko)
                                 Right ok -> return $ Right ok
                >>= return . Data.Either.partitionEithers
+       Write.debug context $ "benchmark: input:" ++ show read_bench
        case read_journals of
         (errs@(_:_), _journals) ->
                (flip mapM_) errs $ \(_path, err) -> do
                        Write.fatal context $ err
         ([], journals) -> do
-               Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
-               let date_reducer =
-                       if ctx_date_reducer ctx
-                       then Filter.Reduce.bool_date <$> ctx_transaction_filter ctx
+               Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
+               let reducer_date =
+                       if ctx_reduce_date ctx
+                       then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
                        else mempty
-               Write.debug context $ "transaction_filter: date_reducer: " ++ show date_reducer
+               Write.debug context $ "filter: transaction: reducer: " ++ show reducer_date
                style_color <- Write.with_color context IO.stdout
                let sty = Ledger.Write.Style
                         { Ledger.Write.style_align = ctx_align ctx
@@ -146,8 +150,9 @@ run context args = do
                         (flip (Ledger.Journal.foldM
                                 (\j j_ts -> do
                                        let ts = Ledger.journal_transactions j
-                                       ts_filtered <-
-                                               case Filter.simplified $ ctx_transaction_filter ctx of
+                                       liftM
+                                        (Data.Map.unionsWith (++) . (:) j_ts) $
+                                               case Filter.simplified $ ctx_filter_transaction ctx of
                                                 Right True  -> return $ ts:[]
                                                 Right False -> return $ []
                                                 Left flt ->
@@ -159,17 +164,15 @@ run context args = do
                                                                                 [] -> Nothing
                                                                                 l  -> Just l
                                                                         ))) $
-                                                       case Filter.simplified date_reducer of
+                                                       case Filter.simplified reducer_date of
                                                         Left reducer -> do
                                                                let (ts_reduced, date_sieve) = Filter.Reduce.map_date reducer ts
-                                                               Write.debug context $ "transaction_filter: date_sieve: "
+                                                               Write.debug context $ "filter: transaction: sieve: "
                                                                 ++ "journal=" ++ (show $ Ledger.journal_file j)
                                                                 ++ ": " ++ show (Interval.Pretty date_sieve)
                                                                return ts_reduced
                                                         Right True  -> return $ ts:[]
                                                         Right False -> return $ []
-                                       return $
-                                               Data.Map.unionsWith (++) (j_ts:ts_filtered)
                                 )))
                         Data.Map.empty
                         journals