{-|

Common cmdargs modes and flags, a command-line options type, and
related utilities used by hledger commands.

-}

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PackageImports      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeFamilies        #-}

module Hledger.Cli.CliOptions (

  -- * cmdargs flags & modes
  helpflags,
  detailedversionflag,
  flattreeflags,
  hiddenflags,
  inputflags,
  reportflags,
  -- outputflags,
  outputFormatFlag,
  outputFileFlag,
  generalflagsgroup1,
  generalflagsgroup2,
  generalflagsgroup3,
  defMode,
  defCommandMode,
  addonCommandMode,
  hledgerCommandMode,
  argsFlag,
  showModeUsage,
  withAliases,
  likelyExecutablesInPath,
  hledgerExecutablesInPath,

  -- * CLI options
  CliOpts(..),
  HasCliOpts(..),
  defcliopts,
  getHledgerCliOpts,
  getHledgerCliOpts',
  rawOptsToCliOpts,
  outputFormats,
  defaultOutputFormat,
  CommandDoc,

  -- possibly these should move into argsToCliOpts
  -- * CLI option accessors
  -- | These do the extra processing required for some options.
  journalFilePathFromOpts,
  rulesFilePathFromOpts,
  outputFileFromOpts,
  outputFormatFromOpts,
  defaultWidth,
  widthFromOpts,
  replaceNumericFlags,
  -- | For register:
  registerWidthsFromOpts,

  -- * Other utils
  hledgerAddons,
  topicForMode,

--  -- * Convenience re-exports
--  module Data.String.Here,
--  module System.Console.CmdArgs.Explicit,
)
where

import qualified Control.Exception as C
import Control.Monad (when)
import Data.Char
import Data.Default
import Data.Either (fromRight, isRight)
import Data.Functor.Identity (Identity)
import Data.List.Extra (groupSortOn, intercalate, isInfixOf, nubSort)
import Data.List.Split (splitOneOf)
import Data.Maybe
--import Data.String.Here
-- import Data.Text (Text)
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
import Data.Time.Clock.POSIX (POSIXTime)


-- common cmdargs flags

-- | Common help flags: --help, --debug, --version...
helpflags :: [Flag RawOpts]
helpflags :: [Flag RawOpts]
helpflags = [
  -- XXX why are these duplicated in defCommandMode below ?
  [Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"help",Name
"h"] (Name -> RawOpts -> RawOpts
setboolopt Name
"help") Name
"show general help (or after CMD, command help)"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"man"] (Name -> RawOpts -> RawOpts
setboolopt Name
"man") Name
"Show user manual with man"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"info"] (Name -> RawOpts -> RawOpts
setboolopt Name
"info") Name
"Show info manual with info"
 -- ,flagNone ["browse-args"] (setboolopt "browse-args") "use a web UI to select options and build up a command line"
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"debug"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"debug" Name
s RawOpts
opts) Name
"[N]" Name
"show debug output (levels 1-9, default: 1)"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"version"] (Name -> RawOpts -> RawOpts
setboolopt Name
"version") Name
"show version information"
 ]

-- | A hidden flag just for the hledger executable.
detailedversionflag :: Flag RawOpts
detailedversionflag :: Flag RawOpts
detailedversionflag = [Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"version+"] (Name -> RawOpts -> RawOpts
setboolopt Name
"version+") Name
"show version information with extra detail"

-- | Common input-related flags: --file, --rules-file, --alias...
inputflags :: [Flag RawOpts]
inputflags :: [Flag RawOpts]
inputflags = [
  [Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"file",Name
"f"]      (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"file" Name
s RawOpts
opts) Name
"FILE" Name
"use a different input file. For stdin, use - (default: $LEDGER_FILE or $HOME/.hledger.journal)"
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"rules-file"]    (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"rules-file" Name
s RawOpts
opts) Name
"RFILE" Name
"CSV conversion rules file (default: FILE.rules)"
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"alias"]         (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"alias" Name
s RawOpts
opts)  Name
"OLD=NEW" Name
"rename accounts named OLD to NEW"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"anon"]          (Name -> RawOpts -> RawOpts
setboolopt Name
"anon") Name
"anonymize accounts and payees"
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"pivot"]         (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"pivot" Name
s RawOpts
opts)  Name
"TAGNAME" Name
"use some other field/tag for account names"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"ignore-assertions",Name
"I"] (Name -> RawOpts -> RawOpts
setboolopt Name
"ignore-assertions") Name
"ignore any balance assertions"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"strict",Name
"s"]    (Name -> RawOpts -> RawOpts
setboolopt Name
"strict") Name
"do extra error checking (check that all posted accounts are declared)"
 ]

-- | Common report-related flags: --period, --cost, etc.
reportflags :: [Flag RawOpts]
reportflags :: [Flag RawOpts]
reportflags = [

  -- report period & interval
  [Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"begin",Name
"b"]     (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"begin" Name
s RawOpts
opts) Name
"DATE" Name
"include postings/txns on or after this date (will be adjusted to preceding subperiod start when using a report interval)"
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"end",Name
"e"]       (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"end" Name
s RawOpts
opts) Name
"DATE" Name
"include postings/txns before this date (will be adjusted to following subperiod end when using a report interval)"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"daily",Name
"D"]     (Name -> RawOpts -> RawOpts
setboolopt Name
"daily") Name
"multiperiod/multicolumn report by day"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"weekly",Name
"W"]    (Name -> RawOpts -> RawOpts
setboolopt Name
"weekly") Name
"multiperiod/multicolumn report by week"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"monthly",Name
"M"]   (Name -> RawOpts -> RawOpts
setboolopt Name
"monthly") Name
"multiperiod/multicolumn report by month"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"quarterly",Name
"Q"] (Name -> RawOpts -> RawOpts
setboolopt Name
"quarterly") Name
"multiperiod/multicolumn report by quarter"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"yearly",Name
"Y"]    (Name -> RawOpts -> RawOpts
setboolopt Name
"yearly") Name
"multiperiod/multicolumn report by year"
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"period",Name
"p"]    (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"period" Name
s RawOpts
opts) Name
"PERIODEXP" Name
"set start date, end date, and/or report interval all at once"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"date2"]         (Name -> RawOpts -> RawOpts
setboolopt Name
"date2") Name
"match the secondary date instead. See command help for other effects. (--effective, --aux-date also accepted)"  -- see also hiddenflags
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"today"]         (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"today" Name
s RawOpts
opts) Name
"DATE" Name
"override today's date (affects relative smart dates, for tests/examples)"
 
  -- status/realness/depth/zero filters
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"unmarked",Name
"U"]  (Name -> RawOpts -> RawOpts
setboolopt Name
"unmarked") Name
"include only unmarked postings/txns (can combine with -P or -C)"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"pending",Name
"P"]   (Name -> RawOpts -> RawOpts
setboolopt Name
"pending") Name
"include only pending postings/txns"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"cleared",Name
"C"]   (Name -> RawOpts -> RawOpts
setboolopt Name
"cleared") Name
"include only cleared postings/txns"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"real",Name
"R"]      (Name -> RawOpts -> RawOpts
setboolopt Name
"real") Name
"include only non-virtual postings"
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"depth"]         (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"depth" Name
s RawOpts
opts) Name
"NUM" Name
"(or -NUM): hide accounts/postings deeper than this"
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"empty",Name
"E"]     (Name -> RawOpts -> RawOpts
setboolopt Name
"empty") Name
"show items with zero amount, normally hidden (and vice-versa in hledger-ui/hledger-web)"

  -- valuation
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"B",Name
"cost"]      (Name -> RawOpts -> RawOpts
setboolopt Name
"B")
   Name
"show amounts converted to their cost/selling amount, using the transaction price."
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"V",Name
"market"]    (Name -> RawOpts -> RawOpts
setboolopt Name
"V")
   ([Name] -> Name
unwords
     [Name
"show amounts converted to period-end market value in their default valuation commodity."
     ,Name
"Equivalent to --value=end."
     ])
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"X",Name
"exchange"]   (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"X" Name
s RawOpts
opts) Name
"COMM"
   ([Name] -> Name
unwords
     [Name
"show amounts converted to current (single period reports)"
     ,Name
"or period-end (multiperiod reports) market value in the specified commodity."
     ,Name
"Equivalent to --value=end,COMM."
     ])
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"value"]         (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"value" Name
s RawOpts
opts) Name
"TYPE[,COMM]"
   ([Name] -> Name
unlines
     [Name
"show amounts converted with valuation TYPE, and optionally to specified commodity COMM. TYPE can be:"
     ,Name
"'then': convert to contemporaneous market value, in default valuation commodity or COMM (print & register commands only)"
     ,Name
"'end':  convert to period-end market value, in default valuation commodity or COMM"
     ,Name
"'now':  convert to current market value, in default valuation commodity or COMM"
     ,Name
"YYYY-MM-DD: convert to market value on the given date, in default valuation commodity or COMM"
     ])
  ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"infer-equity"] (Name -> RawOpts -> RawOpts
setboolopt Name
"infer-equity")
    Name
"in conversion transactions, replace costs (transaction prices) with equity postings, to keep the transactions balanced"
  
  -- history of this flag so far, lest we be confused:
  --  originally --infer-value
  --  2021-02 --infer-market-price added, --infer-value deprecated 
  --  2021-09
  --   --infer-value hidden
  --   --infer-market-price renamed to --infer-market-prices, old spelling still works
  --   ReportOptions{infer_value_} renamed to infer_prices_, BalancingOpts{infer_prices_} renamed to infer_transaction_prices_
  --   some related prices command changes
  --    --costs deprecated and hidden, uses --infer-market-prices instead
  --    --inverted-costs renamed to --infer-reverse-prices
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"infer-market-prices"] (Name -> RawOpts -> RawOpts
setboolopt Name
"infer-market-prices") 
    Name
"use transaction prices (recorded with @ or @@) as additional market prices, as if they were P directives"

  -- generated postings/transactions
 ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"auto"]          (Name -> RawOpts -> RawOpts
setboolopt Name
"auto") Name
"apply automated posting rules to modify transactions"
 ,Name -> [Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. Name -> [Name] -> Update a -> Name -> Name -> Flag a
flagOpt Name
"" [Name
"forecast"]    (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"forecast" Name
s RawOpts
opts) Name
"PERIODEXP" 
  ([Name] -> Name
unlines
   [ Name
"Generate periodic transactions (from periodic transaction rules). By default these begin after the latest recorded transaction, and end 6 months from today, or at the report end date."
   , Name
"Also, in hledger-ui, make future transactions visible."
   , Name
"Note that = (and not a space) is required before PERIODEXP if you wish to supply it."
   ])

  -- general output-related
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq [Name
"commodity-style", Name
"c"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"commodity-style" Name
s RawOpts
opts) Name
"COMM"
    Name
"Override the commodity style in the output for the specified commodity. For example 'EUR1.000,00'."
  
  -- This has special support in hledger-lib:colorOption, keep synced
 ,[Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq  [Name
"color",Name
"colour"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"color" Name
s RawOpts
opts) Name
"WHEN"
   ([Name] -> Name
unlines
     [Name
"Should color-supporting commands use ANSI color codes in text output."
     ,Name
"'auto' (default): whenever stdout seems to be a color-supporting terminal."
     ,Name
"'always' or 'yes': always, useful eg when piping output into 'less -R'."
     ,Name
"'never' or 'no': never."
     ,Name
"A NO_COLOR environment variable overrides this."
     ])
 ,Name -> [Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. Name -> [Name] -> Update a -> Name -> Name -> Flag a
flagOpt Name
"yes" [Name
"pretty"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"pretty" Name
s RawOpts
opts) Name
"WHEN"
   ([Name] -> Name
unlines
     [Name
"Show prettier output, e.g. using unicode box-drawing characters."
     ,Name
"Accepts 'yes' (the default) or 'no'."
     ,Name
"If you provide an argument you must use '=', e.g. '--pretty=yes'."
     ])
 ]

-- | Flags for selecting flat/tree mode, used for reports organised by account.
-- With a True argument, shows some extra help about inclusive/exclusive amounts.
flattreeflags :: Bool -> [Flag RawOpts]
flattreeflags :: Bool -> [Flag RawOpts]
flattreeflags Bool
showamounthelp = [
   [Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"flat",Name
"l"] (Name -> RawOpts -> RawOpts
setboolopt Name
"flat")
     (Name
"show accounts as a flat list (default)"
      Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ if Bool
showamounthelp then Name
". Amounts exclude subaccount amounts, except where the account is depth-clipped." else Name
"")
  ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"tree",Name
"t"] (Name -> RawOpts -> RawOpts
setboolopt Name
"tree")
    (Name
"show accounts as a tree" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ if Bool
showamounthelp then Name
". Amounts include subaccount amounts." else Name
"")
  ]

-- | Common flags that are accepted but not shown in --help,
-- such as --effective, --aux-date.
hiddenflags :: [Flag RawOpts]
hiddenflags :: [Flag RawOpts]
hiddenflags = [
   [Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"effective",Name
"aux-date"] (Name -> RawOpts -> RawOpts
setboolopt Name
"date2") Name
"Ledger-compatible aliases for --date2"
  ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"infer-value"] (Name -> RawOpts -> RawOpts
setboolopt Name
"infer-market-prices") Name
"legacy flag that was renamed"
  ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"pretty-tables"] (Name -> Name -> RawOpts -> RawOpts
setopt Name
"pretty" Name
"always") Name
"legacy flag that was renamed"
  ]

-- | Common output-related flags: --output-file, --output-format...

-- outputflags = [outputFormatFlag, outputFileFlag]

outputFormatFlag :: [String] -> Flag RawOpts
outputFormatFlag :: [Name] -> Flag RawOpts
outputFormatFlag [Name]
fmts = [Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq
  [Name
"output-format",Name
"O"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"output-format" Name
s RawOpts
opts) Name
"FMT"
  (Name
"select the output format. Supported formats:\n" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name -> [Name] -> Name
forall a. [a] -> [[a]] -> [a]
intercalate Name
", " [Name]
fmts Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
".")

-- This has special support in hledger-lib:outputFileOption, keep synced
outputFileFlag :: Flag RawOpts
outputFileFlag :: Flag RawOpts
outputFileFlag = [Name] -> Update RawOpts -> Name -> Name -> Flag RawOpts
forall a. [Name] -> Update a -> Name -> Name -> Flag a
flagReq
  [Name
"output-file",Name
"o"] (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"output-file" Name
s RawOpts
opts) Name
"FILE"
  Name
"write output to FILE. A file extension matching one of the above formats selects that format."

argsFlag :: FlagHelp -> Arg RawOpts
argsFlag :: Name -> Arg RawOpts
argsFlag = Update RawOpts -> Name -> Arg RawOpts
forall a. Update a -> Name -> Arg a
flagArg (\Name
s RawOpts
opts -> RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either Name RawOpts) -> RawOpts -> Either Name RawOpts
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RawOpts -> RawOpts
setopt Name
"args" Name
s RawOpts
opts)

generalflagstitle :: String
generalflagstitle :: Name
generalflagstitle = Name
"\nGeneral flags"

generalflagsgroup1, generalflagsgroup2, generalflagsgroup3 :: (String, [Flag RawOpts])
generalflagsgroup1 :: (Name, [Flag RawOpts])
generalflagsgroup1 = (Name
generalflagstitle, [Flag RawOpts]
inputflags [Flag RawOpts] -> [Flag RawOpts] -> [Flag RawOpts]
forall a. [a] -> [a] -> [a]
++ [Flag RawOpts]
reportflags [Flag RawOpts] -> [Flag RawOpts] -> [Flag RawOpts]
forall a. [a] -> [a] -> [a]
++ [Flag RawOpts]
helpflags)
generalflagsgroup2 :: (Name, [Flag RawOpts])
generalflagsgroup2 = (Name
generalflagstitle, [Flag RawOpts]
inputflags [Flag RawOpts] -> [Flag RawOpts] -> [Flag RawOpts]
forall a. [a] -> [a] -> [a]
++ [Flag RawOpts]
helpflags)
generalflagsgroup3 :: (Name, [Flag RawOpts])
generalflagsgroup3 = (Name
generalflagstitle, [Flag RawOpts]
helpflags)

-- cmdargs mode constructors

-- | An empty cmdargs mode to use as a template.
-- Modes describe the top-level command, ie the program, or a subcommand,
-- telling cmdargs how to parse a command line and how to
-- generate the command's usage text.
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       = []            -- program/command name(s)
 ,modeHelp :: Name
modeHelp        = Name
""            -- short help for this command
 ,modeHelpSuffix :: [Name]
modeHelpSuffix  = []            -- text displayed after the usage
 ,modeGroupFlags :: Group (Flag RawOpts)
modeGroupFlags  = Group :: forall a. [a] -> [a] -> [(Name, [a])] -> Group a
Group {       -- description of flags accepted by the command
    groupNamed :: [(Name, [Flag RawOpts])]
groupNamed   = []             --  named groups of flags
   ,groupUnnamed :: [Flag RawOpts]
groupUnnamed = []             --  ungrouped flags
   ,groupHidden :: [Flag RawOpts]
groupHidden  = []             --  flags not displayed in the usage
   }
 ,modeArgs :: ([Arg RawOpts], Maybe (Arg RawOpts))
modeArgs        = ([], Maybe (Arg RawOpts)
forall a. Maybe a
Nothing) -- description of arguments accepted by the command
 ,modeValue :: RawOpts
modeValue       = RawOpts
forall a. Default a => a
def           -- value returned when this mode is used to parse a command line
 ,modeCheck :: RawOpts -> Either Name RawOpts
modeCheck       = RawOpts -> Either Name RawOpts
forall a b. b -> Either a b
Right         -- whether the mode's value is correct
 ,modeReform :: RawOpts -> Maybe [Name]
modeReform      = Maybe [Name] -> RawOpts -> Maybe [Name]
forall a b. a -> b -> a
const Maybe [Name]
forall a. Maybe a
Nothing -- function to convert the value back to a command line arguments
 ,modeExpandAt :: Bool
modeExpandAt    = Bool
True          -- expand @ arguments for program ?
 ,modeGroupModes :: Group (Mode RawOpts)
modeGroupModes  = [Mode RawOpts] -> Group (Mode RawOpts)
forall a. [a] -> Group a
toGroup []    -- sub-modes
 }

-- | A cmdargs mode suitable for a hledger built-in command
-- with the given names (primary name + optional aliases).
-- The usage message shows [QUERY] as argument.
defCommandMode :: [Name] -> Mode RawOpts
defCommandMode :: [Name] -> Mode RawOpts
defCommandMode [Name]
names = Mode RawOpts
defMode {
   modeNames :: [Name]
modeNames=[Name]
names
  ,modeGroupFlags :: Group (Flag RawOpts)
modeGroupFlags  = Group :: forall a. [a] -> [a] -> [(Name, [a])] -> Group a
Group {
     groupNamed :: [(Name, [Flag RawOpts])]
groupNamed   = []
    ,groupUnnamed :: [Flag RawOpts]
groupUnnamed = [
        [Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"help"] (Name -> RawOpts -> RawOpts
setboolopt Name
"help") Name
"Show command-line help"
      -- ,flagNone ["help"] (setboolopt "help") "Show long help."
       ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"man"] (Name -> RawOpts -> RawOpts
setboolopt Name
"man") Name
"Show user manual with man"
       ,[Name] -> (RawOpts -> RawOpts) -> Name -> Flag RawOpts
forall a. [Name] -> (a -> a) -> Name -> Flag a
flagNone [Name
"info"] (Name -> RawOpts -> RawOpts
setboolopt Name
"info") Name
"Show info manual with info"
      ]
    ,groupHidden :: [Flag RawOpts]
groupHidden  = []             --  flags not displayed in the usage
    }
  ,modeArgs :: ([Arg RawOpts], Maybe (Arg RawOpts))
modeArgs = ([], Arg RawOpts -> Maybe (Arg RawOpts)
forall a. a -> Maybe a
Just (Arg RawOpts -> Maybe (Arg RawOpts))
-> Arg RawOpts -> Maybe (Arg RawOpts)
forall a b. (a -> b) -> a -> b
$ Name -> Arg RawOpts
argsFlag Name
"[QUERY]")
  ,modeValue :: RawOpts
modeValue=Name -> Name -> RawOpts -> RawOpts
setopt Name
"command" (Name -> [Name] -> Name
forall a. a -> [a] -> a
headDef Name
"" [Name]
names) RawOpts
forall a. Default a => a
def
  }

-- | A cmdargs mode representing the hledger add-on command with the
-- given name, providing hledger's common input/reporting/help flags.
-- Just used when invoking addons.
addonCommandMode :: Name -> Mode RawOpts
addonCommandMode :: Name -> Mode RawOpts
addonCommandMode Name
name = ([Name] -> Mode RawOpts
defCommandMode [Name
name]) {
   modeHelp :: Name
modeHelp = Name
""
     -- XXX not needed ?
     -- fromMaybe "" $ lookup (stripAddonExtension name) [
     --   ("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")
     --  ]
  ,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]
     }
  }

-- | A command's documentation. Used both as part of CLI help, and as
-- part of the hledger manual. See parseCommandDoc.
type CommandDoc = String

-- | Build a cmdarg mode for a hledger command,
-- from a help template and flag/argument specifications.
-- Reduces boilerplate a little, though the complicated cmdargs
-- flag and argument specs are still required.
hledgerCommandMode :: CommandDoc -> [Flag RawOpts] -> [(String, [Flag RawOpts])]
  -> [Flag RawOpts] -> ([Arg RawOpts], Maybe (Arg RawOpts)) -> Mode RawOpts
hledgerCommandMode :: Name
-> [Flag RawOpts]
-> [(Name, [Flag RawOpts])]
-> [Flag RawOpts]
-> ([Arg RawOpts], Maybe (Arg RawOpts))
-> Mode RawOpts
hledgerCommandMode Name
doc [Flag RawOpts]
unnamedflaggroup [(Name, [Flag RawOpts])]
namedflaggroups [Flag RawOpts]
hiddenflaggroup ([Arg RawOpts], Maybe (Arg RawOpts))
argsdescr =
  case Name -> Maybe ([Name], Name, [Name])
parseCommandDoc Name
doc of
    Maybe ([Name], Name, [Name])
Nothing -> Name -> Mode RawOpts
forall a. Name -> a
error' (Name -> Mode RawOpts) -> Name -> Mode RawOpts
forall a b. (a -> b) -> a -> b
$ Name
"Could not parse command doc:\n"Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++Name
docName -> Name -> Name
forall a. [a] -> [a] -> [a]
++Name
"\n"  -- PARTIAL:
    Just ([Name]
names, Name
shorthelp, [Name]
longhelplines) ->
      ([Name] -> Mode RawOpts
defCommandMode [Name]
names) {
         modeHelp :: Name
modeHelp        = Name
shorthelp
        ,modeHelpSuffix :: [Name]
modeHelpSuffix  = [Name]
longhelplines
        ,modeGroupFlags :: Group (Flag RawOpts)
modeGroupFlags  = Group :: forall a. [a] -> [a] -> [(Name, [a])] -> Group a
Group {
            groupUnnamed :: [Flag RawOpts]
groupUnnamed = [Flag RawOpts]
unnamedflaggroup
           ,groupNamed :: [(Name, [Flag RawOpts])]
groupNamed   = [(Name, [Flag RawOpts])]
namedflaggroups
           ,groupHidden :: [Flag RawOpts]
groupHidden  = [Flag RawOpts]
hiddenflaggroup
           }
        ,modeArgs :: ([Arg RawOpts], Maybe (Arg RawOpts))
modeArgs        = ([Arg RawOpts], Maybe (Arg RawOpts))
argsdescr
        }

-- | Parse a command's documentation, as follows:
--
-- - First line: the command name then any aliases, as one or more space or comma-separated words
--
-- - Second line to a line containing just _FLAGS, or the end: the short help
--
-- - Any lines after _FLAGS: the long help (split into lines for cmdargs)
--
-- The CLI help displays the short help, then the cmdargs-generated
-- flags list, then the long help (which some day we might make
-- optional again).  The manual displays the short help followed by
-- the long help, with no flags list.
--
parseCommandDoc :: CommandDoc -> Maybe ([Name], String, [String])
parseCommandDoc :: Name -> Maybe ([Name], Name, [Name])
parseCommandDoc Name
t =
  case Name -> [Name]
lines Name
t of
    [] -> Maybe ([Name], Name, [Name])
forall a. Maybe a
Nothing
    (Name
l:[Name]
ls) -> ([Name], Name, [Name]) -> Maybe ([Name], Name, [Name])
forall a. a -> Maybe a
Just ([Name]
names, Name
shorthelp, [Name]
longhelplines)
      where
        names :: [Name]
names = Name -> [Name]
words (Name -> [Name]) -> Name -> [Name]
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> Name -> Name
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Name -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
',',Char
'\\'] then Char
' ' else Char
c) Name
l
        ([Name]
shorthelpls, [Name]
longhelpls) = (Name -> Bool) -> [Name] -> ([Name], [Name])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"_FLAGS") [Name]
ls
        shorthelp :: Name
shorthelp = [Name] -> Name
unlines ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
reverse ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Name -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
shorthelpls
        longhelplines :: [Name]
longhelplines = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Name -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
drop Int
1 [Name]
longhelpls

-- | Get a mode's usage message as a nicely wrapped string.
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])

-- | Get the most appropriate documentation topic for a mode.
-- Currently, that is either the hledger, hledger-ui or hledger-web
-- manual.
topicForMode :: Mode a -> Topic
topicForMode :: Mode a -> Name
topicForMode Mode a
m
  | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"hledger-ui"  = Name
"ui"
  | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"hledger-web" = Name
"web"
  | Bool
otherwise          = Name
"cli"
  where n :: Name
n = Name -> [Name] -> Name
forall a. a -> [a] -> a
headDef Name
"" ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$ Mode a -> [Name]
forall a. Mode a -> [Name]
modeNames Mode a
m

-- | Add command aliases to the command's help string.
withAliases :: String -> [String] -> String
Name
s withAliases :: Name -> [Name] -> Name
`withAliases` []     = Name
s
Name
s `withAliases` [Name]
as = Name
s Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" (" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name -> [Name] -> Name
forall a. [a] -> [[a]] -> [a]
intercalate Name
", " [Name]
as Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
")"
-- 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 {
     CliOpts -> RawOpts
rawopts_         :: RawOpts
    ,CliOpts -> Name
command_         :: String
    ,CliOpts -> [Name]
file_            :: [FilePath]
    ,CliOpts -> InputOpts
inputopts_       :: InputOpts
    ,CliOpts -> ReportSpec
reportspec_      :: ReportSpec
    ,CliOpts -> Maybe Name
output_file_     :: Maybe FilePath
    ,CliOpts -> Maybe Name
output_format_   :: Maybe String
    ,CliOpts -> Int
debug_           :: Int            -- ^ debug level, set by @--debug[=N]@. See also 'Hledger.Utils.debugLevel'.
    ,CliOpts -> Bool
no_new_accounts_ :: Bool           -- add
    ,CliOpts -> Maybe Name
width_           :: Maybe String   -- ^ the --width value provided, if any
    ,CliOpts -> Int
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)
    ,CliOpts -> POSIXTime
progstarttime_   :: POSIXTime
 } deriving (Int -> CliOpts -> Name -> Name
[CliOpts] -> Name -> Name
CliOpts -> Name
(Int -> CliOpts -> Name -> Name)
-> (CliOpts -> Name) -> ([CliOpts] -> Name -> Name) -> Show CliOpts
forall a.
(Int -> a -> Name -> Name)
-> (a -> Name) -> ([a] -> Name -> Name) -> Show a
showList :: [CliOpts] -> Name -> Name
$cshowList :: [CliOpts] -> Name -> Name
show :: CliOpts -> Name
$cshow :: CliOpts -> Name
showsPrec :: Int -> CliOpts -> Name -> Name
$cshowsPrec :: Int -> CliOpts -> Name -> Name
Show)

instance Default CliOpts where def :: CliOpts
def = CliOpts
defcliopts

defcliopts :: CliOpts
defcliopts :: CliOpts
defcliopts = CliOpts :: RawOpts
-> Name
-> [Name]
-> InputOpts
-> ReportSpec
-> Maybe Name
-> Maybe Name
-> Int
-> Bool
-> Maybe Name
-> Int
-> POSIXTime
-> CliOpts
CliOpts
    { rawopts_ :: RawOpts
rawopts_         = RawOpts
forall a. Default a => a
def
    , command_ :: Name
command_         = Name
""
    , file_ :: [Name]
file_            = []
    , inputopts_ :: InputOpts
inputopts_       = InputOpts
definputopts
    , reportspec_ :: ReportSpec
reportspec_      = ReportSpec
forall a. Default a => a
def
    , output_file_ :: Maybe Name
output_file_     = Maybe Name
forall a. Maybe a
Nothing
    , output_format_ :: Maybe Name
output_format_   = Maybe Name
forall a. Maybe a
Nothing
    , debug_ :: Int
debug_           = Int
0
    , no_new_accounts_ :: Bool
no_new_accounts_ = Bool
False
    , width_ :: Maybe Name
width_           = Maybe Name
forall a. Maybe a
Nothing
    , available_width_ :: Int
available_width_ = Int
defaultWidth
    , progstarttime_ :: POSIXTime
progstarttime_   = POSIXTime
0
    }

-- | Default width for hledger console output, when not otherwise specified.
defaultWidth :: Int
defaultWidth :: Int
defaultWidth = Int
80

-- | Replace any numeric flags (eg -2) with their long form (--depth 2),
-- as I'm guessing cmdargs doesn't support this directly.
replaceNumericFlags :: [String] -> [String]
replaceNumericFlags :: [Name] -> [Name]
replaceNumericFlags = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Name
replace
  where
    replace :: Name -> Name
replace (Char
'-':Name
ds) | Bool -> Bool
not (Name -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Name
ds) Bool -> Bool -> Bool
&& (Char -> Bool) -> Name -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit Name
ds = Name
"--depth="Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++Name
ds
    replace Name
s = Name
s

-- | 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 -> IO CliOpts
rawOptsToCliOpts RawOpts
rawopts = do
  Day
currentDay <- IO Day
getCurrentDay
  let day :: Day
day = case Name -> RawOpts -> Maybe Name
maybestringopt Name
"today" RawOpts
rawopts of
              Maybe Name
Nothing -> Day
currentDay
              Just Name
d  -> Day -> Either HledgerParseErrors Day -> Day
forall b a. b -> Either a b -> b
fromRight (Name -> Day
forall a. Name -> a
error' (Name -> Day) -> Name -> Day
forall a b. (a -> b) -> a -> b
$ Name
"Unable to parse date \"" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
d Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\"") -- PARTIAL:
                         (Either HledgerParseErrors Day -> Day)
-> Either HledgerParseErrors Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Text -> Either HledgerParseErrors Day
fixSmartDateStrEither' Day
currentDay (Name -> Text
T.pack Name
d)
  let iopts :: InputOpts
iopts = Day -> RawOpts -> InputOpts
rawOptsToInputOpts Day
day RawOpts
rawopts
  ReportSpec
rspec <- (Name -> IO ReportSpec)
-> (ReportSpec -> IO ReportSpec)
-> Either Name ReportSpec
-> IO ReportSpec
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Name -> IO ReportSpec
forall a. Name -> a
error' ReportSpec -> IO ReportSpec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Name ReportSpec -> IO ReportSpec)
-> Either Name ReportSpec -> IO ReportSpec
forall a b. (a -> b) -> a -> b
$ Day -> RawOpts -> Either Name ReportSpec
rawOptsToReportSpec Day
day RawOpts
rawopts  -- PARTIAL:
  Maybe Int
mcolumns <- Name -> Maybe Int
forall a. Read a => Name -> Maybe a
readMay (Name -> Maybe Int) -> IO Name -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IO Name
getEnvSafe Name
"COLUMNS"
  Maybe Int
mtermwidth <-
#ifdef mingw32_HOST_OS
    return Nothing
#else
    (Terminal -> Capability Int -> Maybe Int
forall a. Terminal -> Capability a -> Maybe a
`getCapability` Capability Int
termColumns) (Terminal -> Maybe Int) -> IO Terminal -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Terminal
setupTermFromEnv
    -- XXX Throws a SetupTermError if the terminfo database could not be read, should catch
#endif
  let availablewidth :: Int
availablewidth = [Int] -> Int
forall a. [a] -> a
head ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Int
mcolumns, Maybe Int
mtermwidth, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
defaultWidth]
  CliOpts -> IO CliOpts
forall (m :: * -> *) a. Monad m => a -> m a
return CliOpts
defcliopts {
              rawopts_ :: RawOpts
rawopts_         = RawOpts
rawopts
             ,command_ :: Name
command_         = Name -> RawOpts -> Name
stringopt Name
"command" RawOpts
rawopts
             ,file_ :: [Name]
file_            = Name -> RawOpts -> [Name]
listofstringopt Name
"file" RawOpts
rawopts
             ,inputopts_ :: InputOpts
inputopts_       = InputOpts
iopts
             ,reportspec_ :: ReportSpec
reportspec_      = ReportSpec
rspec
             ,output_file_ :: Maybe Name
output_file_     = Name -> RawOpts -> Maybe Name
maybestringopt Name
"output-file" RawOpts
rawopts
             ,output_format_ :: Maybe Name
output_format_   = Name -> RawOpts -> Maybe Name
maybestringopt Name
"output-format" RawOpts
rawopts
             ,debug_ :: Int
debug_           = Name -> RawOpts -> Int
posintopt Name
"debug" RawOpts
rawopts
             ,no_new_accounts_ :: Bool
no_new_accounts_ = Name -> RawOpts -> Bool
boolopt Name
"no-new-accounts" RawOpts
rawopts -- add
             ,width_ :: Maybe Name
width_           = Name -> RawOpts -> Maybe Name
maybestringopt Name
"width" RawOpts
rawopts
             ,available_width_ :: Int
available_width_ = Int
availablewidth
             }

-- | A helper for addon commands: this parses options and arguments from
-- the current command line using the given hledger-style cmdargs mode,
-- and returns a CliOpts. Or, with --help or -h present, it prints
-- long or short help, and exits the program.
-- When --debug is present, also prints some debug output.
-- Note this is not used by the main hledger executable.
--
-- The help texts are generated from the mode.
-- Long help includes the full usage description generated by cmdargs
-- (including all supported options), framed by whatever pre- and postamble
-- text the mode specifies. It's intended that this forms a complete
-- help document or manual.
--
-- Short help is a truncated version of the above: the preamble and
-- the first part of the usage, up to the first line containing "flags:"
-- (normally this marks the start of the common hledger flags);
-- plus a mention of --help and the (presumed supported) common
-- hledger options not displayed.
--
-- Tips:
-- Empty lines in the pre/postamble are removed by cmdargs;
-- add a space character to preserve them.
--
getHledgerCliOpts' :: Mode RawOpts -> [String] -> IO CliOpts
getHledgerCliOpts' :: Mode RawOpts -> [Name] -> IO CliOpts
getHledgerCliOpts' Mode RawOpts
mode' [Name]
args' = do
  let rawopts :: RawOpts
rawopts = (Name -> RawOpts)
-> (RawOpts -> RawOpts) -> Either Name RawOpts -> RawOpts
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Name -> RawOpts
forall a. Name -> a
usageError RawOpts -> RawOpts
forall a. a -> a
id (Either Name RawOpts -> RawOpts) -> Either Name RawOpts -> RawOpts
forall a b. (a -> b) -> a -> b
$ Mode RawOpts -> [Name] -> Either Name RawOpts
forall a. Mode a -> [Name] -> Either Name a
process Mode RawOpts
mode' [Name]
args'
  CliOpts
opts <- RawOpts -> IO CliOpts
rawOptsToCliOpts RawOpts
rawopts
  [Name] -> CliOpts -> IO ()
debugArgs [Name]
args' CliOpts
opts
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
"help" Name -> RawOpts -> Bool
`inRawOpts` CliOpts -> RawOpts
rawopts_ CliOpts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Name -> IO ()
putStr Name
shorthelp IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
  -- when ("help" `inRawOpts` rawopts_ opts) $ putStr longhelp  >> exitSuccess
  CliOpts -> IO CliOpts
forall (m :: * -> *) a. Monad m => a -> m a
return CliOpts
opts
  where
    longhelp :: Name
longhelp = Mode RawOpts -> Name
forall a. Mode a -> Name
showModeUsage Mode RawOpts
mode'
    shorthelp :: Name
shorthelp =
      [Name] -> Name
unlines ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$
        ([Name] -> [Name]
forall a. [a] -> [a]
reverse ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Name -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
reverse ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name
"flags:" Name -> Name -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`)) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Name -> [Name]
lines Name
longhelp)
        [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
        [Name
""
        ,Name
"  See also hledger -h for general hledger options."
        ]
    -- | Print debug info about arguments and options if --debug is present.
    debugArgs :: [String] -> CliOpts -> IO ()
    debugArgs :: [Name] -> CliOpts -> IO ()
debugArgs [Name]
args' CliOpts
opts =
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
"--debug" Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
args') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Name
progname' <- IO Name
getProgName
        Name -> IO ()
putStrLn (Name -> IO ()) -> Name -> IO ()
forall a b. (a -> b) -> a -> b
$ Name
"running: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
progname'
        Name -> IO ()
putStrLn (Name -> IO ()) -> Name -> IO ()
forall a b. (a -> b) -> a -> b
$ Name
"raw args: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [Name] -> Name
forall a. Show a => a -> Name
show [Name]
args'
        Name -> IO ()
putStrLn (Name -> IO ()) -> Name -> IO ()
forall a b. (a -> b) -> a -> b
$ Name
"processed opts:\n" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ CliOpts -> Name
forall a. Show a => a -> Name
show CliOpts
opts
        Name -> IO ()
putStrLn (Name -> IO ()) -> Name -> IO ()
forall a b. (a -> b) -> a -> b
$ Name
"search query: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Query -> Name
forall a. Show a => a -> Name
show (ReportSpec -> Query
_rsQuery (ReportSpec -> Query) -> ReportSpec -> Query
forall a b. (a -> b) -> a -> b
$ CliOpts -> ReportSpec
reportspec_ CliOpts
opts)

getHledgerCliOpts :: Mode RawOpts -> IO CliOpts
getHledgerCliOpts :: Mode RawOpts -> IO CliOpts
getHledgerCliOpts Mode RawOpts
mode' = do
  [Name]
args' <- IO [Name]
getArgs IO [Name] -> ([Name] -> IO [Name]) -> IO [Name]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Name] -> IO [Name]
expandArgsAt
  Mode RawOpts -> [Name] -> IO CliOpts
getHledgerCliOpts' Mode RawOpts
mode' [Name]
args' 

-- CliOpts accessors

-- | 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 :: CliOpts -> IO [Name]
journalFilePathFromOpts CliOpts
opts = do
  Name
f <- IO Name
defaultJournalPath
  Name
d <- IO Name
getCurrentDirectory
  case CliOpts -> [Name]
file_ CliOpts
opts of
    [] -> [Name] -> IO [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name
f]
    [Name]
fs -> (Name -> IO Name) -> [Name] -> IO [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> Name -> IO Name
expandPathPreservingPrefix Name
d) [Name]
fs

expandPathPreservingPrefix :: FilePath -> PrefixedFilePath -> IO PrefixedFilePath
expandPathPreservingPrefix :: Name -> Name -> IO Name
expandPathPreservingPrefix Name
d Name
prefixedf = do
  let (Maybe Name
p,Name
f) = Name -> (Maybe Name, Name)
splitReaderPrefix Name
prefixedf
  Name
f' <- Name -> Name -> IO Name
expandPath Name
d Name
f
  Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> IO Name) -> Name -> IO Name
forall a b. (a -> b) -> a -> b
$ case Maybe Name
p of
    Just Name
p  -> Name
p Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
":" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
f'
    Maybe Name
Nothing -> Name
f'

-- | Get the expanded, absolute output file path specified by an
-- -o/--output-file options, or nothing, meaning stdout.
outputFileFromOpts :: CliOpts -> IO (Maybe FilePath)
outputFileFromOpts :: CliOpts -> IO (Maybe Name)
outputFileFromOpts CliOpts
opts = do
  Name
d <- IO Name
getCurrentDirectory
  case CliOpts -> Maybe Name
output_file_ CliOpts
opts of
    Maybe Name
Nothing -> Maybe Name -> IO (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
forall a. Maybe a
Nothing
    Just Name
f  -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> IO Name -> IO (Maybe Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Name -> IO Name
expandPath Name
d Name
f

defaultOutputFormat :: String
defaultOutputFormat :: Name
defaultOutputFormat = Name
"txt"

outputFormats :: [String]
outputFormats :: [Name]
outputFormats = [Name
defaultOutputFormat, Name
"csv", Name
"html"]

-- | 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 :: CliOpts -> Name
outputFormatFromOpts CliOpts
opts =
  case CliOpts -> Maybe Name
output_format_ CliOpts
opts of
    Just Name
f  -> Name
f
    Maybe Name
Nothing ->
      case Name -> Name
filePathExtension (Name -> Name) -> Maybe Name -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CliOpts -> Maybe Name
output_file_ CliOpts
opts of
        Just Name
ext | Name
ext Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
outputFormats -> Name
ext
        Maybe Name
_                                   -> Name
defaultOutputFormat

-- -- | 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 :: Name -> Name
filePathExtension = (Char -> Bool) -> Name -> Name
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') (Name -> Name) -> (Name -> Name) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Name) -> Name
forall a b. (a, b) -> b
snd ((Name, Name) -> Name) -> (Name -> (Name, Name)) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> (Name, Name)
splitExtension (Name -> (Name, Name)) -> (Name -> Name) -> Name -> (Name, Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Name) -> Name
forall a b. (a, b) -> b
snd ((Name, Name) -> Name) -> (Name -> (Name, Name)) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> (Name, Name)
splitFileName

-- | Get the (tilde-expanded) rules file path from options, if any.
rulesFilePathFromOpts :: CliOpts -> IO (Maybe FilePath)
rulesFilePathFromOpts :: CliOpts -> IO (Maybe Name)
rulesFilePathFromOpts CliOpts
opts = do
  Name
d <- IO Name
getCurrentDirectory
  IO (Maybe Name)
-> (Name -> IO (Maybe Name)) -> Maybe Name -> IO (Maybe Name)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Name -> IO (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
forall a. Maybe a
Nothing) ((Name -> Maybe Name) -> IO Name -> IO (Maybe Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Maybe Name
forall a. a -> Maybe a
Just (IO Name -> IO (Maybe Name))
-> (Name -> IO Name) -> Name -> IO (Maybe Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> IO Name
expandPath Name
d) (Maybe Name -> IO (Maybe Name)) -> Maybe Name -> IO (Maybe Name)
forall a b. (a -> b) -> a -> b
$ InputOpts -> Maybe Name
mrules_file_ (InputOpts -> Maybe Name) -> InputOpts -> Maybe Name
forall a b. (a -> b) -> a -> b
$ CliOpts -> InputOpts
inputopts_ CliOpts
opts

-- | 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 -> Int
widthFromOpts CliOpts{width_ :: CliOpts -> Maybe Name
width_=Maybe Name
Nothing, available_width_ :: CliOpts -> Int
available_width_=Int
w} = Int
w
widthFromOpts CliOpts{width_ :: CliOpts -> Maybe Name
width_=Just Name
s}  =
    case Parsec Void Name Int
-> Name -> Name -> Either (ParseErrorBundle Name Void) Int
forall e s a.
Parsec e s a -> Name -> s -> Either (ParseErrorBundle s e) a
runParser (Name -> Int
forall a. Read a => Name -> a
read (Name -> Int)
-> ParsecT Void Name Identity Name -> Parsec Void Name Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecT Void Name Identity Char -> ParsecT Void Name Identity Name
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Name Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar Parsec Void Name Int
-> ParsecT Void Name Identity () -> Parsec Void Name Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Name Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof :: ParsecT Void String Identity Int) Name
"(unknown)" Name
s of
        Left ParseErrorBundle Name Void
e   -> Name -> Int
forall a. Name -> a
usageError (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ Name
"could not parse width option: "Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ParseErrorBundle Name Void -> Name
forall a. Show a => a -> Name
show ParseErrorBundle Name Void
e
        Right Int
w  -> Int
w

-- 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 -> (Int, Maybe Int)
registerWidthsFromOpts CliOpts{width_ :: CliOpts -> Maybe Name
width_=Maybe Name
Nothing, available_width_ :: CliOpts -> Int
available_width_=Int
w} = (Int
w, Maybe Int
forall a. Maybe a
Nothing)
registerWidthsFromOpts CliOpts{width_ :: CliOpts -> Maybe Name
width_=Just Name
s}  =
    case Parsec Void Name (Int, Maybe Int)
-> Name
-> Name
-> Either (ParseErrorBundle Name Void) (Int, Maybe Int)
forall e s a.
Parsec e s a -> Name -> s -> Either (ParseErrorBundle s e) a
runParser Parsec Void Name (Int, Maybe Int)
forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
ParsecT Void s m (Int, Maybe Int)
registerwidthp Name
"(unknown)" Name
s of
        Left ParseErrorBundle Name Void
e   -> Name -> (Int, Maybe Int)
forall a. Name -> a
usageError (Name -> (Int, Maybe Int)) -> Name -> (Int, Maybe Int)
forall a b. (a -> b) -> a -> b
$ Name
"could not parse width option: "Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ParseErrorBundle Name Void -> Name
forall a. Show a => a -> Name
show ParseErrorBundle Name Void
e
        Right (Int, Maybe Int)
ws -> (Int, Maybe Int)
ws
    where
        registerwidthp :: (Stream s, Char ~ Token s) => ParsecT Void s m (Int, Maybe Int)
        registerwidthp :: ParsecT Void s m (Int, Maybe Int)
registerwidthp = do
          Int
totalwidth <- Name -> Int
forall a. Read a => Name -> a
read (Name -> Int) -> ParsecT Void s m Name -> ParsecT Void s m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecT Void s m Char -> ParsecT Void s m Name
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void s m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
          Maybe Int
descwidth <- ParsecT Void s m Int -> ParsecT Void s m (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token s -> ParsecT Void s m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
',' ParsecT Void s m Char
-> ParsecT Void s m Int -> ParsecT Void s m Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Name -> Int
forall a. Read a => Name -> a
read (Name -> Int) -> ParsecT Void s m Name -> ParsecT Void s m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecT Void s m Char -> ParsecT Void s m Name
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void s m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar)
          ParsecT Void s m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
          (Int, Maybe Int) -> ParsecT Void s m (Int, Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
totalwidth, Maybe Int
descwidth)

-- Other utils

-- | Get the sorted unique canonical names of hledger addon commands
-- found in the current user's PATH. These are used in command line
-- parsing and to display the commands list.
--
-- Canonical addon names are the filenames of hledger-* executables in
-- PATH, without the "hledger-" prefix, and without the file extension
-- except when it's needed for disambiguation (see below).
--
-- When there are exactly two versions of an executable (same base
-- name, different extensions) that look like a source and compiled
-- pair (one has .exe, .com, or no extension), the source version will
-- be excluded (even if it happens to be newer). When there are three
-- or more versions (or two versions that don't look like a
-- source/compiled pair), they are all included, with file extensions
-- intact.
--
hledgerAddons :: IO [String]
hledgerAddons :: IO [Name]
hledgerAddons = do
  -- past bug generator
  [Name]
as1 <- IO [Name]
hledgerExecutablesInPath                     -- ["hledger-check","hledger-check-dates","hledger-check-dates.hs","hledger-check.hs","hledger-check.py"]
  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               -- ["check","check-dates","check-dates.hs","check.hs","check.py"]
  let as3 :: [[Name]]
as3 = (Name -> Name) -> [Name] -> [[Name]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupSortOn Name -> Name
takeBaseName [Name]
as2              -- [["check","check.hs","check.py"],["check-dates","check-dates.hs"]]
  let as4 :: [Name]
as4 = ([Name] -> [Name]) -> [[Name]] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Name] -> [Name]
dropRedundantSourceVersion [[Name]]
as3  -- ["check","check.hs","check.py","check-dates"]
  [Name] -> IO [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name]
as4

stripPrognamePrefix :: [a] -> [a]
stripPrognamePrefix = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Name -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Name
progname Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

dropRedundantSourceVersion :: [Name] -> [Name]
dropRedundantSourceVersion [Name
f,Name
g]
  | (Char -> Char) -> Name -> Name
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Name -> Name
takeExtension Name
f) Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
compiledExts = [Name
f]
  | (Char -> Char) -> Name -> Name
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Name -> Name
takeExtension Name
g) Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
compiledExts = [Name
g]
dropRedundantSourceVersion [Name]
fs = [Name]
fs

compiledExts :: [Name]
compiledExts = [Name
"",Name
".com",Name
".exe"]


-- | Get all sorted unique filenames in the current user's PATH.
-- We do not currently filter out non-file objects or files without execute permission.
likelyExecutablesInPath :: IO [String]
likelyExecutablesInPath :: IO [Name]
likelyExecutablesInPath = do
  [Name]
pathdirs <- Name -> Name -> [Name]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOneOf Name
"[:;]" (Name -> [Name]) -> IO Name -> IO [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> IO Name
getEnvSafe Name
"PATH"
  [Name]
pathfiles <- [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [Name]) -> IO [[Name]] -> IO [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Name -> IO [Name]) -> [Name] -> IO [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> IO [Name]
getDirectoryContentsSafe [Name]
pathdirs
  [Name] -> IO [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> IO [Name]) -> [Name] -> IO [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. Ord a => [a] -> [a]
nubSort [Name]
pathfiles
  -- exclude directories and files without execute permission.
  -- These will do a stat for each hledger-*, probably ok.
  -- But they need paths, not just filenames
  -- exes'  <- filterM doesFileExist exe'
  -- exes'' <- filterM isExecutable exes'
  -- return exes''

-- | Get the sorted unique filenames of all hledger-* executables in
-- the current user's PATH. 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.
-- We do not currently filter out non-file objects or files without execute permission.
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

-- isExecutable f = getPermissions f >>= (return . executable)

isHledgerExeName :: String -> Bool
isHledgerExeName :: Name -> Bool
isHledgerExeName = Either HledgerParseErrors () -> Bool
forall a b. Either a b -> Bool
isRight (Either HledgerParseErrors () -> Bool)
-> (Name -> Either HledgerParseErrors ()) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec HledgerParseErrorData Text ()
-> Text -> Either HledgerParseErrors ()
forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith Parsec HledgerParseErrorData Text ()
forall (m :: * -> *). ParsecT HledgerParseErrorData Text m ()
hledgerexenamep (Text -> Either HledgerParseErrors ())
-> (Name -> Text) -> Name -> Either HledgerParseErrors ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
T.pack
    where
      hledgerexenamep :: ParsecT HledgerParseErrorData Text m ()
hledgerexenamep = do
        Text
_ <- Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text))
-> Tokens Text
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall a b. (a -> b) -> a -> b
$ Name -> Text
T.pack Name
progname
        Char
_ <- Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-'
        Name
_ <- ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Name
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT HledgerParseErrorData Text m Char
 -> ParsecT HledgerParseErrorData Text m Name)
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Name
forall a b. (a -> b) -> a -> b
$ [Token Text] -> ParsecT HledgerParseErrorData Text m (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf [Char
'.']
        ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"." ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ParsecT HledgerParseErrorData Text m Text]
-> ParsecT HledgerParseErrorData Text m Text
forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice' ((Name -> ParsecT HledgerParseErrorData Text m Text)
-> [Name] -> [ParsecT HledgerParseErrorData Text m Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ParsecT HledgerParseErrorData Text m Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Text -> ParsecT HledgerParseErrorData Text m Text)
-> (Name -> Text)
-> Name
-> ParsecT HledgerParseErrorData Text m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
T.pack) [Name]
addonExtensions))
        ParsecT HledgerParseErrorData Text m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

-- stripAddonExtension :: String -> String
-- stripAddonExtension = regexReplace re "" where re = "\\.(" ++ intercalate "|" addonExtensions ++ ")$"

addonExtensions :: [String]
addonExtensions :: [Name]
addonExtensions =
  [Name
"bat"
  ,Name
"com"
  ,Name
"exe"
  ,Name
"hs"
  ,Name
"lhs"
  ,Name
"pl"
  ,Name
"py"
  ,Name
"rb"
  ,Name
"rkt"
  ,Name
"sh"
  -- ,""
  ]

getEnvSafe :: String -> IO String
getEnvSafe :: Name -> IO Name
getEnvSafe Name
v = Name -> IO Name
getEnv Name
v IO Name -> (IOException -> IO Name) -> IO Name
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`C.catch` (\(IOException
_::C.IOException) -> Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
"") -- XXX should catch only isDoesNotExistError e

getDirectoryContentsSafe :: FilePath -> IO [String]
getDirectoryContentsSafe :: Name -> IO [Name]
getDirectoryContentsSafe Name
d =
    ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
".",Name
".."])) ([Name] -> [Name]) -> IO [Name] -> IO [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> IO [Name]
getDirectoryContents Name
d) IO [Name] -> (IOException -> IO [Name]) -> IO [Name]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`C.catch` (\(IOException
_::C.IOException) -> [Name] -> IO [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return [])

-- 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)

-- ** Lenses

makeHledgerClassyLenses ''CliOpts

instance HasInputOpts CliOpts where
    inputOpts :: (InputOpts -> f InputOpts) -> CliOpts -> f CliOpts
inputOpts = (InputOpts -> f InputOpts) -> CliOpts -> f CliOpts
forall c. HasCliOpts c => Lens' c InputOpts
inputopts

instance HasBalancingOpts CliOpts where
    balancingOpts :: (BalancingOpts -> f BalancingOpts) -> CliOpts -> f CliOpts
balancingOpts = (InputOpts -> f InputOpts) -> CliOpts -> f CliOpts
forall c. HasInputOpts c => Lens' c InputOpts
inputOpts((InputOpts -> f InputOpts) -> CliOpts -> f CliOpts)
-> ((BalancingOpts -> f BalancingOpts) -> InputOpts -> f InputOpts)
-> (BalancingOpts -> f BalancingOpts)
-> CliOpts
-> f CliOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BalancingOpts -> f BalancingOpts) -> InputOpts -> f InputOpts
forall c. HasBalancingOpts c => Lens' c BalancingOpts
balancingOpts

instance HasReportSpec CliOpts where
    reportSpec :: (ReportSpec -> f ReportSpec) -> CliOpts -> f CliOpts
reportSpec = (ReportSpec -> f ReportSpec) -> CliOpts -> f CliOpts
forall c. HasCliOpts c => Lens' c ReportSpec
reportspec

instance HasReportOptsNoUpdate CliOpts where
    reportOptsNoUpdate :: (ReportOpts -> f ReportOpts) -> CliOpts -> f CliOpts
reportOptsNoUpdate = (ReportSpec -> f ReportSpec) -> CliOpts -> f CliOpts
forall c. HasReportSpec c => Lens' c ReportSpec
reportSpec((ReportSpec -> f ReportSpec) -> CliOpts -> f CliOpts)
-> ((ReportOpts -> f ReportOpts) -> ReportSpec -> f ReportSpec)
-> (ReportOpts -> f ReportOpts)
-> CliOpts
-> f CliOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ReportOpts -> f ReportOpts) -> ReportSpec -> f ReportSpec
forall c. HasReportOptsNoUpdate c => Lens' c ReportOpts
reportOptsNoUpdate

instance HasReportOpts CliOpts where
    reportOpts :: (ReportOpts -> f ReportOpts) -> CliOpts -> f CliOpts
reportOpts = (ReportSpec -> f ReportSpec) -> CliOpts -> f CliOpts
forall c. HasReportSpec c => Lens' c ReportSpec
reportSpec((ReportSpec -> f ReportSpec) -> CliOpts -> f CliOpts)
-> ((ReportOpts -> f ReportOpts) -> ReportSpec -> f ReportSpec)
-> (ReportOpts -> f ReportOpts)
-> CliOpts
-> f CliOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ReportOpts -> f ReportOpts) -> ReportSpec -> f ReportSpec
forall a. HasReportOpts a => ReportableLens' a ReportOpts
reportOpts