UIOptionsParse.hs

-- | UI client options.
module Game.LambdaHack.Client.UI.UIOptionsParse
  ( mkUIOptions, applyUIOptions
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , configError, readError, parseConfig
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.DeepSeq
import qualified Data.Ini as Ini
import qualified Data.Ini.Reader as Ini
import qualified Data.Ini.Types as Ini
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import           Data.Version
import           System.FilePath
import           Text.ParserCombinators.ReadP (readP_to_S)
import           Text.Read

import           Game.LambdaHack.Client.UI.HumanCmd
import qualified Game.LambdaHack.Client.UI.Key as K
import           Game.LambdaHack.Client.UI.UIOptions
import           Game.LambdaHack.Common.ClientOptions
import           Game.LambdaHack.Common.File
import           Game.LambdaHack.Common.Kind
import           Game.LambdaHack.Common.Misc
import           Game.LambdaHack.Common.Save (compatibleVersion, delayPrint)
import qualified Game.LambdaHack.Common.Save as Save
import           Game.LambdaHack.Content.RuleKind

configError :: String -> a
configError err = error $ "Error when parsing configuration file. Please fix config.ui.ini or remove it altogether. The details:\n" ++ err

readError :: Read a => String -> a
readError s = either (configError . ("when reading:\n" ++ s `showFailure`)) id
              $ readEither s

parseConfig :: Ini.Config -> UIOptions
parseConfig cfg =
  let uCommands =
        let mkCommand (ident, keydef) =
              case stripPrefix "Cmd_" ident of
                Just _ ->
                  let (key, def) = readError keydef
                  in (K.mkKM key, def :: CmdTriple)
                Nothing ->
                  configError
                    $ "macro id should start with Cmd_ and it does not:"
                      `showFailure` ident
            section = Ini.allItems "additional_commands" cfg
        in map mkCommand section
      uHeroNames =
        let toNumber (ident, nameAndPronoun) =
              case stripPrefix "HeroName_" ident of
                Just n -> (readError n, readError nameAndPronoun)
                Nothing -> configError
                           $ "wrong hero name id" `showFailure` ident
            section = Ini.allItems "hero_names" cfg
        in map toNumber section
      lookupFail :: forall b. String -> String -> b
      lookupFail optionName err =
        configError $ "config file access failed"
                      `showFailure` (err, optionName, cfg)
      _getOptionMaybe :: forall a. Read a => String -> Maybe a
      _getOptionMaybe optionName =
        let ms = Ini.getOption "ui" optionName cfg
        in either (lookupFail optionName) id . readEither <$> ms
      getOption :: forall a. Read a => String -> a
      getOption optionName =
        let s = fromMaybe (lookupFail optionName "")
                $ Ini.getOption "ui" optionName cfg
        in either (lookupFail optionName) id $ readEither s
      uVi = getOption "movementViKeys_hjklyubn"
      uLeftHand = getOption "movementLeftHandKeys_axwdqezc"
      uChosenFontset = getOption "chosenFontset"
      uAllFontsScale = getOption "allFontsScale"
      uFullscreenMode = getOption "fullscreenMode"
      uhpWarningPercent = getOption "hpWarningPercent"
      uMsgWrapColumn = getOption "msgWrapColumn"
      uHistoryMax = getOption "historyMax"
      uMaxFps = max 1 $ getOption "maxFps"
      uNoAnim = getOption "noAnim"
      uOverrideCmdline = glueSeed $ words $ getOption "overrideCmdline"
      uFonts =
        let toFont (ident, fontString) = (T.pack ident, readError fontString)
            section = Ini.allItems "fonts" cfg
        in map toFont section
      uFontsets =
        let toFontSet (ident, fontSetString) =
              (T.pack ident, readError fontSetString)
            section = Ini.allItems "fontsets" cfg
        in map toFontSet section
      uMessageColors =
        map (second readError) $ Ini.allItems "message_colors" cfg
  in UIOptions{..}

glueSeed :: [String] -> [String]
glueSeed [] = []
glueSeed ("SMGen" : s1 : s2 : rest) =
  ("SMGen" ++ " " ++ s1 ++ " " ++ s2) : glueSeed rest
glueSeed (s : rest) = s : glueSeed rest

-- | Read and parse UI config file.
mkUIOptions :: RuleContent -> ClientOptions -> IO UIOptions
mkUIOptions corule clientOptions = do
  let benchmark = sbenchmark clientOptions
      cfgUIName = rcfgUIName corule
      (configText, cfgUIDefault) = rcfgUIDefault corule
  dataDir <- appDataDir
  let path bkp = dataDir </> bkp <> cfgUIName
  cfgUser <- if benchmark then return Ini.emptyConfig else do
    cpExists <- doesFileExist (path "")
    if not cpExists
      then return Ini.emptyConfig
      else do
        sUser <- readFile (path "")
        return $! either (configError . ("Ini.parse sUser" `showFailure`)) id
                  $ Ini.parse sUser
  let cfgUI = M.unionWith M.union cfgUser cfgUIDefault  -- user cfg preferred
      vExe1 = rexeVersion corule
      vExe2 =
        let optionName = "version"
            -- Lenient to parse, and reject, old config files:
            s = fromMaybe "" $ Ini.getOption "version" optionName cfgUser
            dummyVersion = makeVersion []
        in case find ((== "") . snd) $ readP_to_S parseVersion s of
          Just (ver, "") -> ver
          _ -> dummyVersion
  if benchmark || compatibleVersion vExe1 vExe2 then do
    let conf = parseConfig cfgUI
    -- Catch syntax errors in complex expressions ASAP.
    return $! deepseq conf conf
  else do
    cpExists <- doesFileExist (path "")
    when cpExists $ do
      renameFile (path "") (path "bkp.")
      moveAside <- Save.bkpAllSaves corule clientOptions
      let msg = "Config file" <+> T.pack (path "")
                <+> "from an incompatible version '"
                <> T.pack (showVersion vExe2)
                <> "' detected while starting"
                <+> T.pack (showVersion vExe1)
                <+> "game."
                <+> if moveAside
                    then "The config file and savefiles have been moved aside."
                    else "The config file has been moved aside."
      delayPrint msg
    dataDirExists <- doesFileExist dataDir
    when dataDirExists $  -- may not exist, e.g., when testing
      tryWriteFile (path "") configText
    let confDefault = parseConfig cfgUIDefault
    return confDefault

-- | Modify client options with UI options.
applyUIOptions :: COps -> UIOptions -> ClientOptions -> ClientOptions
applyUIOptions COps{corule} uioptions =
     (\opts -> opts {schosenFontset =
        schosenFontset opts `mplus` Just (uChosenFontset uioptions)}) .
     (\opts -> opts {sallFontsScale =
        sallFontsScale opts `mplus` Just (uAllFontsScale uioptions)}) .
     (\opts -> opts {sfullscreenMode =
        sfullscreenMode opts `mplus` Just (uFullscreenMode uioptions)}) .
     (\opts -> opts {smaxFps =
        smaxFps opts `mplus` Just (uMaxFps uioptions)}) .
     (\opts -> opts {snoAnim =
        snoAnim opts `mplus` Just (uNoAnim uioptions)}) .
     (\opts -> opts {stitle =
        stitle opts `mplus` Just (rtitle corule)}) .
     (\opts -> opts {sfonts = uFonts uioptions}) .
     (\opts -> opts {sfontsets = uFontsets uioptions})