cli/Hcompta/CLI/Command/Print.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 module Hcompta.CLI.Command.Print 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.Foldable (foldr)
  14 import           System.Console.GetOpt
  15                  ( ArgDescr(..)
  16                  , OptDescr(..)
  17                  , usageInfo )
  18 import           System.Environment as Env (getProgName)
  19 import           System.Exit (exitWith, ExitCode(..))
  20 import qualified System.IO as IO
  21
  22 import qualified Hcompta.CLI.Args as Args
  23 import qualified Hcompta.CLI.Context as Context
  24 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  25 import qualified Hcompta.CLI.Write as Write
  26 import qualified Hcompta.Format.Ledger as Ledger
  27 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  28 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  29 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  30 import qualified Hcompta.Lib.Leijen as W
  31 import qualified Hcompta.Model.Filter as Filter
  32 import qualified Hcompta.Model.Filter.Read as Filter.Read
  33
  34 data Ctx
  35  =   Ctx
  36  { ctx_input :: [FilePath]
  37  , ctx_align :: Bool
  38  } deriving (Eq, Show)
  39
  40 nil :: Ctx
  41 nil =
  42         Ctx
  43          { ctx_input = []
  44          , ctx_align = True
  45          }
  46
  47 usage :: IO String
  48 usage = do
  49         bin <- Env.getProgName
  50         return $unlines $
  51                 [ "SYNTAX "
  52                 , "  "++bin++" print [option..]"
  53                 , ""
  54                 , usageInfo "OPTIONS" options
  55                 ]
  56
  57 options :: Args.Options Ctx
  58 options =
  59         [ Option "h" ["help"]
  60          (NoArg (\_context _ctx -> do
  61                 usage >>= IO.hPutStr IO.stderr
  62                 exitWith ExitSuccess))
  63          "show this help"
  64         , Option "i" ["input"]
  65          (ReqArg (\s _context ctx -> do
  66                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  67          "read data from given file, can be use multiple times"
  68         , Option "" ["align"]
  69          (OptArg (\arg context ctx -> do
  70                 ctx_align <- case arg of
  71                  Nothing    -> return $ True
  72                  Just "yes" -> return $ True
  73                  Just "no"  -> return $ False
  74                  Just _     -> Write.fatal context $
  75                         W.text "--align option expects \"yes\", or \"no\" as value"
  76                 return $ ctx{ctx_align})
  77           "[yes|no]")
  78          "align output"
  79         ]
  80
  81 run :: Context.Context -> [String] -> IO ()
  82 run context args = do
  83         (ctx, text_filters) <- Args.parse context usage options (nil, args)
  84         read_journals <- do
  85                 CLI.Ledger.paths context $ ctx_input ctx
  86                 >>= do
  87                         mapM $ \path -> do
  88                                 liftIO $ runExceptT $ Ledger.Read.file path
  89                                 >>= \x -> case x of
  90                                  Left  ko -> return $ Left (path, ko)
  91                                  Right ok -> return $ Right ok
  92                 >>= return . Data.Either.partitionEithers
  93         case read_journals of
  94          (errs@(_:_), _journals) ->
  95                 (flip mapM_) errs $ \(_path, err) -> do
  96                         Write.fatal context $ err
  97          ([], journals) -> do
  98                 (filters::[Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)]) <-
  99                         (flip mapM) text_filters $ \s ->
 100                                 liftIO $ Filter.Read.read Filter.Read.test_transaction s
 101                                 >>= \f -> case f of
 102                                  Left  ko -> Write.fatal context $ ko
 103                                  Right ok -> return ok
 104                 Write.debug context $ "transaction_filter: " ++ show filters
 105                 style_color <- Write.with_color context IO.stdout
 106                 let sty = Ledger.Write.Style
 107                          { Ledger.Write.style_align = ctx_align ctx
 108                          , Ledger.Write.style_color
 109                          }
 110                 let transactions =
 111                         foldr
 112                          (Ledger.Journal.fold
 113                                  (flip (foldr
 114                                          (flip (foldr
 115                                                  (\tr ->
 116                                                         case Filter.test
 117                                                          (foldr Filter.And Filter.Any filters) tr of
 118                                                          False -> id
 119                                                          True  -> (:) tr
 120                                                  ))))
 121                                  . Ledger.journal_transactions))
 122                          []
 123                          journals
 124                 Ledger.Write.put sty IO.stdout $ do
 125                 Ledger.Write.transactions transactions