{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
{-|

Command-line options for the hledger program, and option-parsing utilities.

-}

module Hledger.Cli.Options
where
import qualified Control.Exception as C
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Time.Calendar
import Safe
import System.Console.CmdArgs
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Text
import System.Directory
import System.Environment
import Test.HUnit
import Text.ParserCombinators.Parsec as P
import Text.Printf

import Hledger
import Hledger.Data.FormatStrings as Format
import Hledger.Cli.Version


-- 1. cmdargs mode and flag definitions, for the main and subcommand modes.
-- Flag values are parsed initially to a simple association list to allow reuse.

type RawOpts = [(String,String)]

defmode :: Mode RawOpts
defmode =   Mode {
  modeNames = []
 ,modeHelp = ""
 ,modeHelpSuffix = []
 ,modeValue = []
 ,modeCheck = Right
 ,modeReform = const Nothing
 ,modeExpandAt = True
 ,modeGroupFlags = toGroup []
 ,modeArgs = ([], Nothing)
 ,modeGroupModes = toGroup []
 }

mainmode addons = defmode {
  modeNames = [progname]
 ,modeHelp = "run the specified hledger command. hledger COMMAND --help for more detail. \nIn general, COMMAND should precede OPTIONS."
 ,modeHelpSuffix = [""]
 ,modeGroupFlags = Group {
     groupUnnamed = helpflags
    ,groupHidden = [flagNone ["binary-filename"] (setboolopt "binary-filename") "show the download filename for this executable, and exit"]
                   ++ fileflags -- quietly permit these flags before COMMAND as well
    ,groupNamed = []
    }
 ,modeArgs = ([], Just mainargsflag)
 ,modeGroupModes = Group {
     groupUnnamed = [
     ]
    ,groupHidden = [
        convertmode
     ]
    ,groupNamed = [
      ("Misc commands", [
        addmode
       ,testmode
       ])
     ,("\nReport commands", [
        accountsmode
       ,entriesmode
       ,postingsmode
       -- ,transactionsmode
       ,activitymode
       ,incomestatementmode
       ,balancesheetmode
       ,cashflowmode
       ,statsmode
       ])
     ]
     ++ case addons of [] -> []
                       cs -> [("\nAdd-on commands found", map addonmode cs)]
    }
 }

-- backwards compatibility - allow cmdargs to recognise this command so we can detect and warn
convertmode = (commandmode ["convert"]) {
  modeValue = [("command","convert")]
 ,modeHelp = ""
 ,modeArgs = ([], Just $ flagArg (\s opts -> Right $ setopt "args" s opts) "[CSVFILE]")
 ,modeGroupFlags = Group {
     groupUnnamed = []
    ,groupHidden = []
    ,groupNamed = []
    }
 }
--

addonmode name = defmode {
  modeNames = [name]
 ,modeHelp = printf "[-- OPTIONS]   run the %s-%s program" progname name
 ,modeValue=[("command",name)]
 ,modeGroupFlags = Group {
     groupUnnamed = []
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags1)]
    }
 ,modeArgs = ([], Just addonargsflag)
 }

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."
 ]

generalflagstitle = "\nGeneral flags"
generalflags1 = fileflags ++ reportflags ++ helpflags
generalflags2 = fileflags ++ helpflags
generalflags3 = helpflags

fileflags = [
  flagReq ["file","f"]  (\s opts -> Right $ setopt "file" s opts) "FILE" "use a different journal file; - means stdin"
 ,flagReq ["rules-file"]  (\s opts -> Right $ setopt "rules-file" s opts) "RULESFILE" "conversion rules for CSV (default: FILE.rules)"
 ,flagReq ["alias"]  (\s opts -> Right $ setopt "alias" s opts)  "ACCT=ALIAS" "display ACCT's name as ALIAS in reports"
 ]

reportflags = [
  flagReq  ["begin","b"]     (\s opts -> Right $ setopt "begin" s opts) "DATE" "report on transactions on or after this date"
 ,flagReq  ["end","e"]       (\s opts -> Right $ setopt "end" s opts) "DATE" "report on transactions before this date"
 ,flagReq  ["period","p"]    (\s opts -> Right $ setopt "period" s opts) "PERIODEXP" "report on transactions during the specified period and/or with the specified reporting interval"
 ,flagNone ["daily","D"]     (\opts -> setboolopt "daily" opts) "report by day"
 ,flagNone ["weekly","W"]    (\opts -> setboolopt "weekly" opts) "report by week"
 ,flagNone ["monthly","M"]   (\opts -> setboolopt "monthly" opts) "report by month"
 ,flagNone ["quarterly","Q"] (\opts -> setboolopt "quarterly" opts) "report by quarter"
 ,flagNone ["yearly","Y"]    (\opts -> setboolopt "yearly" opts) "report by year"
 ,flagNone ["cleared","C"]   (\opts -> setboolopt "cleared" opts) "report only on cleared transactions"
 ,flagNone ["uncleared","U"] (\opts -> setboolopt "uncleared" opts) "report only on uncleared transactions"
 ,flagNone ["cost","B"]      (\opts -> setboolopt "cost" opts) "report cost of commodities"
 ,flagReq  ["depth"]         (\s opts -> Right $ setopt "depth" s opts) "N" "hide accounts/transactions deeper than this"
 ,flagReq  ["display","d"]   (\s opts -> Right $ setopt "display" s opts) "DISPLAYEXP" "show only transactions matching the expression, which is 'dOP[DATE]' where OP is <, <=, =, >=, >"
 ,flagNone ["date2","aux-date","effective"]     (\opts -> setboolopt "date2" opts) "use transactions' secondary dates, if any"
 ,flagNone ["empty","E"]     (\opts -> setboolopt "empty" opts) "show empty/zero things which are normally elided"
 ,flagNone ["real","R"]      (\opts -> setboolopt "real" opts) "report only on real (non-virtual) transactions"
 ]

helpflags = [
  flagHelpSimple (setboolopt "help")
 ,flagNone ["debug"] (setboolopt "debug") "Show extra debug output"
 ,flagVersion (setboolopt "version")
 ]

mainargsflag    = flagArg (\s opts -> Right $ setopt "args" s opts) ""
commandargsflag = flagArg (\s opts -> Right $ setopt "args" s opts) "[PATTERNS]"
addonargsflag   = flagArg (\s opts -> Right $ setopt "args" s opts) "[ARGS]"

commandmode names = defmode {modeNames=names, modeValue=[("command",headDef "" names)]}

addmode = (commandmode ["add"]) {
  modeHelp = "prompt for new transactions and append them to the journal"
 ,modeHelpSuffix = ["Defaults come from previous similar transactions; use query patterns to restrict these."]
 ,modeArgs = ([], Just commandargsflag)
 ,modeGroupFlags = Group {
     groupUnnamed = [
      flagNone ["no-new-accounts"]  (\opts -> setboolopt "no-new-accounts" opts) "don't allow creating new accounts"
     ]
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags2)]
    }
 }

testmode = (commandmode ["test"]) {
  modeHelp = "run self-tests, or just the ones matching REGEXPS"
 ,modeArgs = ([], Just $ flagArg (\s opts -> Right $ setopt "args" s opts) "[REGEXPS]")
 ,modeGroupFlags = Group {
     groupUnnamed = []
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags3)]
    }
 }

accountsmode = (commandmode ["balance","bal","accounts"]) {
  modeHelp = "(or accounts) show matched accounts and their balances"
 ,modeArgs = ([], Just commandargsflag)
 ,modeGroupFlags = Group {
     groupUnnamed = [
      flagNone ["flat"] (\opts -> setboolopt "flat" opts) "show full account names, unindented"
     ,flagReq  ["drop"] (\s opts -> Right $ setopt "drop" s opts) "N" "with --flat, omit this many leading account name components"
     ,flagReq  ["format"] (\s opts -> Right $ setopt "format" s opts) "FORMATSTR" "use this custom line format"
     ,flagNone ["no-elide"] (\opts -> setboolopt "no-elide" opts) "no eliding at all, stronger than --empty"
     ,flagNone ["no-total"] (\opts -> setboolopt "no-total" opts) "don't show the final total"
     ]
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags1)]
    }
 }

entriesmode = (commandmode ["print","entries"]) {
  modeHelp = "(or entries) show matched journal entries"
 ,modeArgs = ([], Just commandargsflag)
 ,modeGroupFlags = Group {
     groupUnnamed = []
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags1)]
    }
 }

postingsmode = (commandmode ["register","postings"]) {
  modeHelp = "(or postings) show matched postings and running total"
 ,modeArgs = ([], Just commandargsflag)
 ,modeGroupFlags = Group {
     groupUnnamed = [
      flagOpt (show defaultWidthWithFlag) ["width","w"] (\s opts -> Right $ setopt "width" s opts) "N" "increase or set the output width (default: 80)"
     ,flagNone ["related","r"] (\opts -> setboolopt "related" opts) "show the other postings in the transactions of those that would have been shown"
     ]
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags1)]
    }
 }

transactionsmode = (commandmode ["transactions"]) {
  modeHelp = "show matched transactions and balance in some account(s)"
 ,modeArgs = ([], Just commandargsflag)
 ,modeGroupFlags = Group {
     groupUnnamed = []
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags1)]
    }
 }

activitymode = (commandmode ["activity","histogram"]) {
  modeHelp = "show a barchart of transactions per interval"
 ,modeHelpSuffix = ["The default interval is daily."]
 ,modeArgs = ([], Just commandargsflag)
 ,modeGroupFlags = Group {
     groupUnnamed = []
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags1)]
    }
 }

incomestatementmode = (commandmode ["incomestatement","is"]) {
  modeHelp = "show a standard income statement"
 ,modeArgs = ([], Just commandargsflag)
 ,modeGroupFlags = Group {
     groupUnnamed = []
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags1)]
    }
 }

balancesheetmode = (commandmode ["balancesheet","bs"]) {
  modeHelp = "show a standard balance sheet"
 ,modeArgs = ([], Just commandargsflag)
 ,modeGroupFlags = Group {
     groupUnnamed = []
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags1)]
    }
 }

cashflowmode = (commandmode ["cashflow","cf"]) {
  modeHelp = "show a simple cashflow statement"
 ,modeArgs = ([], Just commandargsflag)
 ,modeGroupFlags = Group {
     groupUnnamed = []
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags1)]
    }
 }

statsmode = (commandmode ["stats"]) {
  modeHelp = "show quick statistics for a journal (or part of it)"
 ,modeArgs = ([], Just commandargsflag)
 ,modeGroupFlags = Group {
     groupUnnamed = []
    ,groupHidden = []
    ,groupNamed = [(generalflagstitle, generalflags1)]
    }
 }

-- 2. ADT holding options used in this package and above, parsed from RawOpts.
-- This represents the command-line options that were provided, with all
-- parsing completed, but before adding defaults or derived values (XXX add)

-- cli options, used in hledger and above
data CliOpts = CliOpts {
     rawopts_         :: RawOpts
    ,command_         :: String
    ,file_            :: Maybe FilePath
    ,rules_file_      :: Maybe FilePath
    ,alias_           :: [String]
    ,debug_           :: Bool
    ,no_new_accounts_ :: Bool           -- add
    ,width_           :: Maybe String   -- register
    ,reportopts_      :: ReportOpts
 } deriving (Show)

defcliopts = CliOpts
    def
    def
    def
    def
    def
    def
    def
    def
    def

instance Default CliOpts where def = defcliopts

-- | 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.
toCliOpts :: RawOpts -> IO CliOpts
toCliOpts rawopts = do
  d <- getCurrentDay
  return defcliopts {
              rawopts_         = rawopts
             ,command_         = stringopt "command" rawopts
             ,file_            = maybestringopt "file" rawopts
             ,rules_file_      = maybestringopt "rules-file" rawopts
             ,alias_           = map stripquotes $ listofstringopt "alias" rawopts
             ,debug_           = boolopt "debug" rawopts
             ,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add
             ,width_           = maybestringopt "width" rawopts    -- register
             ,reportopts_ = defreportopts {
                             begin_     = maybesmartdateopt d "begin" rawopts
                            ,end_       = maybesmartdateopt d "end" rawopts
                            ,period_    = maybeperiodopt d rawopts
                            ,cleared_   = boolopt "cleared" rawopts
                            ,uncleared_ = boolopt "uncleared" rawopts
                            ,cost_      = boolopt "cost" rawopts
                            ,depth_     = maybeintopt "depth" rawopts
                            ,display_   = maybedisplayopt d rawopts
                            ,date2_     = boolopt "date2" rawopts
                            ,empty_     = boolopt "empty" rawopts
                            ,no_elide_  = boolopt "no-elide" rawopts
                            ,real_      = boolopt "real" rawopts
                            ,flat_      = boolopt "flat" rawopts -- balance
                            ,drop_      = intopt "drop" rawopts -- balance
                            ,no_total_  = boolopt "no-total" rawopts -- balance
                            ,daily_     = boolopt "daily" rawopts
                            ,weekly_    = boolopt "weekly" rawopts
                            ,monthly_   = boolopt "monthly" rawopts
                            ,quarterly_ = boolopt "quarterly" rawopts
                            ,yearly_    = boolopt "yearly" rawopts
                            ,format_    = maybestringopt "format" rawopts
                            ,related_   = boolopt "related" rawopts  -- register
                            ,query_     = unwords $ listofstringopt "args" rawopts
                            }
             }

-- | Get all command-line options, specifying any extra commands that are allowed, or fail on parse errors.
getHledgerCliOpts :: [String] -> IO CliOpts
getHledgerCliOpts addons = do
  args <- getArgs
  toCliOpts (decodeRawOpts $ processValue (mainmode addons) $ rearrangeForCmdArgs args) >>= checkCliOpts

-- utils

-- | Get the unique suffixes (without hledger-) of hledger-* executables
-- found in the current user's PATH, or the empty list if there is any
-- problem.
getHledgerAddonCommands :: IO [String]
getHledgerAddonCommands = map (drop (length progname + 1)) `fmap` getHledgerProgramsInPath

-- | Get the unique names of hledger-* executables found in the current
-- user's PATH, or the empty list if there is any problem.
getHledgerProgramsInPath :: IO [String]
getHledgerProgramsInPath = do
  pathdirs <- splitOn ":" `fmap` getEnvSafe "PATH"
  pathexes <- concat `fmap` mapM getDirectoryContentsSafe pathdirs
  return $ nub $ sort $ filter (isRight . parsewith hledgerprog) pathexes
    where
      hledgerprog = string progname >> char '-' >> many1 (letter <|> char '-') >> eof

getEnvSafe v = getEnv v `C.catch` (\(_::C.IOException) -> return "")
getDirectoryContentsSafe d = getDirectoryContents d `C.catch` (\(_::C.IOException) -> return [])

-- | Convert possibly encoded option values to regular unicode strings.
decodeRawOpts = map (\(name,val) -> (name, fromSystemString val))

-- A hacky workaround for http://code.google.com/p/ndmitchell/issues/detail?id=470 :
-- we'd like to permit options before COMMAND as well as after it.
-- Here we make sure at least -f FILE will be accepted in either position.
rearrangeForCmdArgs (fopt@('-':'f':_:_):cmd:rest) = cmd:fopt:rest
rearrangeForCmdArgs ("-f":fval:cmd:rest) = cmd:"-f":fval:rest
rearrangeForCmdArgs as = as

optserror = error' . (++ " (run with --help for usage)")

setopt name val = (++ [(name,singleQuoteIfNeeded val)])

setboolopt name = (++ [(name,"")])

in_ :: String -> RawOpts -> Bool
in_ name = isJust . lookup name

boolopt = in_

maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name

stringopt name = fromMaybe "" . maybestringopt name

listofstringopt name rawopts = [v | (k,v) <- rawopts, k==name]

maybeintopt :: String -> RawOpts -> Maybe Int
maybeintopt name rawopts =
    let ms = maybestringopt name rawopts in
    case ms of Nothing -> Nothing
               Just s -> Just $ readDef (optserror $ "could not parse "++name++" number: "++s) s

intopt name = fromMaybe 0 . maybeintopt name

maybesmartdateopt :: Day -> String -> RawOpts -> Maybe Day
maybesmartdateopt d name rawopts =
        case maybestringopt name rawopts of
          Nothing -> Nothing
          Just s -> either
                    (\e -> optserror $ "could not parse "++name++" date: "++show e)
                    Just
                    $ fixSmartDateStrEither' d s

maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp
maybedisplayopt d rawopts =
    maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts
    where
      fixbracketeddatestr "" = ""
      fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]"

maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan)
maybeperiodopt d rawopts =
    case maybestringopt "period" rawopts of
      Nothing -> Nothing
      Just s -> either
                (\e -> optserror $ "could not parse period option: "++show e)
                Just
                $ parsePeriodExpr d s

-- | Do final validation of processed opts, raising an error if there is trouble.
checkCliOpts :: CliOpts -> IO CliOpts -- or pure..
checkCliOpts opts@CliOpts{reportopts_=ropts} = do
  case formatFromOpts ropts of
    Left err -> optserror $ "could not parse format option: "++err
    Right _ -> return ()
  case widthFromOpts opts of
    Left err -> optserror $ "could not parse width option: "++err
    Right _ -> return ()
  return opts

-- | Parse the format option if provided, possibly returning an error,
-- otherwise get the default value.
formatFromOpts :: ReportOpts -> Either String [FormatString]
formatFromOpts = maybe (Right defaultBalanceFormatString) parseFormatString . format_

-- | Default line format for balance report: "%20(total)  %2(depth_spacer)%-(account)"
defaultBalanceFormatString :: [FormatString]
defaultBalanceFormatString = [
      FormatField False (Just 20) Nothing TotalField
    , FormatLiteral "  "
    , FormatField True (Just 2) Nothing DepthSpacerField
    , FormatField True Nothing Nothing AccountField
    ]

data OutputWidth = TotalWidth Width | FieldWidths [Width] deriving Show
data Width = Width Int | Auto deriving Show

defaultWidth         = 80
defaultWidthWithFlag = 120

-- | Parse the width option if provided, possibly returning an error,
-- otherwise get the default value.
widthFromOpts :: CliOpts -> Either String OutputWidth
widthFromOpts CliOpts{width_=Nothing} = Right $ TotalWidth $ Width defaultWidth
widthFromOpts CliOpts{width_=Just ""} = Right $ TotalWidth $ Width defaultWidthWithFlag
widthFromOpts CliOpts{width_=Just s}  = parseWidth s

parseWidth :: String -> Either String OutputWidth
parseWidth s = case (runParser outputwidth () "(unknown)") s of
    Left  e -> Left $ show e
    Right x -> Right x

outputwidth :: GenParser Char st OutputWidth
outputwidth =
  try (do w <- width
          ws <- many1 (char ',' >> width)
          return $ FieldWidths $ w:ws)
  <|> TotalWidth `fmap` width

width :: GenParser Char st Width
width = (string "auto" >> return Auto)
    <|> (Width . read) `fmap` many1 digit

-- | Get the (tilde-expanded, absolute) journal file path from options, an environment variable, or a default.
journalFilePathFromOpts :: CliOpts -> IO String
journalFilePathFromOpts opts = do
  f <- defaultJournalPath
  d <- getCurrentDirectory
  expandPath d $ fromMaybe f $ file_ opts

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

aliasesFromOpts :: CliOpts -> [(AccountName,AccountName)]
aliasesFromOpts = map parseAlias . alias_
    where
      -- similar to ledgerAlias
      parseAlias :: String -> (AccountName,AccountName)
      parseAlias s = (accountNameWithoutPostingType $ strip orig
                     ,accountNameWithoutPostingType $ strip alias')
          where
            (orig, alias) = break (=='=') s
            alias' = case alias of ('=':rest) -> rest
                                   _ -> orig

showModeHelp :: Mode a -> String
showModeHelp =
  (showText defaultWrap :: [Text] -> String)
  .
  (helpText [] HelpFormatDefault :: Mode a -> [Text])

tests_Hledger_Cli_Options = TestList
 [
 ]