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