@@ -1,53 +1,170 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE NoMonomorphismRestriction #-}
1-- | A 'Config' can be provided to mkVty to customize the applications use of vty.
3-- | A 'Config' can be provided to mkVty to customize the applications use of vty.
3−-- Parts of the structure can be overriden by $HOME/.config/vty.config and then $VTY_CONFIG_FILE.
5+-- The 'Config' provided is mappend'd to 'Config's loaded from $HOME/.config/vty.config and
6+-- $VTY_CONFIG_FILE. The $VTY_CONFIG_FILE takes precedence over the input.conf file or the
7+-- application provided 'Config'.
9+-- Each line of the input config is processed individually. Lines that fail to parse are ignored.
10+-- Later entries take precedence over earlier.
5−-- See also 'classifyTableUserOverrides'.
12+-- * Classify Table Overrides - "map"
17+-- entry := "map" string key modifier_list
18+-- key := KEsc | KChar Char | KBS ... (same as 'Key')
19+-- modifier_list := "[" modifier+ "]"
20+-- modifier := MShift | MCtrl | MMeta | MAlt
21+-- string := "\"" chars+ "\""
24+-- EG: If the contents of input.conf are
27+-- map "\ESC[B" KUp []
28+-- map "\ESC[1;3B" KDown [MAlt]
31+-- Then the bytes "\ESC[B" will result in the KUp event. The bytes "\ESC[1;3B" will result in the
32+-- event KDown with the MAlt modifier.
7module Graphics.Vty.Config where
34module Graphics.Vty.Config where
36+import Control.Applicative hiding (many)
38+import Control.Monad (void)
39+import Control.Monad.Trans.Class
40+import Control.Monad.Trans.Writer
42+import qualified Data.ByteString as BS
9import Data.Default
43import Data.Default
10−import Data.Either (either)
11import Data.Monoid
44import Data.Monoid
13import Graphics.Vty.Input.Events
46import Graphics.Vty.Input.Events
15−import System.FilePath
48+import Text.Parsec hiding ((<|>))
17−import Text.Parsec
49+import Text.Parsec.Token ( GenLanguageDef(..) )
18import qualified Text.Parsec.Token as P
50import qualified Text.Parsec.Token as P
19−import Text.Parsec.Language (haskellDef)
21data Config = Config
52data Config = Config
22− { singleEscPeriod :: Int -- ^ AKA VTIME. The default is 100000 microseconds or 0.1 seconds.
53+ { specifiedEscPeriod :: Maybe Int
23 -- | Debug information about the input process is appended to the file.
54 -- | Debug information about the input process is appended to the file.
24− , debugInputLog :: Maybe FilePath
55+ , debugInputLog :: Maybe FilePath
25− , inputOverrides :: ClassifyTable
56+ , inputOverrides :: ClassifyTable
26 } deriving (Show, Eq)
57 } deriving (Show, Eq)
59+-- | AKA VTIME. The default is 100000 microseconds or 0.1 seconds.
60+singleEscPeriod :: Config -> Int
61+singleEscPeriod = maybe 100000 id . specifiedEscPeriod
28instance Default Config where
63instance Default Config where
29 def = Config
64 def = Config
30− { singleEscPeriod = 100000
65+ { specifiedEscPeriod = Nothing
31− , debugInputLog = Nothing
66+ , debugInputLog = Nothing
32− , inputOverrides = []
67+ , inputOverrides = []
35−-- not a proper monoid but useful as one.
36instance Monoid Config where
70instance Monoid Config where
37 mempty = def
71 mempty = def
72+ mappend c0 c1 = Config
73+ -- latter config takes priority in specifiedEscPeriod
74+ { specifiedEscPeriod = specifiedEscPeriod c1 <|> specifiedEscPeriod c0
75+ -- latter config takes priority in debugInputLog
76+ , debugInputLog = debugInputLog c1 <|> debugInputLog c0
38− mappend c0 c1 = c1 { inputOverrides = inputOverrides c0 <> inputOverrides c1 }
77+ , inputOverrides = inputOverrides c0 <> inputOverrides c1
80+type ConfigParser s a = ParsecT s () (Writer Config) a
82+userConfig :: IO Config
84+ userGlobalConfig <- parseConfigFile "$HOME/.config/vty.config"
85+ overrideConfig <- parseConfigFile "$VTY_CONFIG_FILE"
86+ return $ userGlobalConfig `mappend` overrideConfig
40parseConfigFile :: FilePath -> IO Config
88parseConfigFile :: FilePath -> IO Config
41−parseConfigFile path = either (const def) id <$> parseFromFile parseConfig path
89+parseConfigFile path = runParseConfig path <$> BS.readFile path
43−parseConfig = do
91+runParseConfig :: Stream s (Writer Config) Char => String -> s -> Config
92+runParseConfig name = execWriter . runParserT parseConfig () name
94+-- I tried to use the haskellStyle here but that was specialized (without requirement?) to the
95+-- String stream type.
96+configLanguage :: Stream s m Char => P.GenLanguageDef s u m
97+configLanguage = LanguageDef
98+ { commentStart = "{-"
100+ , commentLine = "--"
101+ , nestedComments = True
102+ , identStart = letter <|> char '_'
103+ , identLetter = alphaNum <|> oneOf "_'"
104+ , opStart = opLetter configLanguage
105+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
106+ , reservedOpNames = []
107+ , reservedNames = []
108+ , caseSensitive = True
111+configLexer :: Stream s m Char => P.GenTokenParser s u m
44− let lexer = P.makeTokenParser haskellDef
112+configLexer = P.makeTokenParser configLanguage
45− parseOverride = do
114+parseOverride = do
47− string "map"
115+ void $ string "map"
48− P.whiteSpace lexer
116+ P.whiteSpace configLexer
49− bytes <- P.stringLiteral
117+ bytes <- P.stringLiteral configLexer
50− key <- parseKey
118+ key <- parseKey
51− modifier <- parseModifier
119+ modifiers <- parseModifiers
120+ lift $ tell $ def { inputOverrides = [(bytes, EvKey key modifiers)] }
123+ key <- P.identifier configLexer
125+ "KChar" -> KChar <$> P.charLiteral configLexer
126+ "KFun" -> KFun . fromInteger <$> P.natural configLexer
127+ "KEsc" -> return KEsc
129+ "KEnter" -> return KEnter
130+ "KLeft" -> return KLeft
131+ "KRight" -> return KRight
133+ "KDown" -> return KDown
134+ "KUpLeft" -> return KUpLeft
135+ "KUpRight" -> return KUpRight
136+ "KDownLeft" -> return KDownLeft
137+ "KDownRight" -> return KDownRight
138+ "KCenter" -> return KCenter
139+ "KBackTab" -> return KBackTab
140+ "KPrtScr" -> return KPrtScr
141+ "KPause" -> return KPause
142+ "KIns" -> return KIns
143+ "KHome" -> return KHome
144+ "KPageUp" -> return KPageUp
145+ "KDel" -> return KDel
146+ "KEnd" -> return KEnd
147+ "KPageDown" -> return KPageDown
148+ "KBegin" -> return KBegin
149+ "KMenu" -> return KMenu
150+ _ -> fail $ key ++ " is not a valid key identifier"
152+parseModifiers = P.brackets configLexer (parseModifier `sepBy` P.symbol configLexer ",")
155+ m <- P.identifier configLexer
157+ "KMenu" -> return MShift
158+ "MCtrl" -> return MCtrl
159+ "MMeta" -> return MMeta
160+ "MAlt" -> return MAlt
161+ _ -> fail $ m ++ " is not a valid modifier identifier"
52− _ <- manyTill space newline
163+ignoreLine = void $ manyTill anyChar newline
53− overrides <- many $ try parseOverride <|> ignoreOverride
164+
165+-- TODO: Generated by a vim macro. There is a better way here. Derive parser? Use Read
167+parseConfig = void $ many $ do
168+ P.whiteSpace configLexer
169+ let directives = [parseOverride]
170+ try (choice directives) <|> ignoreLine