{-|

hledger's cmdargs modes parse command-line arguments to an
intermediate format, RawOpts (an association list), rather than a
fixed ADT like CliOpts. This allows the modes and flags to be reused
more easily by hledger commands/scripts in this and other packages.

-}

module Hledger.Data.RawOptions (
  RawOpts,
  mkRawOpts,
  overRawOpts,
  dropRawOpt,
  setopt,
  setboolopt,
  unsetboolopt,
  appendopts,
  boolopt,
  toggleopt,
  choiceopt,
  collectopts,
  stringopt,
  maybestringopt,
  listofstringopt,
  intopt,
  posintopt,
  maybeintopt,
  maybeposintopt,
  maybecharopt,
  maybeynopt,
  maybeynaopt,
)
where

import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.Default (Default(..))
import Safe (headMay, lastMay, readDef)

import Hledger.Utils
import Data.Char (toLower)
import Data.List (intercalate)


-- | The result of running cmdargs: an association list of option names to string values.
newtype RawOpts = RawOpts { unRawOpts :: [(String,String)] }
  deriving (Show)

instance Default RawOpts where def = RawOpts []

mkRawOpts :: [(String,String)] -> RawOpts
mkRawOpts = RawOpts

overRawOpts :: ([(String,String)] -> [(String,String)]) -> RawOpts -> RawOpts
overRawOpts f = RawOpts . f . unRawOpts

dropRawOpt :: String -> RawOpts -> RawOpts
dropRawOpt a = overRawOpts $ filter (not.(==a).fst)

setopt :: String -> String -> RawOpts -> RawOpts
setopt name val = overRawOpts (++ [(name, val)])

setboolopt :: String -> RawOpts -> RawOpts
setboolopt name = overRawOpts (++ [(name,"")])

unsetboolopt :: String -> RawOpts -> RawOpts
unsetboolopt name = overRawOpts (filter ((/=name).fst))

appendopts :: [(String,String)] -> RawOpts -> RawOpts
appendopts new = overRawOpts (++new)

-- | Is the named flag present ?
boolopt :: String -> RawOpts -> Bool
boolopt name = isJust . lookup name . unRawOpts

-- | Like boolopt, except if the flag is repeated on the command line it toggles the value.
-- An even number of repetitions is equivalent to none.
toggleopt :: String -> RawOpts -> Bool
toggleopt name rawopts = odd $ length [ n | (n,_) <- unRawOpts rawopts, n==name]

-- | From a list of RawOpts, get the last one (ie the right-most on the command line)
-- for which the given predicate returns a Just value.
-- Useful for exclusive choice flags like --daily|--weekly|--quarterly...
--
-- >>> import Safe (readMay)
-- >>> choiceopt Just (RawOpts [("a",""), ("b",""), ("c","")])
-- Just "c"
-- >>> choiceopt (const Nothing) (RawOpts [("a","")])
-- Nothing
-- >>> choiceopt readMay (RawOpts [("LT",""),("EQ",""),("Neither","")]) :: Maybe Ordering
-- Just EQ
choiceopt :: (String -> Maybe a) -- ^ "parser" that returns 'Just' value for valid choice
          -> RawOpts             -- ^ actual options where to look for flag
          -> Maybe a             -- ^ exclusive choice among those returned as 'Just' from "parser"
choiceopt f = lastMay . collectopts (f . fst)

-- | Collects processed and filtered list of options preserving their order
--
-- >>> collectopts (const Nothing) (RawOpts [("x","")])
-- []
-- >>> collectopts Just (RawOpts [("a",""),("b","")])
-- [("a",""),("b","")]
collectopts :: ((String, String) -> Maybe a) -> RawOpts -> [a]
collectopts f = mapMaybe f . unRawOpts

maybestringopt :: String -> RawOpts -> Maybe String
maybestringopt name = lookup name . reverse . unRawOpts

stringopt :: String -> RawOpts -> String
stringopt name = fromMaybe "" . maybestringopt name

maybecharopt :: String -> RawOpts -> Maybe Char
maybecharopt name (RawOpts rawopts) = lookup name rawopts >>= headMay

listofstringopt :: String -> RawOpts -> [String]
listofstringopt name (RawOpts rawopts) = [v | (k,v) <- rawopts, k==name]

-- | Reads the named option's Int argument, if it is present.
-- An argument that is too small or too large will raise an error.
maybeintopt :: String -> RawOpts -> Maybe Int
maybeintopt = maybeclippedintopt minBound maxBound

-- | Reads the named option's natural-number argument, if it is present.
-- An argument that is negative or too large will raise an error.
maybeposintopt :: String -> RawOpts -> Maybe Int
maybeposintopt = maybeclippedintopt 0 maxBound

-- | Reads the named option's Int argument. If not present it will
-- return 0. An argument that is too small or too large will raise an error.
intopt :: String -> RawOpts -> Int
intopt name = fromMaybe 0 . maybeintopt name

-- | Reads the named option's natural-number argument. If not present it will
-- return 0. An argument that is negative or too large will raise an error.
posintopt :: String -> RawOpts -> Int
posintopt name = fromMaybe 0 . maybeposintopt name

-- | Reads the named option's Int argument, if it is present. An argument
-- that does not fit within the given bounds will raise an error.
maybeclippedintopt :: Int -> Int -> String -> RawOpts -> Maybe Int
maybeclippedintopt minVal maxVal name =
    fmap (intOrError . readOrError) . maybestringopt name
  where
    readOrError s = readDef (usageError $ "could not parse " ++ name ++ " number: " ++ s) s
    intOrError n | n >= toInteger minVal && n <= toInteger maxVal = fromInteger n
                 | otherwise = usageError $ "argument to " ++ name
                                         ++ " must lie in the range "
                                         ++ show minVal ++ " to " ++ show maxVal
                                         ++ ", but is " ++ show n

maybeynopt :: String -> RawOpts -> Maybe Bool
maybeynopt name rawopts =
  case maybestringopt name rawopts of
    Just v | map toLower v `elem` ["y","yes","always"] -> Just True
    Just v | map toLower v `elem` ["n","no","never"]   -> Just False
    Just _ -> error' $ name <> " value should be one of " <> (intercalate ", " ["y","yes","n","no"])
    _ -> Nothing

maybeynaopt :: String -> RawOpts -> Maybe YNA
maybeynaopt name rawopts =
  case maybestringopt name rawopts of
    Just v | map toLower v `elem` ["y","yes","always"] -> Just Yes
    Just v | map toLower v `elem` ["n","no","never"]   -> Just No
    Just v | map toLower v `elem` ["a","auto"]         -> Just Auto
    Just _ -> error' $ name <> " value should be one of " <> (intercalate ", " ["y","yes","n","no","a","auto"])
    _ -> Nothing
