@@ -1,7 +1,7 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE KindSignatures #-}
2+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
3+{-# LANGUAGE TypeOperators #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
55-- | A 'Config' can be provided to mkVty to customize the applications use of vty. A config file can
66-- be used to customize vty for a user's system.
77--
@@ -75,9 +75,7 @@ import Prelude hiding (catch)
7575import Control.Applicative hiding (many)
7676
7777import Control.Exception (catch, IOException)
78−import Control.Monad (void)
79−import Control.Monad.Trans.Class
80−import Control.Monad.Trans.Writer
78+import Control.Monad (liftM, guard, void)
8179
8280import qualified Data.ByteString as BS
8381import Data.Default
@@ -85,6 +83,8 @@ import Data.Monoid
8583
8684import Graphics.Vty.Input.Events
8785
86+import GHC.Generics
87+
8888import System.Directory (getAppUserDataDirectory)
8989import System.Posix.Env (getEnv)
9090import System.Posix.IO (stdInput, stdOutput)
@@ -152,8 +152,6 @@ instance Monoid Config where
152152 , termName = termName c1 <|> termName c0
153153 }
154154
155−type ConfigParser s a = ParsecT s () (Writer Config) a
156−
157155-- | Config from @'getAppUserDataDirectory'/config@ and @$VTY_CONFIG_FILE@
158156userConfig :: IO Config
159157userConfig = do
@@ -184,111 +182,99 @@ parseConfigFile path = do
184182 catch (runParseConfig path <$> BS.readFile path)
185183 (\(_ :: IOException) -> return def)
186184
187−runParseConfig :: Stream s (Writer Config) Char => String -> s -> Config
188−runParseConfig name = execWriter . runParserT parseConfig () name
185+type Parser = Parsec BS.ByteString ()
186+
187+runParseConfig :: String -> BS.ByteString -> Config
188+runParseConfig name cfgTxt =
189+ case runParser parseConfig () name cfgTxt of
190+ Right cfg -> cfg
191+ Left{} -> def
189192
190193-- I tried to use the haskellStyle here but that was specialized (without requirement?) to the
191194-- String stream type.
192−configLanguage :: Stream s m Char => P.GenLanguageDef s u m
195+configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m
193196configLanguage = LanguageDef
194− { commentStart = "{-"
195− , commentEnd = "-}"
196− , commentLine = "--"
197− , nestedComments = True
198− , identStart = letter <|> char '_'
199− , identLetter = alphaNum <|> oneOf "_'"
200− , opStart = opLetter configLanguage
201− , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
197+ { commentStart = "{-"
198+ , commentEnd = "-}"
199+ , commentLine = "--"
200+ , nestedComments = True
201+ , identStart = letter <|> char '_'
202+ , identLetter = alphaNum <|> oneOf "_'"
203+ , opStart = opLetter configLanguage
204+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
202205 , reservedOpNames = []
203− , reservedNames = []
204− , caseSensitive = True
206+ , reservedNames = []
207+ , caseSensitive = True
205208 }
206209
207−configLexer :: Stream s m Char => P.GenTokenParser s u m
210+configLexer :: Monad m => P.GenTokenParser BS.ByteString () m
208211configLexer = P.makeTokenParser configLanguage
209212
210−mapDecl :: forall s u (m :: * -> *).
211− (Monad m, Stream s (WriterT Config m) Char) =>
212− ParsecT s u (WriterT Config m) ()
213+mapDecl :: Parser Config
213214mapDecl = do
214− void $ string "map"
215− P.whiteSpace configLexer
215+ "map" <- P.identifier configLexer
216216 termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing)
217217 <|> (Just <$> P.stringLiteral configLexer)
218− bytes <- P.stringLiteral configLexer
219− key <- parseKey
220− modifiers <- parseModifiers
221− lift $ tell $ def { inputMap = [(termIdent, bytes, EvKey key modifiers)] }
222−
223−-- TODO: Generated by a vim macro. There is a better way here. Derive parser? Use Read
224−-- instance? Generics?
225−parseKey :: forall s u (m :: * -> *).
226− Stream s m Char =>
227− ParsecT s u m Key
228−parseKey = do
229− key <- P.identifier configLexer
230− case key of
231− "KChar" -> KChar <$> P.charLiteral configLexer
232− "KFun" -> KFun . fromInteger <$> P.natural configLexer
233− "KEsc" -> return KEsc
234− "KBS" -> return KBS
235− "KEnter" -> return KEnter
236− "KLeft" -> return KLeft
237− "KRight" -> return KRight
238− "KUp" -> return KUp
239− "KDown" -> return KDown
240− "KUpLeft" -> return KUpLeft
241− "KUpRight" -> return KUpRight
242− "KDownLeft" -> return KDownLeft
243− "KDownRight" -> return KDownRight
244− "KCenter" -> return KCenter
245− "KBackTab" -> return KBackTab
246− "KPrtScr" -> return KPrtScr
247− "KPause" -> return KPause
248− "KIns" -> return KIns
249− "KHome" -> return KHome
250− "KPageUp" -> return KPageUp
251− "KDel" -> return KDel
252− "KEnd" -> return KEnd
253− "KPageDown" -> return KPageDown
254− "KBegin" -> return KBegin
255− "KMenu" -> return KMenu
256− _ -> fail $ key ++ " is not a valid key identifier"
257−
258−parseModifiers :: forall s u (m :: * -> *).
259− Stream s m Char =>
260− ParsecT s u m [Modifier]
261−parseModifiers = P.brackets configLexer (parseModifier `sepBy` P.symbol configLexer ",")
262−
263−parseModifier :: forall s u (m :: * -> *).
264− Stream s m Char =>
265− ParsecT s u m Modifier
266−parseModifier = do
267− m <- P.identifier configLexer
268− case m of
269− "MShift" -> return MShift
270− "MCtrl" -> return MCtrl
271− "MMeta" -> return MMeta
272− "MAlt" -> return MAlt
273− _ -> fail $ m ++ " is not a valid modifier identifier"
274−
275−debugLogDecl :: forall s u (m :: * -> *).
276− (Monad m, Stream s (WriterT Config m) Char) =>
277− ParsecT s u (WriterT Config m) ()
218+ bytes <- P.stringLiteral configLexer
219+ key <- parseValue
220+ modifiers <- parseValue
221+ return def { inputMap = [(termIdent, bytes, EvKey key modifiers)] }
222+
223+debugLogDecl :: Parser Config
278224debugLogDecl = do
279− void $ string "debugLog"
280− P.whiteSpace configLexer
281− path <- P.stringLiteral configLexer
282− lift $ tell $ def { debugLog = Just path }
225+ "debugLog" <- P.identifier configLexer
226+ path <- P.stringLiteral configLexer
227+ return def { debugLog = Just path }
283228
284−ignoreLine :: forall s u (m :: * -> *).
285− Stream s m Char => ParsecT s u m ()
229+ignoreLine :: Parser ()
286230ignoreLine = void $ manyTill anyChar newline
287231
288−parseConfig :: forall s u (m :: * -> *).
289− (Monad m, Stream s (WriterT Config m) Char) =>
290− ParsecT s u (WriterT Config m) ()
291−parseConfig = void $ many $ do
232+parseConfig :: Parser Config
233+parseConfig = liftM mconcat $ many $ do
292234 P.whiteSpace configLexer
293− let directives = [mapDecl, debugLogDecl]
294− try (choice directives) <|> ignoreLine
235+ let directives = [try mapDecl, try debugLogDecl]
236+ choice directives <|> (ignoreLine >> return def)
237+
238+class Parse a where parseValue :: Parser a
239+instance Parse Char where parseValue = P.charLiteral configLexer
240+instance Parse Int where parseValue = fromInteger <$> P.natural configLexer
241+instance Parse Key where parseValue = genericParse
242+instance Parse Modifier where parseValue = genericParse
243+instance Parse a => Parse [a] where
244+ parseValue = P.brackets configLexer
245+ (parseValue `sepBy` P.symbol configLexer ",")
246+
247+------------------------------------------------------------------------
248+-- Derived parser for ADTs via generics
249+------------------------------------------------------------------------
250+
251+genericParse :: (Generic a, GParse (Rep a)) => Parser a
252+genericParse = to <$> gparse
253+
254+class GParse f where gparse :: Parser (f a)
255+instance GParse f => GParse (M1 S i f) where gparse = M1 <$> gparse
256+instance GParse U1 where gparse = return U1
257+instance Parse a => GParse (K1 i a) where gparse = K1 <$> parseValue
258+
259+instance (GParse f, GParse g) => GParse (f :*: g) where
260+ gparse = (:*:) <$> gparse <*> gparse
261+
262+instance GParseAlts f => GParse (M1 D i f) where
263+ gparse =
264+ do con <- P.identifier configLexer
265+ M1 <$> gparseAlts con
266+
267+------------------------------------------------------------------------
268+
269+class GParseAlts f where
270+ gparseAlts :: String -> Parser (f a)
271+
272+instance (Constructor i, GParse f) => GParseAlts (M1 C i f) where
273+ gparseAlts con =
274+ do guard (con == conName (M1 Nothing :: C1 i Maybe a))
275+ M1 <$> gparse
276+
277+instance (GParseAlts f, GParseAlts g) => GParseAlts (f :+: g) where
278+ gparseAlts con = L1 <$> gparseAlts con <|> R1 <$> gparseAlts con
279+
280+instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1"