cli/Hcompta/CLI/Command/Print.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 module Hcompta.CLI.Command.Print where
   3
   4 import           Control.Arrow (first)
   5 import           Control.Applicative ((<$>))
   6 import           Control.Monad.IO.Class (liftIO)
   7 import           Control.Monad.Trans.Except (runExceptT)
   8 import qualified Data.Either
   9 import           System.Console.GetOpt
  10                  ( ArgDescr(..)
  11                  , OptDescr(..)
  12                  , usageInfo )
  13 import           System.Environment as Env (getProgName)
  14 import           System.Exit (exitWith, ExitCode(..))
  15 import qualified System.IO as IO
  16
  17 import qualified Hcompta.CLI.Args as Args
  18 import qualified Hcompta.CLI.Context as Context
  19 import qualified Hcompta.CLI.Write as Write
  20 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  21 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  22 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  23 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  24
  25 data Ctx
  26  =   Ctx
  27  { ctx_input :: [FilePath]
  28  } deriving (Eq, Show)
  29
  30 nil :: Ctx
  31 nil =
  32         Ctx
  33          { ctx_input = []
  34          }
  35
  36 usage :: IO String
  37 usage = do
  38         bin <- Env.getProgName
  39         return $unlines $
  40                 [ "SYNTAX "
  41                 , "  "++bin++" print [option..]"
  42                 , ""
  43                 , usageInfo "OPTIONS" options
  44                 ]
  45
  46 options :: Args.Options Ctx
  47 options =
  48         [ Option "h" ["help"]
  49          (NoArg (\_context _ctx -> do
  50                 usage >>= IO.hPutStr IO.stderr
  51                 exitWith ExitSuccess))
  52          "show this help"
  53         , Option "i" ["input"]
  54          (ReqArg (\s _context ctx -> do
  55                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  56          "read data from given file, can be use multiple times"
  57         ]
  58
  59 run :: Context.Context -> [String] -> IO ()
  60 run context args = do
  61         (ctx, _) <-
  62                 first (\ctx -> ctx{ctx_input=reverse $ ctx_input ctx}) <$>
  63                 Args.parse context usage options (nil, args)
  64         CLI.Ledger.paths context $ ctx_input ctx
  65         >>= do mapM $ \path -> do
  66                 liftIO $ runExceptT $
  67                         Ledger.Read.file path
  68                 >>= \x -> case x of
  69                  Left  ko -> return $ Left (path, ko)
  70                  Right ok -> return $ Right ok
  71         >>= return . Data.Either.partitionEithers
  72         >>= \x -> case x of
  73          (kos@(_:_), _oks) ->
  74                 (flip mapM_) kos $ \(_path, ko) -> Write.fatal context ko
  75          ([], journals) -> do
  76                 with_color <- Write.with_color context IO.stdout
  77                 let journal = Ledger.Journal.flatten $ Ledger.Journal.unions journals
  78                 Ledger.Write.put with_color IO.stdout $ do
  79                 Ledger.Write.journal journal