diff --git a/src/Data/Terminfo/Parse.hs b/src/Data/Terminfo/Parse.hs index 9904e53..32b1f38 100644 --- a/src/Data/Terminfo/Parse.hs +++ b/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 diff --git a/src/Graphics/Vty.hs b/src/Graphics/Vty.hs index e194729..d63d6db 100644 --- a/src/Graphics/Vty.hs +++ b/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 diff --git a/src/Graphics/Vty/Config.hs b/src/Graphics/Vty/Config.hs index 3f8a0ce..2f4537b 100644 --- a/src/Graphics/Vty/Config.hs +++ b/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 diff --git a/src/Graphics/Vty/Input.hs b/src/Graphics/Vty/Input.hs index 7b831b0..da60174 100644 --- a/src/Graphics/Vty/Input.hs +++ b/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 diff --git a/src/Graphics/Vty/Input/Terminfo.hs b/src/Graphics/Vty/Input/Terminfo.hs index f4fac26..85bf508 100644 --- a/src/Graphics/Vty/Input/Terminfo.hs +++ b/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 diff --git a/test/VerifyConfig.hs b/test/VerifyConfig.hs index e771ab3..5340e33 100644 --- a/test/VerifyConfig.hs +++ b/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 diff --git a/vty.cabal b/vty.cabal index bbdb5fe..2dc3774 100644 --- a/vty.cabal +++ b/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