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 -> do
 113                                 Write.debug context $ "filter: transaction: " ++ show ok
 114                                 return ok
 115                 return $ ctx{ctx_filter_transaction}) "FILTER")
 116          "filter at transaction level, multiple uses are merged with a logical AND"
 117         ]
 118
 119 run :: Context.Context -> [String] -> IO ()
 120 run context args = do
 121         (ctx, inputs) <- Args.parse context usage options (nil, args)
 122         read_journals <-
 123                 liftM Data.Either.partitionEithers $ do
 124                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 125                 >>= do
 126                         mapM $ \path -> do
 127                                 liftIO $ runExceptT $ Ledger.Read.file
 128                                  (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
 129                                  path
 130                                 >>= \x -> case x of
 131                                  Left  ko -> return $ Left (path, ko)
 132                                  Right ok -> return $ Right ok
 133         case read_journals of
 134          (errs@(_:_), _journals) ->
 135                 forM_ errs $ \(_path, err) -> do
 136                         Write.fatal context $ err
 137          ([], journals) -> do
 138                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 139                 {- NOTE: not used so far
 140                 let reducer_date =
 141                         if ctx_reduce_date ctx
 142                         then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
 143                         else mempty
 144                 Write.debug context $ "filter: transaction: reducer: " ++ show reducer_date
 145                 -}
 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 (Journal.Journal Ledger.Transaction) ]
 158  -> Journal.Journal Ledger.Transaction
 159 ledger_journal _ctx =
 160         Data.Foldable.foldl'
 161          (flip $ Ledger.Journal.fold
 162                  (\Ledger.Journal{Ledger.journal_transactions=j} ->
 163                         mappend j))
 164          mempty