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_reduce_date        :: Bool
  45  , ctx_filter_transaction :: 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_reduce_date = True
  57          , ctx_filter_transaction = mempty
  58          }
  59
  60 usage :: IO String
  61 usage = do
  62         bin <- Env.getProgName
  63         return $unlines $
  64                 [ "SYNTAX "
  65                 , "  "++bin++" journal"
  66                 , " [-t TRANSACTION_FILTER]"
  67                 , " JOURNAL_FILE [...]"
  68                 , ""
  69                 , usageInfo "OPTIONS" options
  70                 ]
  71
  72 options :: Args.Options Ctx
  73 options =
  74         [ Option "h" ["help"]
  75          (NoArg (\_context _ctx -> do
  76                 usage >>= IO.hPutStr IO.stderr
  77                 exitWith ExitSuccess))
  78          "show this help"
  79         , Option "i" ["input"]
  80          (ReqArg (\s _context ctx -> do
  81                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  82          "read data from given file, multiple uses merge the data as would a concatenation do"
  83         , Option "" ["align"]
  84          (OptArg (\arg context ctx -> do
  85                 ctx_align <- case arg of
  86                  Nothing    -> return $ True
  87                  Just "yes" -> return $ True
  88                  Just "no"  -> return $ False
  89                  Just _     -> Write.fatal context $
  90                         W.text "--align option expects \"yes\", or \"no\" as value"
  91                 return $ ctx{ctx_align})
  92           "[yes|no]")
  93          "align output"
  94         , Option "" ["reduce-date"]
  95          (OptArg (\arg context ctx -> do
  96                 ctx_reduce_date <- case arg of
  97                  Nothing    -> return $ True
  98                  Just "yes" -> return $ True
  99                  Just "no"  -> return $ False
 100                  Just _     -> Write.fatal context $
 101                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 102                 return $ ctx{ctx_reduce_date})
 103           "[yes|no]")
 104          "use advanced date reducer to speed up filtering"
 105         , Option "t" ["transaction-filter"]
 106          (ReqArg (\s context ctx -> do
 107                 ctx_filter_transaction <-
 108                         liftM (\t -> (<>) (ctx_filter_transaction ctx)
 109                          (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
 110                         liftIO $ Filter.Read.read Filter.Read.test_transaction s
 111                         >>= \f -> case f of
 112                          Left  ko -> Write.fatal context $ ko
 113                          Right ok -> return ok
 114                 return $ ctx{ctx_filter_transaction}) "FILTER")
 115          "filter at transaction level, multiple uses are merged with a logical AND"
 116         ]
 117
 118 run :: Context.Context -> [String] -> IO ()
 119 run context args = do
 120         (ctx, inputs) <- Args.parse context usage options (nil, args)
 121         read_journals <- do
 122                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 123                 >>= do
 124                         mapM $ \path -> do
 125                                 liftIO $ runExceptT $ Ledger.Read.file path
 126                                 >>= \x -> case x of
 127                                  Left  ko -> return $ Left (path, ko)
 128                                  Right ok -> return $ Right ok
 129                 >>= return . Data.Either.partitionEithers
 130         case read_journals of
 131          (errs@(_:_), _journals) ->
 132                 (flip mapM_) errs $ \(_path, err) -> do
 133                         Write.fatal context $ err
 134          ([], journals) -> do
 135                 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 136                 let reducer_date =
 137                         if ctx_reduce_date ctx
 138                         then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
 139                         else mempty
 140                 Write.debug context $ "filter: transaction: reducer: " ++ show reducer_date
 141                 style_color <- Write.with_color context IO.stdout
 142                 let sty = Ledger.Write.Style
 143                          { Ledger.Write.style_align = ctx_align ctx
 144                          , Ledger.Write.style_color
 145                          }
 146                 transactions <-
 147                         foldM
 148                          (flip (Ledger.Journal.foldM
 149                                  (\j j_ts -> do
 150                                         let ts = Ledger.journal_transactions j
 151                                         liftM
 152                                          (Data.Map.unionsWith (++) . (:) j_ts) $
 153                                                 case Filter.simplified $ ctx_filter_transaction ctx of
 154                                                  Right True  -> return $ ts:[]
 155                                                  Right False -> return $ []
 156                                                  Left flt ->
 157                                                         liftM
 158                                                          (Data.List.map
 159                                                                  (Data.Map.mapMaybe
 160                                                                          (\lt ->
 161                                                                                 case Data.List.filter (Filter.test flt) lt of
 162                                                                                  [] -> Nothing
 163                                                                                  l  -> Just l
 164                                                                          ))) $
 165                                                         case Filter.simplified reducer_date of
 166                                                          Left reducer -> do
 167                                                                 let (ts_reduced, date_sieve) = Filter.Reduce.map_date reducer ts
 168                                                                 Write.debug context $ "filter: transaction: sieve: "
 169                                                                  ++ "journal=" ++ (show $ Ledger.journal_file j)
 170                                                                  ++ ": " ++ show (Interval.Pretty date_sieve)
 171                                                                 return ts_reduced
 172                                                          Right True  -> return $ ts:[]
 173                                                          Right False -> return $ []
 174                                  )))
 175                          Data.Map.empty
 176                          journals
 177                 Ledger.Write.put sty IO.stdout $ do
 178                 Ledger.Write.transactions (Compose transactions)