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.Arrow (first)
   8 import           Control.Monad (Monad(..), forM_, liftM, mapM)
   9 import           Control.Monad.IO.Class (liftIO)
  10 import           Control.Monad.Trans.Except (runExceptT)
  11 import           Data.Bool
  12 import           Data.Either (Either(..), partitionEithers)
  13 import           Data.Foldable (Foldable(..))
  14 import           Data.Functor (Functor(..), (<$>))
  15 import           Data.List ((++))
  16 import           Data.Maybe (Maybe(..))
  17 import           Data.Monoid (Monoid(..), (<>))
  18 import           Data.String (String)
  19 import           Prelude (($), (.), FilePath, IO, flip, unlines)
  20 import           Text.Show (Show(..))
  21 import           System.Console.GetOpt
  22                  ( ArgDescr(..)
  23                  , OptDescr(..)
  24                  , usageInfo )
  25 import           System.Environment as Env (getProgName)
  26 import           System.Exit (exitSuccess)
  27 import qualified System.IO as IO
  28
  29 import           Hcompta.Chart (Chart)
  30 import qualified Hcompta.CLI.Args as Args
  31 import qualified Hcompta.CLI.Context as C
  32 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  33 import qualified Hcompta.CLI.Lang as Lang
  34 import qualified Hcompta.CLI.Write as Write
  35 -- import qualified Hcompta.Date as Date
  36 import qualified Hcompta.Filter as Filter
  37 import qualified Hcompta.Filter.Read as Filter.Read
  38 -- import qualified Hcompta.Filter.Reduce as Filter.Reduce
  39 import qualified Hcompta.Format.Ledger as Ledger
  40 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  41 import qualified Hcompta.Format.Ledger.Amount as Ledger.Amount
  42 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  43 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  44 import qualified Hcompta.Lib.Leijen as W
  45 import qualified Hcompta.Journal as Journal
  46
  47 data Ctx
  48  =   Ctx
  49  { ctx_input              :: [FilePath]
  50  , ctx_output             :: [(Write.Mode, FilePath)]
  51  , ctx_align              :: Bool
  52  , ctx_reduce_date        :: Bool
  53  , ctx_filter_transaction :: Filter.Simplified
  54                              (Filter.Filter_Bool
  55                              (Filter.Filter_Transaction
  56                              (Ledger.Chart_With Ledger.Transaction)))
  57  } deriving (Show)
  58
  59 nil :: Ctx
  60 nil =
  61         Ctx
  62          { ctx_input = []
  63          , ctx_output = []
  64          , ctx_align = True
  65          , ctx_reduce_date = True
  66          , ctx_filter_transaction = mempty
  67          }
  68
  69 usage :: C.Context -> IO String
  70 usage c = do
  71         bin <- Env.getProgName
  72         return $ unlines $
  73                 [ C.translate c Lang.Section_Description
  74                 , "  "++C.translate c Lang.Help_Command_Journal
  75                 , ""
  76                 , C.translate c Lang.Section_Syntax
  77                 , "  "++bin++" journal ["++C.translate c Lang.Type_Option++"] [...]"++
  78                                      " ["++C.translate c Lang.Type_File_Journal++"] [...]"
  79                 , ""
  80                 , usageInfo (C.translate c Lang.Section_Options) (options c)
  81                 ]
  82
  83 options :: C.Context -> Args.Options Ctx
  84 options c =
  85         [ Option "h" ["help"]
  86          (NoArg (\_ctx -> do
  87                 usage c >>= IO.hPutStr IO.stderr
  88                 exitSuccess)) $
  89                 C.translate c Lang.Help_Option_Help
  90         , Option "i" ["input"]
  91          (ReqArg (\s ctx -> do
  92                 return $ ctx{ctx_input=s:ctx_input ctx}) $
  93                 C.translate c Lang.Type_File_Journal) $
  94                 C.translate c Lang.Help_Option_Input
  95         , Option "o" ["output"]
  96          (ReqArg (\s ctx -> do
  97                 return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
  98                 C.translate c Lang.Type_File) $
  99                 C.translate c Lang.Help_Option_Output
 100         , Option "O" ["overwrite"]
 101          (ReqArg (\s ctx -> do
 102                 return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
 103                 C.translate c Lang.Type_File) $
 104                 C.translate c Lang.Help_Option_Overwrite
 105         , Option "" ["align"]
 106          (OptArg (\arg ctx -> do
 107                 ctx_align <- case arg of
 108                  Nothing    -> return $ True
 109                  Just "yes" -> return $ True
 110                  Just "no"  -> return $ False
 111                  Just _     -> Write.fatal c $
 112                         W.text "--align option expects \"yes\", or \"no\" as value"
 113                 return $ ctx{ctx_align})
 114           "[yes|no]")
 115          "align output"
 116         {- NOTE: not used so far.
 117         , Option "" ["reduce-date"]
 118          (OptArg (\arg ctx -> do
 119                 ctx_reduce_date <- case arg of
 120                  Nothing    -> return $ True
 121                  Just "yes" -> return $ True
 122                  Just "no"  -> return $ False
 123                  Just _     -> Write.fatal c $
 124                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 125                 return $ ctx{ctx_reduce_date})
 126           "[yes|no]")
 127          "use advanced date reducer to speed up filtering"
 128         -}
 129         , Option "t" ["transaction-filter"]
 130          (ReqArg (\s ctx -> do
 131                 ctx_filter_transaction <-
 132                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
 133                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
 134                         >>= \f -> case f of
 135                          Left  ko -> Write.fatal c $ ko
 136                          Right ok -> do
 137                                 Write.debug c $ "filter: transaction: " ++ show ok
 138                                 return ok
 139                 return $ ctx{ctx_filter_transaction}) $
 140                 C.translate c Lang.Type_Filter_Transaction) $
 141                 C.translate c Lang.Help_Option_Filter_Transaction
 142         ]
 143
 144 run :: C.Context -> [String] -> IO ()
 145 run c args = do
 146         (ctx, inputs) <-
 147                 first (\x ->
 148                         case ctx_output x of
 149                          [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
 150                          _  -> x) <$>
 151                 Args.parse c usage options (nil, args)
 152         read_journals <-
 153                 liftM Data.Either.partitionEithers $ do
 154                 CLI.Ledger.paths c $ ctx_input ctx ++ inputs
 155                 >>= do
 156                         mapM $ \path -> do
 157                                 liftIO $ runExceptT $ Ledger.Read.file
 158                                  (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
 159                                  path
 160                                 >>= \x -> case x of
 161                                  Left  ko -> return $ Left (path, ko)
 162                                  Right ok -> return $ Right ok
 163         case read_journals of
 164          (errs@(_:_), _journals) ->
 165                 forM_ errs $ \(_path, err) -> do
 166                         Write.fatal c $ err
 167          ([], journals) -> do
 168                 Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 169                 {- NOTE: not used so far
 170                 let reducer_date =
 171                         if ctx_reduce_date ctx
 172                         then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
 173                         else mempty
 174                 Write.debug c $ "filter: transaction: reducer: " ++ show reducer_date
 175                 -}
 176                 let sty = Write.style{ Write.style_pretty = ctx_align ctx }
 177                 let (_chart, amount_styles, journal) = ledger_journal ctx journals
 178                 Write.write c sty (ctx_output ctx) $ do
 179                 Ledger.Write.transactions amount_styles $ fmap Ledger.with_chart journal
 180
 181 ledger_journal
 182  :: Ctx
 183  -> [ Ledger.Journal (Journal.Journal (Ledger.Chart_With Ledger.Transaction)) ]
 184  -> ( Chart Ledger.Account
 185     , Ledger.Amount.Styles
 186     , Journal.Journal (Ledger.Chart_With Ledger.Transaction)
 187     )
 188 ledger_journal _ctx =
 189         Data.Foldable.foldl'
 190          (flip (\j ->
 191                 flip mappend $
 192                 ( Ledger.journal_chart j
 193                 , Ledger.journal_amount_styles j
 194                 , ) $
 195                 Ledger.Journal.fold
 196                  (\Ledger.Journal
 197                          { Ledger.journal_sections=t
 198                          } -> mappend t
 199                  ) j mempty
 200          ))
 201          mempty