{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
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
type InputMap = [(Maybe String, String, Event)]
data VtyUserConfig =
VtyUserConfig { VtyUserConfig -> Maybe String
configDebugLog :: Maybe FilePath
, VtyUserConfig -> InputMap
configInputMap :: InputMap
, VtyUserConfig -> [(String, String)]
configTermWidthMaps :: [(String, FilePath)]
, VtyUserConfig -> Maybe Bool
configAllowCustomUnicodeWidthTables :: Maybe Bool
, VtyUserConfig -> Maybe ColorMode
configPreferredColorMode :: Maybe ColorMode
}
deriving (Int -> VtyUserConfig -> ShowS
[VtyUserConfig] -> ShowS
VtyUserConfig -> String
(Int -> VtyUserConfig -> ShowS)
-> (VtyUserConfig -> String)
-> ([VtyUserConfig] -> ShowS)
-> Show VtyUserConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VtyUserConfig -> ShowS
showsPrec :: Int -> VtyUserConfig -> ShowS
$cshow :: VtyUserConfig -> String
show :: VtyUserConfig -> String
$cshowList :: [VtyUserConfig] -> ShowS
showList :: [VtyUserConfig] -> ShowS
Show, VtyUserConfig -> VtyUserConfig -> Bool
(VtyUserConfig -> VtyUserConfig -> Bool)
-> (VtyUserConfig -> VtyUserConfig -> Bool) -> Eq VtyUserConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VtyUserConfig -> VtyUserConfig -> Bool
== :: VtyUserConfig -> VtyUserConfig -> Bool
$c/= :: VtyUserConfig -> VtyUserConfig -> Bool
/= :: 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 =
VtyUserConfig { configDebugLog :: Maybe String
configDebugLog =
VtyUserConfig -> Maybe String
configDebugLog VtyUserConfig
c1 Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> VtyUserConfig -> Maybe String
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 :: [(String, String)]
configTermWidthMaps =
VtyUserConfig -> [(String, String)]
configTermWidthMaps VtyUserConfig
c1 [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> VtyUserConfig -> [(String, String)]
configTermWidthMaps VtyUserConfig
c0
, configAllowCustomUnicodeWidthTables :: Maybe Bool
configAllowCustomUnicodeWidthTables =
VtyUserConfig -> Maybe Bool
configAllowCustomUnicodeWidthTables VtyUserConfig
c1 Maybe Bool -> Maybe Bool -> Maybe Bool
forall a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 { configDebugLog :: Maybe String
configDebugLog = Maybe String
forall a. Monoid a => a
mempty
, configInputMap :: InputMap
configInputMap = InputMap
forall a. Monoid a => a
mempty
, configTermWidthMaps :: [(String, String)]
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 String
vtyDataDirectory = String -> IO String
getAppUserDataDirectory String
"vty"
vtyConfigPath :: IO FilePath
vtyConfigPath :: IO String
vtyConfigPath = do
String
dir <- IO String
vtyDataDirectory
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
"config"
vtyConfigFileEnvName :: String
vtyConfigFileEnvName :: String
vtyConfigFileEnvName = String
"VTY_CONFIG_FILE"
userConfig :: IO VtyUserConfig
userConfig :: IO VtyUserConfig
userConfig = do
VtyUserConfig
configFile <- IO String
vtyConfigPath IO String -> (String -> IO VtyUserConfig) -> IO VtyUserConfig
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO VtyUserConfig
parseConfigFile
VtyUserConfig
overrideConfig <- IO VtyUserConfig
-> (String -> IO VtyUserConfig) -> Maybe String -> IO VtyUserConfig
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (VtyUserConfig -> IO VtyUserConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig) String -> IO VtyUserConfig
parseConfigFile (Maybe String -> IO VtyUserConfig)
-> IO (Maybe String) -> IO VtyUserConfig
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
String -> IO (Maybe String)
lookupEnv String
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 String
term = String
"width_table_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
term String -> ShowS
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 -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Just String
term -> do
Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
dataDir String -> ShowS
</> ShowS
widthTableFilename String
term
overrideEnvConfig :: IO VtyUserConfig
overrideEnvConfig :: IO VtyUserConfig
overrideEnvConfig = do
Maybe String
d <- String -> IO (Maybe String)
lookupEnv String
"VTY_DEBUG_LOG"
VtyUserConfig -> IO VtyUserConfig
forall a. a -> IO a
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 = d }
parseConfigFile :: FilePath -> IO VtyUserConfig
parseConfigFile :: String -> IO VtyUserConfig
parseConfigFile String
path = do
IO VtyUserConfig
-> (IOException -> IO VtyUserConfig) -> IO VtyUserConfig
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (String -> ByteString -> VtyUserConfig
runParseConfig String
path (ByteString -> VtyUserConfig) -> IO ByteString -> IO VtyUserConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
path)
(\(IOException
_ :: IOException) -> VtyUserConfig -> IO VtyUserConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig)
runParseConfig :: String -> BS.ByteString -> VtyUserConfig
runParseConfig :: String -> ByteString -> VtyUserConfig
runParseConfig String
name ByteString
cfgTxt =
case Parsec ByteString () VtyUserConfig
-> () -> String -> ByteString -> Either ParseError VtyUserConfig
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser Parsec ByteString () VtyUserConfig
parseConfig () String
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 :: 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 = 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 a.
ParsecT ByteString () m a
-> ParsecT ByteString () m a -> ParsecT ByteString () m a
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 a.
ParsecT ByteString () m a
-> ParsecT ByteString () m a -> ParsecT ByteString () m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ParsecT ByteString () m Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"_'"
, 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 = String -> ParsecT ByteString () m Char
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 = 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
String
"map" <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
P.identifier GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
Maybe String
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 a b.
ParsecT ByteString () Identity a
-> ParsecT ByteString () Identity b
-> ParsecT ByteString () Identity b
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 String)
-> ParsecT ByteString () Identity (Maybe String)
forall a b.
ParsecT ByteString () Identity a
-> ParsecT ByteString () Identity b
-> ParsecT ByteString () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe String -> ParsecT ByteString () Identity (Maybe String)
forall a. a -> ParsecT ByteString () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing)
ParsecT ByteString () Identity (Maybe String)
-> ParsecT ByteString () Identity (Maybe String)
-> ParsecT ByteString () Identity (Maybe String)
forall a.
ParsecT ByteString () Identity a
-> ParsecT ByteString () Identity a
-> ParsecT ByteString () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> ParsecT ByteString () Identity String
-> ParsecT ByteString () Identity (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
P.stringLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer)
String
bytes <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
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 a. a -> ParsecT ByteString () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig { configInputMap = [(termIdent, bytes, EvKey key modifiers)] }
debugLogDecl :: Parser VtyUserConfig
debugLogDecl :: Parsec ByteString () VtyUserConfig
debugLogDecl = do
String
"debugLog" <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
P.identifier GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
String
path <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
P.stringLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
VtyUserConfig -> Parsec ByteString () VtyUserConfig
forall a. a -> ParsecT ByteString () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig { configDebugLog = Just path }
colorModeDecl :: Parser VtyUserConfig
colorModeDecl :: Parsec ByteString () VtyUserConfig
colorModeDecl = do
String
"colorMode" <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
P.identifier GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
String
mode <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
P.stringLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
VtyUserConfig -> Parsec ByteString () VtyUserConfig
forall a. a -> ParsecT ByteString () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig { configPreferredColorMode = readMaybe mode }
widthMapDecl :: Parser VtyUserConfig
widthMapDecl :: Parsec ByteString () VtyUserConfig
widthMapDecl = do
String
"widthMap" <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
P.identifier GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
String
tName <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
P.stringLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
String
path <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
P.stringLiteral GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer
VtyUserConfig -> Parsec ByteString () VtyUserConfig
forall a. a -> ParsecT ByteString () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return VtyUserConfig
defaultConfig { configTermWidthMaps = [(tName, path)] }
ignoreLine :: Parser ()
ignoreLine :: ParsecT ByteString () Identity ()
ignoreLine = ParsecT ByteString () Identity String
-> ParsecT ByteString () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT ByteString () Identity String
-> ParsecT ByteString () Identity ())
-> ParsecT ByteString () Identity String
-> ParsecT ByteString () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity String
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 a.
ParsecT ByteString () Identity a
-> ParsecT ByteString () Identity a
-> ParsecT ByteString () Identity a
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 a b.
ParsecT ByteString () Identity a
-> ParsecT ByteString () Identity b
-> ParsecT ByteString () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VtyUserConfig -> Parsec ByteString () VtyUserConfig
forall a. a -> ParsecT ByteString () Identity a
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
-> forall a.
ParsecT ByteString () Identity a
-> ParsecT ByteString () Identity 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 String -> 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
-> String -> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m String
P.symbol GenTokenParser ByteString () Identity
forall (m :: * -> *). Monad m => GenTokenParser ByteString () m
configLexer String
",")
genericParse :: (Generic a, GParse (Rep a)) => Parser a
genericParse :: forall a. (Generic a, GParse (Rep a)) => Parser a
genericParse = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a)
-> ParsecT ByteString () Identity (Rep a Any)
-> ParsecT ByteString () Identity a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity (Rep a Any)
forall a. Parser (Rep a a)
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 = 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)
-> ParsecT ByteString () Identity (M1 S i f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity (f a)
forall a. Parser (f a)
forall (f :: * -> *) a. GParse f => Parser (f a)
gparse
instance GParse U1 where gparse :: forall a. Parser (U1 a)
gparse = U1 a -> ParsecT ByteString () Identity (U1 a)
forall a. a -> ParsecT ByteString () Identity 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 :: forall a. 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
-> ParsecT ByteString () Identity (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 :: forall a. 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 a. Parser (f a)
forall (f :: * -> *) a. GParse f => Parser (f a)
gparse ParsecT ByteString () Identity (g a -> (:*:) f g a)
-> ParsecT ByteString () Identity (g a)
-> ParsecT ByteString () Identity ((:*:) f g a)
forall a b.
ParsecT ByteString () Identity (a -> b)
-> ParsecT ByteString () Identity a
-> ParsecT ByteString () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT ByteString () Identity (g a)
forall a. Parser (g a)
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 <- GenTokenParser ByteString () Identity
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
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
<$> String -> ParsecT ByteString () Identity (f a)
forall a. String -> Parser (f a)
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 Bool -> ParsecT ByteString () Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
con String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== M1 C i Maybe Any -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t i f a -> String
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 a. Parser (f a)
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 = 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)
-> ParsecT ByteString () Identity ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ParsecT ByteString () Identity (f a)
forall a. String -> Parser (f a)
forall (f :: * -> *) a. GParseAlts f => String -> Parser (f a)
gparseAlts String
con ParsecT ByteString () Identity ((:+:) f g a)
-> ParsecT ByteString () Identity ((:+:) f g a)
-> ParsecT ByteString () Identity ((:+:) f g a)
forall a.
ParsecT ByteString () Identity a
-> ParsecT ByteString () Identity a
-> ParsecT ByteString () Identity 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)
-> ParsecT ByteString () Identity ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ParsecT ByteString () Identity (g a)
forall a. String -> Parser (g a)
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
_ = String -> ParsecT ByteString () Identity (V1 a)
forall a. String -> ParsecT ByteString () Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"GParse: V1"
data ConfigUpdateResult =
ConfigurationCreated
| ConfigurationModified
| ConfigurationConflict String
| ConfigurationRedundant
deriving (ConfigUpdateResult -> ConfigUpdateResult -> Bool
(ConfigUpdateResult -> ConfigUpdateResult -> Bool)
-> (ConfigUpdateResult -> ConfigUpdateResult -> Bool)
-> Eq ConfigUpdateResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConfigUpdateResult -> ConfigUpdateResult -> Bool
== :: ConfigUpdateResult -> ConfigUpdateResult -> Bool
$c/= :: ConfigUpdateResult -> ConfigUpdateResult -> Bool
/= :: ConfigUpdateResult -> ConfigUpdateResult -> Bool
Eq, Int -> ConfigUpdateResult -> ShowS
[ConfigUpdateResult] -> ShowS
ConfigUpdateResult -> String
(Int -> ConfigUpdateResult -> ShowS)
-> (ConfigUpdateResult -> String)
-> ([ConfigUpdateResult] -> ShowS)
-> Show ConfigUpdateResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigUpdateResult -> ShowS
showsPrec :: Int -> ConfigUpdateResult -> ShowS
$cshow :: ConfigUpdateResult -> String
show :: ConfigUpdateResult -> String
$cshowList :: [ConfigUpdateResult] -> ShowS
showList :: [ConfigUpdateResult] -> ShowS
Show)
addConfigWidthMap :: FilePath
-> String
-> FilePath
-> 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 IO () -> IO ConfigUpdateResult -> IO ConfigUpdateResult
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConfigUpdateResult -> IO ConfigUpdateResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ConfigUpdateResult
ConfigurationCreated
where
directive :: String
directive = String
"widthMap " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
term String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
tablePath String -> ShowS
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
VtyUserConfig
config <- String -> IO VtyUserConfig
parseConfigFile String
configPath
if (String
term, String
tablePath) (String, String) -> [(String, String)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` VtyUserConfig -> [(String, String)]
configTermWidthMaps VtyUserConfig
config
then ConfigUpdateResult -> IO ConfigUpdateResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ConfigUpdateResult
ConfigurationRedundant
else case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
term (VtyUserConfig -> [(String, String)]
configTermWidthMaps VtyUserConfig
config) of
Just String
other -> ConfigUpdateResult -> IO ConfigUpdateResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConfigUpdateResult -> IO ConfigUpdateResult)
-> ConfigUpdateResult -> IO ConfigUpdateResult
forall a b. (a -> b) -> a -> b
$ String -> ConfigUpdateResult
ConfigurationConflict String
other
Maybe String
Nothing -> do
String -> String -> IO ()
appendFile String
configPath String
directive
ConfigUpdateResult -> IO ConfigUpdateResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ConfigUpdateResult
ConfigurationModified