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

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

-}

module Hledger.Cli.Options
where
import 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
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 ["effective"]     (\opts -> setboolopt "effective" opts) "use transactions' effective 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 = []
    ,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
    ,reportopts_      :: ReportOpts
 } deriving (Show)

defcliopts = CliOpts
    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
             ,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
                            ,effective_ = boolopt "effective" 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
                            ,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 ()
  return opts

-- | Parse any format option provided, possibly raising an error, or 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
    ]

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