Skip to content

Commit 452ca8c

Browse files
hasufellhasufell
committed
Improve key handling in TUI, fixes #875 
1 parent d145260 commit 452ca8c

File tree

4 files changed

+71
-38
lines changed

4 files changed

+71
-38
lines changed

‎app/ghcup/BrickMain.hs

Lines changed: 9 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -94,7 +94,7 @@ data BrickState = BrickState
9494

9595

9696
keyHandlers :: KeyBindings
97-
-> [ ( Vty.Key
97+
-> [ ( KeyCombination
9898
, BrickSettings -> String
9999
, BrickState -> EventM String BrickState ()
100100
)
@@ -131,6 +131,9 @@ showKey Vty.KUp = "↑"
131131
showKey Vty.KDown = "↓"
132132
showKey key = tail (show key)
133133

134+
showMod :: Vty.Modifier -> String
135+
showMod = tail . show
136+
134137

135138
ui :: AttrMap -> BrickState -> Widget String
136139
ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
@@ -147,7 +150,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
147150
. txtWrap
148151
. T.pack
149152
. foldr1 (\x y -> x <> " " <> y)
150-
. fmap (\(key, s, _) -> showKey key <> ":" <> s as)
153+
. fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as)
151154
$ keyHandlers appKeys
152155
header =
153156
minHSize 2 emptyWidget
@@ -321,12 +324,12 @@ eventHandler st@BrickState{..} ev = do
321324
(MouseDown _ Vty.BScrollDown _ _) ->
322325
put (BrickState { appState = moveCursor 1 appState Down, .. })
323326
(VtyEvent (Vty.EvResize _ _)) -> put st
324-
(VtyEvent (Vty.EvKey Vty.KUp _)) ->
327+
(VtyEvent (Vty.EvKey Vty.KUp [])) ->
325328
put BrickState{ appState = moveCursor 1 appState Up, .. }
326-
(VtyEvent (Vty.EvKey Vty.KDown _)) ->
329+
(VtyEvent (Vty.EvKey Vty.KDown [])) ->
327330
put BrickState{ appState = moveCursor 1 appState Down, .. }
328-
(VtyEvent (Vty.EvKey key _)) ->
329-
case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
331+
(VtyEvent (Vty.EvKey key mods)) ->
332+
case find (\(keyCombo, _, _) -> keyCombo == KeyCombination key mods) (keyHandlers kb) of
330333
Nothing -> put st
331334
Just (_, _, handler) -> handler st
332335
_ -> put st

‎data/config.yaml

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,11 @@ gpg-setting: GPGNone # GPGStrict | GPGLax | GPGNone
1616
# TUI key bindings,
1717
# see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key
1818
# for possible values.
19+
# It's also possible to define key+modifier, e.g.:
20+
# quit:
21+
# Key:
22+
# KChar: c
23+
# Mods: [MCtrl]
1924
key-bindings:
2025
up:
2126
KUp: []

‎lib/GHCup/Types.hs

Lines changed: 39 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ module GHCup.Types
2222
( module GHCup.Types
2323
#if defined(BRICK)
2424
, Key(..)
25+
, Modifier(..)
2526
#endif
2627
)
2728
where
@@ -39,14 +40,13 @@ import Optics ( makeLenses )
3940
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
4041
import URI.ByteString
4142
#if defined(BRICK)
42-
import Graphics.Vty ( Key(..) )
43+
import Graphics.Vty ( Key(..), Modifier(..) )
4344
#endif
4445

4546
import qualified Data.ByteString.Lazy as BL
4647
import qualified Data.Text as T
4748
import qualified GHC.Generics as GHC
4849
import qualified Data.List.NonEmpty as NE
49-
import Data.Foldable (foldMap)
5050

5151
#if !defined(BRICK)
5252
data Key = KEsc | KChar Char | KBS | KEnter
@@ -55,8 +55,14 @@ data Key = KEsc | KChar Char | KBS | KEnter
5555
| KFun Int | KBackTab | KPrtScr | KPause | KIns
5656
| KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
5757
deriving (Eq,Show,Read,Ord,GHC.Generic)
58+
59+
data Modifier = MShift | MCtrl | MMeta | MAlt
60+
deriving (Eq,Show,Read,Ord,GHC.Generic)
5861
#endif
5962

63+
data KeyCombination = KeyCombination { key :: Key, mods :: [Modifier] }
64+
deriving (Eq,Show,Read,Ord,GHC.Generic)
65+
6066

6167
--------------------
6268
--[ GHCInfo Tree ]--
@@ -415,47 +421,51 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
415421
}
416422

417423
data UserKeyBindings = UserKeyBindings
418-
{ kUp :: Maybe Key
419-
, kDown :: Maybe Key
420-
, kQuit :: Maybe Key
421-
, kInstall :: Maybe Key
422-
, kUninstall :: Maybe Key
423-
, kSet :: Maybe Key
424-
, kChangelog :: Maybe Key
425-
, kShowAll :: Maybe Key
426-
, kShowAllTools :: Maybe Key
424+
{ kUp :: Maybe KeyCombination
425+
, kDown :: Maybe KeyCombination
426+
, kQuit :: Maybe KeyCombination
427+
, kInstall :: Maybe KeyCombination
428+
, kUninstall :: Maybe KeyCombination
429+
, kSet :: Maybe KeyCombination
430+
, kChangelog :: Maybe KeyCombination
431+
, kShowAll :: Maybe KeyCombination
432+
, kShowAllTools :: Maybe KeyCombination
427433
}
428434
deriving (Show, GHC.Generic)
429435

430436
data KeyBindings = KeyBindings
431-
{ bUp :: Key
432-
, bDown :: Key
433-
, bQuit :: Key
434-
, bInstall :: Key
435-
, bUninstall :: Key
436-
, bSet :: Key
437-
, bChangelog :: Key
438-
, bShowAllVersions :: Key
439-
, bShowAllTools :: Key
437+
{ bUp :: KeyCombination
438+
, bDown :: KeyCombination
439+
, bQuit :: KeyCombination
440+
, bInstall :: KeyCombination
441+
, bUninstall :: KeyCombination
442+
, bSet :: KeyCombination
443+
, bChangelog :: KeyCombination
444+
, bShowAllVersions :: KeyCombination
445+
, bShowAllTools :: KeyCombination
440446
}
441447
deriving (Show, GHC.Generic)
442448

443449
instance NFData KeyBindings
444450
#if defined(IS_WINDOWS) || !defined(BRICK)
445451
instance NFData Key
452+
453+
instance NFData Modifier
454+
446455
#endif
456+
instance NFData KeyCombination
447457

448458
defaultKeyBindings :: KeyBindings
449459
defaultKeyBindings = KeyBindings
450-
{ bUp = KUp
451-
, bDown = KDown
452-
, bQuit = KChar 'q'
453-
, bInstall = KChar 'i'
454-
, bUninstall = KChar 'u'
455-
, bSet = KChar 's'
456-
, bChangelog = KChar 'c'
457-
, bShowAllVersions = KChar 'a'
458-
, bShowAllTools = KChar 't'
460+
{ bUp = KeyCombination { key = KUp , mods = [] }
461+
, bDown = KeyCombination { key = KDown , mods = [] }
462+
, bQuit = KeyCombination { key = KChar 'q', mods = [] }
463+
, bInstall = KeyCombination { key = KChar 'i', mods = [] }
464+
, bUninstall = KeyCombination { key = KChar 'u', mods = [] }
465+
, bSet = KeyCombination { key = KChar 's', mods = [] }
466+
, bChangelog = KeyCombination { key = KChar 'c', mods = [] }
467+
, bShowAllVersions = KeyCombination { key = KChar 'a', mods = [] }
468+
, bShowAllTools = KeyCombination { key = KChar 't', mods = [] }
459469
}
460470

461471
data AppState = AppState

‎lib/GHCup/Types/JSON.hs

Lines changed: 18 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -349,15 +349,13 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Versio
349349
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
350350
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
351351
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
352-
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
352+
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Modifier
353353
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port
354354
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Host
355355
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''UserInfo
356356
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' (T.unpack . T.toLower) . T.stripPrefix (T.pack "authority") . T.pack $ str' } ''Authority
357357
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirror
358358
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirrors
359-
deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
360-
deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
361359

362360
instance FromJSON URLSource where
363361
parseJSON v =
@@ -391,4 +389,21 @@ instance FromJSON URLSource where
391389
r :: [Either GHCupInfo URI] <- o .: "AddSource"
392390
pure (AddSource r)
393391

392+
instance FromJSON KeyCombination where
393+
parseJSON v = proper v <|> simple v
394+
where
395+
simple = withObject "KeyCombination" $ \o -> do
396+
k <- parseJSON (Object o)
397+
pure (KeyCombination k [])
398+
proper = withObject "KeyCombination" $ \o -> do
399+
k <- o .: "Key"
400+
m <- o .: "Mods"
401+
pure $ KeyCombination k m
402+
403+
instance ToJSON KeyCombination where
404+
toJSON (KeyCombination k m) = object ["Key" .= k, "Mods" .= m]
405+
406+
deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
407+
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
394408
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
409+
deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings

0 commit comments

Comments
 (0)