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                                 case Filter.Read.read Filter.Read.test_transaction s of
 101                                  Left  ko -> Write.fatal context $ ko
 102                                  Right ok -> return ok
 103                 Write.debug context $ show filters
 104                 style_color <- Write.with_color context IO.stdout
 105                 let sty = Ledger.Write.Style
 106                          { Ledger.Write.style_align = ctx_align ctx
 107                          , Ledger.Write.style_color
 108                          }
 109                 let transactions =
 110                         foldr
 111                          (Ledger.Journal.fold
 112                                  (flip (foldr
 113                                          (flip (foldr
 114                                                  (\tr ->
 115                                                         case Filter.test
 116                                                          (foldr Filter.And Filter.Any filters) tr of
 117                                                          False -> id
 118                                                          True  -> (:) tr
 119                                                  ))))
 120                                  . Ledger.journal_transactions))
 121                          []
 122                          journals
 123                 Ledger.Write.put sty IO.stdout $ do
 124                 Ledger.Write.transactions transactions