module Hledger.Cli.CliOptions (
helpflags,
detailedversionflag,
inputflags,
reportflags,
outputflags,
generalflagsgroup1,
generalflagsgroup2,
generalflagsgroup3,
defMode,
defCommandMode,
quickAddonCommandMode,
hledgerCommandMode,
argsFlag,
showModeUsage,
withAliases,
CliOpts(..),
defcliopts,
getHledgerCliOpts,
decodeRawOpts,
rawOptsToCliOpts,
checkCliOpts,
outputFormats,
defaultOutputFormat,
defaultBalanceLineFormat,
aliasesFromOpts,
journalFilePathFromOpts,
rulesFilePathFromOpts,
outputFileFromOpts,
outputFormatFromOpts,
defaultWidth,
widthFromOpts,
registerWidthsFromOpts,
maybeAccountNameDrop,
lineFormatFromOpts,
hledgerAddons,
topicForMode,
tests_Hledger_Cli_CliOptions
)
where
import Prelude ()
import Prelude.Compat
import qualified Control.Exception as C
import Control.Monad (when)
import Data.Default
#if !MIN_VERSION_base(4,8,0)
import Data.Functor.Compat ((<$>))
#endif
import Data.Functor.Identity (Identity)
import Data.List.Compat
import Data.List.Split (splitOneOf)
import Data.Ord
import Data.Maybe
import qualified Data.Text as T
import Safe
import System.Console.CmdArgs hiding (Default,def)
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Text
#ifndef mingw32_HOST_OS
import System.Console.Terminfo
#endif
import System.Directory
import System.Environment
import System.Exit (exitSuccess)
import System.FilePath
import Test.HUnit
import Text.Megaparsec.Compat
import Hledger
import Hledger.Cli.DocFiles
import Hledger.Cli.Version
helpflags :: [Flag RawOpts]
helpflags = [
flagNone ["h"] (setboolopt "h") "show general usage (or after CMD, command usage)"
,flagNone ["help"] (setboolopt "help") "show this program's manual as plain text (or after an addon CMD, the add-on's manual)"
,flagNone ["man"] (setboolopt "man") "show this program's manual with man"
,flagNone ["info"] (setboolopt "info") "show this program's manual with info"
,flagReq ["debug"] (\s opts -> Right $ setopt "debug" s opts) "[N]" "show debug output (levels 1-9, default: 1)"
,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 - (default: $LEDGER_FILE or $HOME/.hledger.journal)"
,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" "rename accounts named OLD to NEW"
,flagNone ["anon"] (setboolopt "anon") "anonymize accounts and payees"
,flagReq ["pivot"] (\s opts -> Right $ setopt "pivot" s opts) "TAGNAME" "use some other field/tag for account names"
,flagNone ["ignore-assertions","I"] (setboolopt "ignore-assertions") "ignore any balance assertions"
]
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 report interval all at once (overrides the flags above)"
,flagNone ["date2"] (setboolopt "date2") "show, and make -b/-e/-p/date: match, secondary dates instead"
,flagNone ["unmarked","U"] (setboolopt "unmarked") "include only unmarked postings/txns (can combine with -P or -C)"
,flagNone ["pending","P"] (setboolopt "pending") "include only pending postings/txns"
,flagNone ["cleared","C"] (setboolopt "cleared") "include only cleared 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 items with zero amount, normally hidden"
,flagNone ["cost","B"] (setboolopt "cost") "convert amounts to their cost at transaction time (using the transaction price, if any)"
,flagNone ["value","V"] (setboolopt "value") "convert amounts to their market value on the report end date (using the most recent applicable market price, if any)"
]
outputflags = [
flagReq ["output-format","O"] (\s opts -> Right $ setopt "output-format" s opts) "FMT" "select the output format. Supported formats:\ntxt, csv."
,flagReq ["output-file","o"] (\s opts -> Right $ setopt "output-file" s opts) "FILE" "write output to FILE. A file extension matching one of the above formats selects that format."
]
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 = []
,modeGroupFlags = Group {
groupNamed = []
,groupUnnamed = []
,groupHidden = []
}
,modeArgs = ([], Nothing)
,modeValue = []
,modeCheck = Right
,modeReform = const Nothing
,modeExpandAt = True
,modeGroupModes = toGroup []
}
defCommandMode :: [Name] -> Mode RawOpts
defCommandMode names = defMode {
modeNames=names
,modeGroupFlags = Group {
groupNamed = []
,groupUnnamed = [
flagNone ["h"] (setboolopt "h") "Show usage."
]
,groupHidden = []
}
,modeArgs = ([], Just $ argsFlag "[QUERY]")
,modeValue=[("command", headDef "" names)]
}
quickAddonCommandMode :: Name -> Mode RawOpts
quickAddonCommandMode name = (defCommandMode [name]) {
modeHelp = fromMaybe "" $ lookup (stripAddonExtension name) standardAddonsHelp
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [generalflagsgroup1]
}
}
type HelpTemplate = String
parseHelpTemplate :: HelpTemplate -> Maybe ([Name], String, [String])
parseHelpTemplate t =
case lines t of
[] -> Nothing
(l:ls) -> Just (names, preamble, postamblelines)
where
names = words l
(preamblels, postamblels) = break (== "FLAGS") ls
preamble = unlines $ reverse $ dropWhile null $ reverse preamblels
postamblelines = dropWhile null $ drop 1 postamblels
hledgerCommandMode :: HelpTemplate -> [Flag RawOpts] -> [(Help, [Flag RawOpts])]
-> [Flag RawOpts] -> ([Arg RawOpts], Maybe (Arg RawOpts)) -> Mode RawOpts
hledgerCommandMode tmpl ungroupedflags groupedflags hiddenflags args =
case parseHelpTemplate tmpl of
Nothing -> error' $ "Could not parse help template:\n"++tmpl++"\n"
Just (names, preamble, postamblelines) ->
(defCommandMode names) {
modeHelp = preamble
,modeHelpSuffix = postamblelines
,modeGroupFlags = Group {
groupUnnamed = ungroupedflags
,groupNamed = groupedflags
,groupHidden = hiddenflags
}
,modeArgs = 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")
]
showModeUsage :: Mode a -> String
showModeUsage = (showText defaultWrap :: [Text] -> String) .
(helpText [] HelpFormatDefault :: Mode a -> [Text])
topicForMode :: Mode a -> Topic
topicForMode m
| n == "hledger-ui" = "ui"
| n == "hledger-web" = "web"
| otherwise = "cli"
where n = headDef "" $ modeNames m
withAliases :: String -> [String] -> String
s `withAliases` [] = s
s `withAliases` as = s ++ " (" ++ intercalate ", " as ++ ")"
data CliOpts = CliOpts {
rawopts_ :: RawOpts
,command_ :: String
,file_ :: [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
,available_width_ :: Int
,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
defaultWidth
def
decodeRawOpts :: RawOpts -> RawOpts
decodeRawOpts = map (\(name',val) -> (name', fromSystemString val))
defaultWidth :: Int
defaultWidth = 80
rawOptsToCliOpts :: RawOpts -> IO CliOpts
rawOptsToCliOpts rawopts = checkCliOpts <$> do
ropts <- rawOptsToReportOpts rawopts
mcolumns <- readMay <$> getEnvSafe "COLUMNS"
mtermwidth <-
#ifdef mingw32_HOST_OS
return Nothing
#else
setupTermFromEnv >>= return . flip getCapability termColumns
#endif
let availablewidth = head $ catMaybes [mcolumns, mtermwidth, Just defaultWidth]
return defcliopts {
rawopts_ = rawopts
,command_ = stringopt "command" rawopts
,file_ = map (T.unpack . stripquotes . T.pack) $ listofstringopt "file" rawopts
,rules_file_ = maybestringopt "rules-file" rawopts
,output_file_ = maybestringopt "output-file" rawopts
,output_format_ = maybestringopt "output-format" rawopts
,alias_ = map (T.unpack . stripquotes . T.pack) $ 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
,available_width_ = availablewidth
,reportopts_ = ropts
}
checkCliOpts :: CliOpts -> CliOpts
checkCliOpts opts =
either usageError (const opts) $ do
case lineFormatFromOpts $ reportopts_ opts of
Left err -> Left $ "could not parse format option: "++err
Right _ -> Right ()
getHledgerCliOpts :: Mode RawOpts -> IO CliOpts
getHledgerCliOpts mode' = do
args' <- getArgs
let rawopts = either usageError decodeRawOpts $ process mode' args'
opts <- rawOptsToCliOpts rawopts
debugArgs args' opts
when ("help" `inRawOpts` rawopts_ opts) $ putStr longhelp >> exitSuccess
when ("h" `inRawOpts` rawopts_ opts) $ putStr shorthelp >> exitSuccess
return opts
where
longhelp = showModeUsage mode'
shorthelp =
unlines $
(reverse $ dropWhile null $ reverse $ takeWhile (not . ("flags:" `isInfixOf`)) $ lines longhelp)
++
[""
," See --help for full detail, including common hledger options."
]
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 -> [AccountAlias]
aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp ("--alias "++quoteIfNeeded a) $ T.pack a)
. alias_
journalFilePathFromOpts :: CliOpts -> IO [String]
journalFilePathFromOpts opts = do
f <- defaultJournalPath
d <- getCurrentDirectory
case file_ opts of
[] -> return [f]
fs -> mapM (expandPathPreservingPrefix d) fs
expandPathPreservingPrefix :: FilePath -> PrefixedFilePath -> IO PrefixedFilePath
expandPathPreservingPrefix d prefixedf = do
let (p,f) = splitReaderPrefix prefixedf
f' <- expandPath d f
return $ case p of
Just p -> p ++ ":" ++ f'
Nothing -> f'
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
widthFromOpts :: CliOpts -> Int
widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w
widthFromOpts CliOpts{width_=Just s} =
case runParser (read `fmap` some digitChar <* eof :: ParsecT MPErr String Identity Int) "(unknown)" s of
Left e -> usageError $ "could not parse width option: "++show e
Right w -> w
registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)
registerWidthsFromOpts CliOpts{width_=Nothing, available_width_=w} = (w, Nothing)
registerWidthsFromOpts CliOpts{width_=Just s} =
case runParser registerwidthp "(unknown)" s of
Left e -> usageError $ "could not parse width option: "++show e
Right ws -> ws
where
registerwidthp :: (Stream s, Char ~ Token s) => ParsecT MPErr s m (Int, Maybe Int)
registerwidthp = do
totalwidth <- read `fmap` some digitChar
descwidth <- optional (char ',' >> read `fmap` some digitChar)
eof
return (totalwidth, descwidth)
maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName
maybeAccountNameDrop opts a | tree_ opts = a
| otherwise = accountNameDrop (drop_ opts) a
lineFormatFromOpts :: ReportOpts -> Either String StringFormat
lineFormatFromOpts = maybe (Right defaultBalanceLineFormat) parseStringFormat . format_
defaultBalanceLineFormat :: StringFormat
defaultBalanceLineFormat = BottomAligned [
FormatField False (Just 20) Nothing TotalField
, FormatLiteral " "
, FormatField True (Just 2) Nothing DepthSpacerField
, FormatField True Nothing Nothing AccountField
]
hledgerAddons :: IO [String]
hledgerAddons = do
as1 <- hledgerExecutablesInPath
let as2 = map stripPrognamePrefix as1
let as3 = sortBy (comparing takeBaseName) as2
let as4 = groupBy (\a b -> takeBaseName a == takeBaseName b) as3
let as5 = concatMap dropRedundantSourceVersion as4
return as5
stripPrognamePrefix = drop (length progname + 1)
dropRedundantSourceVersion [f,g]
| takeExtension f `elem` compiledExts = [f]
| takeExtension g `elem` compiledExts = [g]
dropRedundantSourceVersion fs = fs
compiledExts = ["",".com",".exe"]
hledgerExecutablesInPath :: IO [String]
hledgerExecutablesInPath = do
pathdirs <- splitOneOf "[:;]" `fmap` getEnvSafe "PATH"
pathfiles <- concat `fmap` mapM getDirectoryContentsSafe pathdirs
return $ nub $ sort $ filter isHledgerExeName pathfiles
isHledgerExeName :: String -> Bool
isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack
where
hledgerexenamep = do
_ <- mptext $ T.pack progname
_ <- char '-'
_ <- some $ noneOf ['.']
optional (string "." >> choice' (map (mptext . T.pack) 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_CliOptions :: Test
tests_Hledger_Cli_CliOptions = TestList
[
]