cli/Hcompta/CLI/Command/Print.hs

   1 {-# LANGUAGE LambdaCase #-}
   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 qualified Data.List
  10 import           System.Console.GetOpt
  11                  ( ArgDescr(..)
  12                  , OptDescr(..)
  13                  , usageInfo )
  14 import           System.Environment (getProgName)
  15 import           System.Exit (exitWith, ExitCode(..))
  16 import qualified System.IO as IO
  17
  18 import qualified Hcompta.CLI.Args as Args
  19 import qualified Hcompta.CLI.Context as Context
  20 import qualified Hcompta.CLI.Write as Write
  21 import qualified Hcompta.Format.Ledger.Read
  22 import qualified Hcompta.Format.Ledger.Write
  23 import qualified Hcompta.Format.Ledger.Journal
  24 import qualified Hcompta.Model.Journal
  25
  26 data Ctx
  27  =   Ctx
  28  { ctx_input :: [FilePath]
  29  } deriving (Eq, Show)
  30
  31 nil :: Ctx
  32 nil =
  33         Ctx
  34          { ctx_input = []
  35          }
  36
  37 usage :: IO String
  38 usage = do
  39         bin <- getProgName
  40         return $unlines $
  41                 [ "SYNTAX "
  42                 , "  "++bin++" print [option..]"
  43                 , ""
  44                 , usageInfo "OPTIONS" options
  45                 ]
  46
  47 options :: Args.Options Ctx
  48 options =
  49         [ Option "h" ["help"]
  50          (NoArg (\_ctx -> do
  51                 usage >>= IO.hPutStr IO.stderr
  52                 exitWith ExitSuccess))
  53          "show this help"
  54         , Option "i" ["input"]
  55          (ReqArg (\s ctx -> do
  56                 return $ ctx{ctx_input=s:ctx_input ctx}) "file.ledger")
  57          "read data from given file"
  58         ]
  59
  60 run :: Context.Context -> [String] -> IO ()
  61 run context args = do
  62         (ctx, _) <-
  63                 first (\ctx -> ctx{ctx_input=reverse $ ctx_input ctx}) <$>
  64                 Args.parse context usage options (nil, args)
  65         (flip mapM) (ctx_input ctx) $ \path -> do
  66                 liftIO $ runExceptT $
  67                         Hcompta.Format.Ledger.Read.file path
  68                 >>= \case
  69                  Left  ko -> return $ Left (path, ko)
  70                  Right ok -> return $ Right ok
  71         >>= return . Data.Either.partitionEithers
  72         >>= \case
  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 = Hcompta.Model.Journal.unions $
  78                         Data.List.map Hcompta.Format.Ledger.Journal.to_Model journals
  79                 Hcompta.Format.Ledger.Write.showIO with_color IO.stdout $ do
  80                 Hcompta.Format.Ledger.Write.journal journal