module Hledger.Cli.Options (
mainmode,
activitymode,
addmode,
balancemode,
balancesheetmode,
cashflowmode,
incomestatementmode,
printmode,
registermode,
statsmode,
testmode,
convertmode,
defCommandMode,
argsFlag,
helpflags,
inputflags,
reportflags,
generalflagsgroup1,
generalflagsgroup2,
generalflagsgroup3,
RawOpts,
inRawOpts,
boolopt,
intopt,
maybeintopt,
stringopt,
maybestringopt,
listofstringopt,
setopt,
setboolopt,
CliOpts(..),
defcliopts,
aliasesFromOpts,
formatFromOpts,
journalFilePathFromOpts,
rulesFilePathFromOpts,
OutputWidth(..),
Width(..),
defaultWidth,
defaultWidthWithFlag,
widthFromOpts,
getHledgerAddonCommands,
argsToCliOpts,
moveFlagsAfterCommand,
decodeRawOpts,
checkCliOpts,
rawOptsToCliOpts,
optserror,
showModeHelp,
debugArgs,
getCliOpts,
tests_Hledger_Cli_Options
)
where
import qualified Control.Exception as C
import Control.Monad (when)
import Data.Char (isDigit)
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Time.Calendar
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
import Test.HUnit
import Text.ParserCombinators.Parsec as P
import Text.Printf
import Hledger
import Hledger.Data.FormatStrings as Format
import Hledger.Cli.Version
type RawOpts = [(String,String)]
helpflags = [
flagNone ["help","h","?"] (setboolopt "help") "Display general help or (with --help after COMMAND) command help."
,flagOpt "1" ["debug"] (\s opts -> Right $ setopt "debug" s opts) "N" "Show debug output (optional argument sets debug level)"
,flagNone ["version"] (setboolopt "version") "Print version information"
]
inputflags = [
flagReq ["file","f"] (\s opts -> Right $ setopt "file" s opts) "FILE" "use a different journal file; - means stdin"
,flagReq ["rules-file"] (\s opts -> Right $ setopt "rules-file" s opts) "RULESFILE" "conversion rules for CSV (default: FILE.rules)"
,flagReq ["alias"] (\s opts -> Right $ setopt "alias" s opts) "ACCT=ALIAS" "convert ACCT's name to ALIAS"
]
reportflags = [
flagReq ["begin","b"] (\s opts -> Right $ setopt "begin" s opts) "DATE" "report on transactions on or after this date"
,flagReq ["end","e"] (\s opts -> Right $ setopt "end" s opts) "DATE" "report on transactions before this date"
,flagReq ["period","p"] (\s opts -> Right $ setopt "period" s opts) "PERIODEXP" "report on transactions during the specified period and/or with the specified reporting interval"
,flagNone ["daily","D"] (\opts -> setboolopt "daily" opts) "report by day"
,flagNone ["weekly","W"] (\opts -> setboolopt "weekly" opts) "report by week"
,flagNone ["monthly","M"] (\opts -> setboolopt "monthly" opts) "report by month"
,flagNone ["quarterly","Q"] (\opts -> setboolopt "quarterly" opts) "report by quarter"
,flagNone ["yearly","Y"] (\opts -> setboolopt "yearly" opts) "report by year"
,flagNone ["cleared","C"] (\opts -> setboolopt "cleared" opts) "report only on cleared transactions"
,flagNone ["uncleared","U"] (\opts -> setboolopt "uncleared" opts) "report only on uncleared transactions"
,flagNone ["cost","B"] (\opts -> setboolopt "cost" opts) "report cost of commodities"
,flagReq ["depth"] (\s opts -> Right $ setopt "depth" s opts) "N" "hide accounts/transactions deeper than this"
,flagReq ["display","d"] (\s opts -> Right $ setopt "display" s opts) "DISPLAYEXP" "show only transactions matching the expression, which is 'dOP[DATE]' where OP is <, <=, =, >=, >"
,flagNone ["date2","aux-date","effective"] (\opts -> setboolopt "date2" opts) "use transactions' secondary dates, if any"
,flagNone ["empty","E"] (\opts -> setboolopt "empty" opts) "show empty/zero things which are normally elided"
,flagNone ["real","R"] (\opts -> setboolopt "real" opts) "report only on real (non-virtual) transactions"
]
argsFlag desc = flagArg (\s opts -> Right $ setopt "args" s opts) desc
generalflagstitle = "\nGeneral flags"
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") "Display command help."
]
,groupHidden = []
}
,modeArgs = ([], Nothing)
,modeGroupModes = toGroup []
}
defCommandMode names = defMode {
modeNames=names
,modeValue=[("command", headDef "" names)]
,modeArgs = ([], Just $ argsFlag "[PATTERNS]")
}
defAddonCommandMode addon = defMode {
modeNames = [addon]
,modeHelp = printf "run %s-%s" progname addon
,modeValue=[("command",addon)]
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
,modeArgs = ([], Just $ argsFlag "[ARGS]")
}
withAliases :: String -> [String] -> String
s `withAliases` [] = s
s `withAliases` (a:[]) = s ++ " (alias: " ++ a ++ ")"
s `withAliases` as = s ++ " (aliases: " ++ intercalate ", " as ++ ")"
mainmode addons = defMode {
modeNames = [progname]
,modeHelp = unlines [
"run the specified hledger command. Commands:"
]
,modeHelpSuffix = [""]
,modeArgs = ([], Just $ argsFlag "[ARGS]")
,modeGroupModes = Group {
groupNamed = [
("Adding data", [
addmode
])
,("\nBasic reports", [
printmode
,balancemode
,registermode
])
,("\nMore reports", [
activitymode
,incomestatementmode
,balancesheetmode
,cashflowmode
,statsmode
])
,("\nMiscellaneous", [
testmode
])
]
++ case addons of [] -> []
cs -> [("\nAdd-on commands found", map defAddonCommandMode cs)]
,groupUnnamed = [
]
,groupHidden = [
convertmode
]
}
,modeGroupFlags = Group {
groupNamed = [generalflagsgroup3]
,groupUnnamed = []
,groupHidden = inputflags
}
}
addmode = (defCommandMode ["add"]) {
modeHelp = "prompt for new transaction entries and add them to the journal"
,modeHelpSuffix = ["Defaults come from previous similar transactions; use query patterns to restrict these."]
,modeGroupFlags = Group {
groupUnnamed = [
flagNone ["no-new-accounts"] (\opts -> setboolopt "no-new-accounts" opts) "don't allow creating new accounts"
]
,groupHidden = []
,groupNamed = [generalflagsgroup2]
}
}
balancemode = (defCommandMode $ ["balance"] ++ aliases) {
modeHelp = "show matched accounts and their balances" `withAliases` aliases
,modeGroupFlags = Group {
groupUnnamed = [
flagNone ["cumulative"] (\opts -> setboolopt "cumulative" opts) "with a reporting interval, show accumulated totals starting from 0"
,flagNone ["historical","H"] (\opts -> setboolopt "historical" opts) "with a reporting interval, show accurate historical ending balances"
,flagNone ["flat"] (\opts -> setboolopt "flat" opts) "show full account names, unindented"
,flagReq ["drop"] (\s opts -> Right $ setopt "drop" s opts) "N" "with --flat, omit this many leading account name components"
,flagReq ["format"] (\s opts -> Right $ setopt "format" s opts) "FORMATSTR" "use this custom line format"
,flagNone ["no-elide"] (\opts -> setboolopt "no-elide" opts) "no eliding at all, stronger than --empty"
,flagNone ["no-total"] (\opts -> setboolopt "no-total" opts) "don't show the final total"
]
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
}
where aliases = ["b","bal"]
printmode = (defCommandMode $ ["print"] ++ aliases) {
modeHelp = "show matched journal entries" `withAliases` aliases
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
}
where aliases = ["p"]
registermode = (defCommandMode $ ["register"] ++ aliases) {
modeHelp = "show matched postings and running total" `withAliases` aliases
,modeGroupFlags = Group {
groupUnnamed = [
flagOpt (show defaultWidthWithFlag) ["width","w"] (\s opts -> Right $ setopt "width" s opts) "N" "increase or set the output width (default: 80)"
,flagNone ["average","A"] (\opts -> setboolopt "average" opts) "show the running average instead of the running total"
,flagNone ["related","r"] (\opts -> setboolopt "related" opts) "show the other postings in the transactions of those that would have been shown"
]
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
}
where aliases = ["r","reg"]
activitymode = (defCommandMode ["activity"]) {
modeHelp = "show a barchart of transactions per interval"
,modeHelpSuffix = ["The default interval is daily."]
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
}
incomestatementmode = (defCommandMode $ ["incomestatement"]++aliases) {
modeHelp = "show a simple income statement" `withAliases` aliases
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
}
where aliases = ["is","pl"]
balancesheetmode = (defCommandMode $ ["balancesheet"]++aliases) {
modeHelp = "show a simple balance sheet" `withAliases` aliases
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
}
where aliases = ["bs"]
cashflowmode = (defCommandMode ["cashflow","cf"]) {
modeHelp = "show a simple cashflow statement" `withAliases` ["cf"]
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
}
statsmode = (defCommandMode $ ["stats"] ++ aliases) {
modeHelp = "show quick statistics for a journal" `withAliases` aliases
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
}
where aliases = ["s"]
testmode = (defCommandMode ["test"]) {
modeHelp = "run self-tests, or just the ones matching REGEXPS"
,modeArgs = ([], Just $ argsFlag "[REGEXPS]")
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [generalflagsgroup3]
}
}
convertmode = (defCommandMode ["convert"]) {
modeValue = [("command","convert")]
,modeHelp = "convert is no longer needed, just use -f FILE.csv"
,modeArgs = ([], Just $ argsFlag "[CSVFILE]")
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = helpflags
,groupNamed = []
}
}
data CliOpts = CliOpts {
rawopts_ :: RawOpts
,command_ :: String
,file_ :: Maybe FilePath
,rules_file_ :: Maybe FilePath
,alias_ :: [String]
,debug_ :: Int
,no_new_accounts_ :: Bool
,width_ :: Maybe String
,reportopts_ :: ReportOpts
} deriving (Show, Data, Typeable)
defcliopts = CliOpts
def
def
def
def
def
def
def
def
def
instance Default CliOpts where def = defcliopts
rawOptsToCliOpts :: RawOpts -> IO CliOpts
rawOptsToCliOpts rawopts = do
d <- getCurrentDay
return defcliopts {
rawopts_ = rawopts
,command_ = stringopt "command" rawopts
,file_ = maybestringopt "file" rawopts
,rules_file_ = maybestringopt "rules-file" rawopts
,alias_ = map stripquotes $ listofstringopt "alias" rawopts
,debug_ = intopt "debug" rawopts
,no_new_accounts_ = boolopt "no-new-accounts" rawopts
,width_ = maybestringopt "width" rawopts
,reportopts_ = defreportopts {
begin_ = maybesmartdateopt d "begin" rawopts
,end_ = maybesmartdateopt d "end" rawopts
,period_ = maybeperiodopt d rawopts
,cleared_ = boolopt "cleared" rawopts
,uncleared_ = boolopt "uncleared" rawopts
,cost_ = boolopt "cost" rawopts
,depth_ = maybeintopt "depth" rawopts
,display_ = maybedisplayopt d rawopts
,date2_ = boolopt "date2" rawopts
,empty_ = boolopt "empty" rawopts
,no_elide_ = boolopt "no-elide" rawopts
,real_ = boolopt "real" rawopts
,balancetype_ = balancetypeopt rawopts
,flat_ = boolopt "flat" rawopts
,drop_ = intopt "drop" rawopts
,no_total_ = boolopt "no-total" rawopts
,daily_ = boolopt "daily" rawopts
,weekly_ = boolopt "weekly" rawopts
,monthly_ = boolopt "monthly" rawopts
,quarterly_ = boolopt "quarterly" rawopts
,yearly_ = boolopt "yearly" rawopts
,format_ = maybestringopt "format" rawopts
,average_ = boolopt "average" rawopts
,related_ = boolopt "related" rawopts
,query_ = unwords $ listofstringopt "args" rawopts
}
}
argsToCliOpts :: [String] -> [String] -> IO CliOpts
argsToCliOpts args addons = do
let
args' = moveFlagsAfterCommand args
cmdargsopts = System.Console.CmdArgs.Explicit.processValue (mainmode addons) args'
cmdargsopts' = decodeRawOpts cmdargsopts
rawOptsToCliOpts cmdargsopts' >>= checkCliOpts
moveFlagsAfterCommand :: [String] -> [String]
moveFlagsAfterCommand args = move args
where
move (f:a:as) | isMovableNoArgFlag f = (move $ a:as) ++ [f]
move (f:v:a:as) | isMovableReqArgFlag f = (move $ a:as) ++ [f,v]
move (fv:a:as) | isMovableReqArgFlagAndValue fv = (move $ a:as) ++ [fv]
move ("--debug":v:a:as) | not (null v) && all isDigit v = (move $ a:as) ++ ["--debug",v]
move ("--debug":a:as) = (move $ a:as) ++ ["--debug"]
move (fv@('-':'-':'d':'e':'b':'u':'g':'=':_):a:as) = (move $ a:as) ++ [fv]
move as = as
isMovableNoArgFlag a = "-" `isPrefixOf` a && dropWhile (=='-') a `elem` noargflagstomove
isMovableReqArgFlag a = "-" `isPrefixOf` a && dropWhile (=='-') a `elem` reqargflagstomove
isMovableReqArgFlagAndValue ('-':'-':a:as) = case break (== '=') (a:as) of (f:fs,_) -> (f:fs) `elem` reqargflagstomove
_ -> False
isMovableReqArgFlagAndValue ('-':f:_:_) = [f] `elem` reqargflagstomove
isMovableReqArgFlagAndValue _ = False
noargflagstomove = concatMap flagNames $ filter ((==FlagNone).flagInfo) flagstomove
reqargflagstomove = concatMap flagNames $ filter ((==FlagReq ).flagInfo) flagstomove
flagstomove = inputflags ++ helpflags
decodeRawOpts = map (\(name,val) -> (name, fromSystemString val))
checkCliOpts :: CliOpts -> IO CliOpts
checkCliOpts opts@CliOpts{reportopts_=ropts} = do
case formatFromOpts 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
getHledgerAddonCommands :: IO [String]
getHledgerAddonCommands = map (drop (length progname + 1)) `fmap` getHledgerExesInPath
getHledgerExesInPath :: IO [String]
getHledgerExesInPath = do
pathdirs <- splitOn ":" `fmap` getEnvSafe "PATH"
pathfiles <- concat `fmap` mapM getDirectoryContentsSafe pathdirs
let hledgernamed = nub $ sort $ filter isHledgerNamed pathfiles
return hledgernamed
isHledgerNamed = isRight . parsewith (do
string progname
char '-'
many1 (letter <|> char '-')
optional $ (string ".hs" <|> string ".lhs")
eof
)
getEnvSafe v = getEnv v `C.catch` (\(_::C.IOException) -> return "")
getDirectoryContentsSafe d = getDirectoryContents d `C.catch` (\(_::C.IOException) -> return [])
optserror = error' . (++ " (run with --help for usage)")
setopt name val = (++ [(name,singleQuoteIfNeeded val)])
setboolopt name = (++ [(name,"")])
inRawOpts :: String -> RawOpts -> Bool
inRawOpts name = isJust . lookup name
boolopt = inRawOpts
maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name
stringopt name = fromMaybe "" . maybestringopt name
listofstringopt name rawopts = [v | (k,v) <- rawopts, k==name]
maybeintopt :: String -> RawOpts -> Maybe Int
maybeintopt name rawopts =
let ms = maybestringopt name rawopts in
case ms of Nothing -> Nothing
Just s -> Just $ readDef (optserror $ "could not parse "++name++" number: "++s) s
intopt name = fromMaybe 0 . maybeintopt name
maybesmartdateopt :: Day -> String -> RawOpts -> Maybe Day
maybesmartdateopt d name rawopts =
case maybestringopt name rawopts of
Nothing -> Nothing
Just s -> either
(\e -> optserror $ "could not parse "++name++" date: "++show e)
Just
$ fixSmartDateStrEither' d s
maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp
maybedisplayopt d rawopts =
maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts
where
fixbracketeddatestr "" = ""
fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]"
maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan)
maybeperiodopt d rawopts =
case maybestringopt "period" rawopts of
Nothing -> Nothing
Just s -> either
(\e -> optserror $ "could not parse period option: "++show e)
Just
$ parsePeriodExpr d s
balancetypeopt :: RawOpts -> BalanceType
balancetypeopt rawopts
| length [o | o <- ["cumulative","historical"], isset o] > 1
= optserror "please specify at most one of --cumulative and --historical"
| isset "cumulative" = CumulativeBalance
| isset "historical" = HistoricalBalance
| otherwise = PeriodBalance
where
isset = flip boolopt rawopts
formatFromOpts :: ReportOpts -> Either String [FormatString]
formatFromOpts = maybe (Right defaultBalanceFormatString) parseFormatString . format_
defaultBalanceFormatString :: [FormatString]
defaultBalanceFormatString = [
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 = 80
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 () "(unknown)") s of
Left e -> Left $ show e
Right x -> Right x
outputwidthp :: GenParser Char st OutputWidth
outputwidthp =
try (do w <- widthp
ws <- many1 (char ',' >> widthp)
return $ FieldWidths $ w:ws)
<|> TotalWidth `fmap` widthp
widthp :: GenParser Char st Width
widthp = (string "auto" >> return Auto)
<|> (Width . read) `fmap` many1 digit
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
rulesFilePathFromOpts :: CliOpts -> IO (Maybe FilePath)
rulesFilePathFromOpts opts = do
d <- getCurrentDirectory
maybe (return Nothing) (fmap Just . expandPath d) $ rules_file_ opts
showModeHelp :: Mode a -> String
showModeHelp =
(showText defaultWrap :: [Text] -> String)
.
(helpText [] HelpFormatDefault :: Mode a -> [Text])
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)
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
tests_Hledger_Cli_Options = TestList
[
]