content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE TypeOperators #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FlexibleContexts #-}
  -- | Vty supports a configuration file format and provides a
  -- corresponding 'VtyUserConfig' data type. The 'VtyUserConfig' can be
  -- provided to platform packages' @mkVty@ functions to customize the
  -- application's use of Vty.
  --
  -- = Debug
  --
  -- == @colorMode@
  --
  -- Format:
  --
  -- @
  --  colorMode \"<ColorMode8|ColorMode16|ColorMode240 <int>|FullColor>\"
  -- @
  --
  -- The preferred color mode to use, chosen from the constructors of the
  -- 'ColorMode' type. If absent, the backend driver may detect and choose
  -- an appropriate color mode. Implementor's note: backend packages
  -- should respect this setting when it is present even when their
  -- detection indicates that a different color mode should be used.
  --
  -- == @debugLog@
  --
  -- Format:
  --
  -- @
  --  \"debugLog\" string
  -- @
  --
  -- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent
  -- to a debugLog entry at the end of the last config file.
  --
  -- = Input Processing
  --
  -- == @map@
  --
  -- Format:
  --
  -- @
  --  \"map\" term string key modifier_list
  --  where
  --      key := KEsc | KChar Char | KBS ... (same as 'Key')
  --      modifier_list := \"[\" modifier+ \"]\"
  --      modifier := MShift | MCtrl | MMeta | MAlt
  --      term := "_" | string
  -- @
  --
  -- E.g., if the contents are
  --
  -- @
  --  map _       \"\\ESC[B\"    KUp   []
  --  map _       \"\\ESC[1;3B\" KDown [MAlt]
  --  map \"xterm\" \"\\ESC[D\"    KLeft []
  -- @
  --
  -- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all
  -- terminals. The bytes @\"\\ESC[1;3B\"@ will result in the event KDown
  -- with the MAlt modifier on all terminals. The bytes @\"\\ESC[D\"@ will
  -- result in the KLeft event when @TERM@ is @xterm@.
  --
  -- If a debug log is requested then vty will output the current input
  -- table to the log in the above format. A workflow for using this is
  -- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for
  -- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@.
  --
  -- = Unicode Character Width Maps
  --
  -- == @widthMap@
  --
  -- Format:
  --
  -- @
  --  \"widthMap\" string string
  -- @
  --
  -- E.g.,
  --
  -- @
  --   widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\"
  -- @
  --
  -- This directive specifies the path to a Unicode character
  -- width map (the second argument) that should correspond to
  -- the terminal named by first argument. Unicode character
  -- width maps can be produced either by running platform
  -- packages' width table tools or by calling the library routine
  -- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable'. Vty
  -- platform packages should use these configuration settings to attempt
  -- to load and install the specified width map.
  module Graphics.Vty.Config
    ( InputMap
    , VtyUserConfig(..)
    , userConfig
    , overrideEnvConfig
    , currentTerminalName
    , runParseConfig
    , parseConfigFile
    , defaultConfig
  
    , vtyConfigPath
    , widthTableFilename
    , vtyDataDirectory
    , terminalWidthTablePath
    , vtyConfigFileEnvName
  
    , ConfigUpdateResult(..)
    , addConfigWidthMap
    )
  where
  
  import Prelude
  
  import Control.Applicative hiding (many)
  
  import Control.Exception (catch, IOException)
  import Control.Monad (liftM, guard, void)
  
  import qualified Data.ByteString as BS
  #if !(MIN_VERSION_base(4,8,0))
  import Data.Monoid (Monoid(..))
  #endif
  #if !(MIN_VERSION_base(4,11,0))
  import Data.Semigroup (Semigroup(..))
  #endif
  import Text.Read (readMaybe)
  
  import Graphics.Vty.Attributes.Color (ColorMode(..))
  import Graphics.Vty.Input.Events
  
  import GHC.Generics
  
  import System.Directory ( getAppUserDataDirectory, doesFileExist
                          , createDirectoryIfMissing
                          )
  import System.Environment (lookupEnv)
  import System.FilePath ((</>), takeDirectory)
  
  import Text.Parsec hiding ((<|>))
  import Text.Parsec.Token ( GenLanguageDef(..) )
  import qualified Text.Parsec.Token as P
  
  -- | Mappings from input bytes to event in the order specified. Later
  -- entries take precedence over earlier in the case multiple entries
  -- have the same byte string.
  type InputMap = [(Maybe String, String, Event)]
  
  -- | A Vty core library configuration. Platform-specific details are not
  -- included in the VtyUserConfig.
  data VtyUserConfig =
      VtyUserConfig { configDebugLog :: Maybe FilePath
                    -- ^ Debug information is appended to this file if not
                    -- Nothing.
                    , configInputMap :: InputMap
                    -- ^ The (input byte, output event) pairs extend the internal
                    -- input table of VTY and the table from terminfo.
                    --
                    -- See "Graphics.Vty.Config" module documentation for
                    -- documentation of the @map@ directive.
                    , configTermWidthMaps :: [(String, FilePath)]
                    -- ^ Terminal width map files.
                    , configAllowCustomUnicodeWidthTables :: Maybe Bool
                    -- ^ Whether to permit custom Unicode width table loading by
                    -- 'Graphics.Vty.mkVty'. @'Just' 'False'@ indicates that
                    -- table loading should not be performed. Other values permit
                    -- table loading.
                    --
                    -- If a table load is attempted and fails, information
                    -- about the failure will be logged to the debug log if the
                    -- configuration specifies one. If no custom table is loaded
                    -- (or if a load fails), the built-in character width table
                    -- will be used.
                    , configPreferredColorMode :: Maybe ColorMode
                    -- ^ Preferred color mode. If set, this should
                    -- override platform color mode detection.
                    }
                    deriving (Show, Eq)
  
  defaultConfig :: VtyUserConfig
  defaultConfig = mempty
  
  instance Semigroup VtyUserConfig where
      c0 <> c1 =
          -- latter config takes priority for everything but inputMap
          VtyUserConfig { configDebugLog =
                            configDebugLog c1 <|> configDebugLog c0
                        , configInputMap =
                            configInputMap c0 <> configInputMap c1
                        , configTermWidthMaps =
                            configTermWidthMaps c1 <|> configTermWidthMaps c0
                        , configAllowCustomUnicodeWidthTables =
                            configAllowCustomUnicodeWidthTables c1 <|> configAllowCustomUnicodeWidthTables c0
                        , configPreferredColorMode =
                            configPreferredColorMode c1 <|> configPreferredColorMode c0
                        }
  
  instance Monoid VtyUserConfig where
      mempty =
          VtyUserConfig { configDebugLog = mempty
                        , configInputMap = mempty
                        , configTermWidthMaps = []
                        , configAllowCustomUnicodeWidthTables = Nothing
                        , configPreferredColorMode = Nothing
                        }
  #if !(MIN_VERSION_base(4,11,0))
      mappend = (<>)
  #endif
  
  vtyDataDirectory :: IO FilePath
  vtyDataDirectory = getAppUserDataDirectory "vty"
  
  vtyConfigPath :: IO FilePath
  vtyConfigPath = do
      dir <- vtyDataDirectory
      return $ dir </> "config"
  
  vtyConfigFileEnvName :: String
  vtyConfigFileEnvName = "VTY_CONFIG_FILE"
  
  -- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.
  -- If none is found, build a default configuration.
  userConfig :: IO VtyUserConfig
  userConfig = do
      configFile <- vtyConfigPath >>= parseConfigFile
      overrideConfig <- maybe (return defaultConfig) parseConfigFile =<<
          lookupEnv vtyConfigFileEnvName
      let base = configFile <> overrideConfig
      mappend base <$> overrideEnvConfig
  
  widthTableFilename :: String -> String
  widthTableFilename term = "width_table_" <> term <> ".dat"
  
  termVariable :: String
  termVariable = "TERM"
  
  currentTerminalName :: IO (Maybe String)
  currentTerminalName = lookupEnv termVariable
  
  terminalWidthTablePath :: IO (Maybe FilePath)
  terminalWidthTablePath = do
      dataDir <- vtyDataDirectory
      result <- lookupEnv termVariable
      case result of
          Nothing -> return Nothing
          Just term -> do
              return $ Just $ dataDir </> widthTableFilename term
  
  overrideEnvConfig :: IO VtyUserConfig
  overrideEnvConfig = do
      d <- lookupEnv "VTY_DEBUG_LOG"
      return $ defaultConfig { configDebugLog = d }
  
  -- | Parse a Vty configuration file.
  --
  -- Lines in config files that fail to parse are ignored. Later entries
  -- take precedence over earlier ones.
  parseConfigFile :: FilePath -> IO VtyUserConfig
  parseConfigFile path = do
      catch (runParseConfig path <$> BS.readFile path)
            (\(_ :: IOException) -> return defaultConfig)
  
  runParseConfig :: String -> BS.ByteString -> VtyUserConfig
  runParseConfig name cfgTxt =
    case runParser parseConfig () name cfgTxt of
      Right cfg -> cfg
      Left{}    -> defaultConfig
  
  ------------------------------------------------------------------------
  
  type Parser = Parsec BS.ByteString ()
  
  configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
  configLanguage = LanguageDef
      { commentStart    = "{-"
      , commentEnd      = "-}"
      , commentLine     = "--"
      , nestedComments  = True
      , identStart      = letter <|> char '_'
      , identLetter     = alphaNum <|> oneOf "_'"
      , opStart         = opLetter configLanguage
      , opLetter        = oneOf ":!#$%&*+./<=>?@\\^|-~"
      , reservedOpNames = []
      , reservedNames   = []
      , caseSensitive   = True
      }
  
  configLexer :: Monad m => P.GenTokenParser BS.ByteString () m
  configLexer = P.makeTokenParser configLanguage
  
  mapDecl :: Parser VtyUserConfig
  mapDecl = do
      "map" <- P.identifier configLexer
      termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing)
               <|> (Just <$> P.stringLiteral configLexer)
      bytes     <- P.stringLiteral configLexer
      key       <- parseValue
      modifiers <- parseValue
      return defaultConfig { configInputMap = [(termIdent, bytes, EvKey key modifiers)] }
  
  debugLogDecl :: Parser VtyUserConfig
  debugLogDecl = do
      "debugLog" <- P.identifier configLexer
      path       <- P.stringLiteral configLexer
      return defaultConfig { configDebugLog = Just path }
  
  colorModeDecl :: Parser VtyUserConfig
  colorModeDecl = do
      "colorMode" <- P.identifier configLexer
      mode <- P.stringLiteral configLexer
      return defaultConfig { configPreferredColorMode = readMaybe mode }
  
  widthMapDecl :: Parser VtyUserConfig
  widthMapDecl = do
      "widthMap" <- P.identifier configLexer
      tName <- P.stringLiteral configLexer
      path <- P.stringLiteral configLexer
      return defaultConfig { configTermWidthMaps = [(tName, path)] }
  
  ignoreLine :: Parser ()
  ignoreLine = void $ manyTill anyChar newline
  
  parseConfig :: Parser VtyUserConfig
  parseConfig = liftM mconcat $ many $ do
      P.whiteSpace configLexer
      let directives = [try mapDecl, try debugLogDecl, try widthMapDecl, try colorModeDecl]
      choice directives <|> (ignoreLine >> return defaultConfig)
  
  class    Parse a        where parseValue :: Parser a
  instance Parse Char     where parseValue = P.charLiteral configLexer
  instance Parse Int      where parseValue = fromInteger <$> P.natural configLexer
  instance Parse Key      where parseValue = genericParse
  instance Parse Modifier where parseValue = genericParse
  instance Parse a => Parse [a] where
    parseValue = P.brackets configLexer
                   (parseValue `sepBy` P.symbol configLexer ",")
  
  ------------------------------------------------------------------------
  -- Derived parser for ADTs via generics
  ------------------------------------------------------------------------
  
  genericParse :: (Generic a, GParse (Rep a)) => Parser a
  genericParse = to <$> gparse
  
  class    GParse f                      where gparse :: Parser (f a)
  instance GParse f => GParse (M1 S i f) where gparse = M1 <$> gparse
  instance GParse U1                     where gparse = return U1
  instance Parse a => GParse (K1 i a)    where gparse = K1 <$> parseValue
  
  instance (GParse f, GParse g) => GParse (f :*: g) where
    gparse = (:*:) <$> gparse <*> gparse
  
  instance GParseAlts f => GParse (M1 D i f) where
    gparse =
      do con <- P.identifier configLexer
         M1 <$> gparseAlts con
  
  ------------------------------------------------------------------------
  
  class GParseAlts f where
    gparseAlts :: String -> Parser (f a)
  
  instance (Constructor i, GParse f) => GParseAlts (M1 C i f) where
    gparseAlts con =
      do guard (con == conName (M1 Nothing :: C1 i Maybe a))
         M1 <$> gparse
  
  instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where
    gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
  
  instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"
  
  -- | The result of a configuration change attempt made by
  -- 'addConfigWidthMap'.
  data ConfigUpdateResult =
      ConfigurationCreated
      -- ^ A new configuration file file was written with the new width
      -- table entry.
      | ConfigurationModified
      -- ^ An existing configuration file was modified with the new width
      -- table entry.
      | ConfigurationConflict String
      -- ^ The attempted width table entry could not be written to the
      -- configuration due to a conflict; the argument here is the width
      -- table file path for the conflicting entry.
      | ConfigurationRedundant
      -- ^ No change was made because the existing configuration already
      -- contains the specified mapping.
      deriving (Eq, Show)
  
  -- | Add a @widthMap@ directive to the Vty configuration file at the
  -- specified path.
  --
  -- If the configuration path refers to a configuration that already
  -- contains the directive for the specified map and terminal type, the
  -- configuration file will not be modified. If the file does not contain
  -- the directive, it will be appended to the file.
  --
  -- If the configuration path does not exist, a new configuration file
  -- will be created and any directories in the path will also be created.
  --
  -- This returns a 'ConfigUpdateResult' indicating the change to the
  -- configuration. This does not handle exceptions raised by file or
  -- directory permissions issues.
  addConfigWidthMap :: FilePath
                    -- ^ The configuration file path of the configuration
                    -- to modify or create.
                    -> String
                    -- ^ The @TERM@ value for the @widthMap@ directive.
                    -> FilePath
                    -- ^ The width table file path for the directive.
                    -> IO ConfigUpdateResult
  addConfigWidthMap configPath term tablePath = do
      configEx <- doesFileExist configPath
      if configEx
         then updateConfig
         else createConfig >> return ConfigurationCreated
  
      where
          directive = "widthMap " <> show term <> " " <> show tablePath <> "\n"
  
          createConfig = do
              let dir = takeDirectory configPath
              createDirectoryIfMissing True dir
              writeFile configPath directive
  
          updateConfig = do
              config <- parseConfigFile configPath
              if (term, tablePath) `elem` configTermWidthMaps config
                 then return ConfigurationRedundant
                 else case lookup term (configTermWidthMaps config) of
                     Just other -> return $ ConfigurationConflict other
                     Nothing -> do
                         appendFile configPath directive
                         return ConfigurationModified
  