622 lines
		
	
	
		
			24 KiB
		
	
	
	
		
			Haskell
		
	
	
	
	
	
			
		
		
	
	
			622 lines
		
	
	
		
			24 KiB
		
	
	
	
		
			Haskell
		
	
	
	
	
	
| {-|
 | |
| 
 | |
| Common cmdargs modes and flags, a command-line options type, and
 | |
| related utilities used by hledger commands.
 | |
| 
 | |
| -}
 | |
| 
 | |
| {-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts, TypeFamilies #-}
 | |
| 
 | |
| module Hledger.Cli.CliOptions (
 | |
| 
 | |
|   -- * cmdargs flags & modes
 | |
|   helpflags,
 | |
|   detailedversionflag,
 | |
|   inputflags,
 | |
|   reportflags,
 | |
|   outputflags,
 | |
|   generalflagsgroup1,
 | |
|   generalflagsgroup2,
 | |
|   generalflagsgroup3,
 | |
|   defMode,
 | |
|   defCommandMode,
 | |
|   defAddonCommandMode,
 | |
|   argsFlag,
 | |
|   showModeUsage,
 | |
|   withAliases,
 | |
| 
 | |
|   -- * CLI options
 | |
|   CliOpts(..),
 | |
|   defcliopts,
 | |
|   getCliOpts,
 | |
|   decodeRawOpts,
 | |
|   rawOptsToCliOpts,
 | |
|   checkCliOpts,
 | |
|   outputFormats,
 | |
|   defaultOutputFormat,
 | |
|   defaultBalanceLineFormat,
 | |
| 
 | |
|   -- possibly these should move into argsToCliOpts
 | |
|   -- * CLI option accessors
 | |
|   -- | These do the extra processing required for some options.
 | |
|   aliasesFromOpts,
 | |
|   journalFilePathFromOpts,
 | |
|   rulesFilePathFromOpts,
 | |
|   outputFileFromOpts,
 | |
|   outputFormatFromOpts,
 | |
|   defaultWidth,
 | |
|   widthFromOpts,
 | |
|   -- | For register:
 | |
|   registerWidthsFromOpts,
 | |
|   maybeAccountNameDrop,
 | |
|   -- | For balance:
 | |
|   lineFormatFromOpts,
 | |
| 
 | |
|   -- * Other utils
 | |
|   hledgerAddons,
 | |
|   topicForMode,
 | |
| 
 | |
|   -- * Tests
 | |
|   tests_Hledger_Cli_CliOptions
 | |
| 
 | |
| )
 | |
| where
 | |
| 
 | |
| import Prelude ()
 | |
| import Prelude.Compat
 | |
| import qualified Control.Exception as C
 | |
| import Control.Monad (when)
 | |
| import Data.Default
 | |
| #if !MIN_VERSION_base(4,8,0)
 | |
| import Data.Functor.Compat ((<$>))
 | |
| #endif
 | |
| import Data.Functor.Identity (Identity)
 | |
| import Data.List.Compat
 | |
| import Data.List.Split (splitOneOf)
 | |
| import Data.Maybe
 | |
| -- import Data.Text (Text)
 | |
| import qualified Data.Text as T
 | |
| 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 Test.HUnit
 | |
| import Text.Megaparsec
 | |
| 
 | |
| import Hledger
 | |
| import Hledger.Cli.DocFiles
 | |
| import Hledger.Cli.Version
 | |
| 
 | |
| 
 | |
| -- common cmdargs flags
 | |
| 
 | |
| -- | Common help flags: --help, --debug, --version...
 | |
| helpflags :: [Flag RawOpts]
 | |
| helpflags = [
 | |
|   flagNone ["h"]    (setboolopt "h")    "show general usage or (after COMMAND, the command's usage"
 | |
|  ,flagNone ["help"] (setboolopt "help") "show the current program's manual as plain text (or after an add-on COMMAND, the add-on's manual)"
 | |
|  ,flagNone ["man"]  (setboolopt "man")  "show the current program's manual with man"
 | |
|  ,flagNone ["info"] (setboolopt "info") "show the current program's manual with info"
 | |
|  -- ,flagNone ["browse-args"] (setboolopt "browse-args") "use a web UI to select options and build up a command line"
 | |
|  ,flagReq  ["debug"]    (\s opts -> Right $ setopt "debug" s opts) "[N]" "show debug output (levels 1-9, default: 1)"
 | |
|  ,flagNone ["version"] (setboolopt "version") "show version information"
 | |
|  ]
 | |
| 
 | |
| -- | A hidden flag, just for the hledger executable.
 | |
| detailedversionflag :: Flag RawOpts
 | |
| detailedversionflag = flagNone ["version+"] (setboolopt "version+") "show version information with extra detail"
 | |
| 
 | |
| -- | 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 input file. For stdin, use -"
 | |
|  ,flagReq ["rules-file"]  (\s opts -> Right $ setopt "rules-file" s opts) "RFILE" "CSV conversion rules file (default: FILE.rules)"
 | |
|  ,flagReq ["alias"]  (\s opts -> Right $ setopt "alias" s opts)  "OLD=NEW" "display accounts named OLD as NEW"
 | |
|  ,flagNone ["ignore-assertions","I"] (setboolopt "ignore-assertions") "ignore any balance assertions in the journal"
 | |
|  ,flagReq ["pivot"]  (\s opts -> Right $ setopt "pivot" s opts)  "TAGNAME" "organize reports by some tag's value, not by account"
 | |
|  ]
 | |
| 
 | |
| -- | Common report-related flags: --period, --cost, etc.
 | |
| reportflags :: [Flag RawOpts]
 | |
| reportflags = [
 | |
|   flagReq  ["begin","b"]     (\s opts -> Right $ setopt "begin" s opts) "DATE" "include postings/txns on or after this date"
 | |
|  ,flagReq  ["end","e"]       (\s opts -> Right $ setopt "end" s opts) "DATE" "include postings/txns before this date"
 | |
|  ,flagNone ["daily","D"]     (setboolopt "daily") "multiperiod/multicolumn report by day"
 | |
|  ,flagNone ["weekly","W"]    (setboolopt "weekly") "multiperiod/multicolumn report by week"
 | |
|  ,flagNone ["monthly","M"]   (setboolopt "monthly") "multiperiod/multicolumn report by month"
 | |
|  ,flagNone ["quarterly","Q"] (setboolopt "quarterly") "multiperiod/multicolumn report by quarter"
 | |
|  ,flagNone ["yearly","Y"]    (setboolopt "yearly") "multiperiod/multicolumn report by year"
 | |
|  ,flagReq  ["period","p"]    (\s opts -> Right $ setopt "period" s opts) "PERIODEXP" "set start date, end date, and/or report interval all at once (overrides the flags above)"
 | |
|  ,flagNone ["date2"]         (setboolopt "date2") "show, and make -b/-e/-p/date: match, secondary dates instead"
 | |
| 
 | |
|  ,flagNone ["cleared","C"]   (setboolopt "cleared") "include only cleared postings/txns"
 | |
|  ,flagNone ["pending"]       (setboolopt "pending") "include only pending postings/txns"
 | |
|  ,flagNone ["uncleared","U"] (setboolopt "uncleared") "include only uncleared (and pending) postings/txns"
 | |
|  ,flagNone ["real","R"]      (setboolopt "real") "include only non-virtual postings"
 | |
|  ,flagReq  ["depth"]         (\s opts -> Right $ setopt "depth" s opts) "N" "hide accounts/postings deeper than N"
 | |
|  ,flagNone ["empty","E"]     (setboolopt "empty") "show items with zero amount, normally hidden"
 | |
|  ,flagNone ["cost","B"]      (setboolopt "cost") "convert amounts to their cost at transaction time (using the transaction price, if any)"
 | |
|  ,flagNone ["anon"]              (setboolopt "anon") "output ledger with anonymized accounts and payees."
 | |
|  ]
 | |
| 
 | |
| -- | Common output-related flags: --output-file, --output-format...
 | |
| outputflags = [
 | |
|    flagReq  ["output-format","O"] (\s opts -> Right $ setopt "output-format" s opts) "FMT" "select the output format. Supported formats:\ntxt, csv."
 | |
|   ,flagReq  ["output-file","o"]   (\s opts -> Right $ setopt "output-file" s opts) "FILE" "write output to FILE. A file extension matching one of the above formats selects that format."
 | |
|   ]
 | |
| 
 | |
| argsFlag :: FlagHelp -> Arg RawOpts
 | |
| argsFlag desc = flagArg (\s opts -> Right $ setopt "args" s opts) desc
 | |
| 
 | |
| generalflagstitle :: String
 | |
| generalflagstitle = "\nGeneral flags"
 | |
| 
 | |
| generalflagsgroup1, generalflagsgroup2, generalflagsgroup3 :: (String, [Flag RawOpts])
 | |
| generalflagsgroup1 = (generalflagstitle, inputflags ++ reportflags ++ helpflags)
 | |
| generalflagsgroup2 = (generalflagstitle, inputflags ++ helpflags)
 | |
| generalflagsgroup3 = (generalflagstitle, helpflags)
 | |
| 
 | |
| -- cmdargs mode constructors
 | |
| 
 | |
| -- | A basic mode template.
 | |
| defMode :: Mode RawOpts
 | |
| defMode =   Mode {
 | |
|   modeNames = []
 | |
|  ,modeHelp = ""
 | |
|  ,modeHelpSuffix = []
 | |
|  ,modeValue = []
 | |
|  ,modeCheck = Right
 | |
|  ,modeReform = const Nothing
 | |
|  ,modeExpandAt = True
 | |
|  ,modeGroupFlags = Group {
 | |
|      groupNamed = []
 | |
|     ,groupUnnamed = [
 | |
|         flagNone ["h"] (setboolopt "h") "Show command usage."
 | |
|         ]
 | |
|     ,groupHidden = []
 | |
|     }
 | |
|  ,modeArgs = ([], Nothing)
 | |
|  ,modeGroupModes = toGroup []
 | |
|  }
 | |
| 
 | |
| -- | A basic subcommand mode with the given command name(s).
 | |
| defCommandMode :: [Name] -> Mode RawOpts
 | |
| defCommandMode names = defMode {
 | |
|    modeNames=names
 | |
|   ,modeValue=[("command", headDef "" names)]
 | |
|   ,modeArgs = ([], Just $ argsFlag "[QUERY]")
 | |
|   }
 | |
| 
 | |
| -- | A basic subcommand mode suitable for an add-on command.
 | |
| defAddonCommandMode :: Name -> Mode RawOpts
 | |
| defAddonCommandMode addon = defMode {
 | |
|    modeNames = [addon]
 | |
|   ,modeHelp = fromMaybe "" $ lookup (stripAddonExtension addon) standardAddonsHelp
 | |
|   ,modeValue=[("command",addon)]
 | |
|   ,modeGroupFlags = Group {
 | |
|       groupUnnamed = []
 | |
|      ,groupHidden = []
 | |
|      ,groupNamed = [generalflagsgroup1]
 | |
|      }
 | |
|   ,modeArgs = ([], Just $ argsFlag "[ARGS]")
 | |
|   }
 | |
| 
 | |
| -- | Built-in descriptions for some of the known external addons,
 | |
| -- since we don't currently have any way to ask them.
 | |
| standardAddonsHelp :: [(String,String)]
 | |
| standardAddonsHelp = [
 | |
|    ("chart", "generate simple balance pie charts")
 | |
|   ,("interest", "generate interest transaction entries")
 | |
|   ,("irr", "calculate internal rate of return")
 | |
|   ,("vty", "start the curses-style interface")
 | |
|   ,("web", "start the web interface")
 | |
|   ,("accounts", "list account names")
 | |
|   ,("balance-csv", "output a balance report as CSV")
 | |
|   ,("equity", "show a transaction entry zeroing all accounts")
 | |
|   ,("print-unique", "print only transactions with unique descriptions")
 | |
|   ,("register-csv", "output a register report as CSV")
 | |
|   ,("rewrite", "add specified postings to matched transaction entries")
 | |
|   ,("addon",  "dummy add-on command for testing")
 | |
|   ,("addon2", "dummy add-on command for testing")
 | |
|   ,("addon3", "dummy add-on command for testing")
 | |
|   ,("addon4", "dummy add-on command for testing")
 | |
|   ,("addon5", "dummy add-on command for testing")
 | |
|   ,("addon6", "dummy add-on command for testing")
 | |
|   ,("addon7", "dummy add-on command for testing")
 | |
|   ,("addon8", "dummy add-on command for testing")
 | |
|   ,("addon9", "dummy add-on command for testing")
 | |
|   ]
 | |
| 
 | |
| -- | Get a mode's usage message as a nicely wrapped string.
 | |
| showModeUsage :: Mode a -> String
 | |
| showModeUsage = (showText defaultWrap :: [Text] -> String) .
 | |
|                (helpText [] HelpFormatDefault :: Mode a -> [Text])
 | |
| 
 | |
| -- | Get the most appropriate documentation topic for a mode.
 | |
| -- Currently, that is either the hledger, hledger-ui, hledger-web or
 | |
| -- hledger-api manual.
 | |
| topicForMode :: Mode a -> Topic
 | |
| topicForMode m
 | |
|   | n == "hledger-ui"  = "ui"
 | |
|   | n == "hledger-web" = "web"
 | |
|   --  | n == "hledger-api" = lookupDocTxt "api" -- hledger-api uses docopt
 | |
|   | otherwise          = "cli"
 | |
|   where n = headDef "" $ modeNames m
 | |
| 
 | |
| -- | Add command aliases to the command's help string.
 | |
| withAliases :: String -> [String] -> String
 | |
| s `withAliases` []     = s
 | |
| s `withAliases` as = s ++ " (" ++ intercalate ", " as ++ ")"
 | |
| -- s `withAliases` (a:[]) = s ++ " (alias: " ++ a ++ ")"
 | |
| -- s `withAliases` as     = s ++ " (aliases: " ++ intercalate ", " as ++ ")"
 | |
| 
 | |
| 
 | |
| -- help_postscript = [
 | |
| --   -- "DATES can be Y/M/D or smart dates like \"last month\"."
 | |
| --   -- ,"PATTERNS are regular"
 | |
| --   -- ,"expressions which filter by account name.  Prefix a pattern with desc: to"
 | |
| --   -- ,"filter by transaction description instead, prefix with not: to negate it."
 | |
| --   -- ,"When using both, not: comes last."
 | |
| --  ]
 | |
| 
 | |
| 
 | |
| -- CliOpts
 | |
| 
 | |
| -- | Command line options, used in the @hledger@ package and above.
 | |
| -- This is the \"opts\" used throughout hledger CLI code.
 | |
| -- representing the options and arguments that were provided at
 | |
| -- startup on the command-line.
 | |
| data CliOpts = CliOpts {
 | |
|      rawopts_         :: RawOpts
 | |
|     ,command_         :: String
 | |
|     ,file_            :: [FilePath]
 | |
|     ,rules_file_      :: Maybe FilePath
 | |
|     ,output_file_     :: Maybe FilePath
 | |
|     ,output_format_   :: Maybe String
 | |
|     ,alias_           :: [String]
 | |
|     ,ignore_assertions_ :: Bool
 | |
|     ,debug_           :: Int            -- ^ debug level, set by @--debug[=N]@. See also 'Hledger.Utils.debugLevel'.
 | |
|     ,no_new_accounts_ :: Bool           -- add
 | |
|     ,width_           :: Maybe String   -- ^ the --width value provided, if any
 | |
|     ,available_width_ :: Int            -- ^ estimated usable screen width, based on
 | |
|                                         -- 1. the COLUMNS env var, if set
 | |
|                                         -- 2. the width reported by the terminal, if supported
 | |
|                                         -- 3. the default (80)
 | |
|     ,reportopts_      :: ReportOpts
 | |
|  } deriving (Show, Data, Typeable)
 | |
| 
 | |
| instance Default CliOpts where def = defcliopts
 | |
| 
 | |
| defcliopts :: CliOpts
 | |
| defcliopts = CliOpts
 | |
|     def
 | |
|     def
 | |
|     def
 | |
|     def
 | |
|     def
 | |
|     def
 | |
|     def
 | |
|     def
 | |
|     def
 | |
|     def
 | |
|     def
 | |
|     defaultWidth
 | |
|     def
 | |
| 
 | |
| -- | Convert possibly encoded option values to regular unicode strings.
 | |
| decodeRawOpts :: RawOpts -> RawOpts
 | |
| decodeRawOpts = map (\(name',val) -> (name', fromSystemString val))
 | |
| 
 | |
| -- | Default width for hledger console output, when not otherwise specified.
 | |
| defaultWidth :: Int
 | |
| defaultWidth = 80
 | |
| 
 | |
| -- | 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.
 | |
| -- Also records the terminal width, if supported.
 | |
| rawOptsToCliOpts :: RawOpts -> IO CliOpts
 | |
| rawOptsToCliOpts rawopts = checkCliOpts <$> do
 | |
|   ropts <- rawOptsToReportOpts rawopts
 | |
|   mcolumns <- readMay <$> getEnvSafe "COLUMNS"
 | |
|   mtermwidth <-
 | |
| #ifdef mingw32_HOST_OS
 | |
|     return Nothing
 | |
| #else
 | |
|     setupTermFromEnv >>= return . flip getCapability termColumns
 | |
|     -- XXX Throws a SetupTermError if the terminfo database could not be read, should catch
 | |
| #endif
 | |
|   let availablewidth = head $ catMaybes [mcolumns, mtermwidth, Just defaultWidth]
 | |
|   return defcliopts {
 | |
|               rawopts_         = rawopts
 | |
|              ,command_         = stringopt "command" rawopts
 | |
|              ,file_            = map (T.unpack . stripquotes . T.pack) $ listofstringopt "file" rawopts
 | |
|              ,rules_file_      = maybestringopt "rules-file" rawopts
 | |
|              ,output_file_     = maybestringopt "output-file" rawopts
 | |
|              ,output_format_   = maybestringopt "output-format" rawopts
 | |
|              ,alias_           = map (T.unpack . stripquotes . T.pack) $ listofstringopt "alias" rawopts
 | |
|              ,debug_           = intopt "debug" rawopts
 | |
|              ,ignore_assertions_ = boolopt "ignore-assertions" rawopts
 | |
|              ,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add
 | |
|              ,width_           = maybestringopt "width" rawopts
 | |
|              ,available_width_ = availablewidth
 | |
|              ,reportopts_      = ropts
 | |
|              }
 | |
| 
 | |
| -- | Do final validation of processed opts, raising an error if there is trouble.
 | |
| checkCliOpts :: CliOpts -> CliOpts
 | |
| checkCliOpts opts =
 | |
|   either optserror (const opts) $ do
 | |
|     -- XXX move to checkReportOpts or move _format to CliOpts
 | |
|     case lineFormatFromOpts $ reportopts_ opts of
 | |
|       Left err -> Left $ "could not parse format option: "++err
 | |
|       Right _  -> Right ()
 | |
|   -- XXX check registerWidthsFromOpts opts
 | |
| 
 | |
| -- Currently only used by some extras/ scripts:
 | |
| -- | 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
 | |
|   debugArgs args' opts
 | |
|   -- if any (`elem` args) ["--help","-h","-?"]
 | |
|   when ("h" `inRawOpts` rawopts_ opts) $ putStr (showModeUsage mode') >> exitSuccess
 | |
|   when ("help" `inRawOpts` rawopts_ opts) $ printHelpForTopic (topicForMode mode') >> exitSuccess
 | |
|   return opts
 | |
|   where
 | |
|     -- | 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)
 | |
| 
 | |
| -- CliOpts accessors
 | |
| 
 | |
| -- | Get the account name aliases from options, if any.
 | |
| aliasesFromOpts :: CliOpts -> [AccountAlias]
 | |
| aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp ("--alias "++quoteIfNeeded a) $ T.pack a)
 | |
|                   . alias_
 | |
| 
 | |
| -- | Get the (tilde-expanded, absolute) journal file path from
 | |
| -- 1. options, 2. an environment variable, or 3. the default.
 | |
| -- Actually, returns one or more file paths. There will be more
 | |
| -- than one if multiple -f options were provided.
 | |
| -- File paths can have a READER: prefix naming a reader/data format.
 | |
| journalFilePathFromOpts :: CliOpts -> IO [String]
 | |
| journalFilePathFromOpts opts = do
 | |
|   f <- defaultJournalPath
 | |
|   d <- getCurrentDirectory
 | |
|   case file_ opts of
 | |
|     [] -> return [f]
 | |
|     fs -> mapM (expandPathPreservingPrefix d) fs
 | |
| 
 | |
| expandPathPreservingPrefix :: FilePath -> PrefixedFilePath -> IO PrefixedFilePath
 | |
| expandPathPreservingPrefix d prefixedf = do
 | |
|   let (p,f) = splitReaderPrefix prefixedf
 | |
|   f' <- expandPath d f
 | |
|   return $ case p of
 | |
|     Just p  -> p ++ ":" ++ f'
 | |
|     Nothing -> f'
 | |
| 
 | |
| -- | Get the expanded, absolute output file path from options,
 | |
| -- or the default (-, meaning stdout).
 | |
| outputFileFromOpts :: CliOpts -> IO FilePath
 | |
| outputFileFromOpts opts = do
 | |
|   d <- getCurrentDirectory
 | |
|   case output_file_ opts of
 | |
|     Just p  -> expandPath d p
 | |
|     Nothing -> return "-"
 | |
| 
 | |
| defaultOutputFormat = "txt"
 | |
| 
 | |
| outputFormats =
 | |
|   [defaultOutputFormat] ++
 | |
|   ["csv"
 | |
|   ]
 | |
| 
 | |
| -- | Get the output format from the --output-format option,
 | |
| -- otherwise from a recognised file extension in the --output-file option,
 | |
| -- otherwise the default (txt).
 | |
| outputFormatFromOpts :: CliOpts -> String
 | |
| outputFormatFromOpts opts =
 | |
|   case output_format_ opts of
 | |
|     Just f  -> f
 | |
|     Nothing ->
 | |
|       case filePathExtension <$> output_file_ opts of
 | |
|         Just ext | ext `elem` outputFormats -> ext
 | |
|         _                                   -> defaultOutputFormat
 | |
| 
 | |
| -- -- | Get the file name without its last extension, from a file path.
 | |
| -- filePathBaseFileName :: FilePath -> String
 | |
| -- filePathBaseFileName = fst . splitExtension . snd . splitFileName
 | |
| 
 | |
| -- | Get the last file extension, without the dot, from a file path.
 | |
| -- May return the null string.
 | |
| filePathExtension :: FilePath -> String
 | |
| filePathExtension = dropWhile (=='.') . snd . splitExtension . snd . splitFileName
 | |
| 
 | |
| -- | Get the (tilde-expanded) rules file path from options, if any.
 | |
| rulesFilePathFromOpts :: CliOpts -> IO (Maybe FilePath)
 | |
| rulesFilePathFromOpts opts = do
 | |
|   d <- getCurrentDirectory
 | |
|   maybe (return Nothing) (fmap Just . expandPath d) $ rules_file_ opts
 | |
| 
 | |
| -- | Get the width in characters to use for console output.
 | |
| -- This comes from the --width option, or the COLUMNS environment
 | |
| -- variable, or (on posix platforms) the current terminal width, or 80.
 | |
| -- Will raise a parse error for a malformed --width argument.
 | |
| widthFromOpts :: CliOpts -> Int
 | |
| widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w
 | |
| widthFromOpts CliOpts{width_=Just s}  =
 | |
|     case runParser (read `fmap` some digitChar <* eof :: ParsecT Dec String Identity Int) "(unknown)" s of
 | |
|         Left e   -> optserror $ "could not parse width option: "++show e
 | |
|         Right w  -> w
 | |
| 
 | |
| -- for register:
 | |
| 
 | |
| -- | Get the width in characters to use for the register command's console output,
 | |
| -- and also the description column width if specified (following the main width, comma-separated).
 | |
| -- The widths will be as follows:
 | |
| -- @
 | |
| -- no --width flag - overall width is the available width (COLUMNS, or posix terminal width, or 80); description width is unspecified (auto)
 | |
| -- --width W       - overall width is W, description width is auto
 | |
| -- --width W,D     - overall width is W, description width is D
 | |
| -- @
 | |
| -- Will raise a parse error for a malformed --width argument.
 | |
| registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)
 | |
| registerWidthsFromOpts CliOpts{width_=Nothing, available_width_=w} = (w, Nothing)
 | |
| registerWidthsFromOpts CliOpts{width_=Just s}  =
 | |
|     case runParser registerwidthp "(unknown)" s of
 | |
|         Left e   -> optserror $ "could not parse width option: "++show e
 | |
|         Right ws -> ws
 | |
|     where
 | |
|         registerwidthp :: (Stream s, Char ~ Token s) => ParsecT Dec s m (Int, Maybe Int)
 | |
|         registerwidthp = do
 | |
|           totalwidth <- read `fmap` some digitChar
 | |
|           descwidth <- optional (char ',' >> read `fmap` some digitChar)
 | |
|           eof
 | |
|           return (totalwidth, descwidth)
 | |
| 
 | |
| -- | Drop leading components of accounts names as specified by --drop, but only in --flat mode.
 | |
| maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName
 | |
| maybeAccountNameDrop opts a | tree_ opts = a
 | |
|                             | otherwise  = accountNameDrop (drop_ opts) a
 | |
| 
 | |
| -- for balance, currently:
 | |
| 
 | |
| -- | Parse the format option if provided, possibly returning an error,
 | |
| -- otherwise get the default value.
 | |
| lineFormatFromOpts :: ReportOpts -> Either String StringFormat
 | |
| lineFormatFromOpts = maybe (Right defaultBalanceLineFormat) parseStringFormat . format_
 | |
| 
 | |
| -- | Default line format for balance report: "%20(total)  %2(depth_spacer)%-(account)"
 | |
| defaultBalanceLineFormat :: StringFormat
 | |
| defaultBalanceLineFormat = BottomAligned [
 | |
|       FormatField False (Just 20) Nothing TotalField
 | |
|     , FormatLiteral "  "
 | |
|     , FormatField True (Just 2) Nothing DepthSpacerField
 | |
|     , FormatField True Nothing Nothing AccountField
 | |
|     ]
 | |
| 
 | |
| -- Other utils
 | |
| 
 | |
| -- | Get the sorted unique precise names and display names of hledger
 | |
| -- add-ons found in the current user's PATH. The precise names are the
 | |
| -- add-on's filename with the "hledger-" prefix removed. The display
 | |
| -- names have the file extension removed also, except when it's needed
 | |
| -- for disambiguation.
 | |
| --
 | |
| -- -- Also when there are exactly two similar names, one with the .hs or
 | |
| -- -- .lhs extension and the other with the .exe extension or no
 | |
| -- -- extension - presumably source and compiled versions of a haskell
 | |
| -- -- script - we exclude the source version.
 | |
| --
 | |
| -- This function can return add-on names which shadow built-in command
 | |
| -- names, but hledger will ignore these.
 | |
| --
 | |
| hledgerAddons :: IO ([String],[String])
 | |
| hledgerAddons = do
 | |
|   exes <- hledgerExecutablesInPath
 | |
|   let precisenames = -- concatMap dropRedundant $
 | |
|                      -- groupBy (\a b -> dropExtension a == dropExtension b) $
 | |
|                      map stripprefix exes
 | |
|   let displaynames = concatMap stripext $
 | |
|                      groupBy (\a b -> dropExtension a == dropExtension b) precisenames
 | |
|   return (precisenames, displaynames)
 | |
|   where
 | |
|     stripprefix = drop (length progname + 1)
 | |
|     -- dropRedundant [f,f2] | takeExtension f `elem` ["",".exe"] && takeExtension f2 `elem` [".hs",".lhs"] = [f]
 | |
|     -- dropRedundant fs = fs
 | |
|     stripext [f] = [dropExtension f]
 | |
|     stripext fs  = fs
 | |
| 
 | |
| -- | Get the sorted unique filenames of all hledger-* executables in
 | |
| -- the current user's PATH. Currently these are: files in any of the
 | |
| -- PATH directories, named hledger-*, with either no extension (and no
 | |
| -- periods in the name) or one of the addonExtensions.  Limitations:
 | |
| -- we do not currently check that the file is really a file (not eg a
 | |
| -- directory) or whether it has execute permission.
 | |
| hledgerExecutablesInPath :: IO [String]
 | |
| hledgerExecutablesInPath = do
 | |
|   pathdirs <- splitOneOf "[:;]" `fmap` getEnvSafe "PATH"
 | |
|   pathfiles <- concat `fmap` mapM getDirectoryContentsSafe pathdirs
 | |
|   return $ nub $ sort $ filter isHledgerExeName pathfiles
 | |
|   -- XXX should exclude directories and files without execute permission.
 | |
|   -- These will do a stat for each hledger-*, probably ok.
 | |
|   -- But they need paths, not just filenames
 | |
|   -- hledgerexes  <- filterM doesFileExist hledgernamed
 | |
|   -- hledgerexes' <- filterM isExecutable hledgerexes
 | |
|   -- return hledgerexes
 | |
| 
 | |
| -- isExecutable f = getPermissions f >>= (return . executable)
 | |
| 
 | |
| isHledgerExeName :: String -> Bool
 | |
| isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack
 | |
|     where
 | |
|       hledgerexenamep = do
 | |
|         _ <- string progname
 | |
|         _ <- char '-'
 | |
|         _ <- some (noneOf ".")
 | |
|         optional (string "." >> choice' (map string addonExtensions))
 | |
|         eof
 | |
| 
 | |
| stripAddonExtension :: String -> String
 | |
| stripAddonExtension = regexReplace re "" where re = "\\.(" ++ intercalate "|" addonExtensions ++ ")$"
 | |
| 
 | |
| addonExtensions :: [String]
 | |
| addonExtensions =
 | |
|   ["bat"
 | |
|   ,"com"
 | |
|   ,"exe"
 | |
|   ,"hs"
 | |
|   ,"lhs"
 | |
|   ,"pl"
 | |
|   ,"py"
 | |
|   ,"rb"
 | |
|   ,"rkt"
 | |
|   ,"sh"
 | |
|   -- ,""
 | |
|   ]
 | |
| 
 | |
| getEnvSafe :: String -> IO String
 | |
| getEnvSafe v = getEnv v `C.catch` (\(_::C.IOException) -> return "") -- XXX should catch only isDoesNotExistError e
 | |
| 
 | |
| 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)
 | |
| 
 | |
| -- tests
 | |
| 
 | |
| tests_Hledger_Cli_CliOptions :: Test
 | |
| tests_Hledger_Cli_CliOptions = TestList
 | |
|  [
 | |
|  ]
 |