58f0216 · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

Implement the configuration parser using generics

58f0216Eric Mertens10 years ago

src/Graphics/Vty/Config.hs+84−98

compare with master

unifiedsplit

@@ -1,7 +1,7 @@

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}

3−{-# LANGUAGE NoMonomorphismRestriction #-}

3+{-# LANGUAGE TypeOperators #-}

4−{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5-- | A 'Config' can be provided to mkVty to customize the applications use of vty. A config file can

6-- be used to customize vty for a user's system.

7--

@@ -75,9 +75,7 @@ import Prelude hiding (catch)

75import Control.Applicative hiding (many)

77import Control.Exception (catch, IOException)

78−import Control.Monad (void)

78+import Control.Monad (liftM, guard, void)

79−import Control.Monad.Trans.Class

80−import Control.Monad.Trans.Writer

82import qualified Data.ByteString as BS

80import qualified Data.ByteString as BS

83import Data.Default

81import Data.Default

@@ -85,6 +83,8 @@ import Data.Monoid

86import Graphics.Vty.Input.Events

84import Graphics.Vty.Input.Events

86+import GHC.Generics

87+

88import System.Directory (getAppUserDataDirectory)

89import System.Posix.Env (getEnv)

90import System.Posix.IO (stdInput, stdOutput)

@@ -152,8 +152,6 @@ instance Monoid Config where

152 , termName = termName c1 <|> termName c0

153 }

154

155−type ConfigParser s a = ParsecT s () (Writer Config) a

156−

157-- | Config from @'getAppUserDataDirectory'/config@ and @$VTY_CONFIG_FILE@

155-- | Config from @'getAppUserDataDirectory'/config@ and @$VTY_CONFIG_FILE@

158userConfig :: IO Config

156userConfig :: IO Config

159userConfig = do

157userConfig = do

@@ -184,111 +182,99 @@ parseConfigFile path = do

184 catch (runParseConfig path <$> BS.readFile path)

182 catch (runParseConfig path <$> BS.readFile path)

185 (\(_ :: IOException) -> return def)

183 (\(_ :: IOException) -> return def)

186

184

185+type Parser = Parsec BS.ByteString ()

186+

187−runParseConfig :: Stream s (Writer Config) Char => String -> s -> Config

187+runParseConfig :: String -> BS.ByteString -> Config

188−runParseConfig name = execWriter . runParserT parseConfig () name

188+runParseConfig name cfgTxt =

189+ case runParser parseConfig () name cfgTxt of

190+ Right cfg -> cfg

191+ Left{} -> def

189

192

190-- I tried to use the haskellStyle here but that was specialized (without requirement?) to the

193-- I tried to use the haskellStyle here but that was specialized (without requirement?) to the

191-- String stream type.

194-- String stream type.

192−configLanguage :: Stream s m Char => P.GenLanguageDef s u m

195+configLanguage :: Monad m => P.GenLanguageDef BS.ByteString () m

193configLanguage = LanguageDef

196configLanguage = LanguageDef

194− { commentStart = "{-"

197+ { commentStart = "{-"

195− , commentEnd = "-}"

198+ , commentEnd = "-}"

196− , commentLine = "--"

199+ , commentLine = "--"

197− , nestedComments = True

200+ , nestedComments = True

198− , identStart = letter <|> char '_'

201+ , identStart = letter <|> char '_'

199− , identLetter = alphaNum <|> oneOf "_'"

202+ , identLetter = alphaNum <|> oneOf "_'"

200− , opStart = opLetter configLanguage

203+ , opStart = opLetter configLanguage

201− , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"

204+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"

202 , reservedOpNames = []

205 , reservedOpNames = []

203− , reservedNames = []

206+ , reservedNames = []

204− , caseSensitive = True

207+ , caseSensitive = True

205 }

208 }

206

209

207−configLexer :: Stream s m Char => P.GenTokenParser s u m

210+configLexer :: Monad m => P.GenTokenParser BS.ByteString () m

208configLexer = P.makeTokenParser configLanguage

211configLexer = P.makeTokenParser configLanguage

209

212

210−mapDecl :: forall s u (m :: * -> *).

213+mapDecl :: Parser Config

211− (Monad m, Stream s (WriterT Config m) Char) =>

212− ParsecT s u (WriterT Config m) ()

213mapDecl = do

214mapDecl = do

214− void $ string "map"

215− P.whiteSpace configLexer

215+ "map" <- P.identifier configLexer

216 termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing)

217 <|> (Just <$> P.stringLiteral configLexer)

218− bytes <- P.stringLiteral configLexer

218+ bytes <- P.stringLiteral configLexer

219− key <- parseKey

219+ key <- parseValue

220− modifiers <- parseModifiers

220+ modifiers <- parseValue

221− lift $ tell $ def { inputMap = [(termIdent, bytes, EvKey key modifiers)] }

221+ return def { inputMap = [(termIdent, bytes, EvKey key modifiers)] }

222−

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 :: * -> *).

223+debugLogDecl :: Parser Config

276− (Monad m, Stream s (WriterT Config m) Char) =>

277− ParsecT s u (WriterT Config m) ()

278debugLogDecl = do

224debugLogDecl = do

279− void $ string "debugLog"

280− P.whiteSpace configLexer

225+ "debugLog" <- P.identifier configLexer

281− path <- P.stringLiteral configLexer

226+ path <- P.stringLiteral configLexer

282− lift $ tell $ def { debugLog = Just path }

227+ return def { debugLog = Just path }

283

228

284−ignoreLine :: forall s u (m :: * -> *).

229+ignoreLine :: Parser ()

285− Stream s m Char => ParsecT s u m ()

286ignoreLine = void $ manyTill anyChar newline

230ignoreLine = void $ manyTill anyChar newline

287

231

288−parseConfig :: forall s u (m :: * -> *).

232+parseConfig :: Parser Config

289− (Monad m, Stream s (WriterT Config m) Char) =>

290− ParsecT s u (WriterT Config m) ()

291−parseConfig = void $ many $ do

233+parseConfig = liftM mconcat $ many $ do

292 P.whiteSpace configLexer

234 P.whiteSpace configLexer

293 let directives = [mapDecl, debugLogDecl]

235 let directives = [mapDecl, debugLogDecl]

294− try (choice directives) <|> ignoreLine

236+ try (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"

src/Graphics/Vty/Input/Events.hs+6−4

@@ -1,6 +1,8 @@

1+{-# Language DeriveGeneric #-}

1module Graphics.Vty.Input.Events where

2module Graphics.Vty.Input.Events where

3import Data.ByteString

4import Data.ByteString

5+import GHC.Generics

5-- | Representations of non-modifier keys.

7-- | Representations of non-modifier keys.

6--

8--

@@ -15,17 +17,17 @@ data Key = KEsc | KChar Char | KBS | KEnter

18− deriving (Eq,Show,Read,Ord)

20+ deriving (Eq,Show,Read,Ord,Generic)

20-- | Modifier keys. Key codes are interpreted such that users are more likely to

22-- | Modifier keys. Key codes are interpreted such that users are more likely to

21-- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will

23-- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will

22-- generally correspond to the physical Alt key.

24-- generally correspond to the physical Alt key.

23data Modifier = MShift | MCtrl | MMeta | MAlt

25data Modifier = MShift | MCtrl | MMeta | MAlt

24− deriving (Eq,Show,Read,Ord)

26+ deriving (Eq,Show,Read,Ord,Generic)

26-- | Mouse buttons.

28-- | Mouse buttons.

27data Button = BLeft | BMiddle | BRight

29data Button = BLeft | BMiddle | BRight

28− deriving (Eq,Show,Read,Ord)

30+ deriving (Eq,Show,Read,Ord,Generic)

30-- | Events.

32-- | Events.

31data Event

33data Event

@@ -52,6 +54,6 @@ data Event

52 -- input (which is probably bad, so beware!) Note that the data is

54 -- input (which is probably bad, so beware!) Note that the data is

53 -- provided in raw form and you'll have to decode (e.g. as UTF-8) if

55 -- provided in raw form and you'll have to decode (e.g. as UTF-8) if

54 -- that's what your application expects.

56 -- that's what your application expects.

55− deriving (Eq,Show,Read,Ord)

57+ deriving (Eq,Show,Read,Ord,Generic)

57type ClassifyMap = [(String,Event)]

59type ClassifyMap = [(String,Event)]