From 882a9dbf1c5f3d516e36c86d1758d453b1debacd Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Tue, 25 Mar 2014 17:10:30 -0700 Subject: [PATCH] cli, report & raw options cleanups --- hledger-lib/Hledger/Data.hs | 3 + hledger-lib/Hledger/Data/RawOptions.hs | 69 +++ hledger-lib/Hledger/Reports/ReportOptions.hs | 114 ++++- hledger-lib/hledger-lib.cabal | 1 + hledger/Hledger/Cli/Main.hs | 8 +- hledger/Hledger/Cli/Options.hs | 483 ++++++++----------- 6 files changed, 365 insertions(+), 313 deletions(-) create mode 100644 hledger-lib/Hledger/Data/RawOptions.hs diff --git a/hledger-lib/Hledger/Data.hs b/hledger-lib/Hledger/Data.hs index bfeb50343..d2a9960b3 100644 --- a/hledger-lib/Hledger/Data.hs +++ b/hledger-lib/Hledger/Data.hs @@ -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 diff --git a/hledger-lib/Hledger/Data/RawOptions.hs b/hledger-lib/Hledger/Data/RawOptions.hs new file mode 100644 index 000000000..2bb2ff606 --- /dev/null +++ b/hledger-lib/Hledger/Data/RawOptions.hs @@ -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)") + diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index 7c8a008f4..a6381506b 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -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) diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index c6072be56..202ddd24a 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -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 diff --git a/hledger/Hledger/Cli/Main.hs b/hledger/Hledger/Cli/Main.hs index 14ba5cc8d..5b0da8ae4 100644 --- a/hledger/Hledger/Cli/Main.hs +++ b/hledger/Hledger/Cli/Main.hs @@ -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 { diff --git a/hledger/Hledger/Cli/Options.hs b/hledger/Hledger/Cli/Options.hs index ae0999869..d2968be5d 100644 --- a/hledger/Hledger/Cli/Options.hs +++ b/hledger/Hledger/Cli/Options.hs @@ -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, + + -- * CLI options + CliOpts(..), + defcliopts, + -- getCliOpts, + decodeRawOpts, + rawOptsToCliOpts, + checkCliOpts, - -- * tests + -- 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,38 +264,9 @@ 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.. checkCliOpts opts@CliOpts{reportopts_=ropts} = do @@ -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 [ ]