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 ((<$>))
   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           Data.Functor.Compose (Compose(..))
  14 import qualified Data.List
  15 import qualified Data.Map.Strict as Data.Map
  16 import           System.Console.GetOpt
  17                  ( ArgDescr(..)
  18                  , OptDescr(..)
  19                  , usageInfo )
  20 import           Data.Monoid ((<>))
  21 import           Prelude hiding (foldr)
  22 import           System.Environment as Env (getProgName)
  23 import           System.Exit (exitWith, ExitCode(..))
  24 import qualified System.IO as IO
  25
  26 import qualified Hcompta.CLI.Args as Args
  27 import qualified Hcompta.CLI.Context as Context
  28 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  29 import qualified Hcompta.CLI.Write as Write
  30 import qualified Hcompta.Filter as Filter
  31 import qualified Hcompta.Filter.Read as Filter.Read
  32 import qualified Hcompta.Filter.Reduce as Filter.Reduce
  33 import qualified Hcompta.Format.Ledger as Ledger
  34 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  35 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  36 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  37 import qualified Hcompta.Lib.Leijen as W
  38 import qualified Hcompta.Lib.Interval as Interval
  39
  40 data Ctx
  41  =   Ctx
  42  { ctx_input              :: [FilePath]
  43  , ctx_align              :: Bool
  44  , ctx_date_reducer       :: Bool
  45  , ctx_transaction_filter :: Filter.Simplified
  46                              (Filter.Test_Bool
  47                              (Filter.Test_Transaction
  48                              Ledger.Transaction))
  49  } deriving (Show)
  50
  51 nil :: Ctx
  52 nil =
  53         Ctx
  54          { ctx_input = []
  55          , ctx_align = True
  56          , ctx_date_reducer = True
  57          , ctx_transaction_filter = mempty
  58          }
  59
  60 usage :: IO String
  61 usage = do
  62         bin <- Env.getProgName
  63         return $unlines $
  64                 [ "SYNTAX "
  65                 , "  "++bin++" journal [-t TRANSACTION_FILTER]"
  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                 exitWith 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         , Option "" ["date-reducer"]
  93          (OptArg (\arg context ctx -> do
  94                 ctx_date_reducer <- case arg of
  95                  Nothing    -> return $ True
  96                  Just "yes" -> return $ True
  97                  Just "no"  -> return $ False
  98                  Just _     -> Write.fatal context $
  99                         W.text "--date-reducer option expects \"yes\", or \"no\" as value"
 100                 return $ ctx{ctx_date_reducer})
 101           "[yes|no]")
 102          "use advanced date reducer to speed up filtering"
 103         , Option "t" ["transaction-filter"]
 104          (ReqArg (\s context ctx -> do
 105                 ctx_transaction_filter <-
 106                         liftM (\t -> (<>) (ctx_transaction_filter ctx)
 107                          (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
 108                         liftIO $ Filter.Read.read Filter.Read.test_transaction s
 109                         >>= \f -> case f of
 110                          Left  ko -> Write.fatal context $ ko
 111                          Right ok -> return ok
 112                 return $ ctx{ctx_transaction_filter}) "FILTER")
 113          "filter at transaction level, multiple uses are merged with a logical AND"
 114         ]
 115
 116 run :: Context.Context -> [String] -> IO ()
 117 run context args = do
 118         (ctx, _args) <- Args.parse context usage options (nil, args)
 119         read_journals <- do
 120                 CLI.Ledger.paths context $ ctx_input ctx
 121                 >>= do
 122                         mapM $ \path -> do
 123                                 liftIO $ runExceptT $ Ledger.Read.file path
 124                                 >>= \x -> case x of
 125                                  Left  ko -> return $ Left (path, ko)
 126                                  Right ok -> return $ Right ok
 127                 >>= return . Data.Either.partitionEithers
 128         case read_journals of
 129          (errs@(_:_), _journals) ->
 130                 (flip mapM_) errs $ \(_path, err) -> do
 131                         Write.fatal context $ err
 132          ([], journals) -> do
 133                 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
 134                 let date_reducer =
 135                         if ctx_date_reducer ctx
 136                         then Filter.Reduce.bool_date <$> ctx_transaction_filter ctx
 137                         else mempty
 138                 Write.debug context $ "transaction_filter: date_reducer: " ++ show date_reducer
 139                 style_color <- Write.with_color context IO.stdout
 140                 let sty = Ledger.Write.Style
 141                          { Ledger.Write.style_align = ctx_align ctx
 142                          , Ledger.Write.style_color
 143                          }
 144                 transactions <-
 145                         foldM
 146                          (flip (Ledger.Journal.foldM
 147                                  (\j j_ts -> do
 148                                         let ts = Ledger.journal_transactions j
 149                                         ts_filtered <-
 150                                                 case Filter.simplified $ ctx_transaction_filter ctx of
 151                                                  Right True  -> return $ ts:[]
 152                                                  Right False -> return $ []
 153                                                  Left flt ->
 154                                                         liftM
 155                                                          (Data.List.map
 156                                                                  (Data.Map.mapMaybe
 157                                                                          (\lt ->
 158                                                                                 case Data.List.filter (Filter.test flt) lt of
 159                                                                                  [] -> Nothing
 160                                                                                  l  -> Just l
 161                                                                          ))) $
 162                                                         case Filter.simplified date_reducer of
 163                                                          Left reducer -> do
 164                                                                 let (ts_reduced, date_sieve) = Filter.Reduce.map_date reducer ts
 165                                                                 Write.debug context $ "transaction_filter: date_sieve: "
 166                                                                  ++ "journal=" ++ (show $ Ledger.journal_file j)
 167                                                                  ++ ": " ++ show (Interval.Pretty date_sieve)
 168                                                                 return ts_reduced
 169                                                          Right True  -> return $ ts:[]
 170                                                          Right False -> return $ []
 171                                         return $
 172                                                 Data.Map.unionsWith (++) (j_ts:ts_filtered)
 173                                  )))
 174                          Data.Map.empty
 175                          journals
 176                 Ledger.Write.put sty IO.stdout $ do
 177                 Ledger.Write.transactions (Compose transactions)