cli/Hcompta/CLI/Command/Journal.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 module Hcompta.CLI.Command.Journal where
   5
   6 import           Prelude hiding (foldr)
   7 -- import           Control.Arrow (first)
   8 -- import           Control.Applicative ((<$>))
   9 -- import           Control.Monad ((>=>))
  10 import           Control.Monad.IO.Class (liftIO)
  11 import           Control.Monad.Trans.Except (runExceptT)
  12 import qualified Data.Either
  13 import           Data.Foldable (foldr)
  14 import           System.Console.GetOpt
  15                  ( ArgDescr(..)
  16                  , OptDescr(..)
  17                  , usageInfo )
  18 import           System.Environment as Env (getProgName)
  19 import           System.Exit (exitWith, ExitCode(..))
  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.Format.Ledger as Ledger
  27 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  28 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  29 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  30 import qualified Hcompta.Lib.Leijen as W
  31 import qualified Hcompta.Filter as Filter
  32 import qualified Hcompta.Filter.Read as Filter.Read
  33
  34 data Ctx
  35  =   Ctx
  36  { ctx_input              :: [FilePath]
  37  , ctx_align              :: Bool
  38  , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
  39  } deriving (Show)
  40
  41 nil :: Ctx
  42 nil =
  43         Ctx
  44          { ctx_input = []
  45          , ctx_align = True
  46          , ctx_transaction_filter = Filter.Any
  47          }
  48
  49 usage :: IO String
  50 usage = do
  51         bin <- Env.getProgName
  52         return $unlines $
  53                 [ "SYNTAX "
  54                 , "  "++bin++" journal [-t TRANSACTION_FILTER]"
  55                 , ""
  56                 , usageInfo "OPTIONS" options
  57                 ]
  58
  59 options :: Args.Options Ctx
  60 options =
  61         [ Option "h" ["help"]
  62          (NoArg (\_context _ctx -> do
  63                 usage >>= IO.hPutStr IO.stderr
  64                 exitWith ExitSuccess))
  65          "show this help"
  66         , Option "i" ["input"]
  67          (ReqArg (\s _context ctx -> do
  68                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  69          "read data from given file, multiple uses merge the data as would a concatenation do"
  70         , Option "" ["align"]
  71          (OptArg (\arg context ctx -> do
  72                 ctx_align <- case arg of
  73                  Nothing    -> return $ True
  74                  Just "yes" -> return $ True
  75                  Just "no"  -> return $ False
  76                  Just _     -> Write.fatal context $
  77                         W.text "--align option expects \"yes\", or \"no\" as value"
  78                 return $ ctx{ctx_align})
  79           "[yes|no]")
  80          "align output"
  81         , Option "t" ["transaction-filter"]
  82          (ReqArg (\s context ctx -> do
  83                 ctx_transaction_filter <-
  84                         fmap (Filter.And $ ctx_transaction_filter ctx) $
  85                         liftIO $ Filter.Read.read Filter.Read.test_transaction s
  86                         >>= \f -> case f of
  87                          Left  ko -> Write.fatal context $ ko
  88                          Right ok -> return ok
  89                 return $ ctx{ctx_transaction_filter}) "FILTER")
  90          "filter at transaction level, multiple uses are merged with a logical and"
  91         ]
  92
  93 run :: Context.Context -> [String] -> IO ()
  94 run context args = do
  95         (ctx, _args) <- Args.parse context usage options (nil, args)
  96         read_journals <- do
  97                 CLI.Ledger.paths context $ ctx_input ctx
  98                 >>= do
  99                         mapM $ \path -> do
 100                                 liftIO $ runExceptT $ Ledger.Read.file path
 101                                 >>= \x -> case x of
 102                                  Left  ko -> return $ Left (path, ko)
 103                                  Right ok -> return $ Right ok
 104                 >>= return . Data.Either.partitionEithers
 105         case read_journals of
 106          (errs@(_:_), _journals) ->
 107                 (flip mapM_) errs $ \(_path, err) -> do
 108                         Write.fatal context $ err
 109          ([], journals) -> do
 110                 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
 111                 style_color <- Write.with_color context IO.stdout
 112                 let sty = Ledger.Write.Style
 113                          { Ledger.Write.style_align = ctx_align ctx
 114                          , Ledger.Write.style_color
 115                          }
 116                 let transactions =
 117                         foldr
 118                          (Ledger.Journal.fold
 119                                  (flip (foldr
 120                                          (flip (foldr
 121                                                  (\tr ->
 122                                                         case Filter.test (ctx_transaction_filter ctx) tr of
 123                                                          False -> id
 124                                                          True  -> (:) tr
 125                                                  ))))
 126                                  . Ledger.journal_transactions))
 127                          []
 128                          journals
 129                 Ledger.Write.put sty IO.stdout $ do
 130                 Ledger.Write.transactions transactions