module Hledger.Cli.Options (
helpflags,
detailedversionflag,
inputflags,
reportflags,
outputflags,
generalflagsgroup1,
generalflagsgroup2,
generalflagsgroup3,
defMode,
defCommandMode,
defAddonCommandMode,
argsFlag,
showModeHelp,
withAliases,
CliOpts(..),
defcliopts,
getCliOpts,
decodeRawOpts,
rawOptsToCliOpts,
checkCliOpts,
outputFormats,
defaultOutputFormat,
aliasesFromOpts,
journalFilePathFromOpts,
rulesFilePathFromOpts,
outputFileFromOpts,
outputFormatFromOpts,
OutputWidth(..),
Width(..),
defaultWidth,
defaultWidthWithFlag,
widthFromOpts,
maybeAccountNameDrop,
lineFormatFromOpts,
hledgerAddons,
tests_Hledger_Cli_Options
)
where
import Control.Applicative ((<$>), (<*))
import qualified Control.Exception as C
import Control.Monad (when)
import Data.List
import Data.Maybe
import Safe
import System.Console.CmdArgs
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Text
import System.Directory
import System.Environment
import System.Exit (exitSuccess)
import System.FilePath
import Test.HUnit
import Text.Parsec
import Hledger
import Hledger.Data.OutputFormat as OutputFormat
import Hledger.Cli.Version
helpflags :: [Flag RawOpts]
helpflags = [
flagNone ["help","h"] (setboolopt "help") "show general help or (after command) command help"
,flagReq ["debug"] (\s opts -> Right $ setopt "debug" s opts) "N" "show debug output if N is 1-9 (default: 0)"
,flagNone ["version"] (setboolopt "version") "show version information"
]
detailedversionflag :: Flag RawOpts
detailedversionflag = flagNone ["version+"] (setboolopt "version+") "show version information with extra detail"
inputflags :: [Flag RawOpts]
inputflags = [
flagReq ["file","f"] (\s opts -> Right $ setopt "file" s opts) "FILE" "use a different input file. For stdin, use -"
,flagReq ["rules-file"] (\s opts -> Right $ setopt "rules-file" s opts) "RFILE" "CSV conversion rules file (default: FILE.rules)"
,flagReq ["alias"] (\s opts -> Right $ setopt "alias" s opts) "OLD=NEW" "display accounts named OLD as NEW"
,flagNone ["ignore-assertions"] (setboolopt "ignore-assertions") "ignore any balance assertions in the journal"
]
reportflags :: [Flag RawOpts]
reportflags = [
flagReq ["begin","b"] (\s opts -> Right $ setopt "begin" s opts) "DATE" "include postings/txns on or after this date"
,flagReq ["end","e"] (\s opts -> Right $ setopt "end" s opts) "DATE" "include postings/txns before this date"
,flagNone ["daily","D"] (setboolopt "daily") "multiperiod/multicolumn report by day"
,flagNone ["weekly","W"] (setboolopt "weekly") "multiperiod/multicolumn report by week"
,flagNone ["monthly","M"] (setboolopt "monthly") "multiperiod/multicolumn report by month"
,flagNone ["quarterly","Q"] (setboolopt "quarterly") "multiperiod/multicolumn report by quarter"
,flagNone ["yearly","Y"] (setboolopt "yearly") "multiperiod/multicolumn report by year"
,flagReq ["period","p"] (\s opts -> Right $ setopt "period" s opts) "PERIODEXP" "set start date, end date, and/or reporting interval all at once (overrides the flags above)"
,flagNone ["date2","aux-date"] (setboolopt "date2") "use postings/txns' secondary dates instead"
,flagNone ["cleared","C"] (setboolopt "cleared") "include only pending/cleared postings/txns"
,flagNone ["uncleared","U"] (setboolopt "uncleared") "include only uncleared postings/txns"
,flagNone ["real","R"] (setboolopt "real") "include only non-virtual postings"
,flagReq ["depth"] (\s opts -> Right $ setopt "depth" s opts) "N" "hide accounts/postings deeper than N"
,flagNone ["empty","E"] (setboolopt "empty") "show empty/zero things which are normally omitted"
,flagNone ["cost","B"] (setboolopt "cost") "show amounts in their cost price's commodity"
]
outputflags = [
flagReq ["output-file","o"] (\s opts -> Right $ setopt "output-file" s opts) "FILE[.FMT]" "write output to FILE instead of stdout. A recognised FMT suffix influences the format."
,flagReq ["output-format","O"] (\s opts -> Right $ setopt "output-format" s opts) "FMT" "select the output format. Supported formats: txt, csv."
]
argsFlag :: FlagHelp -> Arg RawOpts
argsFlag desc = flagArg (\s opts -> Right $ setopt "args" s opts) desc
generalflagstitle :: String
generalflagstitle = "\nGeneral flags"
generalflagsgroup1, generalflagsgroup2, generalflagsgroup3 :: (String, [Flag RawOpts])
generalflagsgroup1 = (generalflagstitle, inputflags ++ reportflags ++ helpflags)
generalflagsgroup2 = (generalflagstitle, inputflags ++ helpflags)
generalflagsgroup3 = (generalflagstitle, helpflags)
defMode :: Mode RawOpts
defMode = Mode {
modeNames = []
,modeHelp = ""
,modeHelpSuffix = []
,modeValue = []
,modeCheck = Right
,modeReform = const Nothing
,modeExpandAt = True
,modeGroupFlags = Group {
groupNamed = []
,groupUnnamed = [
flagNone ["help","h","?"] (setboolopt "help") "Show command help."
]
,groupHidden = []
}
,modeArgs = ([], Nothing)
,modeGroupModes = toGroup []
}
defCommandMode :: [Name] -> Mode RawOpts
defCommandMode names = defMode {
modeNames=names
,modeValue=[("command", headDef "" names)]
,modeArgs = ([], Just $ argsFlag "[PATTERNS]")
}
defAddonCommandMode :: Name -> Mode RawOpts
defAddonCommandMode addon = defMode {
modeNames = [addon]
,modeHelp = fromMaybe "" $ lookup (stripAddonExtension addon) standardAddonsHelp
,modeValue=[("command",addon)]
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
,modeArgs = ([], Just $ argsFlag "[ARGS]")
}
standardAddonsHelp :: [(String,String)]
standardAddonsHelp = [
("chart", "generate simple balance pie charts")
,("interest", "generate interest transaction entries")
,("irr", "calculate internal rate of return")
,("vty", "start the curses-style interface")
,("web", "start the web interface")
,("accounts", "list account names")
,("balance-csv", "output a balance report as CSV")
,("equity", "show a transaction entry zeroing all accounts")
,("print-unique", "print only transactions with unique descriptions")
,("register-csv", "output a register report as CSV")
,("rewrite", "add specified postings to matched transaction entries")
,("addon", "dummy add-on command for testing")
,("addon2", "dummy add-on command for testing")
,("addon3", "dummy add-on command for testing")
,("addon4", "dummy add-on command for testing")
,("addon5", "dummy add-on command for testing")
,("addon6", "dummy add-on command for testing")
,("addon7", "dummy add-on command for testing")
,("addon8", "dummy add-on command for testing")
,("addon9", "dummy add-on command for testing")
]
showModeHelp :: Mode a -> String
showModeHelp = (showText defaultWrap :: [Text] -> String) .
(helpText [] HelpFormatDefault :: Mode a -> [Text])
withAliases :: String -> [String] -> String
s `withAliases` [] = s
s `withAliases` as = s ++ " (" ++ intercalate ", " as ++ ")"
data CliOpts = CliOpts {
rawopts_ :: RawOpts
,command_ :: String
,file_ :: Maybe FilePath
,rules_file_ :: Maybe FilePath
,output_file_ :: Maybe FilePath
,output_format_ :: Maybe String
,alias_ :: [String]
,ignore_assertions_ :: Bool
,debug_ :: Int
,no_new_accounts_ :: Bool
,width_ :: Maybe String
,reportopts_ :: ReportOpts
} deriving (Show, Data, Typeable)
instance Default CliOpts where def = defcliopts
defcliopts :: CliOpts
defcliopts = CliOpts
def
def
def
def
def
def
def
def
def
def
def
def
decodeRawOpts :: RawOpts -> RawOpts
decodeRawOpts = map (\(name',val) -> (name', fromSystemString val))
rawOptsToCliOpts :: RawOpts -> IO CliOpts
rawOptsToCliOpts rawopts = do
ropts <- rawOptsToReportOpts rawopts
return defcliopts {
rawopts_ = rawopts
,command_ = stringopt "command" rawopts
,file_ = maybestringopt "file" rawopts
,rules_file_ = maybestringopt "rules-file" rawopts
,output_file_ = maybestringopt "output-file" rawopts
,output_format_ = maybestringopt "output-format" rawopts
,alias_ = map stripquotes $ listofstringopt "alias" rawopts
,debug_ = intopt "debug" rawopts
,ignore_assertions_ = boolopt "ignore-assertions" rawopts
,no_new_accounts_ = boolopt "no-new-accounts" rawopts
,width_ = maybestringopt "width" rawopts
,reportopts_ = ropts
}
checkCliOpts :: CliOpts -> IO CliOpts
checkCliOpts opts@CliOpts{reportopts_=ropts} = do
case lineFormatFromOpts ropts of
Left err -> optserror $ "could not parse format option: "++err
Right _ -> return ()
case widthFromOpts opts of
Left err -> optserror $ "could not parse width option: "++err
Right _ -> return ()
return opts
getCliOpts :: Mode RawOpts -> IO CliOpts
getCliOpts mode' = do
args' <- getArgs
let rawopts = decodeRawOpts $ processValue mode' args'
opts <- rawOptsToCliOpts rawopts >>= checkCliOpts
debugArgs args' opts
when ("help" `inRawOpts` rawopts_ opts) $
putStr (showModeHelp mode') >> exitSuccess
return opts
where
debugArgs :: [String] -> CliOpts -> IO ()
debugArgs args' opts =
when ("--debug" `elem` args') $ do
progname' <- getProgName
putStrLn $ "running: " ++ progname'
putStrLn $ "raw args: " ++ show args'
putStrLn $ "processed opts:\n" ++ show opts
d <- getCurrentDay
putStrLn $ "search query: " ++ show (queryFromOpts d $ reportopts_ opts)
aliasesFromOpts :: CliOpts -> [(AccountName,AccountName)]
aliasesFromOpts = map parseAlias . alias_
where
parseAlias :: String -> (AccountName,AccountName)
parseAlias s = (accountNameWithoutPostingType $ strip orig
,accountNameWithoutPostingType $ strip alias')
where
(orig, alias) = break (=='=') s
alias' = case alias of ('=':rest) -> rest
_ -> orig
journalFilePathFromOpts :: CliOpts -> IO String
journalFilePathFromOpts opts = do
f <- defaultJournalPath
d <- getCurrentDirectory
expandPath d $ fromMaybe f $ file_ opts
outputFileFromOpts :: CliOpts -> IO FilePath
outputFileFromOpts opts = do
d <- getCurrentDirectory
case output_file_ opts of
Just p -> expandPath d p
Nothing -> return "-"
defaultOutputFormat = "txt"
outputFormats =
[defaultOutputFormat] ++
["csv"
]
outputFormatFromOpts :: CliOpts -> String
outputFormatFromOpts opts =
case output_format_ opts of
Just f -> f
Nothing ->
case filePathExtension <$> output_file_ opts of
Just ext | ext `elem` outputFormats -> ext
_ -> defaultOutputFormat
filePathExtension :: FilePath -> String
filePathExtension = dropWhile (=='.') . snd . splitExtension . snd . splitFileName
rulesFilePathFromOpts :: CliOpts -> IO (Maybe FilePath)
rulesFilePathFromOpts opts = do
d <- getCurrentDirectory
maybe (return Nothing) (fmap Just . expandPath d) $ rules_file_ opts
lineFormatFromOpts :: ReportOpts -> Either String [OutputFormat]
lineFormatFromOpts = maybe (Right defaultBalanceLineFormat) parseStringFormat . format_
defaultBalanceLineFormat :: [OutputFormat]
defaultBalanceLineFormat = [
FormatField False (Just 20) Nothing TotalField
, FormatLiteral " "
, FormatField True (Just 2) Nothing DepthSpacerField
, FormatField True Nothing Nothing AccountField
]
data OutputWidth =
TotalWidth Width
| FieldWidths [Width]
deriving Show
data Width =
Width Int
| Auto
deriving Show
defaultWidth :: Int
defaultWidth = 80
defaultWidthWithFlag :: Int
defaultWidthWithFlag = 120
widthFromOpts :: CliOpts -> Either String OutputWidth
widthFromOpts CliOpts{width_=Nothing} = Right $ TotalWidth $ Width defaultWidth
widthFromOpts CliOpts{width_=Just ""} = Right $ TotalWidth $ Width defaultWidthWithFlag
widthFromOpts CliOpts{width_=Just s} = parseWidth s
parseWidth :: String -> Either String OutputWidth
parseWidth s = case (runParser (outputwidthp <* eof) () "(unknown)") s of
Left e -> Left $ show e
Right x -> Right x
outputwidthp :: Stream [Char] m t => ParsecT [Char] st m OutputWidth
outputwidthp =
try (do w <- widthp
ws <- many1 (char ',' >> widthp)
return $ FieldWidths $ w:ws)
<|> TotalWidth `fmap` widthp
widthp :: Stream [Char] m t => ParsecT [Char] st m Width
widthp = (string "auto" >> return Auto)
<|> (Width . read) `fmap` many1 digit
maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName
maybeAccountNameDrop opts a | tree_ opts = a
| otherwise = accountNameDrop (drop_ opts) a
hledgerAddons :: IO ([String],[String])
hledgerAddons = do
exes <- hledgerExecutablesInPath
let precisenames =
map stripprefix exes
let displaynames = concatMap stripext $
groupBy (\a b -> dropExtension a == dropExtension b) precisenames
return (precisenames, displaynames)
where
stripprefix = drop (length progname + 1)
stripext [f] = [dropExtension f]
stripext fs = fs
hledgerExecutablesInPath :: IO [String]
hledgerExecutablesInPath = do
pathdirs <- regexSplit "[:;]" `fmap` getEnvSafe "PATH"
pathfiles <- concat `fmap` mapM getDirectoryContentsSafe pathdirs
return $ nub $ sort $ filter isHledgerExeName pathfiles
isHledgerExeName :: String -> Bool
isHledgerExeName = isRight . parsewith hledgerexenamep
where
hledgerexenamep = do
_ <- string progname
_ <- char '-'
_ <- many1 (noneOf ".")
optional (string "." >> choice' (map string addonExtensions))
eof
stripAddonExtension :: String -> String
stripAddonExtension = regexReplace re "" where re = "\\.(" ++ intercalate "|" addonExtensions ++ ")$"
addonExtensions :: [String]
addonExtensions =
["bat"
,"com"
,"exe"
,"hs"
,"lhs"
,"pl"
,"py"
,"rb"
,"rkt"
,"sh"
]
getEnvSafe :: String -> IO String
getEnvSafe v = getEnv v `C.catch` (\(_::C.IOException) -> return "")
getDirectoryContentsSafe :: FilePath -> IO [String]
getDirectoryContentsSafe d =
(filter (not . (`elem` [".",".."])) `fmap` getDirectoryContents d) `C.catch` (\(_::C.IOException) -> return [])
tests_Hledger_Cli_Options :: Test
tests_Hledger_Cli_Options = TestList
[
]