slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cli, report & raw options cleanups

Browse Source
This commit is contained in:
Simon Michael 2014-03-25 17:10:30 -07:00
parent 3fa4824218
commit 882a9dbf1c
6 changed files with 365 additions and 313 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
hledger-lib/Hledger/Data.hs
View File

@ -16,6 +16,7 @@ module Hledger.Data (
module Hledger.Data.Journal,
module Hledger.Data.Ledger,
module Hledger.Data.Posting,
module Hledger.Data.RawOptions,
module Hledger.Data.TimeLog,
module Hledger.Data.Transaction,
module Hledger.Data.Types,
@ -32,10 +33,12 @@ import Hledger.Data.Dates
import Hledger.Data.Journal
import Hledger.Data.Ledger
import Hledger.Data.Posting
import Hledger.Data.RawOptions
import Hledger.Data.TimeLog
import Hledger.Data.Transaction
import Hledger.Data.Types
tests_Hledger_Data :: Test
tests_Hledger_Data = TestList
[
tests_Hledger_Data_Account

69
hledger-lib/Hledger/Data/RawOptions.hs Normal file
View File

@ -0,0 +1,69 @@
{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DeriveDataTypeable #-}
{-|
hledger's cmdargs modes parse command-line arguments to an
intermediate format, RawOpts (an association list), rather than a
fixed ADT like CliOpts. This allows the modes and flags to be reused
more easily by hledger commands/scripts in this and other packages.
-}
module Hledger.Data.RawOptions (
RawOpts,
setopt,
setboolopt,
inRawOpts,
boolopt,
stringopt,
maybestringopt,
listofstringopt,
intopt,
maybeintopt,
optserror
)
where
import Data.Maybe
import Safe
import Hledger.Utils
-- | The result of running cmdargs: an association list of option names to string values.
type RawOpts = [(String,String)]
setopt :: String -> String -> RawOpts -> RawOpts
setopt name val = (++ [(name,singleQuoteIfNeeded val)])
setboolopt :: String -> RawOpts -> RawOpts
setboolopt name = (++ [(name,"")])
-- | Is the named option present ?
inRawOpts :: String -> RawOpts -> Bool
inRawOpts name = isJust . lookup name
boolopt :: String -> RawOpts -> Bool
boolopt = inRawOpts
maybestringopt :: String -> RawOpts -> Maybe String
maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name
stringopt :: String -> RawOpts -> String
stringopt name = fromMaybe "" . maybestringopt name
listofstringopt :: String -> RawOpts -> [String]
listofstringopt name rawopts = [v | (k,v) <- rawopts, k==name]
maybeintopt :: String -> RawOpts -> Maybe Int
maybeintopt name rawopts =
let ms = maybestringopt name rawopts in
case ms of Nothing -> Nothing
Just s -> Just $ readDef (optserror $ "could not parse "++name++" number: "++s) s
intopt :: String -> RawOpts -> Int
intopt name = fromMaybe 0 . maybeintopt name
-- | Raise an error, showing the specified message plus a hint about --help.
optserror :: String -> a
optserror = error' . (++ " (run with --help for usage)")

114
hledger-lib/Hledger/Reports/ReportOptions.hs
View File

@ -1,16 +1,16 @@
{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-}
{-|
Reusable report-related options.
Options common to most hledger reports.
-}
module Hledger.Reports.ReportOptions (
ReportOpts(..),
BalanceType(..),
DisplayExp,
FormatStr,
defreportopts,
rawOptsToReportOpts,
dateSpanFromOpts,
intervalFromOpts,
clearedValueFromOpts,
@ -23,14 +23,15 @@ module Hledger.Reports.ReportOptions (
transactionDateFn,
postingDateFn,
-- * Tests
tests_Hledger_Reports_ReportOptions
)
where
import Data.Data (Data)
import Data.Typeable (Typeable)
import Data.Time.Calendar
import Safe (headMay, lastMay)
import System.Console.CmdArgs -- for defaults support
import System.Console.CmdArgs.Default -- some additional default stuff
import Test.HUnit
import Hledger.Data
@ -38,6 +39,16 @@ import Hledger.Query
import Hledger.Utils
type FormatStr = String
-- | Which balance is being shown in a multi-column balance report.
data BalanceType = PeriodBalance -- ^ The change of balance in each period.
| CumulativeBalance -- ^ The accumulated balance at each period's end, starting from zero at the report start date.
| HistoricalBalance -- ^ The historical balance at each period's end, starting from the account balances at the report start date.
deriving (Eq,Show,Data,Typeable)
instance Default BalanceType where def = PeriodBalance
-- | Standard options for customising report filtering and output,
-- corresponding to hledger's command-line options and query language
-- arguments. Used in hledger-lib and above.
@ -54,31 +65,26 @@ data ReportOpts = ReportOpts {
,empty_ :: Bool
,no_elide_ :: Bool
,real_ :: Bool
,balancetype_ :: BalanceType -- for balance command
,flat_ :: Bool -- for balance command
,drop_ :: Int -- "
,no_total_ :: Bool -- "
,daily_ :: Bool
,weekly_ :: Bool
,monthly_ :: Bool
,quarterly_ :: Bool
,yearly_ :: Bool
,format_ :: Maybe FormatStr
,related_ :: Bool
,average_ :: Bool
,query_ :: String -- all arguments, as a string
-- register
,average_ :: Bool
,related_ :: Bool
-- balance
,balancetype_ :: BalanceType
,flat_ :: Bool
,drop_ :: Int
,no_total_ :: Bool
} deriving (Show, Data, Typeable)
type DisplayExp = String
type FormatStr = String
-- | Which balance is being shown in a multi-column balance report.
data BalanceType = PeriodBalance -- ^ The change of balance in each period.
| CumulativeBalance -- ^ The accumulated balance at each period's end, starting from zero at the report start date.
| HistoricalBalance -- ^ The historical balance at each period's end, starting from the account balances at the report start date.
deriving (Eq,Show,Data,Typeable)
instance Default BalanceType where def = PeriodBalance
instance Default ReportOpts where def = defreportopts
defreportopts :: ReportOpts
defreportopts = ReportOpts
def
def
@ -106,7 +112,73 @@ defreportopts = ReportOpts
def
def
instance Default ReportOpts where def = defreportopts
rawOptsToReportOpts :: RawOpts -> IO ReportOpts
rawOptsToReportOpts rawopts = do
d <- getCurrentDay
return defreportopts{
begin_ = maybesmartdateopt d "begin" rawopts
,end_ = maybesmartdateopt d "end" rawopts
,period_ = maybeperiodopt d rawopts
,cleared_ = boolopt "cleared" rawopts
,uncleared_ = boolopt "uncleared" rawopts
,cost_ = boolopt "cost" rawopts
,depth_ = maybeintopt "depth" rawopts
,display_ = maybedisplayopt d rawopts
,date2_ = boolopt "date2" rawopts
,empty_ = boolopt "empty" rawopts
,no_elide_ = boolopt "no-elide" rawopts
,real_ = boolopt "real" rawopts
,daily_ = boolopt "daily" rawopts
,weekly_ = boolopt "weekly" rawopts
,monthly_ = boolopt "monthly" rawopts
,quarterly_ = boolopt "quarterly" rawopts
,yearly_ = boolopt "yearly" rawopts
,format_ = maybestringopt "format" rawopts
,query_ = unwords $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right
,average_ = boolopt "average" rawopts
,related_ = boolopt "related" rawopts
,balancetype_ = balancetypeopt rawopts
,flat_ = boolopt "flat" rawopts
,drop_ = intopt "drop" rawopts
,no_total_ = boolopt "no-total" rawopts
}
balancetypeopt :: RawOpts -> BalanceType
balancetypeopt rawopts
| length [o | o <- ["cumulative","historical"], isset o] > 1
= optserror "please specify at most one of --cumulative and --historical"
| isset "cumulative" = CumulativeBalance
| isset "historical" = HistoricalBalance
| otherwise = PeriodBalance
where
isset = flip boolopt rawopts
maybesmartdateopt :: Day -> String -> RawOpts -> Maybe Day
maybesmartdateopt d name rawopts =
case maybestringopt name rawopts of
Nothing -> Nothing
Just s -> either
(\e -> optserror $ "could not parse "++name++" date: "++show e)
Just
$ fixSmartDateStrEither' d s
type DisplayExp = String
maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp
maybedisplayopt d rawopts =
maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts
where
fixbracketeddatestr "" = ""
fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]"
maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan)
maybeperiodopt d rawopts =
case maybestringopt "period" rawopts of
Nothing -> Nothing
Just s -> either
(\e -> optserror $ "could not parse period option: "++show e)
Just
$ parsePeriodExpr d s
-- | Figure out the date span we should report on, based on any
-- begin/end/period options provided. A period option will cause begin and
@ -182,6 +254,7 @@ queryFromOptsOnly d opts@ReportOpts{..} = simplifyQuery flagsq
++ (maybe [] ((:[]) . Status) (clearedValueFromOpts opts))
++ (maybe [] ((:[]) . Depth) depth_)
tests_queryFromOpts :: [Test]
tests_queryFromOpts = [
"queryFromOpts" ~: do
assertEqual "" Any (queryFromOpts nulldate defreportopts)
@ -204,6 +277,7 @@ queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts
flagsqopts = []
argsqopts = snd $ parseQuery d query_
tests_queryOptsFromOpts :: [Test]
tests_queryOptsFromOpts = [
"queryOptsFromOpts" ~: do
assertEqual "" [] (queryOptsFromOpts nulldate defreportopts)

1
hledger-lib/hledger-lib.cabal
View File

@ -43,6 +43,7 @@ library
Hledger.Data.Journal
Hledger.Data.Ledger
Hledger.Data.Posting
Hledger.Data.RawOptions
Hledger.Data.TimeLog
Hledger.Data.Transaction
Hledger.Data.Types

8
hledger/Hledger/Cli/Main.hs
View File

@ -62,16 +62,16 @@ import Hledger.Cli.Options
import Hledger.Cli.Tests
import Hledger.Cli.Utils
import Hledger.Cli.Version
import Hledger.Data.Dates (getCurrentDay)
import Hledger.Data.RawOptions (optserror)
import Hledger.Reports.ReportOptions (dateSpanFromOpts, intervalFromOpts, queryFromOpts)
import Hledger.Utils
import Hledger.Reports
import Hledger.Data.Dates
-- | The overall cmdargs mode describing command-line options for hledger.
mainmode addons = defMode {
modeNames = [progname]
,modeHelp = unlines [
]
,modeHelp = unlines []
,modeHelpSuffix = [""]
,modeArgs = ([], Just $ argsFlag "[ARGS]")
,modeGroupModes = Group {

481
hledger/Hledger/Cli/Options.hs
View File

@ -1,72 +1,54 @@
{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DeriveDataTypeable #-}
{-|
Common command-line options and utilities used by hledger's subcommands and addons.
Common cmdargs modes and flags, a command-line options type, and
related utilities used by hledger commands.
-}
module Hledger.Cli.Options (
-- * cmdargs modes & flags
-- | These tell cmdargs how to parse the command line arguments for each hledger subcommand.
argsFlag,
defAddonCommandMode,
defCommandMode,
defMode,
generalflagsgroup1,
generalflagsgroup2,
generalflagsgroup3,
-- * cmdargs flags & modes
helpflags,
inputflags,
reportflags,
-- * Raw options
-- | To allow the cmdargs modes to be reused and extended by other
-- packages (eg, add-ons which want to mimic the standard hledger
-- options), our cmdargs modes parse to an extensible association
-- list (RawOpts) rather than a closed ADT like CliOpts.
RawOpts,
boolopt,
inRawOpts,
intopt,
listofstringopt,
maybeintopt,
maybestringopt,
setboolopt,
setopt,
stringopt,
-- * CLI options
-- | Raw options are converted to a more convenient,
-- package-specific options structure. This is the \"opts\" used
-- throughout hledger CLI code.
CliOpts(..),
defcliopts,
-- * CLI option accessors
-- | Some options require more processing. Possibly these should be merged into argsToCliOpts.
OutputWidth(..),
Width(..),
aliasesFromOpts,
defaultWidth,
defaultWidthWithFlag,
formatFromOpts,
journalFilePathFromOpts,
rulesFilePathFromOpts,
widthFromOpts,
-- * utilities
checkCliOpts,
debugArgs,
decodeRawOpts,
getCliOpts,
getHledgerAddonCommands,
optserror,
rawOptsToCliOpts,
generalflagsgroup1,
generalflagsgroup2,
generalflagsgroup3,
defMode,
defCommandMode,
defAddonCommandMode,
argsFlag,
showModeHelp,
withAliases,
-- * tests
-- * CLI options
CliOpts(..),
defcliopts,
-- getCliOpts,
decodeRawOpts,
rawOptsToCliOpts,
checkCliOpts,
-- possibly these should move into argsToCliOpts
-- * CLI option accessors
-- | These do the extra processing required for some options.
aliasesFromOpts,
journalFilePathFromOpts,
rulesFilePathFromOpts,
-- | For register:
OutputWidth(..),
Width(..),
defaultWidth,
defaultWidthWithFlag,
widthFromOpts,
-- | For balance:
formatFromOpts,
-- * Other utils
getHledgerAddonCommands,
-- * Tests
tests_Hledger_Cli_Options
)
@ -74,18 +56,17 @@ where
import qualified Control.Exception as C
-- import Control.Monad (filterM)
import Control.Monad (when)
-- import Control.Monad (when)
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Time.Calendar
import Safe
import System.Console.CmdArgs
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Text
import System.Directory
import System.Environment
import System.Exit
-- import System.Exit
import Test.HUnit
import Text.ParserCombinators.Parsec as P
@ -93,17 +74,11 @@ import Hledger
import Hledger.Data.OutputFormat as OutputFormat
import Hledger.Cli.Version
--
-- 1. cmdargs mode and flag (option) definitions for the hledger CLI,
-- can be reused by other packages as well.
--
-- | Our cmdargs modes parse arguments into an association list for better reuse.
type RawOpts = [(String,String)]
-- common flags and flag groups
-- common cmdargs flags
-- | Common help flags: --help, --debug, --version...
helpflags :: [Flag RawOpts]
helpflags = [
flagNone ["help","h","?"] (setboolopt "help") "Display general help or (with --help after COMMAND) command help."
-- ,flagNone ["browse-args"] (setboolopt "browse-args") "use a web UI to select options and build up a command line"
@ -112,6 +87,7 @@ helpflags = [
]
-- | Common input-related flags: --file, --rules-file, --alias...
inputflags :: [Flag RawOpts]
inputflags = [
flagReq ["file","f"] (\s opts -> Right $ setopt "file" s opts) "FILE" "use a different journal file; - means stdin"
,flagReq ["rules-file"] (\s opts -> Right $ setopt "rules-file" s opts) "RULESFILE" "conversion rules for CSV (default: FILE.rules)"
@ -119,6 +95,7 @@ inputflags = [
]
-- | Common report-related flags: --period, --cost, --display etc.
reportflags :: [Flag RawOpts]
reportflags = [
flagReq ["begin","b"] (\s opts -> Right $ setopt "begin" s opts) "DATE" "report on transactions on or after this date"
,flagReq ["end","e"] (\s opts -> Right $ setopt "end" s opts) "DATE" "report on transactions before this date"
@ -138,9 +115,13 @@ reportflags = [
,flagNone ["real","R"] (\opts -> setboolopt "real" opts) "report only on real (non-virtual) transactions"
]
argsFlag :: FlagHelp -> Arg RawOpts
argsFlag desc = flagArg (\s opts -> Right $ setopt "args" s opts) desc
generalflagstitle :: String
generalflagstitle = "\nGeneral flags"
generalflagsgroup1, generalflagsgroup2, generalflagsgroup3 :: (String, [Flag RawOpts])
generalflagsgroup1 = (generalflagstitle, inputflags ++ reportflags ++ helpflags)
generalflagsgroup2 = (generalflagstitle, inputflags ++ helpflags)
generalflagsgroup3 = (generalflagstitle, helpflags)
@ -169,6 +150,7 @@ defMode = Mode {
}
-- | A basic subcommand mode with the given command name(s).
defCommandMode :: [Name] -> Mode RawOpts
defCommandMode names = defMode {
modeNames=names
,modeValue=[("command", headDef "" names)]
@ -176,6 +158,7 @@ defCommandMode names = defMode {
}
-- | A basic subcommand mode suitable for an add-on command.
defAddonCommandMode :: Name -> Mode RawOpts
defAddonCommandMode addon = defMode {
modeNames = [addon]
,modeHelp = fromMaybe "" $ lookup (striphs addon) standardAddonsHelp
@ -188,6 +171,7 @@ defAddonCommandMode addon = defMode {
,modeArgs = ([], Just $ argsFlag "[ARGS]")
}
striphs :: String -> String
striphs = regexReplace "\\.l?hs$" ""
-- | Built-in descriptions for some of the known external addons,
@ -207,6 +191,11 @@ standardAddonsHelp = [
,("rewrite", "add specified postings to matched transaction entries")
]
-- | Get a mode's help message as a nicely wrapped string.
showModeHelp :: Mode a -> String
showModeHelp = (showText defaultWrap :: [Text] -> String) .
(helpText [] HelpFormatDefault :: Mode a -> [Text])
-- | Add command aliases to the command's help string.
withAliases :: String -> [String] -> String
s `withAliases` as = s ++ " (" ++ intercalate ", " as ++ ")"
@ -223,14 +212,13 @@ s `withAliases` as = s ++ " (" ++ intercalate ", " as ++ ")"
-- -- ,"When using both, not: comes last."
-- ]
--
-- 2. A package-specific data structure holding options used in this
-- package and above, parsed from RawOpts. This represents the
-- command-line options that were provided, with all parsing
-- completed, but before adding defaults or derived values (XXX add)
--
-- | Command line options. Used in the @hledger@ package and above.
-- CliOpts
-- | Command line options, used in the @hledger@ package and above.
-- This is the \"opts\" used throughout hledger CLI code.
-- representing the options that arguments that were provided at
-- startup on the command-line.
data CliOpts = CliOpts {
rawopts_ :: RawOpts
,command_ :: String
@ -243,6 +231,9 @@ data CliOpts = CliOpts {
,reportopts_ :: ReportOpts
} deriving (Show, Data, Typeable)
instance Default CliOpts where def = defcliopts
defcliopts :: CliOpts
defcliopts = CliOpts
def
def
@ -254,14 +245,16 @@ defcliopts = CliOpts
def
def
instance Default CliOpts where def = defcliopts
-- | Convert possibly encoded option values to regular unicode strings.
decodeRawOpts :: RawOpts -> RawOpts
decodeRawOpts = map (\(name,val) -> (name, fromSystemString val))
-- | Parse raw option string values to the desired final data types.
-- Any relative smart dates will be converted to fixed dates based on
-- today's date. Parsing failures will raise an error.
rawOptsToCliOpts :: RawOpts -> IO CliOpts
rawOptsToCliOpts rawopts = do
d <- getCurrentDay
ropts <- rawOptsToReportOpts rawopts
return defcliopts {
rawopts_ = rawopts
,command_ = stringopt "command" rawopts
@ -271,37 +264,8 @@ rawOptsToCliOpts rawopts = do
,debug_ = intopt "debug" rawopts
,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add
,width_ = maybestringopt "width" rawopts -- register
,reportopts_ = defreportopts {
begin_ = maybesmartdateopt d "begin" rawopts
,end_ = maybesmartdateopt d "end" rawopts
,period_ = maybeperiodopt d rawopts
,cleared_ = boolopt "cleared" rawopts
,uncleared_ = boolopt "uncleared" rawopts
,cost_ = boolopt "cost" rawopts
,depth_ = maybeintopt "depth" rawopts
,display_ = maybedisplayopt d rawopts
,date2_ = boolopt "date2" rawopts
,empty_ = boolopt "empty" rawopts
,no_elide_ = boolopt "no-elide" rawopts
,real_ = boolopt "real" rawopts
,balancetype_ = balancetypeopt rawopts -- balance
,flat_ = boolopt "flat" rawopts -- balance
,drop_ = intopt "drop" rawopts -- balance
,no_total_ = boolopt "no-total" rawopts -- balance
,daily_ = boolopt "daily" rawopts
,weekly_ = boolopt "weekly" rawopts
,monthly_ = boolopt "monthly" rawopts
,quarterly_ = boolopt "quarterly" rawopts
,yearly_ = boolopt "yearly" rawopts
,format_ = maybestringopt "format" rawopts
,average_ = boolopt "average" rawopts -- register
,related_ = boolopt "related" rawopts -- register
,query_ = unwords $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right
,reportopts_ = ropts
}
}
-- | Convert possibly encoded option values to regular unicode strings.
decodeRawOpts = map (\(name,val) -> (name, fromSystemString val))
-- | Do final validation of processed opts, raising an error if there is trouble.
checkCliOpts :: CliOpts -> IO CliOpts -- or pure..
@ -314,159 +278,22 @@ checkCliOpts opts@CliOpts{reportopts_=ropts} = do
Right _ -> return ()
return opts
--
-- utils
--
-- not used:
-- -- | Parse hledger CLI options from the command line using the given
-- -- cmdargs mode, and either return them or, if a help flag is present,
-- -- print the mode help and exit the program.
-- getCliOpts :: Mode RawOpts -> IO CliOpts
-- getCliOpts mode = do
-- args <- getArgs
-- let rawopts = decodeRawOpts $ processValue mode args
-- opts <- rawOptsToCliOpts rawopts >>= checkCliOpts
-- debugArgs args opts
-- -- if any (`elem` args) ["--help","-h","-?"]
-- when ("help" `inRawOpts` rawopts_ opts) $
-- putStr (showModeHelp mode) >> exitSuccess
-- return opts
-- | Get the unique suffixes (without hledger-) of hledger-* executables
-- found in the current user's PATH, or the empty list if there is any
-- problem.
getHledgerAddonCommands :: IO [String]
getHledgerAddonCommands = map (drop (length progname + 1)) `fmap` getHledgerExesInPath
-- | Get the unique names of hledger-*{,.hs} executables found in the current
-- user's PATH, or the empty list if there is any problem.
getHledgerExesInPath :: IO [String]
getHledgerExesInPath = do
pathdirs <- splitOn ":" `fmap` getEnvSafe "PATH"
pathfiles <- concat `fmap` mapM getDirectoryContentsSafe pathdirs
let hledgernamed = nubBy (\a b -> striphs a == striphs b) $ sort $ filter isHledgerExeName pathfiles
where striphs = regexReplace "\\.l?hs$" ""
-- hledgerexes <- filterM isExecutable hledgernamed
return hledgernamed
-- isExecutable f = getPermissions f >>= (return . executable)
isHledgerExeName = isRight . parsewith hledgerexenamep
where
hledgerexenamep = do
string progname
char '-'
many1 (noneOf ".")
optional (string ".hs" <|> string ".lhs")
eof
getEnvSafe v = getEnv v `C.catch` (\(_::C.IOException) -> return "")
getDirectoryContentsSafe d =
(filter (not . (`elem` [".",".."])) `fmap` getDirectoryContents d) `C.catch` (\(_::C.IOException) -> return [])
-- | Raise an error, showing the specified message plus a hint about --help.
optserror = error' . (++ " (run with --help for usage)")
setopt name val = (++ [(name,singleQuoteIfNeeded val)])
setboolopt name = (++ [(name,"")])
-- | Is the named option present ?
inRawOpts :: String -> RawOpts -> Bool
inRawOpts name = isJust . lookup name
boolopt = inRawOpts
maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name
stringopt name = fromMaybe "" . maybestringopt name
listofstringopt name rawopts = [v | (k,v) <- rawopts, k==name]
maybeintopt :: String -> RawOpts -> Maybe Int
maybeintopt name rawopts =
let ms = maybestringopt name rawopts in
case ms of Nothing -> Nothing
Just s -> Just $ readDef (optserror $ "could not parse "++name++" number: "++s) s
intopt name = fromMaybe 0 . maybeintopt name
maybesmartdateopt :: Day -> String -> RawOpts -> Maybe Day
maybesmartdateopt d name rawopts =
case maybestringopt name rawopts of
Nothing -> Nothing
Just s -> either
(\e -> optserror $ "could not parse "++name++" date: "++show e)
Just
$ fixSmartDateStrEither' d s
maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp
maybedisplayopt d rawopts =
maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts
where
fixbracketeddatestr "" = ""
fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]"
maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan)
maybeperiodopt d rawopts =
case maybestringopt "period" rawopts of
Nothing -> Nothing
Just s -> either
(\e -> optserror $ "could not parse period option: "++show e)
Just
$ parsePeriodExpr d s
balancetypeopt :: RawOpts -> BalanceType
balancetypeopt rawopts
| length [o | o <- ["cumulative","historical"], isset o] > 1
= optserror "please specify at most one of --cumulative and --historical"
| isset "cumulative" = CumulativeBalance
| isset "historical" = HistoricalBalance
| otherwise = PeriodBalance
where
isset = flip boolopt rawopts
-- | Parse the format option if provided, possibly returning an error,
-- otherwise get the default value.
formatFromOpts :: ReportOpts -> Either String [OutputFormat]
formatFromOpts = maybe (Right defaultBalanceFormat) parseStringFormat . format_
-- | Default line format for balance report: "%20(total) %2(depth_spacer)%-(account)"
defaultBalanceFormat :: [OutputFormat]
defaultBalanceFormat = [
FormatField False (Just 20) Nothing TotalField
, FormatLiteral " "
, FormatField True (Just 2) Nothing DepthSpacerField
, FormatField True Nothing Nothing AccountField
]
-- | Output width configuration (for register).
data OutputWidth =
TotalWidth Width -- ^ specify the overall width
| FieldWidths [Width] -- ^ specify each field's width
deriving Show
-- | A width value.
data Width =
Width Int -- ^ set width to exactly this number of characters
| Auto -- ^ set width automatically from available space
deriving Show
-- | Default width of hledger console output.
defaultWidth = 80
-- | Width of hledger console output when the -w flag is used with no value.
defaultWidthWithFlag = 120
-- | Parse the width option if provided, possibly returning an error,
-- otherwise get the default value.
widthFromOpts :: CliOpts -> Either String OutputWidth
widthFromOpts CliOpts{width_=Nothing} = Right $ TotalWidth $ Width defaultWidth
widthFromOpts CliOpts{width_=Just ""} = Right $ TotalWidth $ Width defaultWidthWithFlag
widthFromOpts CliOpts{width_=Just s} = parseWidth s
parseWidth :: String -> Either String OutputWidth
parseWidth s = case (runParser outputwidthp () "(unknown)") s of
Left e -> Left $ show e
Right x -> Right x
outputwidthp :: GenParser Char st OutputWidth
outputwidthp =
try (do w <- widthp
ws <- many1 (char ',' >> widthp)
return $ FieldWidths $ w:ws)
<|> TotalWidth `fmap` widthp
widthp :: GenParser Char st Width
widthp = (string "auto" >> return Auto)
<|> (Width . read) `fmap` many1 digit
-- CliOpts accessors
-- | Get the account name aliases from options, if any.
aliasesFromOpts :: CliOpts -> [(AccountName,AccountName)]
@ -495,41 +322,119 @@ rulesFilePathFromOpts opts = do
d <- getCurrentDirectory
maybe (return Nothing) (fmap Just . expandPath d) $ rules_file_ opts
-- | Get a mode's help message as a nicely wrapped string.
showModeHelp :: Mode a -> String
showModeHelp =
(showText defaultWrap :: [Text] -> String) .
(helpText [] HelpFormatDefault :: Mode a -> [Text])
-- for balance, currently:
-- | Parse the format option if provided, possibly returning an error,
-- otherwise get the default value.
formatFromOpts :: ReportOpts -> Either String [OutputFormat]
formatFromOpts = maybe (Right defaultBalanceFormat) parseStringFormat . format_
-- | Default line format for balance report: "%20(total) %2(depth_spacer)%-(account)"
defaultBalanceFormat :: [OutputFormat]
defaultBalanceFormat = [
FormatField False (Just 20) Nothing TotalField
, FormatLiteral " "
, FormatField True (Just 2) Nothing DepthSpacerField
, FormatField True Nothing Nothing AccountField
]
-- for register:
-- | Output width configuration (for register).
data OutputWidth =
TotalWidth Width -- ^ specify the overall width
| FieldWidths [Width] -- ^ specify each field's width
deriving Show
-- | A width value.
data Width =
Width Int -- ^ set width to exactly this number of characters
| Auto -- ^ set width automatically from available space
deriving Show
-- | Default width of hledger console output.
defaultWidth :: Int
defaultWidth = 80
-- | Width of hledger console output when the -w flag is used with no value.
defaultWidthWithFlag :: Int
defaultWidthWithFlag = 120
-- | Parse the width option if provided, possibly returning an error,
-- otherwise get the default value.
widthFromOpts :: CliOpts -> Either String OutputWidth
widthFromOpts CliOpts{width_=Nothing} = Right $ TotalWidth $ Width defaultWidth
widthFromOpts CliOpts{width_=Just ""} = Right $ TotalWidth $ Width defaultWidthWithFlag
widthFromOpts CliOpts{width_=Just s} = parseWidth s
parseWidth :: String -> Either String OutputWidth
parseWidth s = case (runParser outputwidthp () "(unknown)") s of
Left e -> Left $ show e
Right x -> Right x
outputwidthp :: GenParser Char st OutputWidth
outputwidthp =
try (do w <- widthp
ws <- many1 (char ',' >> widthp)
return $ FieldWidths $ w:ws)
<|> TotalWidth `fmap` widthp
widthp :: GenParser Char st Width
widthp = (string "auto" >> return Auto)
<|> (Width . read) `fmap` many1 digit
-- Other utils
-- | Get the unique suffixes (without hledger-) of hledger-* executables
-- found in the current user's PATH, or the empty list if there is any
-- problem.
getHledgerAddonCommands :: IO [String]
getHledgerAddonCommands = map (drop (length progname + 1)) `fmap` getHledgerExesInPath
-- | Get the unique names of hledger-*{,.hs} executables found in the current
-- user's PATH, or the empty list if there is any problem.
getHledgerExesInPath :: IO [String]
getHledgerExesInPath = do
pathdirs <- splitOn ":" `fmap` getEnvSafe "PATH"
pathfiles <- concat `fmap` mapM getDirectoryContentsSafe pathdirs
let hledgernamed = nubBy (\a b -> striphs a == striphs b) $ sort $ filter isHledgerExeName pathfiles
-- hledgerexes <- filterM isExecutable hledgernamed
return hledgernamed
-- isExecutable f = getPermissions f >>= (return . executable)
isHledgerExeName :: String -> Bool
isHledgerExeName = isRight . parsewith hledgerexenamep
where
hledgerexenamep = do
string progname
char '-'
many1 (noneOf ".")
optional (string ".hs" <|> string ".lhs")
eof
getEnvSafe :: String -> IO String
getEnvSafe v = getEnv v `C.catch` (\(_::C.IOException) -> return "")
getDirectoryContentsSafe :: FilePath -> IO [String]
getDirectoryContentsSafe d =
(filter (not . (`elem` [".",".."])) `fmap` getDirectoryContents d) `C.catch` (\(_::C.IOException) -> return [])
-- not used:
-- -- | Print debug info about arguments and options if --debug is present.
-- debugArgs :: [String] -> CliOpts -> IO ()
-- debugArgs args opts =
-- when ("--debug" `elem` args) $ do
-- progname <- getProgName
-- putStrLn $ "running: " ++ progname
-- putStrLn $ "raw args: " ++ show args
-- putStrLn $ "processed opts:\n" ++ show opts
-- d <- getCurrentDay
-- putStrLn $ "search query: " ++ (show $ queryFromOpts d $ reportopts_ opts)
-- | Print debug info about arguments and options if --debug is present.
debugArgs :: [String] -> CliOpts -> IO ()
debugArgs args opts =
when ("--debug" `elem` args) $ do
progname <- getProgName
putStrLn $ "running: " ++ progname
putStrLn $ "raw args: " ++ show args
putStrLn $ "processed opts:\n" ++ show opts
d <- getCurrentDay
putStrLn $ "search query: " ++ (show $ queryFromOpts d $ reportopts_ opts)
-- not used:
-- | Parse hledger CLI options from the command line using the given
-- cmdargs mode, and either return them or, if a help flag is present,
-- print the mode help and exit the program.
getCliOpts :: Mode RawOpts -> IO CliOpts
getCliOpts mode = do
args <- getArgs
let rawopts = decodeRawOpts $ processValue mode args
opts <- rawOptsToCliOpts rawopts >>= checkCliOpts
debugArgs args opts
-- if any (`elem` args) ["--help","-h","-?"]
when ("help" `inRawOpts` rawopts_ opts) $
putStr (showModeHelp mode) >> exitSuccess
return opts
-- tests
tests_Hledger_Cli_Options :: Test
tests_Hledger_Cli_Options = TestList
[
]