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 (Monad(..), forM_, liftM, mapM)
   8 import           Control.Monad.IO.Class (liftIO)
   9 import           Control.Monad.Trans.Except (runExceptT)
  10 import           Data.Bool
  11 import           Data.Either (Either(..), partitionEithers)
  12 import           Data.Foldable (Foldable(..))
  13 import           Data.List ((++), replicate)
  14 import           Data.Maybe (Maybe(..))
  15 import           Data.Monoid (Monoid(..), (<>))
  16 import           Data.String (String)
  17 import           Prelude (($), (.), FilePath, IO, flip, unlines)
  18 import           Text.Show (Show(..))
  19 import           System.Console.GetOpt
  20                  ( ArgDescr(..)
  21                  , OptDescr(..)
  22                  , usageInfo )
  23 import           System.Environment as Env (getProgName)
  24 import           System.Exit (exitSuccess)
  25 import qualified System.IO as IO
  26
  27 import qualified Hcompta.CLI.Args as Args
  28 import qualified Hcompta.CLI.Context as Context
  29 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  30 import qualified Hcompta.CLI.Write as Write
  31 -- import qualified Hcompta.Date as Date
  32 import qualified Hcompta.Filter as Filter
  33 import qualified Hcompta.Filter.Read as Filter.Read
  34 -- import qualified Hcompta.Filter.Reduce as Filter.Reduce
  35 import qualified Hcompta.Format.Ledger as Ledger
  36 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  37 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  38 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  39 import qualified Hcompta.Lib.Leijen as W
  40 import qualified Hcompta.Journal as Journal
  41
  42 data Ctx
  43  =   Ctx
  44  { ctx_input              :: [FilePath]
  45  , ctx_align              :: Bool
  46  , ctx_reduce_date        :: Bool
  47  , ctx_filter_transaction :: Filter.Simplified
  48                              (Filter.Filter_Bool
  49                              (Filter.Filter_Transaction
  50                              Ledger.Transaction))
  51  } deriving (Show)
  52
  53 nil :: Ctx
  54 nil =
  55         Ctx
  56          { ctx_input = []
  57          , ctx_align = True
  58          , ctx_reduce_date = True
  59          , ctx_filter_transaction = mempty
  60          }
  61
  62 usage :: IO String
  63 usage = do
  64         bin <- Env.getProgName
  65         let pad = replicate (length bin) ' '
  66         return $unlines $
  67                 [ "SYNTAX "
  68                 , "  "++bin++" journal [-i JOURNAL_FILE]"
  69                 , "  "++pad++"         [-t TRANSACTION_FILTER]"
  70                 , "  "++pad++"         [JOURNAL_FILE] [...]"
  71                 , ""
  72                 , usageInfo "OPTIONS" options
  73                 ]
  74
  75 options :: Args.Options Ctx
  76 options =
  77         [ Option "h" ["help"]
  78          (NoArg (\_context _ctx -> do
  79                 usage >>= IO.hPutStr IO.stderr
  80                 exitSuccess))
  81          "show this help"
  82         , Option "i" ["input"]
  83          (ReqArg (\s _context ctx -> do
  84                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  85          "read data from given file, multiple uses merge the data as would a concatenation do"
  86         , Option "" ["align"]
  87          (OptArg (\arg context ctx -> do
  88                 ctx_align <- case arg of
  89                  Nothing    -> return $ True
  90                  Just "yes" -> return $ True
  91                  Just "no"  -> return $ False
  92                  Just _     -> Write.fatal context $
  93                         W.text "--align option expects \"yes\", or \"no\" as value"
  94                 return $ ctx{ctx_align})
  95           "[yes|no]")
  96          "align output"
  97         {- NOTE: not used so far.
  98         , Option "" ["reduce-date"]
  99          (OptArg (\arg context ctx -> do
 100                 ctx_reduce_date <- case arg of
 101                  Nothing    -> return $ True
 102                  Just "yes" -> return $ True
 103                  Just "no"  -> return $ False
 104                  Just _     -> Write.fatal context $
 105                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 106                 return $ ctx{ctx_reduce_date})
 107           "[yes|no]")
 108          "use advanced date reducer to speed up filtering"
 109         -}
 110         , Option "t" ["transaction-filter"]
 111          (ReqArg (\s context ctx -> do
 112                 ctx_filter_transaction <-
 113                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
 114                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
 115                         >>= \f -> case f of
 116                          Left  ko -> Write.fatal context $ ko
 117                          Right ok -> do
 118                                 Write.debug context $ "filter: transaction: " ++ show ok
 119                                 return ok
 120                 return $ ctx{ctx_filter_transaction}) "FILTER")
 121          "filter at transaction level, multiple uses are merged with a logical AND"
 122         ]
 123
 124 run :: Context.Context -> [String] -> IO ()
 125 run context args = do
 126         (ctx, inputs) <- Args.parse context usage options (nil, args)
 127         read_journals <-
 128                 liftM Data.Either.partitionEithers $ do
 129                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 130                 >>= do
 131                         mapM $ \path -> do
 132                                 liftIO $ runExceptT $ Ledger.Read.file
 133                                  (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
 134                                  path
 135                                 >>= \x -> case x of
 136                                  Left  ko -> return $ Left (path, ko)
 137                                  Right ok -> return $ Right ok
 138         case read_journals of
 139          (errs@(_:_), _journals) ->
 140                 forM_ errs $ \(_path, err) -> do
 141                         Write.fatal context $ err
 142          ([], journals) -> do
 143                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 144                 {- NOTE: not used so far
 145                 let reducer_date =
 146                         if ctx_reduce_date ctx
 147                         then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
 148                         else mempty
 149                 Write.debug context $ "filter: transaction: reducer: " ++ show reducer_date
 150                 -}
 151                 style_color <- Write.with_color context IO.stdout
 152                 let sty = Ledger.Write.Style
 153                          { Ledger.Write.style_align = ctx_align ctx
 154                          , Ledger.Write.style_color
 155                          }
 156                 let journal = ledger_journal ctx journals
 157                 Ledger.Write.put sty IO.stdout $ do
 158                 Ledger.Write.transactions journal
 159
 160 ledger_journal
 161  :: Ctx
 162  -> [ Ledger.Journal (Journal.Journal Ledger.Transaction) ]
 163  -> Journal.Journal Ledger.Transaction
 164 ledger_journal _ctx =
 165         Data.Foldable.foldl'
 166          (flip $ Ledger.Journal.fold
 167                  (\Ledger.Journal{Ledger.journal_transactions=j} ->
 168                         mappend j))
 169          mempty