add config parser and test

src/Data/Terminfo/Parse.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# OPTIONS_GHC -funbox-strict-fields -O #-}
 module Data.Terminfo.Parse ( module Data.Terminfo.Parse
-                           , Text.ParserCombinators.Parsec.ParseError
+                           , Text.Parsec.ParseError
                            )
     where
 
@@ -106,7 +106,7 @@ constructCapExpression capString buildResults =
                 } 
     in rnf expr `seq` expr
 
-type CapParser a = GenParser Char BuildState a 
+type CapParser a = Parsec String BuildState a 
 
 capExpressionParser :: CapParser BuildResults
 capExpressionParser = do

src/Graphics/Vty.hs

@@ -33,6 +33,7 @@ module Graphics.Vty ( Vty(..)
 
 import Graphics.Vty.Prelude
 
+import Graphics.Vty.Config
 import Graphics.Vty.Input
 import Graphics.Vty.Output
 import Graphics.Vty.Picture
@@ -40,6 +41,7 @@ import Graphics.Vty.Picture
 import Control.Concurrent
 
 import Data.IORef
+import Data.Monoid
 
 -- | The main object.  At most one should be created.
 --
@@ -81,8 +83,14 @@ data Vty = Vty
 
 -- | Set up the state object for using vty.  At most one state object should be
 -- created at a time.
+--
+-- The specified config is added to the 'userConfig'. With the 'userConfig' taking precedence.
+-- See "Graphics.Vty.Config"
+--
+-- For most applications `mkVty def` is sufficient.
 mkVty :: Config -> IO Vty
-mkVty config = do
+mkVty appConfig = do
+    config <- mappend <$> pure appConfig <*> userConfig
     input <- inputForCurrentTerminal config
     out <- outputForCurrentTerminal
     intMkVty input out

src/Graphics/Vty/Config.hs

@@ -1,53 +1,170 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 -- | A 'Config' can be provided to mkVty to customize the applications use of vty.
 --
--- Parts of the structure can be overriden by $HOME/.config/vty.config and then $VTY_CONFIG_FILE.
+-- The 'Config' provided is mappend'd to 'Config's loaded from $HOME/.config/vty.config and
+-- $VTY_CONFIG_FILE. The $VTY_CONFIG_FILE takes precedence over the input.conf file or the
+-- application provided 'Config'.
+-- 
+-- Each line of the input config is processed individually. Lines that fail to parse are ignored.
+-- Later entries take precedence over earlier.
 --
--- See also 'classifyTableUserOverrides'.
+-- * Classify Table Overrides - "map"
+--
+-- Directive format:
+--
+-- @
+--  entry := "map" string key modifier_list
+--  key := KEsc | KChar Char | KBS ... (same as 'Key')
+--  modifier_list := "[" modifier+ "]"
+--  modifier := MShift | MCtrl | MMeta | MAlt
+--  string := "\"" chars+ "\""
+-- @
+--
+-- EG: If the contents of input.conf are
+--
+-- @
+--  map "\ESC[B" KUp []
+--  map "\ESC[1;3B" KDown [MAlt]
+-- @
+--
+-- Then the bytes "\ESC[B" will result in the KUp event. The bytes "\ESC[1;3B" will result in the
+-- event KDown with the MAlt modifier.
 --
 module Graphics.Vty.Config where
 
+import Control.Applicative hiding (many)
+
+import Control.Monad (void)
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Writer
+
+import qualified Data.ByteString as BS
 import Data.Default
-import Data.Either (either)
 import Data.Monoid
 
 import Graphics.Vty.Input.Events
 
-import System.FilePath
-
-import Text.Parsec
+import Text.Parsec hiding ((<|>))
+import Text.Parsec.Token ( GenLanguageDef(..) )
 import qualified Text.Parsec.Token as P
-import Text.Parsec.Language (haskellDef)
 
 data Config = Config
-    { singleEscPeriod   :: Int            -- ^ AKA VTIME. The default is 100000 microseconds or 0.1 seconds.
+    { specifiedEscPeriod :: Maybe Int            
     -- | Debug information about the input process is appended to the file.
-    , debugInputLog     :: Maybe FilePath
-    , inputOverrides    :: ClassifyTable
+    , debugInputLog      :: Maybe FilePath
+    , inputOverrides     :: ClassifyTable
     } deriving (Show, Eq)
 
+-- | AKA VTIME. The default is 100000 microseconds or 0.1 seconds. 
+singleEscPeriod :: Config -> Int
+singleEscPeriod = maybe 100000 id . specifiedEscPeriod
+
 instance Default Config where
     def = Config
-        { singleEscPeriod = 100000
-        , debugInputLog = Nothing
-        , inputOverrides = []
+        { specifiedEscPeriod = Nothing
+        , debugInputLog      = Nothing
+        , inputOverrides     = []
         }
 
--- not a proper monoid but useful as one.
 instance Monoid Config where
     mempty = def
-    mappend c0 c1 = c1 { inputOverrides = inputOverrides c0 <> inputOverrides c1 }
+    mappend c0 c1 = Config
+        -- latter config takes priority in specifiedEscPeriod
+        { specifiedEscPeriod = specifiedEscPeriod c1 <|> specifiedEscPeriod c0
+        -- latter config takes priority in debugInputLog
+        , debugInputLog = debugInputLog c1 <|> debugInputLog c0
+        , inputOverrides = inputOverrides c0 <> inputOverrides c1
+        }
+
+type ConfigParser s a = ParsecT s () (Writer Config) a
+
+userConfig :: IO Config
+userConfig = do
+    userGlobalConfig <- parseConfigFile "$HOME/.config/vty.config"
+    overrideConfig <- parseConfigFile "$VTY_CONFIG_FILE"
+    return $ userGlobalConfig `mappend` overrideConfig
 
 parseConfigFile :: FilePath -> IO Config
-parseConfigFile path = either (const def) id <$> parseFromFile parseConfig path
+parseConfigFile path = runParseConfig path <$> BS.readFile path
 
-parseConfig = do
-    let lexer = P.makeTokenParser haskellDef
-        parseOverride = do
-            P.whiteSpace lexer
-            string "map"
-            P.whiteSpace lexer
-            bytes <- P.stringLiteral
-            key <- parseKey
-            modifier <- parseModifier
-            _ <- manyTill space newline
-    overrides <- many $ try parseOverride <|> ignoreOverride
+runParseConfig :: Stream s (Writer Config) Char => String -> s -> Config
+runParseConfig name = execWriter . runParserT parseConfig () name
+
+-- I tried to use the haskellStyle here but that was specialized (without requirement?) to the
+-- String stream type.
+configLanguage :: Stream s m Char => P.GenLanguageDef s u m
+configLanguage = LanguageDef
+    { commentStart = "{-"
+    , commentEnd = "-}"
+    , commentLine = "--"
+    , nestedComments = True
+    , identStart = letter <|> char '_'
+    , identLetter = alphaNum <|> oneOf "_'"
+    , opStart = opLetter configLanguage
+    , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+    , reservedOpNames = []
+    , reservedNames = []
+    , caseSensitive = True
+    }
+
+configLexer :: Stream s m Char => P.GenTokenParser s u m
+configLexer = P.makeTokenParser configLanguage
+
+parseOverride = do
+    void $ string "map"
+    P.whiteSpace configLexer
+    bytes <- P.stringLiteral configLexer
+    key <- parseKey
+    modifiers <- parseModifiers
+    lift $ tell $ def { inputOverrides = [(bytes, EvKey key modifiers)] }
+
+parseKey = do
+    key <- P.identifier configLexer
+    case key of
+     "KChar" -> KChar <$> P.charLiteral configLexer
+     "KFun" -> KFun . fromInteger <$> P.natural configLexer
+     "KEsc" -> return KEsc
+     "KBS" -> return KBS
+     "KEnter" -> return KEnter
+     "KLeft" -> return KLeft
+     "KRight" -> return KRight
+     "KUp" -> return KUp
+     "KDown" -> return KDown
+     "KUpLeft" -> return KUpLeft
+     "KUpRight" -> return KUpRight
+     "KDownLeft" -> return KDownLeft
+     "KDownRight" -> return KDownRight
+     "KCenter" -> return KCenter
+     "KBackTab" -> return KBackTab
+     "KPrtScr" -> return KPrtScr
+     "KPause" -> return KPause
+     "KIns" -> return KIns
+     "KHome" -> return KHome
+     "KPageUp" -> return KPageUp
+     "KDel" -> return KDel
+     "KEnd" -> return KEnd
+     "KPageDown" -> return KPageDown
+     "KBegin" -> return KBegin
+     "KMenu" -> return KMenu
+     _ -> fail $ key ++ " is not a valid key identifier"
+
+parseModifiers = P.brackets configLexer (parseModifier `sepBy` P.symbol configLexer ",")
+
+parseModifier = do
+    m <- P.identifier configLexer
+    case m of
+        "KMenu" -> return MShift
+        "MCtrl" -> return MCtrl
+        "MMeta" -> return MMeta
+        "MAlt" -> return MAlt
+        _ -> fail $ m ++ " is not a valid modifier identifier"
+
+ignoreLine = void $ manyTill anyChar newline
+
+-- TODO: Generated by a vim macro. There is a better way here. Derive parser? Use Read
+-- instance?
+parseConfig = void $ many $ do
+    P.whiteSpace configLexer
+    let directives = [parseOverride]
+    try (choice directives) <|> ignoreLine

src/Graphics/Vty/Input.hs

@@ -34,19 +34,16 @@ module Graphics.Vty.Input ( Key(..)
                           , Button(..)
                           , Event(..)
                           , Input(..)
-                          , Config(..)
                           , inputForCurrentTerminal
                           , inputForNameAndIO
                           )
     where
 
 import Graphics.Vty.Config
-import Graphics.Vty.Input.Classify
 import Graphics.Vty.Input.Events
 import Graphics.Vty.Input.Loop
 import Graphics.Vty.Input.Terminfo
 
-import Control.Applicative
 import Control.Concurrent
 import Control.Lens
 
@@ -96,8 +93,7 @@ inputForCurrentTerminal config = do
 inputForNameAndIO :: Config -> String -> Fd -> IO Input
 inputForNameAndIO config termName termFd = do
     terminal <- Terminfo.setupTerm termName
-    classifyTable <- mappend <$> pure (classifyTableForTerm termName terminal)
-                             <*> classifyTableUserOverrides
+    let classifyTable = classifyTableForTerm termName terminal `mappend` inputOverrides config
     (setAttrs,unsetAttrs) <- attributeControl termFd
     setAttrs
     input <- initInputForFd config classifyTable termFd 

src/Graphics/Vty/Input/Terminfo.hs

@@ -40,36 +40,6 @@ classifyTableForTerm termName term =
            : universalTable
            : termSpecificTables termName
 
--- | The user can specify a list of classify table entries in $HOME/.config/vty.conf and
--- $VTY_CONFIG_FILE. The file at $VTY_CONFIG_FILE takes precedence over the input.conf file. Both
--- take precedence over the classify tables determined by 'classifyTableForTerm'
--- 
--- Each line of the input config is processed individually. Lines that fail to parse are ignored.
--- Later entries take precedence over earlier.
---
--- Entry format:
---
--- @
---  entry := "map" string key modifier_list
---  key := KEsc | KChar Char | KBS ... (same as 'Key')
---  modifier_list := "[" modifier+ "]"
---  modifier := MShift | MCtrl | MMeta | MAlt
---  string := "\"" chars+ "\""
--- @
---
--- EG: If the contents of input.conf are
---
--- @
---  map "\ESC[B" KUp []
---  map "\ESC[1;3B" KDown [MAlt]
--- @
---
--- Then the bytes "\ESC[B" will result in the KUp event. The bytes "\ESC[1;3B" will result in the
--- event KDown with the MAlt modifier.
---
-classifyTableUserOverrides :: IO ClassifyTable
-classifyTableUserOverrides = return []
-
 -- | key table assumed to be applicable to all terminals.
 universalTable :: ClassifyTable
 universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys]
@@ -103,9 +73,9 @@ visibleChars = [ ([x], EvKey (KChar x) [])
 ctrlChars :: ClassifyTable
 ctrlChars =
     [ ([toEnum x],EvKey (KChar y) [MCtrl])
-    | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),
-      y /= 'i', -- Resolve issue #3 where CTRL-i hides TAB.
-      y /= 'h'  -- CTRL-h should not hide BS
+    | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])
+    , y /= 'i'  -- Resolve issue #3 where CTRL-i hides TAB.
+    , y /= 'h'  -- CTRL-h should not hide BS
     ]
 
 -- | Ctrl+Meta+Char

test/VerifyConfig.hs

@@ -2,6 +2,7 @@
 module Main where
 
 import Graphics.Vty.Config
+import Graphics.Vty.Input.Events
 
 import Control.Applicative
 import Control.Exception
@@ -19,12 +20,23 @@ import Text.Printf
 
 exampleConfig :: String
 exampleConfig = [s|
+-- comments should be ignored.
 map "\ESC[B" KUp []
+askfjla dfasjdflk jasdlkfj asdfj -- lines failing parse should be ignored
 map "\ESC[1;3B" KDown [MAlt]
 |]
 
+exampleConfigConfig :: Config
+exampleConfigConfig = Config
+    { specifiedEscPeriod = def
+    , debugInputLog = def
+    , inputOverrides = [("\ESC[B", EvKey KUp []), ("\ESC[1;3B", EvKey KDown [MAlt])]
+    }
+
 exampleConfigParses :: IO ()
-exampleConfigParses = return ()
+exampleConfigParses = assertEqual "example config parses as expected"
+                                  exampleConfigConfig
+                                  (runParseConfig "exampleConfig" exampleConfig)
 
 main :: IO ()
 main = defaultMain

vty.cabal

@@ -113,7 +113,7 @@ library
 
   ghc-prof-options:    -O2 -funbox-strict-fields -threaded -caf-all -Wall -fspec-constr -fspec-constr-count=10
 
-  cc-options:          -O2
+  cc-options:          -O2 -fpic
 
 test-suite verify-attribute-ops
   default-language:    Haskell2010