0e772f7 · vty · git.iko.soy

git.iko.soy/vty

add support for matching a specific terminal to input map config. cleanup

commit0e772f7361795df093b4c53b453a0cadc418da3f authorCorey O'Connor <coreyoconnor@gmail.com> dateWed 4 Jun 2014, 23:26 (12 years ago) parentcf3d3c4

10 files changed+75−64

compare with master

unifiedsplit

CHANGELOG+7−7 src/Graphics/Vty/Config.hs+17−15 src/Graphics/Vty/Input.hs+5−3 src/Graphics/Vty/Input/Classify.hs+5−4 src/Graphics/Vty/Input/Events.hs+1 src/Graphics/Vty/Input/Loop.hs+10−9 src/Graphics/Vty/Input/Terminfo.hs+13−13 src/Graphics/Vty/Input/Terminfo/ANSIVT.hs+7−7 test/VerifyConfig.hs+5−1 test/VerifyUsingMockInput.hs+5−5

CHANGELOG+7−7

@@ -9,13 +9,13 @@

99 * KASCII is now KChar

1010 * KPN5 is now KCenter

1111 * tests exist.

12− * Applications add to the input tables by setting inputOverrides of the Config.

12+ * Applications can add to the input tables by setting inputMap of the Config.

1313 See Graphics.Vty.Config

1414 * Users can define input table extensions that will apply to all vty applications.

1515 See Graphics.Vty.Config

1616 * terminal timing is now handled by selecting an appropriate VTIME. Previously this was

1717 implemented within Vty itself. This reduced complexity in vty but provides a different

18− meta key behavior. There were no know users of the previous behavior.

18+ meta key behavior and implies a requirement on -threaded.

1919 * The time vty will wait to verify an ESC byte means a single ESC key is the

2020 singleEscPeriod of the Input Config structure.

2121 * removed the typeclass based terminal and display context interface in favor of a data

@@ -29,8 +29,8 @@

2929 * Each layer is an image.

3030 * The layers for a picture are a list of images.

3131 * The first image is the top-most layer. The images are ordered from top to bottom.

32− * The transparent areas for a layer are the backgroundFill areas. These will be implicitly

33− added to to pad images when images of different sizes are joined.

32+ * The transparent areas for a layer are the backgroundFill areas. backgroundFill is

33+ added to pad images when images of different sizes are joined.

3434 * If the background is clear there is no background layer.

3535 * If there is a background character then the bottom layer is the background layer.

3636 * emptyPicture is a Picture with no layers and no cursor

@@ -45,8 +45,8 @@

4545 events.

4646 * Additional information about input and output process can be appended to a debug log

4747 * Set environment variable VTY_DEBUG_LOG to path of debug log

48− * Use "debugLog <path>" config directive

49− * Set 'debugLog' property of Config

48+ * Or use "debugLog <path>" config directive

49+ * Or set 'debugLog' property of the Config provided to mkVty.

5050 * examples moved to vty-examples package. See test directory for cabal file.

5151 * vty-interactive-terminal-test

5252 * interactive test. Useful for building a bug report for vty's author.

@@ -55,7 +55,7 @@

5555 * view a input event log for vty. Example of interacting with user.

5656 * test/EventEcho.hs

5757 * vty-rouge

58− * A bad rouge-like game. Example of layers and image build operations.

58+ * The start of a rouge-like game. Example of layers and image build operations.

5959 * test/Rouge.hs

6060 * vty-benchmark

6161 * benchmarks vty. A series of tests that push random pictures to the terminal. The

src/Graphics/Vty/Config.hs+17−15

@@ -109,20 +109,20 @@ singleEscPeriod :: Config -> Int

109109singleEscPeriod = maybe 100000 id . specifiedEscPeriod

110110

111111instance Default Config where

112− def = Config

113− { specifiedEscPeriod = Nothing

114− , debugLog = Nothing

115− , inputOverrides = []

116− }

112+ def = mempty

117113

118114instance Monoid Config where

119− mempty = def

115+ mempty = Config

116+ { specifiedEscPeriod = Nothing

117+ , debugLog = mempty

118+ , inputMap = mempty

119+ }

120120 mappend c0 c1 = Config

121121 -- latter config takes priority in specifiedEscPeriod

122122 { specifiedEscPeriod = specifiedEscPeriod c1 <|> specifiedEscPeriod c0

123123 -- latter config takes priority in debugInputLog

124− , debugLog = debugLog c1 <|> debugLog c0

125− , inputOverrides = inputOverrides c0 <> inputOverrides c1

124+ , debugLog = debugLog c1 <|> debugLog c0

125+ , inputMap = inputMap c0 <> inputMap c1

126126 }

127127

128128type ConfigParser s a = ParsecT s () (Writer Config) a

@@ -130,12 +130,13 @@ type ConfigParser s a = ParsecT s () (Writer Config) a

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

131131userConfig :: IO Config

132132userConfig = do

133− userConfig <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile

134− overridePath <- tryJust (guard . isDoesNotExistError) $ getEnv "VTY_CONFIG_FILE"

133+ configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile

134+ let maybeEnv = tryJust (guard . isDoesNotExistError) . getEnv

135+ overridePath <- maybeEnv "VTY_CONFIG_FILE"

135136 overrideConfig <- either (const $ return def) parseConfigFile overridePath

136− debugLogPath <- tryJust (guard . isDoesNotExistError) $ getEnv "VTY_DEBUG_LOG"

137+ debugLogPath <- maybeEnv "VTY_DEBUG_LOG"

137138 let debugLogConfig = either (const def) (\p -> def { debugLog = Just p }) debugLogPath

138− return $ mconcat [userConfig, overrideConfig, debugLogConfig]

139+ return $ mconcat [configFile, overrideConfig, debugLogConfig]

139140

140141parseConfigFile :: FilePath -> IO Config

141142parseConfigFile path = do

@@ -168,14 +169,15 @@ configLexer = P.makeTokenParser configLanguage

168169mapDecl = do

169170 void $ string "map"

170171 P.whiteSpace configLexer

171− termIdent <- (char "_" >> return Nothing) <|> (Just <$> P.stringLiteral configLexer)

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

173+ <|> (Just <$> P.stringLiteral configLexer)

172174 bytes <- P.stringLiteral configLexer

173175 key <- parseKey

174176 modifiers <- parseModifiers

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

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

176178

177179-- TODO: Generated by a vim macro. There is a better way here. Derive parser? Use Read

178−-- instance?

180+-- instance? Generics?

179181parseKey = do

180182 key <- P.identifier configLexer

181183 case key of

src/Graphics/Vty/Input.hs+5−3

@@ -151,7 +151,8 @@ inputForCurrentTerminal config = do

151151-- | Set up the terminal attached to the given Fd for input. Returns a 'Input'.

152152--

153153-- The table used to determine the 'Events' to produce for the input bytes comes from

154−-- 'classifyTableForTerm'. Which is then overridden by the table from 'classifyTableUserOverrides'.

154+-- 'classifyMapForTerm'. Which is then overridden by the the applicable entries from

155+-- 'inputMap'.

155156--

156157-- The terminal device is configured with the attributes:

157158--

@@ -179,10 +180,11 @@ inputForCurrentTerminal config = do

179180inputForNameAndIO :: Config -> String -> Fd -> IO Input

180181inputForNameAndIO config termName termFd = do

181182 terminal <- Terminfo.setupTerm termName

182− let classifyTable = classifyTableForTerm termName terminal `mappend` inputOverrides config

183+ let inputOverrides = [(s,e) | (t,s,e) <- inputMap config, t == Nothing || t == Just termName]

184+ activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides

183185 (setAttrs,unsetAttrs) <- attributeControl termFd

184186 setAttrs

185− input <- initInputForFd config classifyTable termFd

187+ input <- initInputForFd config termName activeInputMap termFd

186188 let pokeIO = Catch $ do

187189 let e = error "vty internal failure: this value should not propagate to users"

188190 setAttrs

src/Graphics/Vty/Input/Classify.hs+5−4

@@ -3,7 +3,7 @@

33-- I did not write this so I might just rewrite it for better understanding. Which is not the best

44-- of reasons.

55-- TODO: measure and rewrite if required.

6−-- TODO: The ClassifyTable interface requires this code to always assure later entries override

6+-- TODO: The ClassifyMap interface requires this code to always assure later entries override

77-- earlier.

88module Graphics.Vty.Input.Classify where

@@ -25,7 +25,7 @@ data KClass

2525 | Prefix

2626 deriving(Show, Eq)

2727

28−compile :: ClassifyTable -> [Char] -> KClass

28+compile :: ClassifyMap -> [Char] -> KClass

2929compile table = cl' where

3030 -- take all prefixes and create a set of these

3131 prefixSet = S.fromList $ concatMap (init . inits . fst) $ table

@@ -47,10 +47,11 @@ compile table = cl' where

4747 let inputTails = init $ tail $ tails inputBlock

4848 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputTails of

4949 (s,e) : _ -> Valid e (drop (length s) inputBlock)

50− -- neither a prefix or a full event. Might be interesting to log.

50+ -- neither a prefix or a full event.

51+ -- TODO: debug log

5152 [] -> Invalid

5253

53−classify, classifyTab :: ClassifyTable -> [Char] -> KClass

54+classify, classifyTab :: ClassifyMap -> [Char] -> KClass

5455

5556-- As soon as

5657classify _table s@(c:_) | ord c >= 0xC2

src/Graphics/Vty/Input/Events.hs+1

@@ -40,3 +40,4 @@ data Event

4040 | EvResize Int Int

4141 deriving (Eq,Show,Ord)

4242

43+type ClassifyMap = [(String,Event)]

src/Graphics/Vty/Input/Loop.hs+10−9

@@ -145,7 +145,7 @@ stopIfRequested = do

145145 True <- (liftIO . readIORef) =<< use stopRequestRef

146146 return ()

147147

148−runInputProcessorLoop :: ClassifyTable -> Input -> IORef Bool -> IO ()

148+runInputProcessorLoop :: ClassifyMap -> Input -> IORef Bool -> IO ()

149149runInputProcessorLoop classifyTable input stopFlag = do

150150 let bufferSize = 1024

151151 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do

@@ -165,18 +165,19 @@ attributeControl fd = do

165165 unsetAttrs = setTerminalAttributes fd original Immediately

166166 return (setAttrs,unsetAttrs)

167167

168−logClassifyTable :: Input -> ClassifyTable -> IO()

169−logClassifyTable input classifyTable = case _inputDebug input of

168+logClassifyMap :: Input -> String -> ClassifyMap -> IO()

169+logClassifyMap input termName classifyTable = case _inputDebug input of

170170 Nothing -> return ()

171171 Just h -> do

172172 forM_ classifyTable $ \i -> case i of

173− (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s\n" (show inBytes)

174− (show k)

175− (show mods)

173+ (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show termName)

174+ (show inBytes)

175+ (show k)

176+ (show mods)

176177 _ -> return ()

177178

178−initInputForFd :: Config -> ClassifyTable -> Fd -> IO Input

179−initInputForFd config classifyTable inFd = do

179+initInputForFd :: Config -> String -> ClassifyMap -> Fd -> IO Input

180+initInputForFd config termName classifyTable inFd = do

180181 applyTimingConfig inFd config

181182 stopFlag <- newIORef False

182183 input <- Input <$> newChan

@@ -186,7 +187,7 @@ initInputForFd config classifyTable inFd = do

186187 <*> maybe (return Nothing)

187188 (\f -> Just <$> openFile f AppendMode)

188189 (debugLog config)

189− logClassifyTable input classifyTable

190+ logClassifyMap input termName classifyTable

190191 _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag

191192 return input

192193

src/Graphics/Vty/Input/Terminfo.hs+13−13

@@ -33,26 +33,26 @@ import System.Console.Terminfo

3333--

3434-- \todo terminfo meta is not supported.

3535-- \todo no 8bit

36−classifyTableForTerm :: String -> Terminal -> ClassifyTable

37−classifyTableForTerm termName term =

38− concat $ capsClassifyTable term keysFromCapsTable

36+classifyMapForTerm :: String -> Terminal -> ClassifyMap

37+classifyMapForTerm termName term =

38+ concat $ capsClassifyMap term keysFromCapsTable

3939 : universalTable

4040 : termSpecificTables termName

4141

4242-- | key table applicable to all terminals.

4343--

4444-- TODO: some probably only applicable to ANSI/VT100 terminals.

45−universalTable :: ClassifyTable

45+universalTable :: ClassifyMap

4646universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys]

4747

48−capsClassifyTable :: Terminal -> [(String,Event)] -> ClassifyTable

49−capsClassifyTable terminal table = [(x,y) | (Just x,y) <- map extractCap table]

48+capsClassifyMap :: Terminal -> [(String,Event)] -> ClassifyMap

49+capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table]

5050 where extractCap = first (getCapability terminal . tiGetStr)

5151

5252-- | tables specific to a given terminal that are not derivable from terminfo.

5353--

5454-- TODO: Adds the ANSI/VT100/VT50 tables regardless of term identifier.

55−termSpecificTables :: String -> [ClassifyTable]

55+termSpecificTables :: String -> [ClassifyMap]

5656termSpecificTables _termName = ANSIVT.classifyTable

5757

5858-- | Visible characters in the ISO-8859-1 and UTF-8 common set.

@@ -62,7 +62,7 @@ termSpecificTables _termName = ANSIVT.classifyTable

6262--

6363-- TODO: resolve

6464-- 1. start at ' '. The earlier characters are all 'ctrlChar'

65−visibleChars :: ClassifyTable

65+visibleChars :: ClassifyMap

6666visibleChars = [ ([x], EvKey (KChar x) [])

6767 | x <- [' ' .. toEnum 0xC1]

6868 ]

@@ -70,7 +70,7 @@ visibleChars = [ ([x], EvKey (KChar x) [])

7070-- | Non visible characters in the ISO-8859-1 and UTF-8 common set translated to ctrl + char.

7171--

7272-- \todo resolve CTRL-i is the same as tab

73−ctrlChars :: ClassifyTable

73+ctrlChars :: ClassifyMap

7474ctrlChars =

7575 [ ([toEnum x],EvKey (KChar y) [MCtrl])

7676 | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])

@@ -79,11 +79,11 @@ ctrlChars =

7979 ]

8080

8181-- | Ctrl+Meta+Char

82−ctrlMetaChars :: ClassifyTable

82+ctrlMetaChars :: ClassifyMap

8383ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars

8484

8585-- | esc, meta esc, delete, meta delete, enter, meta enter

86−specialSupportKeys :: ClassifyTable

86+specialSupportKeys :: ClassifyMap

8787specialSupportKeys =

8888 [ -- special support for ESC

8989 ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])

@@ -150,7 +150,7 @@ specialSupportKeys =

150150-- * kRIT - shift right

151151--

152152-- * kcuu1 - up

153−keysFromCapsTable :: ClassifyTable

153+keysFromCapsTable :: ClassifyMap

154154keysFromCapsTable =

155155 [ ("ka1", EvKey KUpLeft [])

156156 , ("ka3", EvKey KUpRight [])

@@ -180,5 +180,5 @@ keysFromCapsTable =

180180 ] ++ functionKeyCapsTable

181181

182182-- | cap names for function keys

183−functionKeyCapsTable :: ClassifyTable

183+functionKeyCapsTable :: ClassifyMap

184184functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])

src/Graphics/Vty/Input/Terminfo/ANSIVT.hs+7−7

@@ -10,7 +10,7 @@ import Graphics.Vty.Input.Events

1010-- | Encoding for navigation keys.

1111--

1212-- TODO: This is not the same as the input bytes pulled from teh caps table.

13−navKeys0 :: ClassifyTable

13+navKeys0 :: ClassifyMap

1414navKeys0 =

1515 [ k "G" KCenter

1616 , k "P" KPause

@@ -25,7 +25,7 @@ navKeys0 =

2525 where k c s = ("\ESC["++c,EvKey s [])

2626

2727-- | encoding for shift, meta and ctrl plus arrows/home/end

28−navKeys1 :: ClassifyTable

28+navKeys1 :: ClassifyMap

2929navKeys1 =

3030 [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)

3131 | charCnt <- ["1;", ""], -- we can have a count or not

@@ -35,14 +35,14 @@ navKeys1 =

3535 ]

3636

3737-- | encoding for ins, del, pageup, pagedown, home, end

38−navKeys2 :: ClassifyTable

38+navKeys2 :: ClassifyMap

3939navKeys2 =

4040 let k n s = ("\ESC["++show n++"~",EvKey s [])

4141 in zipWith k [2::Int,3,5,6,1,4]

4242 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]

4343

4444-- | encoding for ctrl + ins, del, pageup, pagedown, home, end

45−navKeys3 :: ClassifyTable

45+navKeys3 :: ClassifyMap

4646navKeys3 =

4747 let k n s = ("\ESC["++show n++";5~",EvKey s [MCtrl])

4848 in zipWith k [2::Int,3,5,6,1,4]

@@ -55,7 +55,7 @@ navKeys3 =

5555-- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html

5656--

5757-- This encoding depends on the terminal.

58−functionKeys1 :: ClassifyTable

58+functionKeys1 :: ClassifyMap

5959functionKeys1 =

6060 let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in

6161 concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]

@@ -69,13 +69,13 @@ functionKeys1 =

6969-- the same as ESC should examine km and current encoding.

7070-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by

7171-- special_support_keys.

72−functionKeys2 :: ClassifyTable

72+functionKeys2 :: ClassifyMap

7373functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])

7474 | x <- '\t':[' ' .. '~']

7575 , x /= '['

7676 ]

7777

78−classifyTable :: [ClassifyTable]

78+classifyTable :: [ClassifyMap]

7979classifyTable =

8080 [ navKeys0

8181 , navKeys1

test/VerifyConfig.hs+5−1

@@ -33,7 +33,11 @@ exampleConfigConfig :: Config

3333exampleConfigConfig = Config

3434 { specifiedEscPeriod = def

3535 , debugLog = Just "/tmp/vty-debug.txt"

36− , inputOverrides = [("\ESC[B", EvKey KUp []), ("\ESC[1;3B", EvKey KDown [MAlt])]

36+ , inputMap = [ (Nothing, "\ESC[B", EvKey KUp [])

37+ , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt])

38+ , (Just "xterm", "\ESC[1;3B", EvKey KDown [MAlt])

39+ , (Just "xterm-256-color", "\ESC[1;3B", EvKey KDown [MAlt])

40+ ]

3741 }

3842

3943exampleConfigParses :: IO ()

test/VerifyUsingMockInput.hs+5−5

@@ -103,14 +103,14 @@ compareEvents inputSpec expectedEvents outEvents = compareEvents' expectedEvents

103103 printf "received events %s\n" (show outEvents) :: IO ()

104104 return False

105105

106−assertEventsFromSynInput :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool

106+assertEventsFromSynInput :: ClassifyMap -> InputSpec -> ExpectedSpec -> IO Bool

107107assertEventsFromSynInput table inputSpec expectedEvents = do

108108 let maxDuration = sum [t | Delay t <- inputSpec] + minDetectableDelay

109109 eventCount = length expectedEvents

110110 (writeFd, readFd) <- openPseudoTerminal

111111 (setTermAttr,_) <- attributeControl readFd

112112 setTermAttr

113− input <- initInputForFd def table readFd

113+ input <- initInputForFd def "dummy" table readFd

114114 eventsRef <- newIORef []

115115 let writeWaitClose = do

116116 synthesizeInput inputSpec writeFd

@@ -159,7 +159,7 @@ verifyCapsSynInputToEvent :: Property IO

159159verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->

160160 forEachOf terminalsOfInterest $ \termName -> monadic $ do

161161 term <- setupTerm termName

162− let table = capsClassifyTable term keysFromCapsTable

162+ let table = capsClassifyMap term keysFromCapsTable

163163 inputSeq = gen table

164164 events = map snd inputSeq

165165 keydowns = map (Bytes . fst) inputSeq

@@ -179,7 +179,7 @@ verifyFullSynInputToEvent :: Property IO

179179verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->

180180 forEachOf terminalsOfInterest $ \termName -> monadic $ do

181181 term <- setupTerm termName

182− let table = classifyTableForTerm termName term

182+ let table = classifyMapForTerm termName term

183183 inputSeq = gen table

184184 events = map snd inputSeq

185185 keydowns = map (Bytes . fst) inputSeq

@@ -190,7 +190,7 @@ verifyFullSynInputToEvent_2x :: Property IO

190190verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->

191191 forEachOf terminalsOfInterest $ \termName -> monadic $ do

192192 term <- setupTerm termName

193− let table = classifyTableForTerm termName term

193+ let table = classifyMapForTerm termName term

194194 inputSeq = gen table

195195 events = concatMap ((\s -> [s,s]) . snd) inputSeq

196196 keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq