cli/Hcompta/CLI/Command/Journal.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 module Hcompta.CLI.Command.Journal where
   5
   6 import           Prelude hiding (foldr)
   7 -- import           Control.Arrow (first)
   8 -- import           Control.Applicative ((<$>))
   9 -- import           Control.Monad ((>=>))
  10 import           Control.Monad.IO.Class (liftIO)
  11 import           Control.Monad.Trans.Except (runExceptT)
  12 import qualified Data.Either
  13 import           Data.Functor.Compose (Compose(..))
  14 import qualified Data.List
  15 import qualified Data.Map.Strict as Data.Map
  16 import           Data.Foldable (foldr)
  17 import           System.Console.GetOpt
  18                  ( ArgDescr(..)
  19                  , OptDescr(..)
  20                  , usageInfo )
  21 import           System.Environment as Env (getProgName)
  22 import           System.Exit (exitWith, ExitCode(..))
  23 import qualified System.IO as IO
  24
  25 import qualified Hcompta.CLI.Args as Args
  26 import qualified Hcompta.CLI.Context as Context
  27 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  28 import qualified Hcompta.CLI.Write as Write
  29 import qualified Hcompta.Format.Ledger as Ledger
  30 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  31 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  32 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  33 import qualified Hcompta.Lib.Leijen as W
  34 import qualified Hcompta.Filter as Filter
  35 import qualified Hcompta.Filter.Read as Filter.Read
  36
  37 data Ctx
  38  =   Ctx
  39  { ctx_input              :: [FilePath]
  40  , ctx_align              :: Bool
  41  , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
  42  } deriving (Show)
  43
  44 nil :: Ctx
  45 nil =
  46         Ctx
  47          { ctx_input = []
  48          , ctx_align = True
  49          , ctx_transaction_filter = Filter.Any
  50          }
  51
  52 usage :: IO String
  53 usage = do
  54         bin <- Env.getProgName
  55         return $unlines $
  56                 [ "SYNTAX "
  57                 , "  "++bin++" journal [-t TRANSACTION_FILTER]"
  58                 , ""
  59                 , usageInfo "OPTIONS" options
  60                 ]
  61
  62 options :: Args.Options Ctx
  63 options =
  64         [ Option "h" ["help"]
  65          (NoArg (\_context _ctx -> do
  66                 usage >>= IO.hPutStr IO.stderr
  67                 exitWith ExitSuccess))
  68          "show this help"
  69         , Option "i" ["input"]
  70          (ReqArg (\s _context ctx -> do
  71                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  72          "read data from given file, multiple uses merge the data as would a concatenation do"
  73         , Option "" ["align"]
  74          (OptArg (\arg context ctx -> do
  75                 ctx_align <- case arg of
  76                  Nothing    -> return $ True
  77                  Just "yes" -> return $ True
  78                  Just "no"  -> return $ False
  79                  Just _     -> Write.fatal context $
  80                         W.text "--align option expects \"yes\", or \"no\" as value"
  81                 return $ ctx{ctx_align})
  82           "[yes|no]")
  83          "align output"
  84         , Option "t" ["transaction-filter"]
  85          (ReqArg (\s context ctx -> do
  86                 ctx_transaction_filter <-
  87                         fmap (Filter.And $ ctx_transaction_filter ctx) $
  88                         liftIO $ Filter.Read.read Filter.Read.test_transaction s
  89                         >>= \f -> case f of
  90                          Left  ko -> Write.fatal context $ ko
  91                          Right ok -> return ok
  92                 return $ ctx{ctx_transaction_filter}) "FILTER")
  93          "filter at transaction level, multiple uses are merged with a logical and"
  94         ]
  95
  96 run :: Context.Context -> [String] -> IO ()
  97 run context args = do
  98         (ctx, _args) <- Args.parse context usage options (nil, args)
  99         read_journals <- do
 100                 CLI.Ledger.paths context $ ctx_input ctx
 101                 >>= do
 102                         mapM $ \path -> do
 103                                 liftIO $ runExceptT $ Ledger.Read.file path
 104                                 >>= \x -> case x of
 105                                  Left  ko -> return $ Left (path, ko)
 106                                  Right ok -> return $ Right ok
 107                 >>= return . Data.Either.partitionEithers
 108         case read_journals of
 109          (errs@(_:_), _journals) ->
 110                 (flip mapM_) errs $ \(_path, err) -> do
 111                         Write.fatal context $ err
 112          ([], journals) -> do
 113                 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
 114                 style_color <- Write.with_color context IO.stdout
 115                 let sty = Ledger.Write.Style
 116                          { Ledger.Write.style_align = ctx_align ctx
 117                          , Ledger.Write.style_color
 118                          }
 119                 let transactions =
 120                         foldr
 121                          (Ledger.Journal.fold
 122                                  (\j ->
 123                                         let ts = Ledger.journal_transactions j in
 124                                         Data.Map.unionWith (++) $
 125                                         case ctx_transaction_filter ctx of
 126                                          Filter.Any -> ts
 127                                          _ ->
 128                                                 Data.Map.mapMaybe
 129                                                  (\lt ->
 130                                                         case Data.List.filter
 131                                                          (Filter.test (ctx_transaction_filter ctx)) lt of
 132                                                          [] -> Nothing
 133                                                          l -> Just l
 134                                                  )
 135                                                  ts
 136                                  ))
 137                          Data.Map.empty
 138                          journals
 139                 Ledger.Write.put sty IO.stdout $ do
 140                 Ledger.Write.transactions (Compose transactions)