{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts, TypeFamilies, OverloadedStrings, PackageImports #-}
module Hledger.Cli.CliOptions (
helpflags,
detailedversionflag,
hiddenflags,
inputflags,
reportflags,
outputFormatFlag,
outputFileFlag,
generalflagsgroup1,
generalflagsgroup2,
generalflagsgroup3,
defMode,
defCommandMode,
addonCommandMode,
hledgerCommandMode,
argsFlag,
showModeUsage,
withAliases,
likelyExecutablesInPath,
hledgerExecutablesInPath,
CliOpts(..),
defcliopts,
getHledgerCliOpts,
getHledgerCliOpts',
rawOptsToCliOpts,
checkCliOpts,
outputFormats,
defaultOutputFormat,
defaultBalanceLineFormat,
CommandDoc,
journalFilePathFromOpts,
rulesFilePathFromOpts,
outputFileFromOpts,
outputFormatFromOpts,
defaultWidth,
widthFromOpts,
replaceNumericFlags,
registerWidthsFromOpts,
lineFormatFromOpts,
hledgerAddons,
topicForMode,
)
where
import Prelude ()
import "base-compat-batteries" Prelude.Compat
import qualified Control.Exception as C
import Control.Monad (when)
import Data.Char
import Data.Default
import Data.Either (isRight)
import Data.Functor.Identity (Identity)
import "base-compat-batteries" Data.List.Compat
import Data.List.Extra (nubSort)
import Data.List.Split (splitOneOf)
import Data.Ord
import Data.Maybe
import qualified Data.Text as T
import Data.Void (Void)
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 Text.Megaparsec
import Text.Megaparsec.Char
import Hledger
import Hledger.Cli.DocFiles
import Hledger.Cli.Version
helpflags :: [Flag RawOpts]
helpflags = [
flagNone ["help","h"] (setboolopt "help") "show general usage (or after CMD, command usage)"
,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"
,flagNone ["date2"] (setboolopt "date2") "match the secondary date instead. See command help for other effects. (--effective, --aux-date also accepted)"
,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) "NUM" "(or -NUM): hide accounts/postings deeper than this"
,flagNone ["empty","E"] (setboolopt "empty") "show items with zero amount, normally hidden (and vice-versa in hledger-ui/hledger-web)"
,flagNone ["B","cost"] (setboolopt "B")
"show amounts converted to their cost, using the transaction price. Equivalent to --value=cost."
,flagNone ["V","market"] (setboolopt "V")
(unwords
["show amounts converted to current market value (single period reports)"
,"or period-end market value (multiperiod reports) in their default valuation commodity."
,"Equivalent to --value=now / --value=end."
])
,flagReq ["X","exchange"] (\s opts -> Right $ setopt "X" s opts) "COMM"
(unwords
["show amounts converted to current (single period reports)"
,"or period-end (multiperiod reports) market value in the specified commodity."
,"Equivalent to --value=now,COMM / --value=end,COMM."
])
,flagReq ["value"] (\s opts -> Right $ setopt "value" s opts) "TYPE[,COMM]"
(unlines
["TYPE is cost, end, now or YYYY-MM-DD."
,"COMM is an optional commodity symbol."
,"Shows amounts converted to:"
,"- cost using transaction prices, then optionally to COMM using period-end market prices"
,"- period-end market value, in default valuation commodity or COMM"
,"- current market value, in default valuation commodity or COMM"
,"- market value on the given date, in default valuation commodity or COMM"
])
,flagNone ["auto"] (setboolopt "auto") "apply automated posting rules to modify transactions"
,flagOpt "" ["forecast"] (\s opts -> Right $ setopt "forecast" s opts) "PERIODEXP"
(unlines
[ "Generate periodic transactions (from periodic transaction rules). By default these begin after the latest recorded transaction, and end 6 months from today, or at the report end date."
, "Also, in hledger-ui, make future transactions visible."
, "Note that = (and not a space) is required before PERIODEXP if you wish to supply it."
])
]
hiddenflags :: [Flag RawOpts]
hiddenflags = [
flagNone ["effective","aux-date"] (setboolopt "date2") "Ledger-compatible aliases for --date2"
]
outputFormatFlag :: [String] -> Flag RawOpts
outputFormatFlag fmts = flagReq
["output-format","O"] (\s opts -> Right $ setopt "output-format" s opts) "FMT"
("select the output format. Supported formats:\n" ++ intercalate ", " fmts ++ ".")
outputFileFlag :: Flag RawOpts
outputFileFlag = 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 = def
,modeCheck = Right
,modeReform = const Nothing
,modeExpandAt = True
,modeGroupModes = toGroup []
}
defCommandMode :: [Name] -> Mode RawOpts
defCommandMode names = defMode {
modeNames=names
,modeGroupFlags = Group {
groupNamed = []
,groupUnnamed = [
flagNone ["help"] (setboolopt "help") "Show usage."
]
,groupHidden = []
}
,modeArgs = ([], Just $ argsFlag "[QUERY]")
,modeValue=setopt "command" (headDef "" names) def
}
addonCommandMode :: Name -> Mode RawOpts
addonCommandMode name = (defCommandMode [name]) {
modeHelp = ""
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = hiddenflags
,groupNamed = [generalflagsgroup1]
}
}
type CommandDoc = String
hledgerCommandMode :: CommandDoc -> [Flag RawOpts] -> [(String, [Flag RawOpts])]
-> [Flag RawOpts] -> ([Arg RawOpts], Maybe (Arg RawOpts)) -> Mode RawOpts
hledgerCommandMode doc unnamedflaggroup namedflaggroups hiddenflaggroup argsdescr =
case parseCommandDoc doc of
Nothing -> error' $ "Could not parse command doc:\n"++doc++"\n"
Just (names, shorthelp, longhelplines) ->
(defCommandMode names) {
modeHelp = shorthelp
,modeHelpSuffix = longhelplines
,modeGroupFlags = Group {
groupUnnamed = unnamedflaggroup
,groupNamed = namedflaggroups
,groupHidden = hiddenflaggroup
}
,modeArgs = argsdescr
}
parseCommandDoc :: CommandDoc -> Maybe ([Name], String, [String])
parseCommandDoc t =
case lines t of
[] -> Nothing
(l:ls) -> Just (names, shorthelp, longhelplines)
where
names = words $ map (\c -> if c `elem` [',','\\'] then ' ' else c) l
(shorthelpls, longhelpls) = break (== "_FLAGS") ls
shorthelp = unlines $ reverse $ dropWhile null $ reverse shorthelpls
longhelplines = dropWhile null $ drop 1 longhelpls
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]
,inputopts_ :: InputOpts
,reportopts_ :: ReportOpts
,output_file_ :: Maybe FilePath
,output_format_ :: Maybe String
,debug_ :: Int
,no_new_accounts_ :: Bool
,width_ :: Maybe String
,available_width_ :: Int
} deriving (Show, Data, Typeable)
instance Default CliOpts where def = defcliopts
defcliopts :: CliOpts
defcliopts = CliOpts
def
def
def
def
def
def
def
def
def
def
defaultWidth
defaultWidth :: Int
defaultWidth = 80
replaceNumericFlags :: [String] -> [String]
replaceNumericFlags = map replace
where
replace ('-':ds) | not (null ds) && all isDigit ds = "--depth="++ds
replace s = s
rawOptsToCliOpts :: RawOpts -> IO CliOpts
rawOptsToCliOpts rawopts = checkCliOpts <$> do
let iopts = rawOptsToInputOpts rawopts
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_ = listofstringopt "file" rawopts
,inputopts_ = iopts
,reportopts_ = ropts
,output_file_ = maybestringopt "output-file" rawopts
,output_format_ = maybestringopt "output-format" rawopts
,debug_ = intopt "debug" rawopts
,no_new_accounts_ = boolopt "no-new-accounts" rawopts
,width_ = maybestringopt "width" rawopts
,available_width_ = availablewidth
}
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 -> [String] -> IO CliOpts
getHledgerCliOpts' mode' args' = do
let rawopts = either usageError id $ process mode' args'
opts <- rawOptsToCliOpts rawopts
debugArgs args' opts
when ("help" `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 also hledger -h for general 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)
getHledgerCliOpts :: Mode RawOpts -> IO CliOpts
getHledgerCliOpts mode' = do
args' <- getArgs >>= expandArgsAt
getHledgerCliOpts' mode' args'
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"
,"html"
]
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) $ mrules_file_ $ inputopts_ 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 Void 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 Void s m (Int, Maybe Int)
registerwidthp = do
totalwidth <- read `fmap` some digitChar
descwidth <- optional (char ',' >> read `fmap` some digitChar)
eof
return (totalwidth, descwidth)
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]
| map toLower (takeExtension f) `elem` compiledExts = [f]
| map toLower (takeExtension g) `elem` compiledExts = [g]
dropRedundantSourceVersion fs = fs
compiledExts = ["",".com",".exe"]
likelyExecutablesInPath :: IO [String]
likelyExecutablesInPath = do
pathdirs <- splitOneOf "[:;]" `fmap` getEnvSafe "PATH"
pathfiles <- concat `fmap` mapM getDirectoryContentsSafe pathdirs
return $ nubSort pathfiles
hledgerExecutablesInPath :: IO [String]
hledgerExecutablesInPath = filter isHledgerExeName <$> likelyExecutablesInPath
isHledgerExeName :: String -> Bool
isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack
where
hledgerexenamep = do
_ <- string $ T.pack progname
_ <- char '-'
_ <- some $ noneOf ['.']
optional (string "." >> choice' (map (string . T.pack) addonExtensions))
eof
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 [])