hledger/Options.hs

{-# OPTIONS_GHC -cpp #-}
{-|
Command-line options for the application.
-}

module Options 
where
import System
import System.Console.GetOpt
import System.Environment
import Text.Printf
import Text.RegexPR (gsubRegexPRBy)
import Data.Char (toLower)
import Ledger.IO (IOArgs,
                  ledgerenvvar,ledgerdefaultpath,myLedgerPath,
                  timelogenvvar,timelogdefaultpath,myTimelogPath)
import Ledger.Parse
import Ledger.Utils
import Ledger.Types
import Ledger.Dates
import Codec.Binary.UTF8.String (decodeString)
import Control.Monad (liftM)

progname      = "hledger"
timeprogname  = "hours"

usagehdr = (
  "Usage: hledger [OPTIONS] [COMMAND [PATTERNS]]\n" ++
  "       hours   [OPTIONS] [COMMAND [PATTERNS]]\n" ++
  "       hledger convert CSVFILE ACCOUNTNAME RULESFILE\n" ++
  "\n" ++
  "hledger uses your ~/.ledger or $LEDGER file (or another specified with -f),\n" ++
  "while hours uses your ~/.timelog or $TIMELOG file.\n" ++
  "\n" ++
  "COMMAND is one of (may be abbreviated):\n" ++
  "  add       - prompt for new transactions and add them to the ledger\n" ++
  "  balance   - show accounts, with balances\n" ++
  "  convert   - convert CSV data to ledger format and print on stdout\n" ++
  "  histogram - show transaction counts per day or other interval\n" ++
  "  print     - show transactions in ledger format\n" ++
  "  register  - show transactions as a register with running balance\n" ++
#ifdef VTY
  "  ui        - run a simple curses-based text ui\n" ++
#endif
#ifdef HAPPS
  "  web       - run a simple web ui\n" ++
#endif
  "  test      - run self-tests\n" ++
  "\n" ++
  "PATTERNS are regular expressions which filter by account name.\n" ++
  "Prefix with desc: to filter by transaction description instead.\n" ++
  "Prefix with not: to negate a pattern. When using both, not: comes last.\n" ++
  "\n" ++
  "DATES can be y/m/d or ledger-style smart dates like \"last month\".\n" ++
  "\n" ++
  "Options:"
  )
usageftr = ""
usage = usageInfo usagehdr options ++ usageftr

-- | Command-line options we accept.
options :: [OptDescr Opt]
options = [
  Option ['f'] ["file"]         (ReqArg File "FILE")   "use a different ledger/timelog file; - means stdin"
 ,Option ['b'] ["begin"]        (ReqArg Begin "DATE")  "report on transactions on or after this date"
 ,Option ['e'] ["end"]          (ReqArg End "DATE")    "report on transactions before this date"
 ,Option ['p'] ["period"]       (ReqArg Period "EXPR") ("report on transactions during the specified period\n" ++
                                                       "and/or with the specified reporting interval\n")
 ,Option ['C'] ["cleared"]      (NoArg  Cleared)       "report only on cleared transactions"
 ,Option ['U'] ["uncleared"]    (NoArg  UnCleared)     "report only on uncleared transactions"
 ,Option ['B'] ["cost","basis"] (NoArg  CostBasis)     "report cost of commodities"
 ,Option []    ["depth"]        (ReqArg Depth "N")     "hide accounts/transactions deeper than this"
 ,Option ['d'] ["display"]      (ReqArg Display "EXPR") ("show only transactions matching EXPR (where\n" ++
                                                        "EXPR is 'dOP[DATE]' and OP is <, <=, =, >=, >)")
 ,Option ['E'] ["empty"]        (NoArg  Empty)         "show empty/zero things which are normally elided"
 ,Option ['R'] ["real"]         (NoArg  Real)          "report only on real (non-virtual) transactions"
 ,Option []    ["no-total"]     (NoArg  NoTotal)       "balance report: hide the final total"
-- ,Option ['s'] ["subtotal"]     (NoArg  SubTotal)      "balance report: show subaccounts"
 ,Option ['W'] ["weekly"]       (NoArg  WeeklyOpt)     "register report: show weekly summary"
 ,Option ['M'] ["monthly"]      (NoArg  MonthlyOpt)    "register report: show monthly summary"
 ,Option ['Q'] ["quarterly"]    (NoArg  QuarterlyOpt)  "register report: show quarterly summary"
 ,Option ['Y'] ["yearly"]       (NoArg  YearlyOpt)     "register report: show yearly summary"
 ,Option ['h'] ["help"] (NoArg  Help)                  "show this help"
 ,Option ['V'] ["version"]      (NoArg  Version)       "show version information"
 ,Option ['v'] ["verbose"]      (NoArg  Verbose)       "show verbose test output"
 ,Option []    ["debug"]        (NoArg  Debug)         "show some debug output"
 ,Option []    ["debug-no-ui"]  (NoArg  DebugNoUI)     "run ui commands with no output"
 ]

-- | An option value from a command-line flag.
data Opt = 
    File    {value::String} | 
    Begin   {value::String} | 
    End     {value::String} | 
    Period  {value::String} | 
    Cleared | 
    UnCleared | 
    CostBasis | 
    Depth   {value::String} | 
    Display {value::String} | 
    Empty | 
    Real | 
    NoTotal |
    SubTotal |
    WeeklyOpt |
    MonthlyOpt |
    QuarterlyOpt |
    YearlyOpt |
    Help |
    Verbose |
    Version
    | Debug
    | DebugNoUI
    deriving (Show,Eq)

-- these make me nervous
optsWithConstructor f opts = concatMap get opts
    where get o = if f v == o then [o] else [] where v = value o

optsWithConstructors fs opts = concatMap get opts
    where get o = if any (\f -> f == o) fs then [o] else []

optValuesForConstructor f opts = concatMap get opts
    where get o = if f v == o then [v] else [] where v = value o

optValuesForConstructors fs opts = concatMap get opts
    where get o = if any (\f -> f v == o) fs then [v] else [] where v = value o

-- | Parse the command-line arguments into options, command name, and
-- command arguments. Any dates in the options are converted to explicit
-- YYYY/MM/DD format based on the current time.
parseArguments :: IO ([Opt], String, [String])
parseArguments = do
  args <- liftM (map decodeString) getArgs
  let (os,as,es) = getOpt Permute options args
--  istimequery <- usingTimeProgramName
--  let os' = if istimequery then (Period "today"):os else os
  os'' <- fixOptDates os
  case (as,es) of
    (cmd:args,[])   -> return (os'',cmd,args)
    ([],[])         -> return (os'',"",[])
    (_,errs)        -> ioError (userError (concat errs ++ usage))

-- | Convert any fuzzy dates within these option values to explicit ones,
-- based on today's date.
fixOptDates :: [Opt] -> IO [Opt]
fixOptDates opts = do
  d <- getCurrentDay
  return $ map (fixopt d) opts
  where
    fixopt d (Begin s)   = Begin $ fixSmartDateStr d s
    fixopt d (End s)     = End $ fixSmartDateStr d s
    fixopt d (Display s) = -- hacky
        Display $ gsubRegexPRBy "\\[.+?\\]" fixbracketeddatestr s
        where fixbracketeddatestr s = "[" ++ (fixSmartDateStr d $ init $ tail s) ++ "]"
    fixopt _ o            = o

-- | Figure out the overall date span we should report on, based on any
-- begin/end/period options provided. If there is a period option, the
-- others are ignored.
dateSpanFromOpts :: Day -> [Opt] -> DateSpan
dateSpanFromOpts refdate opts
    | not $ null popts = snd $ parsePeriodExpr refdate $ last popts
    | otherwise = DateSpan lastb laste
    where
      popts = optValuesForConstructor Period opts
      bopts = optValuesForConstructor Begin opts
      eopts = optValuesForConstructor End opts
      lastb = listtomaybeday bopts
      laste = listtomaybeday eopts
      listtomaybeday vs = if null vs then Nothing else Just $ parse $ last vs
          where parse = parsedate . fixSmartDateStr refdate

-- | Figure out the reporting interval, if any, specified by the options.
-- If there is a period option, the others are ignored.
intervalFromOpts :: [Opt] -> Interval
intervalFromOpts opts
    | not $ null popts = fst $ parsePeriodExpr refdate $ last popts
    | null otheropts = NoInterval
    | otherwise = case last otheropts of
                    WeeklyOpt  -> Weekly
                    MonthlyOpt -> Monthly
                    QuarterlyOpt -> Quarterly
                    YearlyOpt  -> Yearly
    where
      popts = optValuesForConstructor Period opts
      otheropts = filter (`elem` [WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts
      -- doesn't affect the interval, but parsePeriodExpr needs something
      refdate = parsedate "0001/01/01"

-- | Get the value of the (last) depth option, if any, otherwise a large number.
depthFromOpts :: [Opt] -> Int
depthFromOpts opts = fromMaybe 9999 $ listtomaybeint $ optValuesForConstructor Depth opts
    where
      listtomaybeint [] = Nothing
      listtomaybeint vs = Just $ read $ last vs

-- | Get the value of the (last) display option, if any.
displayFromOpts :: [Opt] -> Maybe String
displayFromOpts opts = listtomaybe $ optValuesForConstructor Display opts
    where
      listtomaybe [] = Nothing
      listtomaybe vs = Just $ last vs

-- | Get a maybe boolean representing the last cleared/uncleared option if any.
clearedValueFromOpts opts | null os = Nothing
                          | last os == Cleared = Just True
                          | otherwise = Just False
    where os = optsWithConstructors [Cleared,UnCleared] opts

-- | Was the program invoked via the \"hours\" alias ?
usingTimeProgramName :: IO Bool
usingTimeProgramName = do
  progname <- getProgName
  return $ map toLower progname == timeprogname

-- | Get the ledger file path from options, an environment variable, or a default
ledgerFilePathFromOpts :: [Opt] -> IO String
ledgerFilePathFromOpts opts = do
  istimequery <- usingTimeProgramName
  f <- if istimequery then myTimelogPath else myLedgerPath
  return $ last $ f:(optValuesForConstructor File opts)

-- | Gather filter pattern arguments into a list of account patterns and a
-- list of description patterns. We interpret pattern arguments as
-- follows: those prefixed with "desc:" are description patterns, all
-- others are account patterns; also patterns prefixed with "not:" are
-- negated. not: should come after desc: if both are used.
parsePatternArgs :: [String] -> ([String],[String])
parsePatternArgs args = (as, ds')
    where
      descprefix = "desc:"
      (ds, as) = partition (descprefix `isPrefixOf`) args
      ds' = map (drop (length descprefix)) ds

-- | Convert application options to more generic types for the library.
optsToIOArgs :: [Opt] -> [String] -> LocalTime -> IOArgs
optsToIOArgs opts args t = (dateSpanFromOpts (localDay t) opts
                         ,clearedValueFromOpts opts
                         ,Real `elem` opts
                         ,CostBasis `elem` opts
                         ,apats
                         ,dpats
                         ) where (apats,dpats) = parsePatternArgs args