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.Date as Date
  31 import qualified Hcompta.Filter as Filter
  32 import qualified Hcompta.Filter.Read as Filter.Read
  33 import qualified Hcompta.Filter.Reduce as Filter.Reduce
  34 import qualified Hcompta.Format.Ledger as Ledger
  35 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  36 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  37 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  38 import qualified Hcompta.Lib.Leijen as W
  39 import qualified Hcompta.Lib.Interval as Interval
  40
  41 data Ctx
  42  =   Ctx
  43  { ctx_input              :: [FilePath]
  44  , ctx_align              :: Bool
  45  , ctx_reduce_date        :: Bool
  46  , ctx_filter_transaction :: Filter.Simplified
  47                              (Filter.Test_Bool
  48                              (Filter.Test_Transaction
  49                              Ledger.Transaction))
  50  } deriving (Show)
  51
  52 nil :: Ctx
  53 nil =
  54         Ctx
  55          { ctx_input = []
  56          , ctx_align = True
  57          , ctx_reduce_date = True
  58          , ctx_filter_transaction = mempty
  59          }
  60
  61 usage :: IO String
  62 usage = do
  63         bin <- Env.getProgName
  64         return $unlines $
  65                 [ "SYNTAX "
  66                 , "  "++bin++" journal"
  67                 , " [-t TRANSACTION_FILTER]"
  68                 , " JOURNAL_FILE [...]"
  69                 , ""
  70                 , usageInfo "OPTIONS" options
  71                 ]
  72
  73 options :: Args.Options Ctx
  74 options =
  75         [ Option "h" ["help"]
  76          (NoArg (\_context _ctx -> do
  77                 usage >>= IO.hPutStr IO.stderr
  78                 exitWith ExitSuccess))
  79          "show this help"
  80         , Option "i" ["input"]
  81          (ReqArg (\s _context ctx -> do
  82                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  83          "read data from given file, multiple uses merge the data as would a concatenation do"
  84         , Option "" ["align"]
  85          (OptArg (\arg context ctx -> do
  86                 ctx_align <- case arg of
  87                  Nothing    -> return $ True
  88                  Just "yes" -> return $ True
  89                  Just "no"  -> return $ False
  90                  Just _     -> Write.fatal context $
  91                         W.text "--align option expects \"yes\", or \"no\" as value"
  92                 return $ ctx{ctx_align})
  93           "[yes|no]")
  94          "align output"
  95         , Option "" ["reduce-date"]
  96          (OptArg (\arg context ctx -> do
  97                 ctx_reduce_date <- case arg of
  98                  Nothing    -> return $ True
  99                  Just "yes" -> return $ True
 100                  Just "no"  -> return $ False
 101                  Just _     -> Write.fatal context $
 102                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 103                 return $ ctx{ctx_reduce_date})
 104           "[yes|no]")
 105          "use advanced date reducer to speed up filtering"
 106         , Option "t" ["transaction-filter"]
 107          (ReqArg (\s context ctx -> do
 108                 ctx_filter_transaction <-
 109                         liftM (\t -> (<>) (ctx_filter_transaction ctx)
 110                          (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
 111                         liftIO $ Filter.Read.read Filter.Read.test_transaction s
 112                         >>= \f -> case f of
 113                          Left  ko -> Write.fatal context $ ko
 114                          Right ok -> 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, read_bench) <- Date.bench $ do
 123                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 124                 >>= do
 125                         mapM $ \path -> do
 126                                 liftIO $ runExceptT $ Ledger.Read.file path
 127                                 >>= \x -> case x of
 128                                  Left  ko -> return $ Left (path, ko)
 129                                  Right ok -> return $ Right ok
 130                 >>= return . Data.Either.partitionEithers
 131         Write.debug context $ "benchmark: input:" ++ show read_bench
 132         case read_journals of
 133          (errs@(_:_), _journals) ->
 134                 (flip mapM_) errs $ \(_path, err) -> do
 135                         Write.fatal context $ err
 136          ([], journals) -> do
 137                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 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                 style_color <- Write.with_color context IO.stdout
 144                 let sty = Ledger.Write.Style
 145                          { Ledger.Write.style_align = ctx_align ctx
 146                          , Ledger.Write.style_color
 147                          }
 148                 transactions <-
 149                         foldM
 150                          (flip (Ledger.Journal.foldM
 151                                  (\j j_ts -> do
 152                                         let ts = Ledger.journal_transactions j
 153                                         liftM
 154                                          (Data.Map.unionsWith (++) . (:) j_ts) $
 155                                                 case Filter.simplified $ ctx_filter_transaction ctx of
 156                                                  Right True  -> return $ ts:[]
 157                                                  Right False -> return $ []
 158                                                  Left flt ->
 159                                                         liftM
 160                                                          (Data.List.map
 161                                                                  (Data.Map.mapMaybe
 162                                                                          (\lt ->
 163                                                                                 case Data.List.filter (Filter.test flt) lt of
 164                                                                                  [] -> Nothing
 165                                                                                  l  -> Just l
 166                                                                          ))) $
 167                                                         case Filter.simplified reducer_date of
 168                                                          Left reducer -> do
 169                                                                 let (ts_reduced, date_sieve) = Filter.Reduce.map_date reducer ts
 170                                                                 Write.debug context $ "filter: transaction: sieve: "
 171                                                                  ++ "journal=" ++ (show $ Ledger.journal_file j)
 172                                                                  ++ ": " ++ show (Interval.Pretty date_sieve)
 173                                                                 return ts_reduced
 174                                                          Right True  -> return $ ts:[]
 175                                                          Right False -> return $ []
 176                                  )))
 177                          Data.Map.empty
 178                          journals
 179                 Ledger.Write.put sty IO.stdout $ do
 180                 Ledger.Write.transactions (Compose transactions)