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 -> 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 <-
 121                 liftM Data.Either.partitionEithers $ do
 122                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 123                 >>= do
 124                         mapM $ \path -> do
 125                                 liftIO $ runExceptT $ Ledger.Read.file
 126                                  (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
 127                                  path
 128                                 >>= \x -> case x of
 129                                  Left  ko -> return $ Left (path, ko)
 130                                  Right ok -> return $ Right ok
 131         case read_journals of
 132          (errs@(_:_), _journals) ->
 133                 forM_ errs $ \(_path, err) -> do
 134                         Write.fatal context $ err
 135          ([], journals) -> do
 136                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 137                 {- NOTE: not used so far
 138                 let reducer_date =
 139                         if ctx_reduce_date ctx
 140                         then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
 141                         else mempty
 142                 Write.debug context $ "filter: transaction: reducer: " ++ show reducer_date
 143                 -}
 144                 style_color <- Write.with_color context IO.stdout
 145                 let sty = Ledger.Write.Style
 146                          { Ledger.Write.style_align = ctx_align ctx
 147                          , Ledger.Write.style_color
 148                          }
 149                 let journal = ledger_journal ctx journals
 150                 Ledger.Write.put sty IO.stdout $ do
 151                 Ledger.Write.transactions journal
 152
 153 ledger_journal
 154  :: Ctx
 155  -> [ Ledger.Journal (Journal.Journal Ledger.Transaction) ]
 156  -> Journal.Journal Ledger.Transaction
 157 ledger_journal _ctx =
 158         Data.Foldable.foldl'
 159          (flip $ Ledger.Journal.fold
 160                  (\Ledger.Journal{Ledger.journal_transactions=j} ->
 161                         mappend j))
 162          mempty