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           Data.Foldable ()
  13 import qualified Data.List
  14 import           System.Console.GetOpt
  15                  ( ArgDescr(..)
  16                  , OptDescr(..)
  17                  , usageInfo )
  18 import           Data.Monoid ((<>))
  19 import           Prelude hiding (foldr)
  20 import           System.Environment as Env (getProgName)
  21 import           System.Exit (exitWith, ExitCode(..))
  22 import qualified System.IO as IO
  23
  24 import qualified Hcompta.CLI.Args as Args
  25 import qualified Hcompta.CLI.Context as Context
  26 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  27 import qualified Hcompta.CLI.Write as Write
  28 import qualified Hcompta.Date as Date
  29 import qualified Hcompta.Filter as Filter
  30 import qualified Hcompta.Filter.Read as Filter.Read
  31 import qualified Hcompta.Filter.Reduce as Filter.Reduce
  32 import qualified Hcompta.Format.Ledger as Ledger
  33 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  34 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  35 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  36 import qualified Hcompta.Lib.Leijen as W
  37 import qualified Hcompta.Journal as Journal
  38
  39 data Ctx
  40  =   Ctx
  41  { ctx_input              :: [FilePath]
  42  , ctx_align              :: Bool
  43  , ctx_reduce_date        :: Bool
  44  , ctx_filter_transaction :: Filter.Simplified
  45                              (Filter.Filter_Bool
  46                              (Filter.Filter_Transaction
  47                              Ledger.Transaction))
  48  } deriving (Show)
  49
  50 nil :: Ctx
  51 nil =
  52         Ctx
  53          { ctx_input = []
  54          , ctx_align = True
  55          , ctx_reduce_date = True
  56          , ctx_filter_transaction = mempty
  57          }
  58
  59 usage :: IO String
  60 usage = do
  61         bin <- Env.getProgName
  62         return $unlines $
  63                 [ "SYNTAX "
  64                 , "  "++bin++" journal"
  65                 , " [-t TRANSACTION_FILTER]"
  66                 , " JOURNAL_FILE [...]"
  67                 , ""
  68                 , usageInfo "OPTIONS" options
  69                 ]
  70
  71 options :: Args.Options Ctx
  72 options =
  73         [ Option "h" ["help"]
  74          (NoArg (\_context _ctx -> do
  75                 usage >>= IO.hPutStr IO.stderr
  76                 exitWith ExitSuccess))
  77          "show this help"
  78         , Option "i" ["input"]
  79          (ReqArg (\s _context ctx -> do
  80                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  81          "read data from given file, multiple uses merge the data as would a concatenation do"
  82         , Option "" ["align"]
  83          (OptArg (\arg context ctx -> do
  84                 ctx_align <- case arg of
  85                  Nothing    -> return $ True
  86                  Just "yes" -> return $ True
  87                  Just "no"  -> return $ False
  88                  Just _     -> Write.fatal context $
  89                         W.text "--align option expects \"yes\", or \"no\" as value"
  90                 return $ ctx{ctx_align})
  91           "[yes|no]")
  92          "align output"
  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         , Option "t" ["transaction-filter"]
 105          (ReqArg (\s context ctx -> do
 106                 ctx_filter_transaction <-
 107                         liftM (\t -> (<>) (ctx_filter_transaction ctx)
 108                          (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
 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, read_bench) <- Date.bench $ do
 121                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 122                 >>= do
 123                         mapM $ \path -> do
 124                                 liftIO $ runExceptT $ Ledger.Read.file
 125                                  (Ledger.Read.context $ Ledger.journal
 126                                          { Ledger.journal_transactions=Const
 127                                                  ( mempty
 128                                                  , ctx_filter_transaction ctx
 129                                                  -- , ctx_filter_posting     ctx
 130                                                  ) })
 131                                  path
 132                                 >>= \x -> case x of
 133                                  Left  ko -> return $ Left (path, ko)
 134                                  Right ok -> return $ Right ok
 135                 >>= return . Data.Either.partitionEithers
 136         Write.debug context $ "benchmark: input:" ++ show read_bench
 137         case read_journals of
 138          (errs@(_:_), _journals) ->
 139                 (flip mapM_) errs $ \(_path, err) -> do
 140                         Write.fatal context $ err
 141          ([], journals) -> do
 142                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 143                 let reducer_date =
 144                         if ctx_reduce_date ctx
 145                         then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
 146                         else mempty
 147                 Write.debug context $ "filter: transaction: reducer: " ++ show reducer_date
 148                 style_color <- Write.with_color context IO.stdout
 149                 let sty = Ledger.Write.Style
 150                          { Ledger.Write.style_align = ctx_align ctx
 151                          , Ledger.Write.style_color
 152                          }
 153                 let journal = ledger_journal ctx journals
 154                 Ledger.Write.put sty IO.stdout $ do
 155                 Ledger.Write.transactions journal
 156
 157 ledger_journal
 158  :: Ctx
 159  -> [Ledger.Journal (Const
 160       ( Journal.Journal Ledger.Transaction
 161       , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Transaction Ledger.Transaction))
 162       ))
 163       Ledger.Transaction
 164     ]
 165  -> Journal.Journal Ledger.Transaction
 166 ledger_journal _ctx journals =
 167         Data.List.foldl'
 168          (flip $ Ledger.Journal.fold
 169                  (\Ledger.Journal{Ledger.journal_transactions=Const (ts, _)} ->
 170                         mappend ts))
 171          mempty
 172          journals