{-# 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,
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 :: [Flag RawOpts]
helpflags = [
[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["help","h"] (Name -> RawOpts -> RawOpts
setboolopt "help") "show general usage (or after CMD, command usage)"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq ["debug"] (\s :: Name
s opts :: 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 "debug" Name
s RawOpts
opts) "[N]" "show debug output (levels 1-9, default: 1)"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["version"] (Name -> RawOpts -> RawOpts
setboolopt "version") "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 ["version+"] (Name -> RawOpts -> RawOpts
setboolopt "version+") "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 ["file","f"] (\s :: Name
s opts :: 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 "file" Name
s RawOpts
opts) "FILE" "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 ["rules-file"] (\s :: Name
s opts :: 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 "rules-file" Name
s RawOpts
opts) "RFILE" "CSV conversion rules file (default: FILE.rules)"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq ["alias"] (\s :: Name
s opts :: 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 "alias" Name
s RawOpts
opts) "OLD=NEW" "rename accounts named OLD to NEW"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["anon"] (Name -> RawOpts -> RawOpts
setboolopt "anon") "anonymize accounts and payees"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq ["pivot"] (\s :: Name
s opts :: 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 "pivot" Name
s RawOpts
opts) "TAGNAME" "use some other field/tag for account names"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["ignore-assertions","I"] (Name -> RawOpts -> RawOpts
setboolopt "ignore-assertions") "ignore any balance assertions"
]
reportflags :: [Flag RawOpts]
reportflags :: [Flag RawOpts]
reportflags = [
[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq ["begin","b"] (\s :: Name
s opts :: 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 "begin" Name
s RawOpts
opts) "DATE" "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 ["end","e"] (\s :: Name
s opts :: 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 "end" Name
s RawOpts
opts) "DATE" "include postings/txns before this date"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["daily","D"] (Name -> RawOpts -> RawOpts
setboolopt "daily") "multiperiod/multicolumn report by day"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["weekly","W"] (Name -> RawOpts -> RawOpts
setboolopt "weekly") "multiperiod/multicolumn report by week"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["monthly","M"] (Name -> RawOpts -> RawOpts
setboolopt "monthly") "multiperiod/multicolumn report by month"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["quarterly","Q"] (Name -> RawOpts -> RawOpts
setboolopt "quarterly") "multiperiod/multicolumn report by quarter"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["yearly","Y"] (Name -> RawOpts -> RawOpts
setboolopt "yearly") "multiperiod/multicolumn report by year"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq ["period","p"] (\s :: Name
s opts :: 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 "period" Name
s RawOpts
opts) "PERIODEXP" "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 ["date2"] (Name -> RawOpts -> RawOpts
setboolopt "date2") "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 ["unmarked","U"] (Name -> RawOpts -> RawOpts
setboolopt "unmarked") "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 ["pending","P"] (Name -> RawOpts -> RawOpts
setboolopt "pending") "include only pending postings/txns"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["cleared","C"] (Name -> RawOpts -> RawOpts
setboolopt "cleared") "include only cleared postings/txns"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["real","R"] (Name -> RawOpts -> RawOpts
setboolopt "real") "include only non-virtual postings"
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq ["depth"] (\s :: Name
s opts :: 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 "depth" Name
s RawOpts
opts) "NUM" "(or -NUM): hide accounts/postings deeper than this"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["empty","E"] (Name -> RawOpts -> RawOpts
setboolopt "empty") "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 ["B","cost"] (Name -> RawOpts -> RawOpts
setboolopt "B")
"show amounts converted to their cost/selling amount, using the transaction price. Equivalent to --value=cost."
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["V","market"] (Name -> RawOpts -> RawOpts
setboolopt "V")
([Name] -> Name
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."
])
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq ["X","exchange"] (\s :: Name
s opts :: 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 "X" Name
s RawOpts
opts) "COMM"
([Name] -> Name
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."
])
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq ["value"] (\s :: Name
s opts :: 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 "value" Name
s RawOpts
opts) "TYPE[,COMM]"
([Name] -> Name
unlines
["show amounts converted with valuation TYPE, and optionally to specified commodity COMM. TYPE can be:"
,"'cost': convert to cost using transaction prices, then optionally to COMM using period-end market prices"
,"'then': convert to contemporaneous market value, in default valuation commodity or COMM (print & register commands only)"
,"'end': convert to period-end market value, in default valuation commodity or COMM"
,"'now': convert to current market value, in default valuation commodity or COMM"
,"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 ["infer-value"] (Name -> RawOpts -> RawOpts
setboolopt "infer-value") "with -V/-X/--value, also infer market prices from transactions"
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["auto"] (Name -> RawOpts -> RawOpts
setboolopt "auto") "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 "" ["forecast"] (\s :: Name
s opts :: 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 "forecast" Name
s RawOpts
opts) "PERIODEXP"
([Name] -> Name
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."
])
,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq ["color","colour"] (\s :: Name
s opts :: 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 "color" Name
s RawOpts
opts) "WHEN"
([Name] -> Name
unlines
["Should color-supporting commands use ANSI color codes in text output."
,"'auto' (default): whenever stdout seems to be a color-supporting terminal."
,"'always' or 'yes': always, useful eg when piping output into 'less -R'."
,"'never' or 'no': never."
,"A NO_COLOR environment variable overrides this."
])
]
flattreeflags :: Bool -> [Flag RawOpts]
flattreeflags :: Bool -> [Flag RawOpts]
flattreeflags showamounthelp :: Bool
showamounthelp = [
[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["flat","l"] (Name -> RawOpts -> RawOpts
setboolopt "flat")
("show accounts as a flat list (default)"
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ if Bool
showamounthelp then ". Amounts exclude subaccount amounts, except where the account is depth-clipped." else "")
,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["tree","t"] (Name -> RawOpts -> RawOpts
setboolopt "tree")
("show accounts as a tree" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ if Bool
showamounthelp then ". Amounts include subaccount amounts." else "")
]
hiddenflags :: [Flag RawOpts]
hiddenflags :: [Flag RawOpts]
hiddenflags = [
[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone ["effective","aux-date"] (Name -> RawOpts -> RawOpts
setboolopt "date2") "Ledger-compatible aliases for --date2"
]
outputFormatFlag :: [String] -> Flag RawOpts
outputFormatFlag :: [Name] -> Flag RawOpts
outputFormatFlag fmts :: [Name]
fmts = [Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq
["output-format","O"] (\s :: Name
s opts :: 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 "output-format" Name
s RawOpts
opts) "FMT"
("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]
fmts Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ ".")
outputFileFlag :: Flag RawOpts
outputFileFlag :: Flag RawOpts
outputFileFlag = [Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq
["output-file","o"] (\s :: Name
s opts :: 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 "output-file" Name
s RawOpts
opts) "FILE"
"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 desc :: Name
desc = Update RawOpts -> Name -> Arg RawOpts
forall a. Update a -> Name -> Arg a
flagArg (\s :: Name
s opts :: 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 "args" Name
s RawOpts
opts) Name
desc
generalflagstitle :: String
generalflagstitle :: Name
generalflagstitle = "\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 = ""
,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 names :: [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 ["help"] (Name -> RawOpts -> RawOpts
setboolopt "help") "Show usage."
]
,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 "[QUERY]")
,modeValue :: RawOpts
modeValue=Name -> Name -> RawOpts -> RawOpts
setopt "command" (Name -> [Name] -> Name
forall a. a -> [a] -> a
headDef "" [Name]
names) RawOpts
forall a. Default a => a
def
}
addonCommandMode :: Name -> Mode RawOpts
addonCommandMode :: Name -> Mode RawOpts
addonCommandMode name :: Name
name = ([Name] -> Mode RawOpts
defCommandMode [Name
name]) {
modeHelp :: Name
modeHelp = ""
,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 doc :: Name
doc unnamedflaggroup :: [Flag RawOpts]
unnamedflaggroup namedflaggroups :: [(Name, [Flag RawOpts])]
namedflaggroups hiddenflaggroup :: [Flag RawOpts]
hiddenflaggroup argsdescr :: ([Arg RawOpts], Maybe (Arg RawOpts))
argsdescr =
case Name -> Maybe ([Name], Name, [Name])
parseCommandDoc Name
doc of
Nothing -> Name -> Mode RawOpts
forall a. Name -> a
error' (Name -> Mode RawOpts) -> Name -> Mode RawOpts
forall a b. (a -> b) -> a -> b
$ "Could not parse command doc:\n"Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++Name
docName -> Name -> Name
forall a. [a] -> [a] -> [a]
++"\n"
Just (names :: [Name]
names, shorthelp :: Name
shorthelp, longhelplines :: [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 t :: Name
t =
case Name -> [Name]
lines Name
t of
[] -> Maybe ([Name], Name, [Name])
forall a. Maybe a
Nothing
(l :: Name
l:ls :: [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 (\c :: Char
c -> if Char
c Char -> Name -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [',','\\'] then ' ' else Char
c) Name
l
(shorthelpls :: [Name]
shorthelpls, longhelpls :: [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
== "_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 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 m :: Mode a
m
| Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== "hledger-ui" = "ui"
| Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== "hledger-web" = "web"
| Bool
otherwise = "cli"
where n :: Name
n = Name -> [Name] -> Name
forall a. a -> [a] -> a
headDef "" ([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
s :: Name
s withAliases :: Name -> [Name] -> Name
`withAliases` [] = Name
s
s :: Name
s `withAliases` as :: [Name]
as = Name
s Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ " (" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name -> [Name] -> Name
forall a. [a] -> [[a]] -> [a]
intercalate ", " [Name]
as Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ ")"
data CliOpts = CliOpts {
CliOpts -> RawOpts
rawopts_ :: RawOpts
,CliOpts -> Name
command_ :: String
,CliOpts -> [Name]
file_ :: [FilePath]
,CliOpts -> InputOpts
inputopts_ :: InputOpts
,CliOpts -> ReportOpts
reportopts_ :: ReportOpts
,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 = RawOpts
-> Name
-> [Name]
-> InputOpts
-> ReportOpts
-> Maybe Name
-> Maybe Name
-> Int
-> Bool
-> Maybe Name
-> Int
-> CliOpts
CliOpts
RawOpts
forall a. Default a => a
def
Name
forall a. Default a => a
def
[Name]
forall a. Default a => a
def
InputOpts
forall a. Default a => a
def
ReportOpts
forall a. Default a => a
def
Maybe Name
forall a. Default a => a
def
Maybe Name
forall a. Default a => a
def
Int
forall a. Default a => a
def
Bool
forall a. Default a => a
def
Maybe Name
forall a. Default a => a
def
Int
defaultWidth
defaultWidth :: Int
defaultWidth :: Int
defaultWidth = 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 ('-':ds :: 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 = "--depth="Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++Name
ds
replace s :: Name
s = Name
s
rawOptsToCliOpts :: RawOpts -> IO CliOpts
rawOptsToCliOpts :: RawOpts -> IO CliOpts
rawOptsToCliOpts rawopts :: RawOpts
rawopts = CliOpts -> CliOpts
checkCliOpts (CliOpts -> CliOpts) -> IO CliOpts -> IO CliOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
let iopts :: InputOpts
iopts = RawOpts -> InputOpts
rawOptsToInputOpts RawOpts
rawopts
ReportOpts
ropts <- RawOpts -> IO ReportOpts
rawOptsToReportOpts 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 "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 "command" RawOpts
rawopts
,file_ :: [Name]
file_ = Name -> RawOpts -> [Name]
listofstringopt "file" RawOpts
rawopts
,inputopts_ :: InputOpts
inputopts_ = InputOpts
iopts
,reportopts_ :: ReportOpts
reportopts_ = ReportOpts
ropts
,output_file_ :: Maybe Name
output_file_ = Name -> RawOpts -> Maybe Name
maybestringopt "output-file" RawOpts
rawopts
,output_format_ :: Maybe Name
output_format_ = Name -> RawOpts -> Maybe Name
maybestringopt "output-format" RawOpts
rawopts
,debug_ :: Int
debug_ = Name -> RawOpts -> Int
posintopt "debug" RawOpts
rawopts
,no_new_accounts_ :: Bool
no_new_accounts_ = Name -> RawOpts -> Bool
boolopt "no-new-accounts" RawOpts
rawopts
,width_ :: Maybe Name
width_ = Name -> RawOpts -> Maybe Name
maybestringopt "width" RawOpts
rawopts
,available_width_ :: Int
available_width_ = Int
availablewidth
}
checkCliOpts :: CliOpts -> CliOpts
checkCliOpts :: CliOpts -> CliOpts
checkCliOpts opts :: CliOpts
opts =
(Name -> CliOpts) -> (() -> CliOpts) -> Either Name () -> CliOpts
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Name -> CliOpts
forall a. Name -> a
usageError (CliOpts -> () -> CliOpts
forall a b. a -> b -> a
const CliOpts
opts) (Either Name () -> CliOpts) -> Either Name () -> CliOpts
forall a b. (a -> b) -> a -> b
$ do
case ReportOpts -> Either Name StringFormat
lineFormatFromOpts (ReportOpts -> Either Name StringFormat)
-> ReportOpts -> Either Name StringFormat
forall a b. (a -> b) -> a -> b
$ CliOpts -> ReportOpts
reportopts_ CliOpts
opts of
Left err :: Name
err -> Name -> Either Name ()
forall a b. a -> Either a b
Left (Name -> Either Name ()) -> Name -> Either Name ()
forall a b. (a -> b) -> a -> b
$ "could not parse format option: "Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++Name
err
Right _ -> () -> Either Name ()
forall a b. b -> Either a b
Right ()
getHledgerCliOpts' :: Mode RawOpts -> [String] -> IO CliOpts
getHledgerCliOpts' :: Mode RawOpts -> [Name] -> IO CliOpts
getHledgerCliOpts' mode' :: Mode RawOpts
mode' args' :: [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 ("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
. ("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]
++
[""
," See also hledger -h for general hledger options."
]
debugArgs :: [String] -> CliOpts -> IO ()
debugArgs :: [Name] -> CliOpts -> IO ()
debugArgs args' :: [Name]
args' opts :: CliOpts
opts =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ("--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
$ "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
$ "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
$ "processed opts:\n" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ CliOpts -> Name
forall a. Show a => a -> Name
show CliOpts
opts
Day
d <- IO Day
getCurrentDay
Name -> IO ()
putStrLn (Name -> IO ()) -> Name -> IO ()
forall a b. (a -> b) -> a -> b
$ "search query: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Query -> Name
forall a. Show a => a -> Name
show (Day -> ReportOpts -> Query
queryFromOpts Day
d (ReportOpts -> Query) -> ReportOpts -> Query
forall a b. (a -> b) -> a -> b
$ CliOpts -> ReportOpts
reportopts_ CliOpts
opts)
getHledgerCliOpts :: Mode RawOpts -> IO CliOpts
getHledgerCliOpts :: Mode RawOpts -> IO CliOpts
getHledgerCliOpts mode' :: 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 opts :: 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]
fs :: [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 d :: Name
d prefixedf :: Name
prefixedf = do
let (p :: Maybe Name
p,f :: 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 p :: Name
p -> Name
p Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ ":" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
f'
Nothing -> Name
f'
outputFileFromOpts :: CliOpts -> IO FilePath
outputFileFromOpts :: CliOpts -> IO Name
outputFileFromOpts opts :: CliOpts
opts = do
Name
d <- IO Name
getCurrentDirectory
case CliOpts -> Maybe Name
output_file_ CliOpts
opts of
Just p :: Name
p -> Name -> Name -> IO Name
expandPath Name
d Name
p
Nothing -> Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return "-"
defaultOutputFormat :: Name
defaultOutputFormat = "txt"
outputFormats :: [Name]
outputFormats =
[Name
defaultOutputFormat] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
["csv"
,"html"
]
outputFormatFromOpts :: CliOpts -> String
outputFormatFromOpts :: CliOpts -> Name
outputFormatFromOpts opts :: CliOpts
opts =
case CliOpts -> Maybe Name
output_format_ CliOpts
opts of
Just f :: Name
f -> Name
f
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 ext :: Name
ext | Name
ext Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
outputFormats -> Name
ext
_ -> 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
=='.') (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 opts :: 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 s :: 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) "(unknown)" Name
s of
Left e :: ParseErrorBundle Name Void
e -> Name -> Int
forall a. Name -> a
usageError (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ "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 w :: 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 s :: 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 "(unknown)" Name
s of
Left e :: 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
$ "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 ws :: (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 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)
lineFormatFromOpts :: ReportOpts -> Either String StringFormat
lineFormatFromOpts :: ReportOpts -> Either Name StringFormat
lineFormatFromOpts = Either Name StringFormat
-> (Name -> Either Name StringFormat)
-> Maybe Name
-> Either Name StringFormat
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (StringFormat -> Either Name StringFormat
forall a b. b -> Either a b
Right StringFormat
defaultBalanceLineFormat) Name -> Either Name StringFormat
parseStringFormat (Maybe Name -> Either Name StringFormat)
-> (ReportOpts -> Maybe Name)
-> ReportOpts
-> Either Name StringFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReportOpts -> Maybe Name
format_
defaultBalanceLineFormat :: StringFormat
defaultBalanceLineFormat :: StringFormat
defaultBalanceLineFormat = [StringFormatComponent] -> StringFormat
BottomAligned [
Bool
-> Maybe Int
-> Maybe Int
-> ReportItemField
-> StringFormatComponent
FormatField Bool
False (Int -> Maybe Int
forall a. a -> Maybe a
Just 20) Maybe Int
forall a. Maybe a
Nothing ReportItemField
TotalField
, Name -> StringFormatComponent
FormatLiteral " "
, Bool
-> Maybe Int
-> Maybe Int
-> ReportItemField
-> StringFormatComponent
FormatField Bool
True (Int -> Maybe Int
forall a. a -> Maybe a
Just 2) Maybe Int
forall a. Maybe a
Nothing ReportItemField
DepthSpacerField
, Bool
-> Maybe Int
-> Maybe Int
-> ReportItemField
-> StringFormatComponent
FormatField Bool
True Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing ReportItemField
AccountField
]
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 (\a :: Name
a b :: 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
+ 1)
dropRedundantSourceVersion :: [Name] -> [Name]
dropRedundantSourceVersion [f :: Name
f,g :: 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 fs :: [Name]
fs = [Name]
fs
compiledExts :: [Name]
compiledExts = ["",".com",".exe"]
likelyExecutablesInPath :: IO [String]
likelyExecutablesInPath :: IO [Name]
likelyExecutablesInPath = do
[Name]
pathdirs <- Name -> Name -> [Name]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOneOf "[:;]" (Name -> [Name]) -> IO Name -> IO [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> IO Name
getEnvSafe "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 Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Tokens Text -> ParsecT CustomErr Text m Text)
-> Tokens Text -> ParsecT CustomErr Text m 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 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 ['.']
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 "." 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 =
["bat"
,"com"
,"exe"
,"hs"
,"lhs"
,"pl"
,"py"
,"rb"
,"rkt"
,"sh"
]
getEnvSafe :: String -> IO String
getEnvSafe :: Name -> IO Name
getEnvSafe v :: 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 "")
getDirectoryContentsSafe :: FilePath -> IO [String]
getDirectoryContentsSafe :: Name -> IO [Name]
getDirectoryContentsSafe d :: 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]) -> 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 [])