cli/Hcompta/CLI/Command/Print.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Hcompta.CLI.Command.Print where
   4
   5 import           Control.Arrow (first)
   6 import           Control.Applicative ((<$>))
   7 import           Control.Monad.IO.Class (liftIO)
   8 import           Control.Monad.Trans.Except (runExceptT)
   9 import qualified Data.Either
  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.Format.Ledger as CLI.Ledger
  21 import qualified Hcompta.CLI.Write as Write
  22 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  23 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  24 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  25 import qualified Hcompta.Lib.Leijen as W
  26
  27 data Ctx
  28  =   Ctx
  29  { ctx_input :: [FilePath]
  30  , ctx_align :: Bool
  31  } deriving (Eq, Show)
  32
  33 nil :: Ctx
  34 nil =
  35         Ctx
  36          { ctx_input = []
  37          , ctx_align = True
  38          }
  39
  40 usage :: IO String
  41 usage = do
  42         bin <- Env.getProgName
  43         return $unlines $
  44                 [ "SYNTAX "
  45                 , "  "++bin++" print [option..]"
  46                 , ""
  47                 , usageInfo "OPTIONS" options
  48                 ]
  49
  50 options :: Args.Options Ctx
  51 options =
  52         [ Option "h" ["help"]
  53          (NoArg (\_context _ctx -> do
  54                 usage >>= IO.hPutStr IO.stderr
  55                 exitWith ExitSuccess))
  56          "show this help"
  57         , Option "i" ["input"]
  58          (ReqArg (\s _context ctx -> do
  59                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  60          "read data from given file, can be use multiple times"
  61         , Option "" ["align"]
  62          (OptArg (\arg context ctx -> do
  63                 ctx_align <- case arg of
  64                  Nothing    -> return $ True
  65                  Just "yes" -> return $ True
  66                  Just "no"  -> return $ False
  67                  Just _     -> Write.fatal context $
  68                         W.text "--align option expects \"yes\", or \"no\" as value"
  69                 return $ ctx{ctx_align})
  70           "[yes|no]")
  71          "align output"
  72         ]
  73
  74 run :: Context.Context -> [String] -> IO ()
  75 run context args = do
  76         (ctx, _) <-
  77                 first (\ctx -> ctx{ctx_input=reverse $ ctx_input ctx}) <$>
  78                 Args.parse context usage options (nil, args)
  79         do
  80                 CLI.Ledger.paths context $ ctx_input ctx
  81                 >>= do mapM $ \path -> do
  82                         liftIO $ runExceptT $
  83                                 Ledger.Read.file path
  84                         >>= \x -> case x of
  85                          Left  ko -> return $ Left (path, ko)
  86                          Right ok -> return $ Right ok
  87                 >>= return . Data.Either.partitionEithers
  88                 >>= \x -> case x of
  89                  (kos@(_:_), _oks) ->
  90                         (flip mapM_) kos $ \(_path, ko) -> Write.fatal context ko
  91                  ([], journals) -> do
  92                         style_color <- Write.with_color context IO.stdout
  93                         let sty = Ledger.Write.Style
  94                                  { Ledger.Write.style_align = ctx_align ctx
  95                                  , Ledger.Write.style_color
  96                                  }
  97                         let journal = Ledger.Journal.flatten $ Ledger.Journal.unions journals
  98                         Ledger.Write.put sty IO.stdout $ do
  99                         Ledger.Write.journal journal