{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleContexts, TypeFamilies, OverloadedStrings, PackageImports #-}
module Hledger.Cli.CliOptions (
helpflags,
detailedversionflag,
flattreeflags,
hiddenflags,
inputflags,
reportflags,
outputFormatFlag,
outputFileFlag,
generalflagsgroup1,
generalflagsgroup2,
generalflagsgroup3,
defMode,
defCommandMode,
addonCommandMode,
hledgerCommandMode,
argsFlag,
showModeUsage,
withAliases,
likelyExecutablesInPath,
hledgerExecutablesInPath,
CliOpts(..),
defcliopts,
getHledgerCliOpts,
getHledgerCliOpts',
rawOptsToCliOpts,
outputFormats,
defaultOutputFormat,
CommandDoc,
journalFilePathFromOpts,
rulesFilePathFromOpts,
outputFileFromOpts,
outputFormatFromOpts,
defaultWidth,
widthFromOpts,
replaceNumericFlags,
registerWidthsFromOpts,
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 :: [Flag RawOpts]
helpflags = [
[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"help",Name
"h"] (Name -> RawOpts -> RawOpts
setboolopt Name
"help") Name
"show general help (or after CMD, command help)"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"man"] (Name -> RawOpts -> RawOpts
setboolopt Name
"man") Name
"Show user manual with man"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"info"] (Name -> RawOpts -> RawOpts
setboolopt Name
"info") Name
"Show info manual with info"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"debug"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"debug" Name
s RawOpts
opts) Name
"[N]" Name
"show debug output (levels 1-9, default: 1)"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"version"] (Name -> RawOpts -> RawOpts
setboolopt Name
"version") Name
"show version information"
]
detailedversionflag :: Flag RawOpts
detailedversionflag :: Flag RawOpts
detailedversionflag = [Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"version+"] (Name -> RawOpts -> RawOpts
setboolopt Name
"version+") Name
"show version information with extra detail"
inputflags :: [Flag RawOpts]
inputflags :: [Flag RawOpts]
inputflags = [
[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"file",Name
"f"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"file" Name
s RawOpts
opts) Name
"FILE" Name
"use a different input file. For stdin, use - (default: $LEDGER_FILE or $HOME/.hledger.journal)"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"rules-file"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"rules-file" Name
s RawOpts
opts) Name
"RFILE" Name
"CSV conversion rules file (default: FILE.rules)"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"alias"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"alias" Name
s RawOpts
opts) Name
"OLD=NEW" Name
"rename accounts named OLD to NEW"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"anon"] (Name -> RawOpts -> RawOpts
setboolopt Name
"anon") Name
"anonymize accounts and payees"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"pivot"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"pivot" Name
s RawOpts
opts) Name
"TAGNAME" Name
"use some other field/tag for account names"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"ignore-assertions",Name
"I"] (Name -> RawOpts -> RawOpts
setboolopt Name
"ignore-assertions") Name
"ignore any balance assertions"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"strict",Name
"s"] (Name -> RawOpts -> RawOpts
setboolopt Name
"strict") Name
"do extra error checking (check that all posted accounts are declared)"
]
reportflags :: [Flag RawOpts]
reportflags :: [Flag RawOpts]
reportflags = [
[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"begin",Name
"b"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"begin" Name
s RawOpts
opts) Name
"DATE" Name
"include postings/txns on or after this date"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"end",Name
"e"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"end" Name
s RawOpts
opts) Name
"DATE" Name
"include postings/txns before this date"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"daily",Name
"D"] (Name -> RawOpts -> RawOpts
setboolopt Name
"daily") Name
"multiperiod/multicolumn report by day"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"weekly",Name
"W"] (Name -> RawOpts -> RawOpts
setboolopt Name
"weekly") Name
"multiperiod/multicolumn report by week"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"monthly",Name
"M"] (Name -> RawOpts -> RawOpts
setboolopt Name
"monthly") Name
"multiperiod/multicolumn report by month"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"quarterly",Name
"Q"] (Name -> RawOpts -> RawOpts
setboolopt Name
"quarterly") Name
"multiperiod/multicolumn report by quarter"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"yearly",Name
"Y"] (Name -> RawOpts -> RawOpts
setboolopt Name
"yearly") Name
"multiperiod/multicolumn report by year"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"period",Name
"p"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"period" Name
s RawOpts
opts) Name
"PERIODEXP" Name
"set start date, end date, and/or report interval all at once"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"date2"] (Name -> RawOpts -> RawOpts
setboolopt Name
"date2") Name
"match the secondary date instead. See command help for other effects. (--effective, --aux-date also accepted)"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"unmarked",Name
"U"] (Name -> RawOpts -> RawOpts
setboolopt Name
"unmarked") Name
"include only unmarked postings/txns (can combine with -P or -C)"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"pending",Name
"P"] (Name -> RawOpts -> RawOpts
setboolopt Name
"pending") Name
"include only pending postings/txns"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"cleared",Name
"C"] (Name -> RawOpts -> RawOpts
setboolopt Name
"cleared") Name
"include only cleared postings/txns"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"real",Name
"R"] (Name -> RawOpts -> RawOpts
setboolopt Name
"real") Name
"include only non-virtual postings"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"depth"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"depth" Name
s RawOpts
opts) Name
"NUM" Name
"(or -NUM): hide accounts/postings deeper than this"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"empty",Name
"E"] (Name -> RawOpts -> RawOpts
setboolopt Name
"empty") Name
"show items with zero amount, normally hidden (and vice-versa in hledger-ui/hledger-web)"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"B",Name
"cost"] (Name -> RawOpts -> RawOpts
setboolopt Name
"B")
Name
"show amounts converted to their cost/selling amount, using the transaction price."
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"V",Name
"market"] (Name -> RawOpts -> RawOpts
setboolopt Name
"V")
([Name] -> Name
unwords
[Name
"show amounts converted to period-end market value in their default valuation commodity."
,Name
"Equivalent to --value=end."
])
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"X",Name
"exchange"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"X" Name
s RawOpts
opts) Name
"COMM"
([Name] -> Name
unwords
[Name
"show amounts converted to current (single period reports)"
,Name
"or period-end (multiperiod reports) market value in the specified commodity."
,Name
"Equivalent to --value=end,COMM."
])
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"value"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"value" Name
s RawOpts
opts) Name
"TYPE[,COMM]"
([Name] -> Name
unlines
[Name
"show amounts converted with valuation TYPE, and optionally to specified commodity COMM. TYPE can be:"
,Name
"'then': convert to contemporaneous market value, in default valuation commodity or COMM (print & register commands only)"
,Name
"'end': convert to period-end market value, in default valuation commodity or COMM"
,Name
"'now': convert to current market value, in default valuation commodity or COMM"
,Name
"YYYY-MM-DD: convert to market value on the given date, in default valuation commodity or COMM"
])
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"infer-market-price",Name
"infer-value"] (Name -> RawOpts -> RawOpts
setboolopt Name
"infer-market-price")
Name
"use transaction prices (recorded with @ or @@) as additional market prices, as if they were P directives"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"auto"] (Name -> RawOpts -> RawOpts
setboolopt Name
"auto") Name
"apply automated posting rules to modify transactions"
,Name -> [Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. Name -> [Name] -> Update a -> Name -> Name -> Flag a
flagOpt Name
"" [Name
"forecast"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"forecast" Name
s RawOpts
opts) Name
"PERIODEXP"
([Name] -> Name
unlines
[ Name
"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."
, Name
"Also, in hledger-ui, make future transactions visible."
, Name
"Note that = (and not a space) is required before PERIODEXP if you wish to supply it."
])
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"color",Name
"colour"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"color" Name
s RawOpts
opts) Name
"WHEN"
([Name] -> Name
unlines
[Name
"Should color-supporting commands use ANSI color codes in text output."
,Name
"'auto' (default): whenever stdout seems to be a color-supporting terminal."
,Name
"'always' or 'yes': always, useful eg when piping output into 'less -R'."
,Name
"'never' or 'no': never."
,Name
"A NO_COLOR environment variable overrides this."
])
]
flattreeflags :: Bool -> [Flag RawOpts]
flattreeflags :: Bool -> [Flag RawOpts]
flattreeflags Bool
showamounthelp = [
[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"flat",Name
"l"] (Name -> RawOpts -> RawOpts
setboolopt Name
"flat")
(Name
"show accounts as a flat list (default)"
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ if Bool
showamounthelp then Name
". Amounts exclude subaccount amounts, except where the account is depth-clipped." else Name
"")
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"tree",Name
"t"] (Name -> RawOpts -> RawOpts
setboolopt Name
"tree")
(Name
"show accounts as a tree" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ if Bool
showamounthelp then Name
". Amounts include subaccount amounts." else Name
"")
]
hiddenflags :: [Flag RawOpts]
hiddenflags :: [Flag RawOpts]
hiddenflags = [
[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"effective",Name
"aux-date"] (Name -> RawOpts -> RawOpts
setboolopt Name
"date2") Name
"Ledger-compatible aliases for --date2"
]
outputFormatFlag :: [String] -> Flag RawOpts
outputFormatFlag :: [Name] -> Flag RawOpts
outputFormatFlag [Name]
fmts = [Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq
[Name
"output-format",Name
"O"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"output-format" Name
s RawOpts
opts) Name
"FMT"
(Name
"select the output format. Supported formats:\n" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name -> [Name] -> Name
forall a. [a] -> [[a]] -> [a]
intercalate Name
", " [Name]
fmts Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
".")
outputFileFlag :: Flag RawOpts
outputFileFlag :: Flag RawOpts
outputFileFlag = [Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq
[Name
"output-file",Name
"o"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"output-file" Name
s RawOpts
opts) Name
"FILE"
Name
"write output to FILE. A file extension matching one of the above formats selects that format."
argsFlag :: FlagHelp -> Arg RawOpts
argsFlag :: Name -> Arg RawOpts
argsFlag Name
desc = Update RawOpts -> Name -> Arg RawOpts
forall a. Update a -> Name -> Arg a
flagArg (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"args" Name
s RawOpts
opts) Name
desc
generalflagstitle :: String
generalflagstitle :: Name
generalflagstitle = Name
"\nGeneral flags"
generalflagsgroup1, generalflagsgroup2, generalflagsgroup3 :: (String, [Flag RawOpts])
generalflagsgroup1 :: (Name, [Flag RawOpts])
generalflagsgroup1 = (Name
generalflagstitle, [Flag RawOpts]
inputflags [Flag RawOpts] -> [Flag RawOpts] -> [Flag RawOpts]
forall a. [a] -> [a] -> [a]
++ [Flag RawOpts]
reportflags [Flag RawOpts] -> [Flag RawOpts] -> [Flag RawOpts]
forall a. [a] -> [a] -> [a]
++ [Flag RawOpts]
helpflags)
generalflagsgroup2 :: (Name, [Flag RawOpts])
generalflagsgroup2 = (Name
generalflagstitle, [Flag RawOpts]
inputflags [Flag RawOpts] -> [Flag RawOpts] -> [Flag RawOpts]
forall a. [a] -> [a] -> [a]
++ [Flag RawOpts]
helpflags)
generalflagsgroup3 :: (Name, [Flag RawOpts])
generalflagsgroup3 = (Name
generalflagstitle, [Flag RawOpts]
helpflags)
defMode :: Mode RawOpts
defMode :: Mode RawOpts
defMode = Mode :: forall a.
Group (Mode a)
-> [Name]
-> a
-> (a -> Either Name a)
-> (a -> Maybe [Name])
-> Bool
-> Name
-> [Name]
-> ([Arg a], Maybe (Arg a))
-> Group (Flag a)
-> Mode a
Mode {
modeNames :: [Name]
modeNames = []
,modeHelp :: Name
modeHelp = Name
""
,modeHelpSuffix :: [Name]
modeHelpSuffix = []
,modeGroupFlags :: Group (Flag RawOpts)
modeGroupFlags = Group :: forall a. [a] -> [a] -> [(Name, [a])] -> Group a
Group {
groupNamed :: [(Name, [Flag RawOpts])]
groupNamed = []
,groupUnnamed :: [Flag RawOpts]
groupUnnamed = []
,groupHidden :: [Flag RawOpts]
groupHidden = []
}
,modeArgs :: ([Arg RawOpts], Maybe (Arg RawOpts))
modeArgs = ([], Maybe (Arg RawOpts)
forall a. Maybe a
Nothing)
,modeValue :: RawOpts
modeValue = RawOpts
forall a. Default a => a
def
,modeCheck :: RawOpts -> Either Name RawOpts
modeCheck = RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right
,modeReform :: RawOpts -> Maybe [Name]
modeReform = Maybe [Name] -> RawOpts -> Maybe [Name]
forall a b. a -> b -> a
const Maybe [Name]
forall a. Maybe a
Nothing
,modeExpandAt :: Bool
modeExpandAt = Bool
True
,modeGroupModes :: Group (Mode RawOpts)
modeGroupModes = [Mode RawOpts] -> Group (Mode RawOpts)
forall a. [a] -> Group a
toGroup []
}
defCommandMode :: [Name] -> Mode RawOpts
defCommandMode :: [Name] -> Mode RawOpts
defCommandMode [Name]
names = Mode RawOpts
defMode {
modeNames :: [Name]
modeNames=[Name]
names
,modeGroupFlags :: Group (Flag RawOpts)
modeGroupFlags = Group :: forall a. [a] -> [a] -> [(Name, [a])] -> Group a
Group {
groupNamed :: [(Name, [Flag RawOpts])]
groupNamed = []
,groupUnnamed :: [Flag RawOpts]
groupUnnamed = [
[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"help"] (Name -> RawOpts -> RawOpts
setboolopt Name
"help") Name
"Show command-line help"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"man"] (Name -> RawOpts -> RawOpts
setboolopt Name
"man") Name
"Show user manual with man"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"info"] (Name -> RawOpts -> RawOpts
setboolopt Name
"info") Name
"Show info manual with info"
]
,groupHidden :: [Flag RawOpts]
groupHidden = []
}
,modeArgs :: ([Arg RawOpts], Maybe (Arg RawOpts))
modeArgs = ([], Arg RawOpts -> Maybe (Arg RawOpts)
forall a. a -> Maybe a
Just (Arg RawOpts -> Maybe (Arg RawOpts))
-> Arg RawOpts -> Maybe (Arg RawOpts)
forall a b. (a -> b) -> a -> b
$ Name -> Arg RawOpts
argsFlag Name
"[QUERY]")
,modeValue :: RawOpts
modeValue=Name -> Name -> RawOpts -> RawOpts
setopt Name
"command" (Name -> [Name] -> Name
forall a. a -> [a] -> a
headDef Name
"" [Name]
names) RawOpts
forall a. Default a => a
def
}
addonCommandMode :: Name -> Mode RawOpts
addonCommandMode :: Name -> Mode RawOpts
addonCommandMode Name
name = ([Name] -> Mode RawOpts
defCommandMode [Name
name]) {
modeHelp :: Name
modeHelp = Name
""
,modeGroupFlags :: Group (Flag RawOpts)
modeGroupFlags = Group :: forall a. [a] -> [a] -> [(Name, [a])] -> Group a
Group {
groupUnnamed :: [Flag RawOpts]
groupUnnamed = []
,groupHidden :: [Flag RawOpts]
groupHidden = [Flag RawOpts]
hiddenflags
,groupNamed :: [(Name, [Flag RawOpts])]
groupNamed = [(Name, [Flag RawOpts])
generalflagsgroup1]
}
}
type CommandDoc = String
hledgerCommandMode :: CommandDoc -> [Flag RawOpts] -> [(String, [Flag RawOpts])]
-> [Flag RawOpts] -> ([Arg RawOpts], Maybe (Arg RawOpts)) -> Mode RawOpts
hledgerCommandMode :: Name
-> [Flag RawOpts]
-> [(Name, [Flag RawOpts])]
-> [Flag RawOpts]
-> ([Arg RawOpts], Maybe (Arg RawOpts))
-> Mode RawOpts
hledgerCommandMode Name
doc [Flag RawOpts]
unnamedflaggroup [(Name, [Flag RawOpts])]
namedflaggroups [Flag RawOpts]
hiddenflaggroup ([Arg RawOpts], Maybe (Arg RawOpts))
argsdescr =
case Name -> Maybe ([Name], Name, [Name])
parseCommandDoc Name
doc of
Maybe ([Name], Name, [Name])
Nothing -> Name -> Mode RawOpts
forall a. Name -> a
error' (Name -> Mode RawOpts) -> Name -> Mode RawOpts
forall a b. (a -> b) -> a -> b
$ Name
"Could not parse command doc:\n"Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++Name
docName -> Name -> Name
forall a. [a] -> [a] -> [a]
++Name
"\n"
Just ([Name]
names, Name
shorthelp, [Name]
longhelplines) ->
([Name] -> Mode RawOpts
defCommandMode [Name]
names) {
modeHelp :: Name
modeHelp = Name
shorthelp
,modeHelpSuffix :: [Name]
modeHelpSuffix = [Name]
longhelplines
,modeGroupFlags :: Group (Flag RawOpts)
modeGroupFlags = Group :: forall a. [a] -> [a] -> [(Name, [a])] -> Group a
Group {
groupUnnamed :: [Flag RawOpts]
groupUnnamed = [Flag RawOpts]
unnamedflaggroup
,groupNamed :: [(Name, [Flag RawOpts])]
groupNamed = [(Name, [Flag RawOpts])]
namedflaggroups
,groupHidden :: [Flag RawOpts]
groupHidden = [Flag RawOpts]
hiddenflaggroup
}
,modeArgs :: ([Arg RawOpts], Maybe (Arg RawOpts))
modeArgs = ([Arg RawOpts], Maybe (Arg RawOpts))
argsdescr
}
parseCommandDoc :: CommandDoc -> Maybe ([Name], String, [String])
parseCommandDoc :: Name -> Maybe ([Name], Name, [Name])
parseCommandDoc Name
t =
case Name -> [Name]
lines Name
t of
[] -> Maybe ([Name], Name, [Name])
forall a. Maybe a
Nothing
(Name
l:[Name]
ls) -> ([Name], Name, [Name]) -> Maybe ([Name], Name, [Name])
forall a. a -> Maybe a
Just ([Name]
names, Name
shorthelp, [Name]
longhelplines)
where
names :: [Name]
names = Name -> [Name]
words (Name -> [Name]) -> Name -> [Name]
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> Name -> Name
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Name -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
',',Char
'\\'] then Char
' ' else Char
c) Name
l
([Name]
shorthelpls, [Name]
longhelpls) = (Name -> Bool) -> [Name] -> ([Name], [Name])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"_FLAGS") [Name]
ls
shorthelp :: Name
shorthelp = [Name] -> Name
unlines ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
reverse ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Name -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
shorthelpls
longhelplines :: [Name]
longhelplines = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Name -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
drop Int
1 [Name]
longhelpls
showModeUsage :: Mode a -> String
showModeUsage :: Mode a -> Name
showModeUsage = (TextFormat -> [Text] -> Name
showText TextFormat
defaultWrap :: [Text] -> String) ([Text] -> Name) -> (Mode a -> [Text]) -> Mode a -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
([Name] -> HelpFormat -> Mode a -> [Text]
forall a. [Name] -> HelpFormat -> Mode a -> [Text]
helpText [] HelpFormat
HelpFormatDefault :: Mode a -> [Text])
topicForMode :: Mode a -> Topic
topicForMode :: Mode a -> Name
topicForMode Mode a
m
| Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"hledger-ui" = Name
"ui"
| Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"hledger-web" = Name
"web"
| Bool
otherwise = Name
"cli"
where n :: Name
n = Name -> [Name] -> Name
forall a. a -> [a] -> a
headDef Name
"" ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$ Mode a -> [Name]
forall a. Mode a -> [Name]
modeNames Mode a
m
withAliases :: String -> [String] -> String
Name
s withAliases :: Name -> [Name] -> Name
`withAliases` [] = Name
s
Name
s `withAliases` [Name]
as = Name
s Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" (" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name -> [Name] -> Name
forall a. [a] -> [[a]] -> [a]
intercalate Name
", " [Name]
as Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
")"
data CliOpts = CliOpts {
CliOpts -> RawOpts
rawopts_ :: RawOpts
,CliOpts -> Name
command_ :: String
,CliOpts -> [Name]
file_ :: [FilePath]
,CliOpts -> InputOpts
inputopts_ :: InputOpts
,CliOpts -> ReportSpec
reportspec_ :: ReportSpec
,CliOpts -> Maybe Name
output_file_ :: Maybe FilePath
,CliOpts -> Maybe Name
output_format_ :: Maybe String
,CliOpts -> Int
debug_ :: Int
,CliOpts -> Bool
no_new_accounts_ :: Bool
,CliOpts -> Maybe Name
width_ :: Maybe String
,CliOpts -> Int
available_width_ :: Int
} deriving (Int -> CliOpts -> Name -> Name
[CliOpts] -> Name -> Name
CliOpts -> Name
(Int -> CliOpts -> Name -> Name)
-> (CliOpts -> Name) -> ([CliOpts] -> Name -> Name) -> Show CliOpts
forall a.
(Int -> a -> Name -> Name)
-> (a -> Name) -> ([a] -> Name -> Name) -> Show a
showList :: [CliOpts] -> Name -> Name
$cshowList :: [CliOpts] -> Name -> Name
show :: CliOpts -> Name
$cshow :: CliOpts -> Name
showsPrec :: Int -> CliOpts -> Name -> Name
$cshowsPrec :: Int -> CliOpts -> Name -> Name
Show)
instance Default CliOpts where def :: CliOpts
def = CliOpts
defcliopts
defcliopts :: CliOpts
defcliopts :: CliOpts
defcliopts = CliOpts :: RawOpts
-> Name
-> [Name]
-> InputOpts
-> ReportSpec
-> Maybe Name
-> Maybe Name
-> Int
-> Bool
-> Maybe Name
-> Int
-> CliOpts
CliOpts
{ rawopts_ :: RawOpts
rawopts_ = RawOpts
forall a. Default a => a
def
, command_ :: Name
command_ = Name
""
, file_ :: [Name]
file_ = []
, inputopts_ :: InputOpts
inputopts_ = InputOpts
forall a. Default a => a
def
, reportspec_ :: ReportSpec
reportspec_ = ReportSpec
forall a. Default a => a
def
, output_file_ :: Maybe Name
output_file_ = Maybe Name
forall a. Maybe a
Nothing
, output_format_ :: Maybe Name
output_format_ = Maybe Name
forall a. Maybe a
Nothing
, debug_ :: Int
debug_ = Int
0
, no_new_accounts_ :: Bool
no_new_accounts_ = Bool
False
, width_ :: Maybe Name
width_ = Maybe Name
forall a. Maybe a
Nothing
, available_width_ :: Int
available_width_ = Int
defaultWidth
}
defaultWidth :: Int
defaultWidth :: Int
defaultWidth = Int
80
replaceNumericFlags :: [String] -> [String]
replaceNumericFlags :: [Name] -> [Name]
replaceNumericFlags = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Name
replace
where
replace :: Name -> Name
replace (Char
'-':Name
ds) | Bool -> Bool
not (Name -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Name
ds) Bool -> Bool -> Bool
&& (Char -> Bool) -> Name -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit Name
ds = Name
"--depth="Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++Name
ds
replace Name
s = Name
s
rawOptsToCliOpts :: RawOpts -> IO CliOpts
rawOptsToCliOpts :: RawOpts -> IO CliOpts
rawOptsToCliOpts RawOpts
rawopts = do
let iopts :: InputOpts
iopts = RawOpts -> InputOpts
rawOptsToInputOpts RawOpts
rawopts
ReportSpec
rspec <- RawOpts -> IO ReportSpec
rawOptsToReportSpec RawOpts
rawopts
Maybe Int
mcolumns <- Name -> Maybe Int
forall a. Read a => Name -> Maybe a
readMay (Name -> Maybe Int) -> IO Name -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IO Name
getEnvSafe Name
"COLUMNS"
Maybe Int
mtermwidth <-
#ifdef mingw32_HOST_OS
return Nothing
#else
IO Terminal
setupTermFromEnv IO Terminal -> (Terminal -> IO (Maybe Int)) -> IO (Maybe Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> IO (Maybe Int))
-> (Terminal -> Maybe Int) -> Terminal -> IO (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Terminal -> Capability Int -> Maybe Int)
-> Capability Int -> Terminal -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Terminal -> Capability Int -> Maybe Int
forall a. Terminal -> Capability a -> Maybe a
getCapability Capability Int
termColumns
#endif
let availablewidth :: Int
availablewidth = [Int] -> Int
forall a. [a] -> a
head ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Int
mcolumns, Maybe Int
mtermwidth, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
defaultWidth]
CliOpts -> IO CliOpts
forall (m :: * -> *) a. Monad m => a -> m a
return CliOpts
defcliopts {
rawopts_ :: RawOpts
rawopts_ = RawOpts
rawopts
,command_ :: Name
command_ = Name -> RawOpts -> Name
stringopt Name
"command" RawOpts
rawopts
,file_ :: [Name]
file_ = Name -> RawOpts -> [Name]
listofstringopt Name
"file" RawOpts
rawopts
,inputopts_ :: InputOpts
inputopts_ = InputOpts
iopts
,reportspec_ :: ReportSpec
reportspec_ = ReportSpec
rspec
,output_file_ :: Maybe Name
output_file_ = Name -> RawOpts -> Maybe Name
maybestringopt Name
"output-file" RawOpts
rawopts
,output_format_ :: Maybe Name
output_format_ = Name -> RawOpts -> Maybe Name
maybestringopt Name
"output-format" RawOpts
rawopts
,debug_ :: Int
debug_ = Name -> RawOpts -> Int
posintopt Name
"debug" RawOpts
rawopts
,no_new_accounts_ :: Bool
no_new_accounts_ = Name -> RawOpts -> Bool
boolopt Name
"no-new-accounts" RawOpts
rawopts
,width_ :: Maybe Name
width_ = Name -> RawOpts -> Maybe Name
maybestringopt Name
"width" RawOpts
rawopts
,available_width_ :: Int
available_width_ = Int
availablewidth
}
getHledgerCliOpts' :: Mode RawOpts -> [String] -> IO CliOpts
getHledgerCliOpts' :: Mode RawOpts -> [Name] -> IO CliOpts
getHledgerCliOpts' Mode RawOpts
mode' [Name]
args' = do
let rawopts :: RawOpts
rawopts = (Name -> RawOpts)
-> (RawOpts -> RawOpts) -> Either Name RawOpts -> RawOpts
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Name -> RawOpts
forall a. Name -> a
usageError RawOpts -> RawOpts
forall a. a -> a
id (Either Name RawOpts -> RawOpts) -> Either Name RawOpts -> RawOpts
forall a b. (a -> b) -> a -> b
$ Mode RawOpts -> [Name] -> Either Name RawOpts
forall a. Mode a -> [Name] -> Either Name a
process Mode RawOpts
mode' [Name]
args'
CliOpts
opts <- RawOpts -> IO CliOpts
rawOptsToCliOpts RawOpts
rawopts
[Name] -> CliOpts -> IO ()
debugArgs [Name]
args' CliOpts
opts
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
"help" Name -> RawOpts -> Bool
`inRawOpts` CliOpts -> RawOpts
rawopts_ CliOpts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Name -> IO ()
putStr Name
shorthelp IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
CliOpts -> IO CliOpts
forall (m :: * -> *) a. Monad m => a -> m a
return CliOpts
opts
where
longhelp :: Name
longhelp = Mode RawOpts -> Name
forall a. Mode a -> Name
showModeUsage Mode RawOpts
mode'
shorthelp :: Name
shorthelp =
[Name] -> Name
unlines ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$
([Name] -> [Name]
forall a. [a] -> [a]
reverse ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Name -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
reverse ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name
"flags:" Name -> Name -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`)) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Name -> [Name]
lines Name
longhelp)
[Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
[Name
""
,Name
" See also hledger -h for general hledger options."
]
debugArgs :: [String] -> CliOpts -> IO ()
debugArgs :: [Name] -> CliOpts -> IO ()
debugArgs [Name]
args' CliOpts
opts =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
"--debug" Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
args') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Name
progname' <- IO Name
getProgName
Name -> IO ()
putStrLn (Name -> IO ()) -> Name -> IO ()
forall a b. (a -> b) -> a -> b
$ Name
"running: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
progname'
Name -> IO ()
putStrLn (Name -> IO ()) -> Name -> IO ()
forall a b. (a -> b) -> a -> b
$ Name
"raw args: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [Name] -> Name
forall a. Show a => a -> Name
show [Name]
args'
Name -> IO ()
putStrLn (Name -> IO ()) -> Name -> IO ()
forall a b. (a -> b) -> a -> b
$ Name
"processed opts:\n" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ CliOpts -> Name
forall a. Show a => a -> Name
show CliOpts
opts
Name -> IO ()
putStrLn (Name -> IO ()) -> Name -> IO ()
forall a b. (a -> b) -> a -> b
$ Name
"search query: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Query -> Name
forall a. Show a => a -> Name
show (ReportSpec -> Query
rsQuery (ReportSpec -> Query) -> ReportSpec -> Query
forall a b. (a -> b) -> a -> b
$ CliOpts -> ReportSpec
reportspec_ CliOpts
opts)
getHledgerCliOpts :: Mode RawOpts -> IO CliOpts
getHledgerCliOpts :: Mode RawOpts -> IO CliOpts
getHledgerCliOpts Mode RawOpts
mode' = do
[Name]
args' <- IO [Name]
getArgs IO [Name] -> ([Name] -> IO [Name]) -> IO [Name]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Name] -> IO [Name]
expandArgsAt
Mode RawOpts -> [Name] -> IO CliOpts
getHledgerCliOpts' Mode RawOpts
mode' [Name]
args'
journalFilePathFromOpts :: CliOpts -> IO [String]
journalFilePathFromOpts :: CliOpts -> IO [Name]
journalFilePathFromOpts CliOpts
opts = do
Name
f <- IO Name
defaultJournalPath
Name
d <- IO Name
getCurrentDirectory
case CliOpts -> [Name]
file_ CliOpts
opts of
[] -> [Name] -> IO [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name
f]
[Name]
fs -> (Name -> IO Name) -> [Name] -> IO [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> Name -> IO Name
expandPathPreservingPrefix Name
d) [Name]
fs
expandPathPreservingPrefix :: FilePath -> PrefixedFilePath -> IO PrefixedFilePath
expandPathPreservingPrefix :: Name -> Name -> IO Name
expandPathPreservingPrefix Name
d Name
prefixedf = do
let (Maybe Name
p,Name
f) = Name -> (Maybe Name, Name)
splitReaderPrefix Name
prefixedf
Name
f' <- Name -> Name -> IO Name
expandPath Name
d Name
f
Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> IO Name) -> Name -> IO Name
forall a b. (a -> b) -> a -> b
$ case Maybe Name
p of
Just Name
p -> Name
p Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
":" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
f'
Maybe Name
Nothing -> Name
f'
outputFileFromOpts :: CliOpts -> IO FilePath
outputFileFromOpts :: CliOpts -> IO Name
outputFileFromOpts CliOpts
opts = do
Name
d <- IO Name
getCurrentDirectory
case CliOpts -> Maybe Name
output_file_ CliOpts
opts of
Just Name
p -> Name -> Name -> IO Name
expandPath Name
d Name
p
Maybe Name
Nothing -> Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
"-"
defaultOutputFormat :: Name
defaultOutputFormat = Name
"txt"
outputFormats :: [Name]
outputFormats =
[Name
defaultOutputFormat] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
[Name
"csv"
,Name
"html"
]
outputFormatFromOpts :: CliOpts -> String
outputFormatFromOpts :: CliOpts -> Name
outputFormatFromOpts CliOpts
opts =
case CliOpts -> Maybe Name
output_format_ CliOpts
opts of
Just Name
f -> Name
f
Maybe Name
Nothing ->
case Name -> Name
filePathExtension (Name -> Name) -> Maybe Name -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CliOpts -> Maybe Name
output_file_ CliOpts
opts of
Just Name
ext | Name
ext Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
outputFormats -> Name
ext
Maybe Name
_ -> Name
defaultOutputFormat
filePathExtension :: FilePath -> String
filePathExtension :: Name -> Name
filePathExtension = (Char -> Bool) -> Name -> Name
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') (Name -> Name) -> (Name -> Name) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Name) -> Name
forall a b. (a, b) -> b
snd ((Name, Name) -> Name) -> (Name -> (Name, Name)) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> (Name, Name)
splitExtension (Name -> (Name, Name)) -> (Name -> Name) -> Name -> (Name, Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Name) -> Name
forall a b. (a, b) -> b
snd ((Name, Name) -> Name) -> (Name -> (Name, Name)) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> (Name, Name)
splitFileName
rulesFilePathFromOpts :: CliOpts -> IO (Maybe FilePath)
rulesFilePathFromOpts :: CliOpts -> IO (Maybe Name)
rulesFilePathFromOpts CliOpts
opts = do
Name
d <- IO Name
getCurrentDirectory
IO (Maybe Name)
-> (Name -> IO (Maybe Name)) -> Maybe Name -> IO (Maybe Name)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Name -> IO (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
forall a. Maybe a
Nothing) ((Name -> Maybe Name) -> IO Name -> IO (Maybe Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Maybe Name
forall a. a -> Maybe a
Just (IO Name -> IO (Maybe Name))
-> (Name -> IO Name) -> Name -> IO (Maybe Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> IO Name
expandPath Name
d) (Maybe Name -> IO (Maybe Name)) -> Maybe Name -> IO (Maybe Name)
forall a b. (a -> b) -> a -> b
$ InputOpts -> Maybe Name
mrules_file_ (InputOpts -> Maybe Name) -> InputOpts -> Maybe Name
forall a b. (a -> b) -> a -> b
$ CliOpts -> InputOpts
inputopts_ CliOpts
opts
widthFromOpts :: CliOpts -> Int
widthFromOpts :: CliOpts -> Int
widthFromOpts CliOpts{width_ :: CliOpts -> Maybe Name
width_=Maybe Name
Nothing, available_width_ :: CliOpts -> Int
available_width_=Int
w} = Int
w
widthFromOpts CliOpts{width_ :: CliOpts -> Maybe Name
width_=Just Name
s} =
case Parsec Void Name Int
-> Name -> Name -> Either (ParseErrorBundle Name Void) Int
forall e s a.
Parsec e s a -> Name -> s -> Either (ParseErrorBundle s e) a
runParser (Name -> Int
forall a. Read a => Name -> a
read (Name -> Int)
-> ParsecT Void Name Identity Name -> Parsec Void Name Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecT Void Name Identity Char -> ParsecT Void Name Identity Name
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Name Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar Parsec Void Name Int
-> ParsecT Void Name Identity () -> Parsec Void Name Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Name Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof :: ParsecT Void String Identity Int) Name
"(unknown)" Name
s of
Left ParseErrorBundle Name Void
e -> Name -> Int
forall a. Name -> a
usageError (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ Name
"could not parse width option: "Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ParseErrorBundle Name Void -> Name
forall a. Show a => a -> Name
show ParseErrorBundle Name Void
e
Right Int
w -> Int
w
registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)
registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)
registerWidthsFromOpts CliOpts{width_ :: CliOpts -> Maybe Name
width_=Maybe Name
Nothing, available_width_ :: CliOpts -> Int
available_width_=Int
w} = (Int
w, Maybe Int
forall a. Maybe a
Nothing)
registerWidthsFromOpts CliOpts{width_ :: CliOpts -> Maybe Name
width_=Just Name
s} =
case Parsec Void Name (Int, Maybe Int)
-> Name
-> Name
-> Either (ParseErrorBundle Name Void) (Int, Maybe Int)
forall e s a.
Parsec e s a -> Name -> s -> Either (ParseErrorBundle s e) a
runParser Parsec Void Name (Int, Maybe Int)
forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
ParsecT Void s m (Int, Maybe Int)
registerwidthp Name
"(unknown)" Name
s of
Left ParseErrorBundle Name Void
e -> Name -> (Int, Maybe Int)
forall a. Name -> a
usageError (Name -> (Int, Maybe Int)) -> Name -> (Int, Maybe Int)
forall a b. (a -> b) -> a -> b
$ Name
"could not parse width option: "Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ParseErrorBundle Name Void -> Name
forall a. Show a => a -> Name
show ParseErrorBundle Name Void
e
Right (Int, Maybe Int)
ws -> (Int, Maybe Int)
ws
where
registerwidthp :: (Stream s, Char ~ Token s) => ParsecT Void s m (Int, Maybe Int)
registerwidthp :: ParsecT Void s m (Int, Maybe Int)
registerwidthp = do
Int
totalwidth <- Name -> Int
forall a. Read a => Name -> a
read (Name -> Int) -> ParsecT Void s m Name -> ParsecT Void s m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecT Void s m Char -> ParsecT Void s m Name
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void s m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
Maybe Int
descwidth <- ParsecT Void s m Int -> ParsecT Void s m (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token s -> ParsecT Void s m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
',' ParsecT Void s m Char
-> ParsecT Void s m Int -> ParsecT Void s m Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Name -> Int
forall a. Read a => Name -> a
read (Name -> Int) -> ParsecT Void s m Name -> ParsecT Void s m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecT Void s m Char -> ParsecT Void s m Name
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void s m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar)
ParsecT Void s m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
(Int, Maybe Int) -> ParsecT Void s m (Int, Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
totalwidth, Maybe Int
descwidth)
hledgerAddons :: IO [String]
hledgerAddons :: IO [Name]
hledgerAddons = do
[Name]
as1 <- IO [Name]
hledgerExecutablesInPath
let as2 :: [Name]
as2 = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Name
forall a. [a] -> [a]
stripPrognamePrefix [Name]
as1
let as3 :: [Name]
as3 = (Name -> Name -> Ordering) -> [Name] -> [Name]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Name -> Name) -> Name -> Name -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Name -> Name
takeBaseName) [Name]
as2
let as4 :: [[Name]]
as4 = (Name -> Name -> Bool) -> [Name] -> [[Name]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\Name
a Name
b -> Name -> Name
takeBaseName Name
a Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Name
takeBaseName Name
b) [Name]
as3
let as5 :: [Name]
as5 = ([Name] -> [Name]) -> [[Name]] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Name] -> [Name]
dropRedundantSourceVersion [[Name]]
as4
[Name] -> IO [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name]
as5
stripPrognamePrefix :: [a] -> [a]
stripPrognamePrefix = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Name -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Name
progname Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
dropRedundantSourceVersion :: [Name] -> [Name]
dropRedundantSourceVersion [Name
f,Name
g]
| (Char -> Char) -> Name -> Name
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Name -> Name
takeExtension Name
f) Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
compiledExts = [Name
f]
| (Char -> Char) -> Name -> Name
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Name -> Name
takeExtension Name
g) Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
compiledExts = [Name
g]
dropRedundantSourceVersion [Name]
fs = [Name]
fs
compiledExts :: [Name]
compiledExts = [Name
"",Name
".com",Name
".exe"]
likelyExecutablesInPath :: IO [String]
likelyExecutablesInPath :: IO [Name]
likelyExecutablesInPath = do
[Name]
pathdirs <- Name -> Name -> [Name]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOneOf Name
"[:;]" (Name -> [Name]) -> IO Name -> IO [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> IO Name
getEnvSafe Name
"PATH"
[Name]
pathfiles <- [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [Name]) -> IO [[Name]] -> IO [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Name -> IO [Name]) -> [Name] -> IO [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> IO [Name]
getDirectoryContentsSafe [Name]
pathdirs
[Name] -> IO [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> IO [Name]) -> [Name] -> IO [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. Ord a => [a] -> [a]
nubSort [Name]
pathfiles
hledgerExecutablesInPath :: IO [String]
hledgerExecutablesInPath :: IO [Name]
hledgerExecutablesInPath = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
isHledgerExeName ([Name] -> [Name]) -> IO [Name] -> IO [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Name]
likelyExecutablesInPath
isHledgerExeName :: String -> Bool
isHledgerExeName :: Name -> Bool
isHledgerExeName = Either (ParseErrorBundle Text CustomErr) () -> Bool
forall a b. Either a b -> Bool
isRight (Either (ParseErrorBundle Text CustomErr) () -> Bool)
-> (Name -> Either (ParseErrorBundle Text CustomErr) ())
-> Name
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec CustomErr Text ()
-> Text -> Either (ParseErrorBundle Text CustomErr) ()
forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith Parsec CustomErr Text ()
forall (m :: * -> *). ParsecT CustomErr Text m ()
hledgerexenamep (Text -> Either (ParseErrorBundle Text CustomErr) ())
-> (Name -> Text)
-> Name
-> Either (ParseErrorBundle Text CustomErr) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
T.pack
where
hledgerexenamep :: ParsecT CustomErr Text m ()
hledgerexenamep = do
Text
_ <- Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Tokens Text -> ParsecT CustomErr Text m (Tokens Text))
-> Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall a b. (a -> b) -> a -> b
$ Name -> Text
T.pack Name
progname
Char
_ <- Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-'
Name
_ <- ParsecT CustomErr Text m Char -> ParsecT CustomErr Text m Name
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT CustomErr Text m Char -> ParsecT CustomErr Text m Name)
-> ParsecT CustomErr Text m Char -> ParsecT CustomErr Text m Name
forall a b. (a -> b) -> a -> b
$ [Token Text] -> ParsecT CustomErr Text m (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf [Char
'.']
ParsecT CustomErr Text m Text
-> ParsecT CustomErr Text m (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"." ParsecT CustomErr Text m Text
-> ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ParsecT CustomErr Text m Text] -> ParsecT CustomErr Text m Text
forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice' ((Name -> ParsecT CustomErr Text m Text)
-> [Name] -> [ParsecT CustomErr Text m Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ParsecT CustomErr Text m Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Text -> ParsecT CustomErr Text m Text)
-> (Name -> Text) -> Name -> ParsecT CustomErr Text m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
T.pack) [Name]
addonExtensions))
ParsecT CustomErr Text m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
addonExtensions :: [String]
addonExtensions :: [Name]
addonExtensions =
[Name
"bat"
,Name
"com"
,Name
"exe"
,Name
"hs"
,Name
"lhs"
,Name
"pl"
,Name
"py"
,Name
"rb"
,Name
"rkt"
,Name
"sh"
]
getEnvSafe :: String -> IO String
getEnvSafe :: Name -> IO Name
getEnvSafe Name
v = Name -> IO Name
getEnv Name
v IO Name -> (IOException -> IO Name) -> IO Name
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`C.catch` (\(IOException
_::C.IOException) -> Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
"")
getDirectoryContentsSafe :: FilePath -> IO [String]
getDirectoryContentsSafe :: Name -> IO [Name]
getDirectoryContentsSafe Name
d =
((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
".",Name
".."])) ([Name] -> [Name]) -> IO [Name] -> IO [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> IO [Name]
getDirectoryContents Name
d) IO [Name] -> (IOException -> IO [Name]) -> IO [Name]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`C.catch` (\(IOException
_::C.IOException) -> [Name] -> IO [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return [])