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