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.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
  14                  ( ArgDescr(..)
  15                  , OptDescr(..)
  16                  , usageInfo )
  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
  22
  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
  37
  38 data Ctx
  39  =   Ctx
  40  { ctx_input              :: [FilePath]
  41  , ctx_align              :: Bool
  42  , ctx_reduce_date        :: Bool
  43  , ctx_filter_transaction :: Filter.Simplified
  44                              (Filter.Filter_Bool
  45                              (Filter.Filter_Transaction
  46                              Ledger.Transaction))
  47  } deriving (Show)
  48
  49 nil :: Ctx
  50 nil =
  51         Ctx
  52          { ctx_input = []
  53          , ctx_align = True
  54          , ctx_reduce_date = True
  55          , ctx_filter_transaction = mempty
  56          }
  57
  58 usage :: IO String
  59 usage = do
  60         bin <- Env.getProgName
  61         return $unlines $
  62                 [ "SYNTAX "
  63                 , "  "++bin++" journal"
  64                 , " [-t TRANSACTION_FILTER]"
  65                 , " 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                 exitWith 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         , 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})
 101           "[yes|no]")
 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
 109                         >>= \f -> case f of
 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"
 114         ]
 115
 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
 121                 >>= do
 122                         mapM $ \path -> do
 123                                 liftIO $ runExceptT $ Ledger.Read.file
 124                                  (Ledger.Read.context $ Ledger.journal
 125                                          { Ledger.journal_transactions=Const
 126                                                  ( mempty
 127                                                  , ctx_filter_transaction ctx
 128                                                  ) })
 129                                  path
 130                                 >>= \x -> case x of
 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
 139          ([], journals) -> do
 140                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 141                 let reducer_date =
 142                         if ctx_reduce_date ctx
 143                         then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
 144                         else mempty
 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
 150                          }
 151                 let journal = ledger_journal ctx journals
 152                 Ledger.Write.put sty IO.stdout $ do
 153                 Ledger.Write.transactions journal
 154
 155 ledger_journal
 156  :: Ctx
 157  -> [Ledger.Journal (Const
 158       ( Journal.Journal Ledger.Transaction
 159       , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Transaction Ledger.Transaction))
 160       ))
 161       Ledger.Transaction
 162     ]
 163  -> Journal.Journal Ledger.Transaction
 164 ledger_journal _ctx journals =
 165         Data.Foldable.foldl'
 166          (flip $ Ledger.Journal.fold
 167                  (\Ledger.Journal{Ledger.journal_transactions=Const (j, _)} ->
 168                         mappend j))
 169          mempty journals