{-# 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 { VtyUserConfig -> Maybe FilePath
configDebugLog :: Maybe FilePath
                  -- ^ Debug information is appended to this file if not
                  -- Nothing.
                  , VtyUserConfig -> InputMap
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.
                  , VtyUserConfig -> [(FilePath, FilePath)]
configTermWidthMaps :: [(String, FilePath)]
                  -- ^ Terminal width map files.
                  , VtyUserConfig -> Maybe Bool
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.
                  , VtyUserConfig -> Maybe ColorMode
configPreferredColorMode :: Maybe ColorMode
                  -- ^ Preferred color mode. If set, this should
                  -- override platform color mode detection.
                  }
                  deriving (Int -> VtyUserConfig -> ShowS
[VtyUserConfig] -> ShowS
VtyUserConfig -> FilePath
(Int -> VtyUserConfig -> ShowS)
-> (VtyUserConfig -> FilePath)
-> ([VtyUserConfig] -> ShowS)
-> Show VtyUserConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [VtyUserConfig] -> ShowS
$cshowList :: [VtyUserConfig] -> ShowS
show :: VtyUserConfig -> FilePath
$cshow :: VtyUserConfig -> FilePath
showsPrec :: Int -> VtyUserConfig -> ShowS
$cshowsPrec :: Int -> VtyUserConfig -> ShowS
Show, VtyUserConfig -> VtyUserConfig -> Bool
(VtyUserConfig -> VtyUserConfig -> Bool)
-> (VtyUserConfig -> VtyUserConfig -> Bool) -> Eq VtyUserConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VtyUserConfig -> VtyUserConfig -> Bool
$c/= :: VtyUserConfig -> VtyUserConfig -> Bool
== :: VtyUserConfig -> VtyUserConfig -> Bool
$c== :: VtyUserConfig -> VtyUserConfig -> Bool
Eq)

defaultConfig :: VtyUserConfig
defaultConfig :: VtyUserConfig
defaultConfig = VtyUserConfig
forall a. Monoid a => a
mempty

instance Semigroup VtyUserConfig where
    VtyUserConfig
c0 <> :: VtyUserConfig -> VtyUserConfig -> VtyUserConfig
<> VtyUserConfig
c1 =
        -- latter config takes priority for everything but inputMap
        VtyUserConfig :: Maybe FilePath
-> InputMap
-> [(FilePath, FilePath)]
-> Maybe Bool
-> Maybe ColorMode
-> VtyUserConfig
VtyUserConfig { configDebugLog :: Maybe FilePath
configDebugLog =
                          VtyUserConfig -> Maybe FilePath
configDebugLog VtyUserConfig
c1 Maybe FilePath -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> VtyUserConfig -> Maybe FilePath
configDebugLog VtyUserConfig
c0
                      , configInputMap :: InputMap
configInputMap =
                          VtyUserConfig -> InputMap
configInputMap VtyUserConfig
c0 InputMap -> InputMap -> InputMap
forall a. Semigroup a => a -> a -> a
<> VtyUserConfig -> InputMap
configInputMap VtyUserConfig
c1
                      , configTermWidthMaps :: [(FilePath, FilePath)]
configTermWidthMaps =
                          VtyUserConfig -> [(FilePath, FilePath)]
configTermWidthMaps VtyUserConfig
c1 [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> VtyUserConfig -> [(FilePath, FilePath)]
configTermWidthMaps VtyUserConfig
c0
                      , configAllowCustomUnicodeWidthTables :: Maybe Bool
configAllowCustomUnicodeWidthTables =
                          VtyUserConfig -> Maybe Bool
configAllowCustomUnicodeWidthTables VtyUserConfig
c1 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> VtyUserConfig -> Maybe Bool
configAllowCustomUnicodeWidthTables VtyUserConfig
c0
                      , configPreferredColorMode :: Maybe ColorMode
configPreferredColorMode =
                          VtyUserConfig -> Maybe ColorMode
configPreferredColorMode VtyUserConfig
c1 Maybe ColorMode -> Maybe ColorMode -> Maybe ColorMode
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> VtyUserConfig -> Maybe ColorMode
configPreferredColorMode VtyUserConfig
c0
                      }

instance Monoid VtyUserConfig where
    mempty :: VtyUserConfig
mempty =
        VtyUserConfig :: Maybe FilePath
-> InputMap
-> [(FilePath, FilePath)]
-> Maybe Bool
-> Maybe ColorMode
-> VtyUserConfig
VtyUserConfig { configDebugLog :: Maybe FilePath
configDebugLog = Maybe FilePath
forall a. Monoid a => a
mempty
                      , configInputMap :: InputMap
configInputMap = InputMap
forall a. Monoid a => a
mempty
                      , configTermWidthMaps :: [(FilePath, FilePath)]
configTermWidthMaps = []
                      , configAllowCustomUnicodeWidthTables :: Maybe Bool
configAllowCustomUnicodeWidthTables = Maybe Bool
forall a. Maybe a
Nothing
                      , configPreferredColorMode :: Maybe ColorMode
configPreferredColorMode = Maybe ColorMode
forall a. Maybe a
Nothing
                      }
#if !(MIN_VERSION_base(4,11,0))
    mappend = (<>)
#endif

vtyDataDirectory :: IO FilePath
vtyDataDirectory :: IO FilePath
vtyDataDirectory = FilePath -> IO FilePath
getAppUserDataDirectory FilePath
"vty"

vtyConfigPath :: IO FilePath
vtyConfigPath :: IO FilePath
vtyConfigPath = do
    FilePath
dir <- IO FilePath
vtyDataDirectory
    FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> ShowS
</> FilePath
"config"

vtyConfigFileEnvName :: String
vtyConfigFileEnvName :: FilePath
vtyConfigFileEnvName = FilePath
"VTY_CONFIG_FILE"

-- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@.
-- If none is found, build a default configuration.
userConfig :: IO VtyUserConfig
userConfig :: IO VtyUserConfig
userConfig = do
    VtyUserConfig
configFile <- IO FilePath
vtyConfigPath IO FilePath -> (FilePath -> IO VtyUserConfig) -> IO VtyUserConfig
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO VtyUserConfig
parseConfigFile
    VtyUserConfig
overrideConfig <- IO VtyUserConfig
-> (FilePath -> IO VtyUserConfig)
-> Maybe FilePath
-> IO VtyUserConfig
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (VtyUserConfig -> IO VtyUserConfig
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig) FilePath -> IO VtyUserConfig
parseConfigFile (Maybe FilePath -> IO VtyUserConfig)
-> IO (Maybe FilePath) -> IO VtyUserConfig
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
vtyConfigFileEnvName
    let base :: VtyUserConfig
base = VtyUserConfig
configFile VtyUserConfig -> VtyUserConfig -> VtyUserConfig
forall a. Semigroup a => a -> a -> a
<> VtyUserConfig
overrideConfig
    VtyUserConfig -> VtyUserConfig -> VtyUserConfig
forall a. Monoid a => a -> a -> a
mappend VtyUserConfig
base (VtyUserConfig -> VtyUserConfig)
-> IO VtyUserConfig -> IO VtyUserConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO VtyUserConfig
overrideEnvConfig

widthTableFilename :: String -> String
widthTableFilename :: ShowS
widthTableFilename FilePath
term = FilePath
"width_table_" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
term FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
".dat"

termVariable :: String
termVariable :: FilePath
termVariable = FilePath
"TERM"

currentTerminalName :: IO (Maybe String)
currentTerminalName :: IO (Maybe FilePath)
currentTerminalName = FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
termVariable

terminalWidthTablePath :: IO (Maybe FilePath)
terminalWidthTablePath :: IO (Maybe FilePath)
terminalWidthTablePath = do
    FilePath
dataDir <- IO FilePath
vtyDataDirectory
    Maybe FilePath
result <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
termVariable
    case Maybe FilePath
result of
        Maybe FilePath
Nothing -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
        Just FilePath
term -> do
            Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dataDir FilePath -> ShowS
</> ShowS
widthTableFilename FilePath
term

overrideEnvConfig :: IO VtyUserConfig
overrideEnvConfig :: IO VtyUserConfig
overrideEnvConfig = do
    Maybe FilePath
d <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"VTY_DEBUG_LOG"
    VtyUserConfig -> IO VtyUserConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (VtyUserConfig -> IO VtyUserConfig)
-> VtyUserConfig -> IO VtyUserConfig
forall a b. (a -> b) -> a -> b
$ VtyUserConfig
defaultConfig { configDebugLog :: Maybe FilePath
configDebugLog = Maybe FilePath
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 :: FilePath -> IO VtyUserConfig
parseConfigFile FilePath
path = do
    IO VtyUserConfig
-> (IOException -> IO VtyUserConfig) -> IO VtyUserConfig
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (FilePath -> ByteString -> VtyUserConfig
runParseConfig FilePath
path (ByteString -> VtyUserConfig) -> IO ByteString -> IO VtyUserConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BS.readFile FilePath
path)
          (\(IOException
_ :: IOException) -> VtyUserConfig -> IO VtyUserConfig
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig)

runParseConfig :: String -> BS.ByteString -> VtyUserConfig
runParseConfig :: FilePath -> ByteString -> VtyUserConfig
runParseConfig FilePath
name ByteString
cfgTxt =
  case Parsec ByteString () VtyUserConfig
-> () -> FilePath -> ByteString -> Either ParseError VtyUserConfig
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> FilePath -> s -> Either ParseError a
runParser Parsec ByteString () VtyUserConfig
parseConfig () FilePath
name ByteString
cfgTxt of
    Right VtyUserConfig
cfg -> VtyUserConfig
cfg
    Left{}    -> VtyUserConfig
defaultConfig

------------------------------------------------------------------------

type Parser = Parsec BS.ByteString ()

configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
configLanguage :: GenLanguageDef ByteString () m
configLanguage = LanguageDef :: forall s u (m :: * -> *).
FilePath
-> FilePath
-> FilePath
-> Bool
-> ParsecT s u m Char
-> ParsecT s u m Char
-> ParsecT s u m Char
-> ParsecT s u m Char
-> [FilePath]
-> [FilePath]
-> Bool
-> GenLanguageDef s u m
LanguageDef
    { commentStart :: FilePath
commentStart    = FilePath
"{-"
    , commentEnd :: FilePath
commentEnd      = FilePath
"-}"
    , commentLine :: FilePath
commentLine     = FilePath
"--"
    , nestedComments :: Bool
nestedComments  = Bool
True
    , identStart :: ParsecT ByteString () m Char
identStart      = ParsecT ByteString () m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter ParsecT ByteString () m Char
-> ParsecT ByteString () m Char -> ParsecT ByteString () m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT ByteString () m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'_'
    , identLetter :: ParsecT ByteString () m Char
identLetter     = ParsecT ByteString () m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT ByteString () m Char
-> ParsecT ByteString () m Char -> ParsecT ByteString () m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePath -> ParsecT ByteString () m Char
forall s (m :: * -> *) u.
Stream s m Char =>
FilePath -> ParsecT s u m Char
oneOf FilePath
"_'"
    , opStart :: ParsecT ByteString () m Char
opStart         = GenLanguageDef ByteString () m -> ParsecT ByteString () m Char
forall s u (m :: * -> *).
GenLanguageDef s u m -> ParsecT s u m Char
opLetter GenLanguageDef ByteString () m
forall (m :: * -> *). Monad m => GenLanguageDef ByteString () m
configLanguage
    , opLetter :: ParsecT ByteString () m Char
opLetter        = FilePath -> ParsecT ByteString () m Char
forall s (m :: * -> *) u.
Stream s m Char =>
FilePath -> ParsecT s u m Char
oneOf FilePath
":!#$%&*+./<=>?@\\^|-~"
    , reservedOpNames :: [FilePath]
reservedOpNames = []
    , reservedNames :: [FilePath]
reservedNames   = []
    , caseSensitive :: Bool
caseSensitive   = Bool
True
    }

configLexer :: Monad m => P.GenTokenParser BS.ByteString () m
configLexer :: GenTokenParser ByteString () m
configLexer = GenLanguageDef ByteString () m -> GenTokenParser ByteString () m
forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
P.makeTokenParser GenLanguageDef ByteString () m
forall (m :: * -> *). Monad m => GenLanguageDef ByteString () m
configLanguage

mapDecl :: Parser VtyUserConfig
mapDecl :: Parsec ByteString () VtyUserConfig
mapDecl = do
    FilePath
"map" <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m FilePath
P.identifier GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
    Maybe FilePath
termIdent <- (Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'_' ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity ()
-> ParsecT ByteString () Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity ()
forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
P.whiteSpace GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer ParsecT ByteString () Identity ()
-> ParsecT ByteString () Identity (Maybe FilePath)
-> ParsecT ByteString () Identity (Maybe FilePath)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe FilePath -> ParsecT ByteString () Identity (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing)
             ParsecT ByteString () Identity (Maybe FilePath)
-> ParsecT ByteString () Identity (Maybe FilePath)
-> ParsecT ByteString () Identity (Maybe FilePath)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath)
-> ParsecT ByteString () Identity FilePath
-> ParsecT ByteString () Identity (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m FilePath
P.stringLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer)
    FilePath
bytes     <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m FilePath
P.stringLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
    Key
key       <- Parser Key
forall a. Parse a => Parser a
parseValue
    [Modifier]
modifiers <- Parser [Modifier]
forall a. Parse a => Parser a
parseValue
    VtyUserConfig -> Parsec ByteString () VtyUserConfig
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig { configInputMap :: InputMap
configInputMap = [(Maybe FilePath
termIdent, FilePath
bytes, Key -> [Modifier] -> Event
EvKey Key
key [Modifier]
modifiers)] }

debugLogDecl :: Parser VtyUserConfig
debugLogDecl :: Parsec ByteString () VtyUserConfig
debugLogDecl = do
    FilePath
"debugLog" <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m FilePath
P.identifier GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
    FilePath
path       <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m FilePath
P.stringLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
    VtyUserConfig -> Parsec ByteString () VtyUserConfig
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig { configDebugLog :: Maybe FilePath
configDebugLog = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
path }

colorModeDecl :: Parser VtyUserConfig
colorModeDecl :: Parsec ByteString () VtyUserConfig
colorModeDecl = do
    FilePath
"colorMode" <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m FilePath
P.identifier GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
    FilePath
mode <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m FilePath
P.stringLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
    VtyUserConfig -> Parsec ByteString () VtyUserConfig
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig { configPreferredColorMode :: Maybe ColorMode
configPreferredColorMode = FilePath -> Maybe ColorMode
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
mode }

widthMapDecl :: Parser VtyUserConfig
widthMapDecl :: Parsec ByteString () VtyUserConfig
widthMapDecl = do
    FilePath
"widthMap" <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m FilePath
P.identifier GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
    FilePath
tName <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m FilePath
P.stringLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
    FilePath
path <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m FilePath
P.stringLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
    VtyUserConfig -> Parsec ByteString () VtyUserConfig
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig { configTermWidthMaps :: [(FilePath, FilePath)]
configTermWidthMaps = [(FilePath
tName, FilePath
path)] }

ignoreLine :: Parser ()
ignoreLine :: ParsecT ByteString () Identity ()
ignoreLine = ParsecT ByteString () Identity FilePath
-> ParsecT ByteString () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT ByteString () Identity FilePath
 -> ParsecT ByteString () Identity ())
-> ParsecT ByteString () Identity FilePath
-> ParsecT ByteString () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity FilePath
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT ByteString () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT ByteString () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline

parseConfig :: Parser VtyUserConfig
parseConfig :: Parsec ByteString () VtyUserConfig
parseConfig = ([VtyUserConfig] -> VtyUserConfig)
-> ParsecT ByteString () Identity [VtyUserConfig]
-> Parsec ByteString () VtyUserConfig
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [VtyUserConfig] -> VtyUserConfig
forall a. Monoid a => [a] -> a
mconcat (ParsecT ByteString () Identity [VtyUserConfig]
 -> Parsec ByteString () VtyUserConfig)
-> ParsecT ByteString () Identity [VtyUserConfig]
-> Parsec ByteString () VtyUserConfig
forall a b. (a -> b) -> a -> b
$ Parsec ByteString () VtyUserConfig
-> ParsecT ByteString () Identity [VtyUserConfig]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (Parsec ByteString () VtyUserConfig
 -> ParsecT ByteString () Identity [VtyUserConfig])
-> Parsec ByteString () VtyUserConfig
-> ParsecT ByteString () Identity [VtyUserConfig]
forall a b. (a -> b) -> a -> b
$ do
    GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity ()
forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
P.whiteSpace GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
    let directives :: [Parsec ByteString () VtyUserConfig]
directives = [Parsec ByteString () VtyUserConfig
-> Parsec ByteString () VtyUserConfig
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parsec ByteString () VtyUserConfig
mapDecl, Parsec ByteString () VtyUserConfig
-> Parsec ByteString () VtyUserConfig
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parsec ByteString () VtyUserConfig
debugLogDecl, Parsec ByteString () VtyUserConfig
-> Parsec ByteString () VtyUserConfig
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parsec ByteString () VtyUserConfig
widthMapDecl, Parsec ByteString () VtyUserConfig
-> Parsec ByteString () VtyUserConfig
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parsec ByteString () VtyUserConfig
colorModeDecl]
    [Parsec ByteString () VtyUserConfig]
-> Parsec ByteString () VtyUserConfig
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [Parsec ByteString () VtyUserConfig]
directives Parsec ByteString () VtyUserConfig
-> Parsec ByteString () VtyUserConfig
-> Parsec ByteString () VtyUserConfig
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ParsecT ByteString () Identity ()
ignoreLine ParsecT ByteString () Identity ()
-> Parsec ByteString () VtyUserConfig
-> Parsec ByteString () VtyUserConfig
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VtyUserConfig -> Parsec ByteString () VtyUserConfig
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig)

class    Parse a        where parseValue :: Parser a
instance Parse Char     where parseValue :: ParsecT ByteString () Identity Char
parseValue = GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity Char
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m Char
P.charLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
instance Parse Int      where parseValue :: Parser Int
parseValue = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int)
-> ParsecT ByteString () Identity Integer -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity Integer
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m Integer
P.natural GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
instance Parse Key      where parseValue :: Parser Key
parseValue = Parser Key
forall a. (Generic a, GParse (Rep a)) => Parser a
genericParse
instance Parse Modifier where parseValue :: Parser Modifier
parseValue = Parser Modifier
forall a. (Generic a, GParse (Rep a)) => Parser a
genericParse
instance Parse a => Parse [a] where
  parseValue :: Parser [a]
parseValue = GenTokenParser ByteString () Identity -> Parser [a] -> Parser [a]
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
P.brackets GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
                 (Parser a
forall a. Parse a => Parser a
parseValue Parser a -> ParsecT ByteString () Identity FilePath -> Parser [a]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
`sepBy` GenTokenParser ByteString () Identity
-> FilePath -> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> FilePath -> ParsecT s u m FilePath
P.symbol GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer FilePath
",")

------------------------------------------------------------------------
-- Derived parser for ADTs via generics
------------------------------------------------------------------------

genericParse :: (Generic a, GParse (Rep a)) => Parser a
genericParse :: Parser a
genericParse = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a)
-> ParsecT ByteString () Identity (Rep a Any) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity (Rep a Any)
forall (f :: * -> *) a. GParse f => Parser (f a)
gparse

class    GParse f                      where gparse :: Parser (f a)
instance GParse f => GParse (M1 S i f) where gparse :: Parser (M1 S i f a)
gparse = f a -> M1 S i f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 S i f a)
-> ParsecT ByteString () Identity (f a) -> Parser (M1 S i f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity (f a)
forall (f :: * -> *) a. GParse f => Parser (f a)
gparse
instance GParse U1                     where gparse :: Parser (U1 a)
gparse = U1 a -> Parser (U1 a)
forall (m :: * -> *) a. Monad m => a -> m a
return U1 a
forall k (p :: k). U1 p
U1
instance Parse a => GParse (K1 i a)    where gparse :: Parser (K1 i a a)
gparse = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a)
-> ParsecT ByteString () Identity a -> Parser (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity a
forall a. Parse a => Parser a
parseValue

instance (GParse f, GParse g) => GParse (f :*: g) where
  gparse :: Parser ((:*:) f g a)
gparse = f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f a -> g a -> (:*:) f g a)
-> ParsecT ByteString () Identity (f a)
-> ParsecT ByteString () Identity (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity (f a)
forall (f :: * -> *) a. GParse f => Parser (f a)
gparse ParsecT ByteString () Identity (g a -> (:*:) f g a)
-> ParsecT ByteString () Identity (g a) -> Parser ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT ByteString () Identity (g a)
forall (f :: * -> *) a. GParse f => Parser (f a)
gparse

instance GParseAlts f => GParse (M1 D i f) where
  gparse :: Parser (M1 D i f a)
gparse =
    do FilePath
con <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m FilePath
P.identifier GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
       f a -> M1 D i f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 D i f a)
-> ParsecT ByteString () Identity (f a) -> Parser (M1 D i f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> ParsecT ByteString () Identity (f a)
forall (f :: * -> *) a. GParseAlts f => FilePath -> Parser (f a)
gparseAlts FilePath
con

------------------------------------------------------------------------

class GParseAlts f where
  gparseAlts :: String -> Parser (f a)

instance (Constructor i, GParse f) => GParseAlts (M1 C i f) where
  gparseAlts :: FilePath -> Parser (M1 C i f a)
gparseAlts FilePath
con =
    do Bool -> ParsecT ByteString () Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FilePath
con FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== M1 C i Maybe Any -> FilePath
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> FilePath
conName (Maybe a -> M1 C i Maybe a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 Maybe a
forall a. Maybe a
Nothing :: C1 i Maybe a))
       f a -> M1 C i f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 C i f a)
-> ParsecT ByteString () Identity (f a) -> Parser (M1 C i f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity (f a)
forall (f :: * -> *) a. GParse f => Parser (f a)
gparse

instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where
  gparseAlts :: FilePath -> Parser ((:+:) f g a)
gparseAlts FilePath
con = f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> (:+:) f g a)
-> ParsecT ByteString () Identity (f a) -> Parser ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> ParsecT ByteString () Identity (f a)
forall (f :: * -> *) a. GParseAlts f => FilePath -> Parser (f a)
gparseAlts FilePath
con Parser ((:+:) f g a)
-> Parser ((:+:) f g a) -> Parser ((:+:) f g a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g a -> (:+:) f g a)
-> ParsecT ByteString () Identity (g a) -> Parser ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> ParsecT ByteString () Identity (g a)
forall (f :: * -> *) a. GParseAlts f => FilePath -> Parser (f a)
gparseAlts FilePath
con

instance GParseAlts V1 where gparseAlts :: FilePath -> Parser (V1 a)
gparseAlts FilePath
_ = FilePath -> Parser (V1 a)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"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 (ConfigUpdateResult -> ConfigUpdateResult -> Bool
(ConfigUpdateResult -> ConfigUpdateResult -> Bool)
-> (ConfigUpdateResult -> ConfigUpdateResult -> Bool)
-> Eq ConfigUpdateResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConfigUpdateResult -> ConfigUpdateResult -> Bool
$c/= :: ConfigUpdateResult -> ConfigUpdateResult -> Bool
== :: ConfigUpdateResult -> ConfigUpdateResult -> Bool
$c== :: ConfigUpdateResult -> ConfigUpdateResult -> Bool
Eq, Int -> ConfigUpdateResult -> ShowS
[ConfigUpdateResult] -> ShowS
ConfigUpdateResult -> FilePath
(Int -> ConfigUpdateResult -> ShowS)
-> (ConfigUpdateResult -> FilePath)
-> ([ConfigUpdateResult] -> ShowS)
-> Show ConfigUpdateResult
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ConfigUpdateResult] -> ShowS
$cshowList :: [ConfigUpdateResult] -> ShowS
show :: ConfigUpdateResult -> FilePath
$cshow :: ConfigUpdateResult -> FilePath
showsPrec :: Int -> ConfigUpdateResult -> ShowS
$cshowsPrec :: Int -> ConfigUpdateResult -> ShowS
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 :: FilePath -> FilePath -> FilePath -> IO ConfigUpdateResult
addConfigWidthMap FilePath
configPath FilePath
term FilePath
tablePath = do
    Bool
configEx <- FilePath -> IO Bool
doesFileExist FilePath
configPath
    if Bool
configEx
       then IO ConfigUpdateResult
updateConfig
       else IO ()
createConfig IO () -> IO ConfigUpdateResult -> IO ConfigUpdateResult
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConfigUpdateResult -> IO ConfigUpdateResult
forall (m :: * -> *) a. Monad m => a -> m a
return ConfigUpdateResult
ConfigurationCreated

    where
        directive :: FilePath
directive = FilePath
"widthMap " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> FilePath
show FilePath
term FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> FilePath
show FilePath
tablePath FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n"

        createConfig :: IO ()
createConfig = do
            let dir :: FilePath
dir = ShowS
takeDirectory FilePath
configPath
            Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
            FilePath -> FilePath -> IO ()
writeFile FilePath
configPath FilePath
directive

        updateConfig :: IO ConfigUpdateResult
updateConfig = do
            VtyUserConfig
config <- FilePath -> IO VtyUserConfig
parseConfigFile FilePath
configPath
            if (FilePath
term, FilePath
tablePath) (FilePath, FilePath) -> [(FilePath, FilePath)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` VtyUserConfig -> [(FilePath, FilePath)]
configTermWidthMaps VtyUserConfig
config
               then ConfigUpdateResult -> IO ConfigUpdateResult
forall (m :: * -> *) a. Monad m => a -> m a
return ConfigUpdateResult
ConfigurationRedundant
               else case FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
term (VtyUserConfig -> [(FilePath, FilePath)]
configTermWidthMaps VtyUserConfig
config) of
                   Just FilePath
other -> ConfigUpdateResult -> IO ConfigUpdateResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConfigUpdateResult -> IO ConfigUpdateResult)
-> ConfigUpdateResult -> IO ConfigUpdateResult
forall a b. (a -> b) -> a -> b
$ FilePath -> ConfigUpdateResult
ConfigurationConflict FilePath
other
                   Maybe FilePath
Nothing -> do
                       FilePath -> FilePath -> IO ()
appendFile FilePath
configPath FilePath
directive
                       ConfigUpdateResult -> IO ConfigUpdateResult
forall (m :: * -> *) a. Monad m => a -> m a
return ConfigUpdateResult
ConfigurationModified