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