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           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  32 import qualified Hcompta.Model.Filter as Filter
  33 import qualified Hcompta.Model.Filter.Read as Filter.Read
  34
  35 data Ctx
  36  =   Ctx
  37  { ctx_input :: [FilePath]
  38  , ctx_align :: Bool
  39  } deriving (Eq, Show)
  40
  41 nil :: Ctx
  42 nil =
  43         Ctx
  44          { ctx_input = []
  45          , ctx_align = True
  46          }
  47
  48 usage :: IO String
  49 usage = do
  50         bin <- Env.getProgName
  51         return $unlines $
  52                 [ "SYNTAX "
  53                 , "  "++bin++" print [option..]"
  54                 , ""
  55                 , usageInfo "OPTIONS" options
  56                 ]
  57
  58 options :: Args.Options Ctx
  59 options =
  60         [ Option "h" ["help"]
  61          (NoArg (\_context _ctx -> do
  62                 usage >>= IO.hPutStr IO.stderr
  63                 exitWith ExitSuccess))
  64          "show this help"
  65         , Option "i" ["input"]
  66          (ReqArg (\s _context ctx -> do
  67                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  68          "read data from given file, can be use multiple times"
  69         , Option "" ["align"]
  70          (OptArg (\arg context ctx -> do
  71                 ctx_align <- case arg of
  72                  Nothing    -> return $ True
  73                  Just "yes" -> return $ True
  74                  Just "no"  -> return $ False
  75                  Just _     -> Write.fatal context $
  76                         W.text "--align option expects \"yes\", or \"no\" as value"
  77                 return $ ctx{ctx_align})
  78           "[yes|no]")
  79          "align output"
  80         ]
  81
  82 run :: Context.Context -> [String] -> IO ()
  83 run context args = do
  84         (ctx, text_filters) <- Args.parse context usage options (nil, args)
  85         read_journals <- do
  86                 CLI.Ledger.paths context $ ctx_input ctx
  87                 >>= do
  88                         mapM $ \path -> do
  89                                 liftIO $ runExceptT $ Ledger.Read.file path
  90                                 >>= \x -> case x of
  91                                  Left  ko -> return $ Left (path, ko)
  92                                  Right ok -> return $ Right ok
  93                 >>= return . Data.Either.partitionEithers
  94         case read_journals of
  95          (errs@(_:_), _journals) ->
  96                 (flip mapM_) errs $ \(_path, err) -> do
  97                         Write.fatal context $ toDoc context err
  98          ([], journals) -> do
  99                 (filters::[Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)]) <-
 100                         (flip mapM) text_filters $ \s ->
 101                                 case Filter.Read.read Filter.Read.test_transaction s of
 102                                  Left  ko -> Write.fatal context $ toDoc context ko
 103                                  Right ok -> return ok
 104                 Write.debug context $ 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