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