git.iko.soy/vty
on d64ff96 help sign in
vty/src/Graphics/Vty/Config.hs
306 lines 10 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6-- | Vty supports a configuration file format and associated 'Config'
7-- data type. The 'Config' can be provided to 'mkVty' to customize the
8-- application's use of Vty.
9--
10-- Lines in config files that fail to parse are ignored. Later entries
11-- take precedence over earlier ones.
12--
13-- = Debug
14--
15-- == @debugLog@
16--
17-- Format:
18--
19-- @
20-- \"debugLog\" string
21-- @
22--
23-- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent
24-- to a debugLog entry at the end of the last config file.
25--
26-- = Input Processing
27--
28-- == @map@
29--
30-- Format:
31--
32-- @
33-- \"map\" term string key modifier_list
34-- where
35-- key := KEsc | KChar Char | KBS ... (same as 'Key')
36-- modifier_list := \"[\" modifier+ \"]\"
37-- modifier := MShift | MCtrl | MMeta | MAlt
38-- term := "_" | string
39-- @
40--
41-- E.g., if the contents are
42--
43-- @
44-- map _ \"\\ESC[B\" KUp []
45-- map _ \"\\ESC[1;3B\" KDown [MAlt]
46-- map \"xterm\" \"\\ESC[D\" KLeft []
47-- @
48--
49-- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all
50-- terminals. The bytes @\"\\ESC[1;3B\"@ will result in the event KDown
51-- with the MAlt modifier on all terminals. The bytes @\"\\ESC[D\"@ will
52-- result in the KLeft event when @TERM@ is @xterm@.
53--
54-- If a debug log is requested then vty will output the current input
55-- table to the log in the above format. A workflow for using this is
56-- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for
57-- incorrect mappings. Add corrected mappings to @$HOME/.vty/config@.
58module Graphics.Vty.Config
59 ( InputMap
60 , Config(..)
61 , VtyConfigurationError(..)
62 , userConfig
63 , overrideEnvConfig
64 , standardIOConfig
65 , runParseConfig
66 , parseConfigFile
67 , defaultConfig
68 )
69where
71import Prelude
73import Control.Applicative hiding (many)
75import Control.Exception (catch, IOException, Exception(..), throwIO)
76import Control.Monad (liftM, guard, void)
78import qualified Data.ByteString as BS
79import Data.Monoid (Monoid(..))
80#if !(MIN_VERSION_base(4,11,0))
81import Data.Semigroup (Semigroup(..))
82#endif
83import Data.Typeable (Typeable)
85import Graphics.Vty.Input.Events
87import GHC.Generics
89import System.Directory (getAppUserDataDirectory)
90import System.Posix.Env (getEnv)
91import System.Posix.IO (stdInput, stdOutput)
92import System.Posix.Types (Fd(..))
94import Text.Parsec hiding ((<|>))
95import Text.Parsec.Token ( GenLanguageDef(..) )
96import qualified Text.Parsec.Token as P
98-- | Type of errors that can be thrown when configuring VTY
99data VtyConfigurationError
100 = VtyMissingTermEnvVar -- ^ TERM environment variable not set
101 deriving (Show, Eq, Typeable)
103instance Exception VtyConfigurationError where
104 displayException VtyMissingTermEnvVar = "TERM environment variable not set"
106-- | Mappings from input bytes to event in the order specified. Later
107-- entries take precedence over earlier in the case multiple entries
108-- have the same byte string.
109type InputMap = [(Maybe String, String, Event)]
111-- | A Vty configuration.
112data Config = Config
113 {
114 -- | The default is 1 character.
115 vmin :: Maybe Int
116 -- | The default is 100 milliseconds, 0.1 seconds.
117 , vtime :: Maybe Int
118 -- | The default is False.
119 , mouseMode :: Maybe Bool
120 -- | The default is False.
121 , bracketedPasteMode :: Maybe Bool
122 -- | Debug information is appended to this file if not Nothing.
123 , debugLog :: Maybe FilePath
124 -- | The (input byte, output event) pairs extend the internal input
125 -- table of VTY and the table from terminfo.
126 --
127 -- See "Graphics.Vty.Config" module documentation for documentation
128 -- of the @map@ directive.
129 , inputMap :: InputMap
130 -- | The input file descriptor to use. The default is
131 -- 'System.Posix.IO.stdInput'
132 , inputFd :: Maybe Fd
133 -- | The output file descriptor to use. The default is
134 -- 'System.Posix.IO.stdOutput'
135 , outputFd :: Maybe Fd
136 -- | The terminal name used to look up terminfo capabilities.
137 -- The default is the value of the TERM environment variable.
138 , termName :: Maybe String
139 } deriving (Show, Eq)
141defaultConfig :: Config
142defaultConfig = mempty
144instance Semigroup Config where
145 c0 <> c1 = Config
146 -- latter config takes priority for everything but inputMap
147 { vmin = vmin c1 <|> vmin c0
148 , vtime = vtime c1 <|> vtime c0
149 , mouseMode = mouseMode c1
150 , bracketedPasteMode = bracketedPasteMode c1
151 , debugLog = debugLog c1 <|> debugLog c0
152 , inputMap = inputMap c0 <> inputMap c1
153 , inputFd = inputFd c1 <|> inputFd c0
154 , outputFd = outputFd c1 <|> outputFd c0
155 , termName = termName c1 <|> termName c0
156 }
158instance Monoid Config where
159 mempty = Config
160 { vmin = Nothing
161 , vtime = Nothing
162 , mouseMode = Nothing
163 , bracketedPasteMode = Nothing
164 , debugLog = mempty
165 , inputMap = mempty
166 , inputFd = Nothing
167 , outputFd = Nothing
168 , termName = Nothing
169 }
170#if !(MIN_VERSION_base(4,11,0))
171 mappend = (<>)
172#endif
174-- | Load a configuration from @'getAppUserDataDirectory'/config@ and
175-- @$VTY_CONFIG_FILE@.
176userConfig :: IO Config
177userConfig = do
178 configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile
179 overrideConfig <- maybe (return defaultConfig) parseConfigFile =<< getEnv "VTY_CONFIG_FILE"
180 let base = configFile <> overrideConfig
181 mappend base <$> overrideEnvConfig
183overrideEnvConfig :: IO Config
184overrideEnvConfig = do
185 d <- getEnv "VTY_DEBUG_LOG"
186 return $ defaultConfig { debugLog = d }
188-- | Configures VTY using defaults suitable for terminals. This function
189-- can raise 'VtyConfigurationError'.
190standardIOConfig :: IO Config
191standardIOConfig = do
192 mb <- getEnv "TERM"
193 case mb of
194 Nothing -> throwIO VtyMissingTermEnvVar
195 Just t ->
196 return defaultConfig
197 { vmin = Just 1
198 , mouseMode = Just False
199 , bracketedPasteMode = Just False
200 , vtime = Just 100
201 , inputFd = Just stdInput
202 , outputFd = Just stdOutput
203 , termName = Just t
204 }
206parseConfigFile :: FilePath -> IO Config
207parseConfigFile path = do
208 catch (runParseConfig path <$> BS.readFile path)
209 (\(_ :: IOException) -> return defaultConfig)
211runParseConfig :: String -> BS.ByteString -> Config
212runParseConfig name cfgTxt =
213 case runParser parseConfig () name cfgTxt of
214 Right cfg -> cfg
215 Left{} -> defaultConfig
217------------------------------------------------------------------------
219type Parser = Parsec BS.ByteString ()
221configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
222configLanguage = LanguageDef
223 { commentStart = "{-"
224 , commentEnd = "-}"
225 , commentLine = "--"
226 , nestedComments = True
227 , identStart = letter <|> char '_'
228 , identLetter = alphaNum <|> oneOf "_'"
229 , opStart = opLetter configLanguage
230 , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
231 , reservedOpNames = []
232 , reservedNames = []
233 , caseSensitive = True
234 }
236configLexer :: Monad m => P.GenTokenParser BS.ByteString () m
237configLexer = P.makeTokenParser configLanguage
239mapDecl :: Parser Config
240mapDecl = do
241 "map" <- P.identifier configLexer
242 termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing)
243 <|> (Just <$> P.stringLiteral configLexer)
244 bytes <- P.stringLiteral configLexer
245 key <- parseValue
246 modifiers <- parseValue
247 return defaultConfig { inputMap = [(termIdent, bytes, EvKey key modifiers)] }
249debugLogDecl :: Parser Config
250debugLogDecl = do
251 "debugLog" <- P.identifier configLexer
252 path <- P.stringLiteral configLexer
253 return defaultConfig { debugLog = Just path }
255ignoreLine :: Parser ()
256ignoreLine = void $ manyTill anyChar newline
258parseConfig :: Parser Config
259parseConfig = liftM mconcat $ many $ do
260 P.whiteSpace configLexer
261 let directives = [try mapDecl, try debugLogDecl]
262 choice directives <|> (ignoreLine >> return defaultConfig)
264class Parse a where parseValue :: Parser a
265instance Parse Char where parseValue = P.charLiteral configLexer
266instance Parse Int where parseValue = fromInteger <$> P.natural configLexer
267instance Parse Key where parseValue = genericParse
268instance Parse Modifier where parseValue = genericParse
269instance Parse a => Parse [a] where
270 parseValue = P.brackets configLexer
271 (parseValue `sepBy` P.symbol configLexer ",")
273------------------------------------------------------------------------
274-- Derived parser for ADTs via generics
275------------------------------------------------------------------------
277genericParse :: (Generic a, GParse (Rep a)) => Parser a
278genericParse = to <$> gparse
280class GParse f where gparse :: Parser (f a)
281instance GParse f => GParse (M1 S i f) where gparse = M1 <$> gparse
282instance GParse U1 where gparse = return U1
283instance Parse a => GParse (K1 i a) where gparse = K1 <$> parseValue
285instance (GParse f, GParse g) => GParse (f :*: g) where
286 gparse = (:*:) <$> gparse <*> gparse
288instance GParseAlts f => GParse (M1 D i f) where
289 gparse =
290 do con <- P.identifier configLexer
291 M1 <$> gparseAlts con
293------------------------------------------------------------------------
295class GParseAlts f where
296 gparseAlts :: String -> Parser (f a)
298instance (Constructor i, GParse f) => GParseAlts (M1 C i f) where
299 gparseAlts con =
300 do guard (con == conName (M1 Nothing :: C1 i Maybe a))
301 M1 <$> gparse
303instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where
304 gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
306instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"