-- | Module    : Termonad.Cli
-- Description : Termonad CLI argument parsing module.
-- Copyright   : (c) Dennis Gosnell, 2023
-- License     : BSD3
-- Stability   : experimental
-- Portability : POSIX
--
-- This module exposes Termonad's CLI argument parsing functionality.
--
-- The main function for parsing CLI arguments is 'parseCliArgs'.  The function
-- that knows how to combine CLI arguments with normal 'ConfigOptions' is
-- 'applyCliArgs'.

module Termonad.Cli where

import Termonad.Prelude

import Control.Applicative ((<|>), (<**>))
import Data.Text (pack)
import GI.Vte (CursorBlinkMode)
import Options.Applicative (fullDesc, info, helper, progDesc, ParserInfo, execParser, Parser, Mod, OptionFields, option, str, value, short, long, metavar, help, ReadM, maybeReader, auto, flag')
import Termonad.Types (ConfigOptions (..), Option (Set, Unset), ShowScrollbar, FontSize (..), ShowTabBar, showScrollbarFromString, showTabBarFromString, cursorBlinkModeFromString, FontConfig (..))


-- | A data type that contains arguments from the command line.
data CliArgs = CliArgs
  { cliConfigOptions :: CliConfigOptions
  , extraCliArgs :: ExtraCliArgs
  } deriving (Eq, Show)

-- | The default 'CliArgs'.  This corresponds to the value 'CliArgs' will
-- become when no CLI arguments have been passed.
--
-- >>> :{
--   let defCliArgs =
--         CliArgs
--           { cliConfigOptions = defaultCliConfigOptions
--           , extraCliArgs = defaultExtraCliArgs
--           }
--   in defaultCliArgs == defCliArgs
-- :}
-- True
defaultCliArgs :: CliArgs
defaultCliArgs =
  CliArgs
    { cliConfigOptions = defaultCliConfigOptions
    , extraCliArgs = defaultExtraCliArgs
    }

-- | CLI arguments that correspond to fields in 'ConfigOptions'.
--
-- See 'ConfigOptions' for what each of these options mean.
data CliConfigOptions = CliConfigOptions
  { cliConfFontFamily :: !(Option Text)
  , cliConfFontSize :: !(Option FontSize)
  , cliConfShowScrollbar :: !(Option ShowScrollbar)
  , cliConfScrollbackLen :: !(Option Integer)
  , cliConfConfirmExit :: !(Option Bool)
  , cliConfWordCharExceptions :: !(Option Text)
  , cliConfShowMenu :: !(Option Bool)
  , cliConfShowTabBar :: !(Option ShowTabBar)
  , cliConfCursorBlinkMode :: !(Option CursorBlinkMode)
  , cliConfBoldIsBright :: !(Option Bool)
  , cliConfEnableSixel :: !(Option Bool)
  , cliConfAllowBold :: !(Option Bool)
  } deriving (Eq, Show)

-- | The default 'CliConfigOptions'.  All 'Option's are 'Unset', which means
-- they won't override options from 'ConfigOptions' in 'applyCliArgs'.
--
-- >>> :{
--   let defCliConfOpt =
--         CliConfigOptions
--           { cliConfFontFamily = Unset
--           , cliConfFontSize = Unset
--           , cliConfShowScrollbar = Unset
--           , cliConfScrollbackLen = Unset
--           , cliConfConfirmExit = Unset
--           , cliConfWordCharExceptions = Unset
--           , cliConfShowMenu = Unset
--           , cliConfShowTabBar = Unset
--           , cliConfCursorBlinkMode = Unset
--           , cliConfBoldIsBright = Unset
--           , cliConfEnableSixel = Unset
--           , cliConfAllowBold = Unset
--           }
--   in defaultCliConfigOptions == defCliConfOpt
-- :}
-- True
defaultCliConfigOptions :: CliConfigOptions
defaultCliConfigOptions =
  CliConfigOptions
    { cliConfFontFamily = Unset
    , cliConfFontSize = Unset
    , cliConfShowScrollbar = Unset
    , cliConfScrollbackLen = Unset
    , cliConfConfirmExit = Unset
    , cliConfWordCharExceptions = Unset
    , cliConfShowMenu = Unset
    , cliConfShowTabBar = Unset
    , cliConfCursorBlinkMode = Unset
    , cliConfBoldIsBright = Unset
    , cliConfEnableSixel = Unset
    , cliConfAllowBold = Unset
    }

-- | Extra CLI arguments for values that don't make sense in 'ConfigOptions'.
data ExtraCliArgs = ExtraCliArgs
  deriving (Eq, Show)

-- | The default 'ExtraCliArgs'.
--
-- >>> :{
--   let defExtraCliArgs =
--         ExtraCliArgs
--   in defaultExtraCliArgs == defExtraCliArgs
-- :}
-- True
defaultExtraCliArgs :: ExtraCliArgs
defaultExtraCliArgs = ExtraCliArgs

-- | Similar to 'Options.Applicative.strOption', but specifically work on a
-- value that is an 'Option'.
strOption' :: IsString s => Mod OptionFields (Option s) -> Parser (Option s)
strOption' mods = option (fmap Set str) (value Unset <> mods)

-- | Similar to 'Options.Applicative.option', but specifically work on a
-- value that is an 'Option'.
option' :: ReadM a -> Mod OptionFields (Option a) -> Parser (Option a)
option' readM mods = option (fmap Set readM) (value Unset <> mods)

-- | Similar to 'Options.Applicative.maybeReader', but work on 'Text' instead
-- of 'String'.
maybeTextReader :: (Text -> Maybe a) -> ReadM a
maybeTextReader f = maybeReader (f . pack)

-- | Helper for making a 'flag' CLI argument that optionally takes a @no-@ prefix.
--
-- Example:
--
-- > 'optionFlag' 'True' 'False' 'f' 'n' "foo" "Does foo" "Does not do foo" :: Parser (Option Bool)
--
-- This creates a 'Parser' that accepts both a @--foo@ and a @--no-foo@ flag.
-- Passing @--foo@ returns @'Set' 'True'@, while passing @--no-foo@ returns
-- @'Set' 'False'@.  Passing neither @--foo@ nor @--no-foo@ returns 'Unset'.
--
-- TODO: This doesn't quite work.  If the user passes both @--foo@ and
-- @--no-foo@ flags, this should ideally take the value of the last flag
-- passed.  However, it appears that if you pass both flags, the second
-- flag is just not recognized and optparse-applicative raises an error.
optionFlag
  :: a -- ^ Value when specified /without/ @no-@ prefix.
  -> a -- ^ Value when specified /with/ @no-@ prefix.
  -> Char -- ^ Short flag for /without/ @no-@ prefix.
  -> Char -- ^ Short flag for /with/ @no-@ prefix.
  -> String -- ^ Long flag.
  -> String -- ^ Help text for /without/ @no-@ prefix option.
  -> String -- ^ Help text for /with/ @no-@ prefix option.
  -> Parser (Option a)
optionFlag valNormal valNo shortNormal shortNo longFlag helpNormal helpNo =
  flagNormal <|> flagNo <|> pure Unset
  where
    flagNormal =
      flag' (Set valNormal) (short shortNormal <> long longFlag <> help helpNormal)
    flagNo =
      flag' (Set valNo) (short shortNo <> long ("no-" <> longFlag) <> help helpNo)

cliConfigOptionsParser :: Parser CliConfigOptions
cliConfigOptionsParser =
  CliConfigOptions
    <$> fontFamilyParser
    <*> fontSizeParser
    <*> showScrollbarParser
    <*> scrollbackLenParser
    <*> confirmExitParser
    <*> wordCharExceptionsParser
    <*> showMenuParser
    <*> showTabBarParser
    <*> cursorBlinkModeParser
    <*> boldIsBrightParser
    <*> enableSixelParser
    <*> allowBoldParser

fontFamilyParser :: Parser (Option Text)
fontFamilyParser =
  strOption'
    ( short 'f' <>
      long "font-family" <>
      metavar "FONT_FAMILY" <>
      help
        "Font family to use. Defaults to \"Monospace\". Examples: \
        \\"DejaVu Sans Mono\", \"Source Code Pro\""
    )

fontSizeParser :: Parser (Option FontSize)
fontSizeParser = f <$> pointsParser <*> unitsParser
  where
    f :: Option Int -> Option Double -> Option FontSize
    f optionPoints optionUnits =
      case (fmap FontSizePoints optionPoints, fmap FontSizeUnits optionUnits) of
        (Unset, units) -> units
        (points, _) -> points

    pointsParser :: Parser (Option Int)
    pointsParser =
      option'
        auto
        ( short 'p' <>
          long "font-size-points" <>
          metavar "POINTS" <>
          help
            "Font size in POINTS. Defaults to \"12\" if not specified. \
            \If you specify both --font-size-points and --font-size-units, \
            \--font-size-points will take priority.  --font-size-points \
            \should be similar to font sizes you may be \
            \familiar with from other applications."
        )

    unitsParser :: Parser (Option Double)
    unitsParser =
      option'
        auto
        ( short 'u' <>
          long "font-size-units" <>
          metavar "UNITS" <>
          help
            "Font size in device units/pixels. Example: \"20.5\", \
            \\"30\".  If not specified, the default from \
            \--font-size-points is used."
        )

showScrollbarParser :: Parser (Option ShowScrollbar)
showScrollbarParser =
  option'
    (maybeTextReader showScrollbarFromString)
    ( short 'l' <>
      long "show-scrollbar" <>
      metavar "SHOW_SCROLLBAR" <>
      help
        "Whether or not to show a scrollbar in the terminal. \
        \Defaults to \"if-needed\".  Possible values = \"never\": \
        \never show the scrollbar, \"always\": always show the \
        \scrollbar, \"if-needed\": only show the scrollbar if \
        \enough text on the screen"
    )

scrollbackLenParser :: Parser (Option Integer)
scrollbackLenParser =
  option'
    auto
    ( short 'b' <>
      long "scrollback-length" <>
      metavar "SCROLLBACK_LENGTH" <>
      help
        "Number of lines to keep in the scrollback buffer in the \
        \terminal.  Defaults to 10000 lines.  Examples: \"200\", \
        \\"3000\""
    )

confirmExitParser :: Parser (Option Bool)
confirmExitParser =
  optionFlag
    True
    False
    'x'
    'C'
    "confirm-exit"
    "Ask for confirmation when closing terminals or Termonad itself. \
    \Defaults to asking for confirmation if not specified."
    "Do not ask for confirmation when closing terminals or Termonad \
    \itself. Defaults to asking for confirmation if not specified."

wordCharExceptionsParser :: Parser (Option Text)
wordCharExceptionsParser =
  strOption'
    ( short 'w' <>
      long "word-char-exceptions" <>
      metavar "EXCEPTIONS" <>
      help
        "The characters in this list will be counted as part of a word \
        \when double-clicking to select text in the terminal. Defaults \
        \to \"-#%&+,./=?@\\_~:\""
    )

showMenuParser :: Parser (Option Bool)
showMenuParser =
  optionFlag
    True
    False
    'm'
    'u'
    "show-menu"
    "Show the menu bar.  Defaults to showing the menu bar when not \
    \specified."
    "Do not show the menu bar.  Defaults to showing the menu bar when \
    \not specified."

showTabBarParser :: Parser (Option ShowTabBar)
showTabBarParser =
  option'
    (maybeTextReader showTabBarFromString)
    ( short 'l' <>
      long "show-tab-bar" <>
      metavar "SHOW_TAB_BAR" <>
      help
        "Whether or not to show the tab bar in the terminal. \
        \Defaults to \"if-needed\".  Possible values = \"never\": \
        \never show the tab bar, \"always\": always show the \
        \tab bar, \"if-needed\": only show the tab bar if \
        \multiple tabs are open."
    )

cursorBlinkModeParser :: Parser (Option CursorBlinkMode)
cursorBlinkModeParser =
  option'
    (maybeTextReader cursorBlinkModeFromString)
    ( short 'n' <>
      long "cursor-blink" <>
      metavar "BLINK_MODE" <>
      help
        "How to handle cursor blink.  Defaults to \"on\". Possible \
        \values = \"system\": follow system settings, \"on\": cursor \
        \blinks, \"off\": no cursor blink."
    )

boldIsBrightParser :: Parser (Option Bool)
boldIsBrightParser =
  optionFlag
    True
    False
    'd'
    'r'
    "bold-is-bright"
    "Force bold text to use bright colors.  Defaults to not forcing \
    \bold text to use bright colors."
    "Do not force bold text to use bright colors.  Defaults to not forcing \
    \bold text to use bright colors."

enableSixelParser :: Parser (Option Bool)
enableSixelParser =
  optionFlag
    True
    False
    's'
    'i'
    "sixel"
    "Enable SIXEL support.  Note that you need to build Termonad with \
    \a VTE with SIXEL support for this to work.  Defaults to not \
    \enabling SIXEL."
    "Disable SIXEL support.  Defaults to disabling SIXEL support."

allowBoldParser :: Parser (Option Bool)
allowBoldParser =
  optionFlag
    True
    False
    'a'
    'o'
    "allow-bold"
    "Allow Termonad to show bold text.  Defaults to enabled."
    "Disable Termonad from showing text as bold.  Defaults to \
    \allow showing text as bold."

extraCliArgsParser :: Parser ExtraCliArgs
extraCliArgsParser = pure ExtraCliArgs

cliArgsParser :: Parser CliArgs
cliArgsParser =
  CliArgs <$> cliConfigOptionsParser <*> extraCliArgsParser

cliArgsParserInfo :: ParserInfo CliArgs
cliArgsParserInfo =
  info
    (cliArgsParser <**> helper)
    ( fullDesc <>
      progDesc "A VTE-based terminal emulator configurable in Haskell"
    )

-- | Parse and return CliArguments.
parseCliArgs :: IO CliArgs
parseCliArgs = execParser cliArgsParserInfo

-- | Overwrite the arguments in 'ConfigOptions' that have been 'Set' in
-- 'CliArgs'.
--
-- >>> import Termonad.Types (defaultConfigOptions)
-- >>> let cliConfOpts = defaultCliConfigOptions { cliConfScrollbackLen = Set 50 }
-- >>> let cliArgs = defaultCliArgs { cliConfigOptions = cliConfOpts }
-- >>> let overwrittenConfOpts = defaultConfigOptions { scrollbackLen = 50 }
-- >>> applyCliArgs cliArgs defaultConfigOptions == overwrittenConfOpts
-- True
applyCliArgs :: CliArgs -> ConfigOptions -> ConfigOptions
applyCliArgs cliArgs confOpts =
  let oldFontConf = fontConfig confOpts
      newFontConfig =
        oldFontConf
          { fontFamily =
              fromOption
                (fontFamily oldFontConf)
                (cliConfFontFamily cliConfOpts)
          , fontSize =
              fromOption
                (fontSize oldFontConf)
                (cliConfFontSize cliConfOpts)
          }
  in
  confOpts
    { fontConfig = newFontConfig
    , showScrollbar = fromOpt showScrollbar cliConfShowScrollbar
    , scrollbackLen = fromOpt scrollbackLen cliConfScrollbackLen
    , confirmExit = fromOpt confirmExit cliConfConfirmExit
    , wordCharExceptions = fromOpt wordCharExceptions cliConfWordCharExceptions
    , showMenu = fromOpt showMenu cliConfShowMenu
    , showTabBar = fromOpt showTabBar cliConfShowTabBar
    , cursorBlinkMode = fromOpt cursorBlinkMode cliConfCursorBlinkMode
    , boldIsBright = fromOpt boldIsBright cliConfBoldIsBright
    , enableSixel = fromOpt enableSixel cliConfEnableSixel
    , allowBold = fromOpt allowBold cliConfAllowBold
    }
  where
    fromOpt
      :: forall a. (ConfigOptions -> a) -> (CliConfigOptions -> Option a) -> a
    fromOpt getConfVal getCliVal =
      fromOption
        (getConfVal confOpts)
        (getCliVal cliConfOpts)

    fromOption :: forall b. b -> Option b -> b
    fromOption defVal = \case
      Set a -> a
      Unset -> defVal

    cliConfOpts :: CliConfigOptions
    cliConfOpts = cliConfigOptions cliArgs