@@ -1,53 +1,170 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE NoMonomorphismRestriction #-}
13-- | A 'Config' can be provided to mkVty to customize the applications use of vty.
24--
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'.
8+--
9+-- Each line of the input config is processed individually. Lines that fail to parse are ignored.
10+-- Later entries take precedence over earlier.
411--
5−-- See also 'classifyTableUserOverrides'.
12+-- * Classify Table Overrides - "map"
13+--
14+-- Directive format:
15+--
16+-- @
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+ "\""
22+-- @
23+--
24+-- EG: If the contents of input.conf are
25+--
26+-- @
27+-- map "\ESC[B" KUp []
28+-- map "\ESC[1;3B" KDown [MAlt]
29+-- @
30+--
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.
633--
734module Graphics.Vty.Config where
835
36+import Control.Applicative hiding (many)
37+
38+import Control.Monad (void)
39+import Control.Monad.Trans.Class
40+import Control.Monad.Trans.Writer
41+
42+import qualified Data.ByteString as BS
943import Data.Default
10−import Data.Either (either)
1144import Data.Monoid
1245
1346import Graphics.Vty.Input.Events
1447
15−import System.FilePath
16−
17−import Text.Parsec
48+import Text.Parsec hiding ((<|>))
49+import Text.Parsec.Token ( GenLanguageDef(..) )
1850import qualified Text.Parsec.Token as P
19−import Text.Parsec.Language (haskellDef)
2051
2152data Config = Config
22− { singleEscPeriod :: Int -- ^ AKA VTIME. The default is 100000 microseconds or 0.1 seconds.
53+ { specifiedEscPeriod :: Maybe Int
2354 -- | Debug information about the input process is appended to the file.
24− , debugInputLog :: Maybe FilePath
25− , inputOverrides :: ClassifyTable
55+ , debugInputLog :: Maybe FilePath
56+ , inputOverrides :: ClassifyTable
2657 } deriving (Show, Eq)
2758
59+-- | AKA VTIME. The default is 100000 microseconds or 0.1 seconds.
60+singleEscPeriod :: Config -> Int
61+singleEscPeriod = maybe 100000 id . specifiedEscPeriod
62+
2863instance Default Config where
2964 def = Config
30− { singleEscPeriod = 100000
31− , debugInputLog = Nothing
32− , inputOverrides = []
65+ { specifiedEscPeriod = Nothing
66+ , debugInputLog = Nothing
67+ , inputOverrides = []
3368 }
3469
35−-- not a proper monoid but useful as one.
3670instance Monoid Config where
3771 mempty = def
38− mappend c0 c1 = c1 { inputOverrides = inputOverrides c0 <> inputOverrides c1 }
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
77+ , inputOverrides = inputOverrides c0 <> inputOverrides c1
78+ }
79+
80+type ConfigParser s a = ParsecT s () (Writer Config) a
81+
82+userConfig :: IO Config
83+userConfig = do
84+ userGlobalConfig <- parseConfigFile "$HOME/.config/vty.config"
85+ overrideConfig <- parseConfigFile "$VTY_CONFIG_FILE"
86+ return $ userGlobalConfig `mappend` overrideConfig
3987
4088parseConfigFile :: FilePath -> IO Config
41−parseConfigFile path = either (const def) id <$> parseFromFile parseConfig path
42−
43−parseConfig = do
44− let lexer = P.makeTokenParser haskellDef
45− parseOverride = do
46− P.whiteSpace lexer
47− string "map"
48− P.whiteSpace lexer
49− bytes <- P.stringLiteral
50− key <- parseKey
51− modifier <- parseModifier
52− _ <- manyTill space newline
53− overrides <- many $ try parseOverride <|> ignoreOverride
89+parseConfigFile path = runParseConfig path <$> BS.readFile path
90+
91+runParseConfig :: Stream s (Writer Config) Char => String -> s -> Config
92+runParseConfig name = execWriter . runParserT parseConfig () name
93+
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 = "{-"
99+ , commentEnd = "-}"
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
109+ }
110+
111+configLexer :: Stream s m Char => P.GenTokenParser s u m
112+configLexer = P.makeTokenParser configLanguage
113+
114+parseOverride = do
115+ void $ string "map"
116+ P.whiteSpace configLexer
117+ bytes <- P.stringLiteral configLexer
118+ key <- parseKey
119+ modifiers <- parseModifiers
120+ lift $ tell $ def { inputOverrides = [(bytes, EvKey key modifiers)] }
121+
122+parseKey = do
123+ key <- P.identifier configLexer
124+ case key of
125+ "KChar" -> KChar <$> P.charLiteral configLexer
126+ "KFun" -> KFun . fromInteger <$> P.natural configLexer
127+ "KEsc" -> return KEsc
128+ "KBS" -> return KBS
129+ "KEnter" -> return KEnter
130+ "KLeft" -> return KLeft
131+ "KRight" -> return KRight
132+ "KUp" -> return KUp
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"
151+
152+parseModifiers = P.brackets configLexer (parseModifier `sepBy` P.symbol configLexer ",")
153+
154+parseModifier = do
155+ m <- P.identifier configLexer
156+ case m of
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"
162+
163+ignoreLine = void $ manyTill anyChar newline
164+
165+-- TODO: Generated by a vim macro. There is a better way here. Derive parser? Use Read
166+-- instance?
167+parseConfig = void $ many $ do
168+ P.whiteSpace configLexer
169+ let directives = [parseOverride]
170+ try (choice directives) <|> ignoreLine