{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase, MultiWayIf #-}
-- | Vty supports a configuration file format and associated 'Config'
-- data type. The 'Config' can be provided to 'mkVty' to customize the
-- application's use of Vty.
--
-- Lines in config files that fail to parse are ignored. Later entries
-- take precedence over earlier ones.
--
-- = Debug
--
-- == @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 be loaded and used when
-- the value of TERM matches the first argument. Unicode character
-- width maps can be produced either by running the provided binary
-- @vty-build-width-table@ or by calling the library routine
-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable'. The
-- 'Graphics.Vty.mkVty' function will use these configuration settings
-- to attempt to load and install the specified width map. See the
-- documentation for 'Graphics.Vty.mkVty' for details.
module Graphics.Vty.Config
  ( InputMap
  , Config(..)
  , VtyConfigurationError(..)
  , userConfig
  , overrideEnvConfig
  , standardIOConfig
  , runParseConfig
  , parseConfigFile
  , defaultConfig
  , getTtyEraseChar
  , currentTerminalName

  , vtyConfigPath
  , widthTableFilename
  , vtyDataDirectory
  , terminalWidthTablePath
  , vtyConfigFileEnvName

  , ConfigUpdateResult(..)
  , addConfigWidthMap
  )
where

import Prelude

import Control.Applicative hiding (many)

import Control.Exception (catch, IOException, Exception(..), throwIO)
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 Data.Typeable (Typeable)

import Graphics.Vty.Input.Events
import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode)

import GHC.Generics

import System.Directory ( getAppUserDataDirectory, doesFileExist
                        , createDirectoryIfMissing
                        )
import System.Environment (lookupEnv)
import System.FilePath ((</>), takeDirectory)
import System.Posix.IO (stdInput, stdOutput)
import System.Posix.Types (Fd(..))
import Foreign.C.Types (CInt(..), CChar(..))

import Text.Parsec hiding ((<|>))
import Text.Parsec.Token ( GenLanguageDef(..) )
import qualified Text.Parsec.Token as P

-- | Type of errors that can be thrown when configuring VTY
data VtyConfigurationError =
    VtyMissingTermEnvVar
    -- ^ TERM environment variable not set
    deriving (Int -> VtyConfigurationError -> ShowS
[VtyConfigurationError] -> ShowS
VtyConfigurationError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VtyConfigurationError] -> ShowS
$cshowList :: [VtyConfigurationError] -> ShowS
show :: VtyConfigurationError -> String
$cshow :: VtyConfigurationError -> String
showsPrec :: Int -> VtyConfigurationError -> ShowS
$cshowsPrec :: Int -> VtyConfigurationError -> ShowS
Show, VtyConfigurationError -> VtyConfigurationError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VtyConfigurationError -> VtyConfigurationError -> Bool
$c/= :: VtyConfigurationError -> VtyConfigurationError -> Bool
== :: VtyConfigurationError -> VtyConfigurationError -> Bool
$c== :: VtyConfigurationError -> VtyConfigurationError -> Bool
Eq, Typeable)

instance Exception VtyConfigurationError where
    displayException :: VtyConfigurationError -> String
displayException VtyConfigurationError
VtyMissingTermEnvVar = String
"TERM environment variable not set"

-- | 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 configuration.
data Config =
    Config { Config -> Maybe Int
vmin  :: Maybe Int
           -- ^ The default is 1 character.
           , Config -> Maybe Int
vtime :: Maybe Int
           -- ^ The default is 100 milliseconds, 0.1 seconds.
           , Config -> Maybe Bool
mouseMode :: Maybe Bool
           -- ^ The default is False.
           , Config -> Maybe Bool
bracketedPasteMode :: Maybe Bool
           -- ^ The default is False.
           , Config -> Maybe String
debugLog :: Maybe FilePath
           -- ^ Debug information is appended to this file if not
           -- Nothing.
           , Config -> InputMap
inputMap :: 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.
           , Config -> Maybe Fd
inputFd :: Maybe Fd
           -- ^ The input file descriptor to use. The default is
           -- 'System.Posix.IO.stdInput'
           , Config -> Maybe Fd
outputFd :: Maybe Fd
           -- ^ The output file descriptor to use. The default is
           -- 'System.Posix.IO.stdOutput'
           , Config -> Maybe String
termName :: Maybe String
           -- ^ The terminal name used to look up terminfo capabilities.
           -- The default is the value of the TERM environment variable.
           , Config -> [(String, String)]
termWidthMaps :: [(String, FilePath)]
           -- ^ Terminal width map files.
           , Config -> Maybe Bool
allowCustomUnicodeWidthTables :: 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.
           , Config -> Maybe ColorMode
colorMode :: Maybe ColorMode
           -- ^ The color mode used to know how many colors the terminal
           -- supports.
           }
           deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show, Config -> Config -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq)

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

instance Semigroup Config where
    Config
c0 <> :: Config -> Config -> Config
<> Config
c1 =
        -- latter config takes priority for everything but inputMap
        Config { vmin :: Maybe Int
vmin = Config -> Maybe Int
vmin Config
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe Int
vmin Config
c0
               , vtime :: Maybe Int
vtime = Config -> Maybe Int
vtime Config
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe Int
vtime Config
c0
               , mouseMode :: Maybe Bool
mouseMode = Config -> Maybe Bool
mouseMode Config
c1
               , bracketedPasteMode :: Maybe Bool
bracketedPasteMode = Config -> Maybe Bool
bracketedPasteMode Config
c1
               , debugLog :: Maybe String
debugLog = Config -> Maybe String
debugLog Config
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe String
debugLog Config
c0
               , inputMap :: InputMap
inputMap = Config -> InputMap
inputMap Config
c0 forall a. Semigroup a => a -> a -> a
<> Config -> InputMap
inputMap Config
c1
               , inputFd :: Maybe Fd
inputFd = Config -> Maybe Fd
inputFd Config
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe Fd
inputFd Config
c0
               , outputFd :: Maybe Fd
outputFd = Config -> Maybe Fd
outputFd Config
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe Fd
outputFd Config
c0
               , termName :: Maybe String
termName = Config -> Maybe String
termName Config
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe String
termName Config
c0
               , termWidthMaps :: [(String, String)]
termWidthMaps = Config -> [(String, String)]
termWidthMaps Config
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> [(String, String)]
termWidthMaps Config
c0
               , allowCustomUnicodeWidthTables :: Maybe Bool
allowCustomUnicodeWidthTables =
                   Config -> Maybe Bool
allowCustomUnicodeWidthTables Config
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe Bool
allowCustomUnicodeWidthTables Config
c0
               , colorMode :: Maybe ColorMode
colorMode = Config -> Maybe ColorMode
colorMode Config
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe ColorMode
colorMode Config
c0
               }

instance Monoid Config where
    mempty :: Config
mempty =
        Config { vmin :: Maybe Int
vmin = forall a. Maybe a
Nothing
               , vtime :: Maybe Int
vtime = forall a. Maybe a
Nothing
               , mouseMode :: Maybe Bool
mouseMode = forall a. Maybe a
Nothing
               , bracketedPasteMode :: Maybe Bool
bracketedPasteMode = forall a. Maybe a
Nothing
               , debugLog :: Maybe String
debugLog = forall a. Monoid a => a
mempty
               , inputMap :: InputMap
inputMap = forall a. Monoid a => a
mempty
               , inputFd :: Maybe Fd
inputFd = forall a. Maybe a
Nothing
               , outputFd :: Maybe Fd
outputFd = forall a. Maybe a
Nothing
               , termName :: Maybe String
termName = forall a. Maybe a
Nothing
               , termWidthMaps :: [(String, String)]
termWidthMaps = []
               , allowCustomUnicodeWidthTables :: Maybe Bool
allowCustomUnicodeWidthTables = forall a. Maybe a
Nothing
               , colorMode :: Maybe ColorMode
colorMode = forall a. Maybe a
Nothing
               }
#if !(MIN_VERSION_base(4,11,0))
    mappend = (<>)
#endif

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

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

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

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

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

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

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

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

overrideEnvConfig :: IO Config
overrideEnvConfig :: IO Config
overrideEnvConfig = do
    Maybe String
d <- String -> IO (Maybe String)
lookupEnv String
"VTY_DEBUG_LOG"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Config
defaultConfig { debugLog :: Maybe String
debugLog = Maybe String
d }

-- | Configures VTY using defaults suitable for terminals. This function
-- can raise 'VtyConfigurationError'.
standardIOConfig :: IO Config
standardIOConfig :: IO Config
standardIOConfig = do
    Maybe String
mb <- String -> IO (Maybe String)
lookupEnv String
termVariable
    case Maybe String
mb of
      Maybe String
Nothing -> forall e a. Exception e => e -> IO a
throwIO VtyConfigurationError
VtyMissingTermEnvVar
      Just String
t -> do
        ColorMode
mcolorMode <- String -> IO ColorMode
detectColorMode String
t
        forall (m :: * -> *) a. Monad m => a -> m a
return Config
defaultConfig
          { vmin :: Maybe Int
vmin               = forall a. a -> Maybe a
Just Int
1
          , mouseMode :: Maybe Bool
mouseMode          = forall a. a -> Maybe a
Just Bool
False
          , bracketedPasteMode :: Maybe Bool
bracketedPasteMode = forall a. a -> Maybe a
Just Bool
False
          , vtime :: Maybe Int
vtime              = forall a. a -> Maybe a
Just Int
100
          , inputFd :: Maybe Fd
inputFd            = forall a. a -> Maybe a
Just Fd
stdInput
          , outputFd :: Maybe Fd
outputFd           = forall a. a -> Maybe a
Just Fd
stdOutput
          , termName :: Maybe String
termName           = forall a. a -> Maybe a
Just String
t
          , colorMode :: Maybe ColorMode
colorMode          = forall a. a -> Maybe a
Just ColorMode
mcolorMode
          }

parseConfigFile :: FilePath -> IO Config
parseConfigFile :: String -> IO Config
parseConfigFile String
path = do
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (String -> ByteString -> Config
runParseConfig String
path forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
path)
          (\(IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return Config
defaultConfig)

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

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

type Parser = Parsec BS.ByteString ()

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

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

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

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

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

ignoreLine :: Parser ()
ignoreLine :: ParsecT ByteString () Identity ()
ignoreLine = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline

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

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

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

genericParse :: (Generic a, GParse (Rep a)) => Parser a
genericParse :: forall a. (Generic a, GParse (Rep a)) => Parser a
genericParse = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall a. Parser (M1 S i f a)
gparse = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GParse f => Parser (f a)
gparse
instance GParse U1                     where gparse :: forall a. Parser (U1 a)
gparse = forall (m :: * -> *) a. Monad m => a -> m a
return forall k (p :: k). U1 p
U1
instance Parse a => GParse (K1 i a)    where gparse :: forall a. Parser (K1 i a a)
gparse = forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parse a => Parser a
parseValue

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

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

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

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

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

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

instance GParseAlts V1 where gparseAlts :: forall a. String -> Parser (V1 a)
gparseAlts String
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"GParse: V1"

foreign import ccall "vty_get_tty_erase" cGetTtyErase :: Fd -> IO CChar

-- | Get the "erase" character for the terminal attached to the
-- specified file descriptor. This is the character configured by 'stty
-- erase'. If the call to 'tcgetattr' fails, this will return 'Nothing'.
-- Otherwise it will return the character that has been configured to
-- indicate the canonical mode ERASE behavior. That character can then
-- be added to the table of strings that we interpret to mean Backspace.
--
-- For more details, see:
--
-- * https://www.gnu.org/software/libc/manual/html_node/Canonical-or-Not.html
-- * https://www.gsp.com/cgi-bin/man.cgi?section=1&topic=stty
-- * https://github.com/matterhorn-chat/matterhorn/issues/565
getTtyEraseChar :: Fd -> IO (Maybe Char)
getTtyEraseChar :: Fd -> IO (Maybe Char)
getTtyEraseChar Fd
fd = do
    CChar
c <- Fd -> IO CChar
cGetTtyErase Fd
fd
    if CChar
c forall a. Eq a => a -> a -> Bool
/= CChar
0
       then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum CChar
c
       else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

data ConfigUpdateResult =
    ConfigurationCreated
    | ConfigurationModified
    | ConfigurationConflict String
    | ConfigurationRedundant
    deriving (ConfigUpdateResult -> ConfigUpdateResult -> Bool
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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigUpdateResult] -> ShowS
$cshowList :: [ConfigUpdateResult] -> ShowS
show :: ConfigUpdateResult -> String
$cshow :: ConfigUpdateResult -> String
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 @True@ if the configuration was created or modified and
-- @False@ otherwise. 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 :: String -> String -> String -> IO ConfigUpdateResult
addConfigWidthMap String
configPath String
term String
tablePath = do
    Bool
configEx <- String -> IO Bool
doesFileExist String
configPath
    if Bool
configEx
       then IO ConfigUpdateResult
updateConfig
       else IO ()
createConfig forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ConfigUpdateResult
ConfigurationCreated

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

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

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