module Hledger.Cli.Options (
helpflags,
inputflags,
reportflags,
generalflagsgroup1,
generalflagsgroup2,
generalflagsgroup3,
defMode,
defCommandMode,
defAddonCommandMode,
argsFlag,
showModeHelp,
withAliases,
CliOpts(..),
defcliopts,
getCliOpts,
decodeRawOpts,
rawOptsToCliOpts,
checkCliOpts,
aliasesFromOpts,
journalFilePathFromOpts,
rulesFilePathFromOpts,
OutputWidth(..),
Width(..),
defaultWidth,
defaultWidthWithFlag,
widthFromOpts,
formatFromOpts,
hledgerAddons,
tests_Hledger_Cli_Options
)
where
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.ParserCombinators.Parsec as P
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"
,flagOpt "1" ["debug"] (\s opts -> Right $ setopt "debug" s opts) "N" "show debug output (increase N for more)"
,flagNone ["version"] (setboolopt "version") "show version information"
]
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"
]
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"] (\opts -> setboolopt "daily" opts) "multiperiod/multicolumn report by day"
,flagNone ["weekly","W"] (\opts -> setboolopt "weekly" opts) "multiperiod/multicolumn report by week"
,flagNone ["monthly","M"] (\opts -> setboolopt "monthly" opts) "multiperiod/multicolumn report by month"
,flagNone ["quarterly","Q"] (\opts -> setboolopt "quarterly" opts) "multiperiod/multicolumn report by quarter"
,flagNone ["yearly","Y"] (\opts -> setboolopt "yearly" opts) "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"] (\opts -> setboolopt "date2" opts) "use postings/txns' secondary dates instead"
,flagNone ["cleared","C"] (\opts -> setboolopt "cleared" opts) "include only cleared postings/txns"
,flagNone ["uncleared","U"] (\opts -> setboolopt "uncleared" opts) "include only uncleared postings/txns"
,flagNone ["real","R"] (\opts -> setboolopt "real" opts) "include only non-virtual postings"
,flagReq ["depth"] (\s opts -> Right $ setopt "depth" s opts) "N" "hide accounts/postings deeper than N"
,flagNone ["empty","E"] (\opts -> setboolopt "empty" opts) "show empty/zero things which are normally omitted"
,flagNone ["cost","B"] (\opts -> setboolopt "cost" opts) "show amounts in their cost price's commodity"
]
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
,alias_ :: [String]
,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
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
,alias_ = map stripquotes $ listofstringopt "alias" rawopts
,debug_ = intopt "debug" 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 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
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
rulesFilePathFromOpts :: CliOpts -> IO (Maybe FilePath)
rulesFilePathFromOpts opts = do
d <- getCurrentDirectory
maybe (return Nothing) (fmap Just . expandPath d) $ rules_file_ opts
formatFromOpts :: ReportOpts -> Either String [OutputFormat]
formatFromOpts = maybe (Right defaultBalanceFormat) parseStringFormat . format_
defaultBalanceFormat :: [OutputFormat]
defaultBalanceFormat = [
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 () "(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
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
[
]