cli/Hcompta/CLI/Command.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE TupleSections #-}
   4 module Hcompta.CLI.Command where
   5
   6 import           Control.Monad (Monad(..))
   7 import           Data.Bool
   8 import           Data.List ((++))
   9 import           Data.Maybe (Maybe(..), fromMaybe)
  10 import           Data.Monoid ((<>))
  11 import           Data.Ord (Ord(..))
  12 import           Data.String (String)
  13 import qualified Data.Text.Lazy as TL
  14 import           Prelude (($), (.), Bounded(..), Enum(..), IO, unlines)
  15 import           System.Console.GetOpt
  16                  ( ArgDescr(..)
  17                  , OptDescr(..)
  18                  , usageInfo )
  19 import           System.Environment (getProgName)
  20 import           System.Exit (exitSuccess)
  21 import qualified System.IO as IO
  22
  23 import qualified Hcompta.CLI.Args as Args
  24 import qualified Hcompta.CLI.Command.Balance as Command.Balance
  25 import qualified Hcompta.CLI.Command.GL as Command.GL
  26 import qualified Hcompta.CLI.Command.Journal as Command.Journal
  27 import qualified Hcompta.CLI.Command.Journals as Command.Journals
  28 import qualified Hcompta.CLI.Command.Stats as Command.Stats
  29 import qualified Hcompta.CLI.Command.Tags as Command.Tags
  30 import           Hcompta.CLI.Context (Context)
  31 import qualified Hcompta.CLI.Context as Context
  32 import qualified Hcompta.CLI.Lang as Lang
  33 import qualified Hcompta.CLI.Write as Write
  34 import qualified Hcompta.Lib.Leijen as W
  35
  36 usage :: IO String
  37 usage = do
  38         bin <- getProgName
  39         return $ unlines $
  40                 [ "SYNTAX "
  41                 , "  "++bin++" [option..] <command> [arguments]"
  42                 , ""
  43                 , usageInfo "OPTIONS" options
  44                 , "COMMANDS (use "++bin++" <command> --help for specific help)"
  45                 , "  balance  [-i JOURNAL_FILE]"
  46                 , "           [-b BALANCE_FILTER]"
  47                 , "           [-p POSTING_FILTER]"
  48                 , "           [-t TRANSACTION_FILTER]"
  49                 , "           [JOURNAL_FILE] [...]"
  50                 , "  gl       [-i JOURNAL_FILE]"
  51                 , "           [-g GL_FILTER]"
  52                 , "           [-p POSTING_FILTER]"
  53                 , "           [-t TRANSACTION_FILTER]"
  54                 , "           [JOURNAL_FILE] [...]"
  55                 , "  journal  [-i JOURNAL_FILE]"
  56                 , "           [-t TRANSACTION_FILTER]"
  57                 , "           [JOURNAL_FILE] [...]"
  58                 , "  journals [-i JOURNAL_FILE]"
  59                 , "           [JOURNAL_FILE] [...]"
  60                 , "  stats    [-i JOURNAL_FILE]"
  61                 , "           [-t TRANSACTION_FILTER]"
  62                 , "           [JOURNAL_FILE] [...]"
  63                 , "  tags     [-i JOURNAL_FILE]"
  64                 , "           [-t TRANSACTION_FILTER]"
  65                 , "           [JOURNAL_FILE] [...]"
  66                 ]
  67
  68 options :: Args.Options Context
  69 options =
  70         [ Option "h" ["help"]
  71          (NoArg (\_opts _context -> do
  72                 usage >>= IO.hPutStr IO.stderr
  73                 exitSuccess))
  74          "show this help"
  75         , Option "v" ["verbosity"]
  76          (OptArg (\arg _context context ->
  77                 case arg of
  78                  Nothing      ->
  79                         case Context.verbosity context of
  80                          v | v < maxBound ->
  81                                 return $ context{Context.verbosity=succ v}
  82                          _ -> return $ context
  83                  Just "error" -> return $ context{Context.verbosity=Context.Verbosity_Error}
  84                  Just "warn"  -> return $ context{Context.verbosity=Context.Verbosity_Warn}
  85                  Just "info"  -> return $ context{Context.verbosity=Context.Verbosity_Info}
  86                  Just "debug" -> return $ context{Context.verbosity=Context.Verbosity_Debug}
  87                  Just _       -> Write.fatal context $
  88                         W.text "--verbosity option expects \"error\", \"warn\", \"info\", or \"debug\" as value")
  89                 "error|warn|info|debug"
  90                 )
  91          "increment or set verbosity level, can be use multiple times"
  92         , Option "" ["color"]
  93          (OptArg (\arg _context context -> do
  94                 color <- case arg of
  95                  Nothing     -> return $ Just True
  96                  Just "yes"  -> return $ Just True
  97                  Just "no"   -> return $ Just False
  98                  Just "auto" -> return $ Nothing
  99                  Just _      -> Write.fatal context $
 100                         W.text "--color option expects \"auto\" (default), \"yes\", or \"no\" as value"
 101                 return $ context{Context.color})
 102           "[auto|yes|no]")
 103          "colorize output"
 104         , Option "" ["lang"]
 105          (ReqArg (\lang _context context -> do
 106                 return $ context{Context.lang =
 107                         fromMaybe (Context.lang context) $
 108                         Lang.lang_of_strings [lang]
 109                  })
 110           "[xx|xx-XX]")
 111          "RFC1766 / ISO 639-1 language code (eg, fr, en-GB, etc.)"
 112         ]
 113
 114 run :: Context -> String -> [String] -> IO ()
 115 run context cmd args =
 116         case cmd of
 117          "balance"  -> Command.Balance.run  context args
 118          "gl"       -> Command.GL.run       context args
 119          "journal"  -> Command.Journal.run  context args
 120          "journals" -> Command.Journals.run context args
 121          "stats"    -> Command.Stats.run    context args
 122          "tags"     -> Command.Tags.run     context args
 123          _ -> usage >>= Write.fatal context .
 124                 ((W.text "unknown command: " <> (W.text $ TL.pack cmd) <> W.line) <>) .
 125                 W.text . TL.pack