Merge branch 'improved-key-brick'

app/ghcup/BrickMain.hs

@@ -95,7 +95,7 @@ data BrickState = BrickState
 
 
 keyHandlers :: KeyBindings
-            -> [ ( Vty.Key
+            -> [ ( KeyCombination
                  , BrickSettings -> String
                  , BrickState -> EventM String BrickState ()
                  )
@@ -132,6 +132,9 @@ showKey Vty.KUp = "↑"
 showKey Vty.KDown = "↓"
 showKey key = tail (show key)
 
+showMod :: Vty.Modifier -> String
+showMod = tail . show
+
 
 ui :: AttrMap -> BrickState -> Widget String
 ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
@@ -148,7 +151,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
       . txtWrap
       . T.pack
       . foldr1 (\x y -> x <> "  " <> y)
-      . fmap (\(key, s, _) -> showKey key <> ":" <> s as)
+      . fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as)
       $ keyHandlers appKeys
   header =
     minHSize 2 emptyWidget
@@ -322,12 +325,12 @@ eventHandler st@BrickState{..} ev = do
     (MouseDown _ Vty.BScrollDown _ _) ->
       put (BrickState { appState = moveCursor 1 appState Down, .. })
     (VtyEvent (Vty.EvResize _ _)) -> put st
-    (VtyEvent (Vty.EvKey Vty.KUp _)) ->
+    (VtyEvent (Vty.EvKey Vty.KUp [])) ->
       put BrickState{ appState = moveCursor 1 appState Up, .. }
-    (VtyEvent (Vty.EvKey Vty.KDown _)) ->
+    (VtyEvent (Vty.EvKey Vty.KDown [])) ->
       put BrickState{ appState = moveCursor 1 appState Down, .. }
-    (VtyEvent (Vty.EvKey key _)) ->
+    (VtyEvent (Vty.EvKey key mods)) ->
-      case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
+      case find (\(keyCombo, _, _) -> keyCombo == KeyCombination key mods) (keyHandlers kb) of
         Nothing -> put st
         Just (_, _, handler) -> handler st
     _ -> put st

data/config.yaml

@@ -16,6 +16,11 @@ gpg-setting: GPGNone # GPGStrict | GPGLax | GPGNone
 # TUI key bindings,
 # see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key
 # for possible values.
+# It's also possible to define key+modifier, e.g.:
+#   quit:
+#     Key:
+#       KChar: c
+#     Mods: [MCtrl]
 key-bindings:
   up:
     KUp: []

lib/GHCup/Types.hs

@@ -22,6 +22,7 @@ module GHCup.Types
   ( module GHCup.Types
 #if defined(BRICK)
   , Key(..)
+  , Modifier(..)
 #endif
   )
   where
@@ -40,7 +41,7 @@ import           Optics                         ( makeLenses )
 import           Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
 import           URI.ByteString
 #if defined(BRICK)
-import           Graphics.Vty                   ( Key(..) )
+import           Graphics.Vty                   ( Key(..), Modifier(..) )
 #endif
 
 import qualified Data.ByteString.Lazy          as BL
@@ -55,8 +56,14 @@ data Key = KEsc  | KChar Char | KBS | KEnter
          | KFun Int | KBackTab | KPrtScr | KPause | KIns
          | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
     deriving (Eq,Show,Read,Ord,GHC.Generic)
+
+data Modifier = MShift | MCtrl | MMeta | MAlt
+    deriving (Eq,Show,Read,Ord,GHC.Generic)
 #endif
 
+data KeyCombination = KeyCombination { key :: Key, mods :: [Modifier] }
+    deriving (Eq,Show,Read,Ord,GHC.Generic)
+
 
 
     --------------------
@@ -431,47 +438,51 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
   }
 
 data UserKeyBindings = UserKeyBindings
-  { kUp        :: Maybe Key
+  { kUp           :: Maybe KeyCombination
-  , kDown      :: Maybe Key
+  , kDown         :: Maybe KeyCombination
-  , kQuit      :: Maybe Key
+  , kQuit         :: Maybe KeyCombination
-  , kInstall   :: Maybe Key
+  , kInstall      :: Maybe KeyCombination
-  , kUninstall :: Maybe Key
+  , kUninstall    :: Maybe KeyCombination
-  , kSet       :: Maybe Key
+  , kSet          :: Maybe KeyCombination
-  , kChangelog :: Maybe Key
+  , kChangelog    :: Maybe KeyCombination
-  , kShowAll   :: Maybe Key
+  , kShowAll      :: Maybe KeyCombination
-  , kShowAllTools :: Maybe Key
+  , kShowAllTools :: Maybe KeyCombination
   }
   deriving (Show, GHC.Generic)
 
 data KeyBindings = KeyBindings
-  { bUp        :: Key
+  { bUp              :: KeyCombination
-  , bDown      :: Key
+  , bDown            :: KeyCombination
-  , bQuit      :: Key
+  , bQuit            :: KeyCombination
-  , bInstall   :: Key
+  , bInstall         :: KeyCombination
-  , bUninstall :: Key
+  , bUninstall       :: KeyCombination
-  , bSet       :: Key
+  , bSet             :: KeyCombination
-  , bChangelog :: Key
+  , bChangelog       :: KeyCombination
-  , bShowAllVersions :: Key
+  , bShowAllVersions :: KeyCombination
-  , bShowAllTools :: Key
+  , bShowAllTools    :: KeyCombination
   }
   deriving (Show, GHC.Generic)
 
 instance NFData KeyBindings
 #if defined(IS_WINDOWS) || !defined(BRICK)
 instance NFData Key
+
+instance NFData Modifier
+
 #endif
+instance NFData KeyCombination
 
 defaultKeyBindings :: KeyBindings
 defaultKeyBindings = KeyBindings
-  { bUp = KUp
+  { bUp              = KeyCombination { key = KUp      , mods = [] }
-  , bDown = KDown
+  , bDown            = KeyCombination { key = KDown    , mods = [] }
-  , bQuit = KChar 'q'
+  , bQuit            = KeyCombination { key = KChar 'q', mods = [] }
-  , bInstall = KChar 'i'
+  , bInstall         = KeyCombination { key = KChar 'i', mods = [] }
-  , bUninstall = KChar 'u'
+  , bUninstall       = KeyCombination { key = KChar 'u', mods = [] }
-  , bSet = KChar 's'
+  , bSet             = KeyCombination { key = KChar 's', mods = [] }
-  , bChangelog = KChar 'c'
+  , bChangelog       = KeyCombination { key = KChar 'c', mods = [] }
-  , bShowAllVersions = KChar 'a'
+  , bShowAllVersions = KeyCombination { key = KChar 'a', mods = [] }
-  , bShowAllTools = KChar 't'
+  , bShowAllTools    = KeyCombination { key = KChar 't', mods = [] }
   }
 
 data AppState = AppState

lib/GHCup/Types/JSON.hs

@@ -286,15 +286,13 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupI
 deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
 deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, constructorTagModifier = \str' -> if str' == "StackSetupURL" then str' else maybe str' T.unpack . T.stripPrefix (T.pack "S") . T.pack $ str' } ''StackSetupURLSource
 deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
-deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
+deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Modifier
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Host
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''UserInfo
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' (T.unpack . T.toLower) . T.stripPrefix (T.pack "authority") . T.pack $ str' } ''Authority
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirror
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirrors
-deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
-deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
 
 instance FromJSON URLSource where
   parseJSON v =
@@ -328,4 +326,21 @@ instance FromJSON URLSource where
       r :: [Either GHCupInfo URI] <- o .: "AddSource"
       pure (AddSource r)
 
+instance FromJSON KeyCombination where
+  parseJSON v = proper v <|> simple v
+   where
+    simple = withObject "KeyCombination" $ \o -> do
+      k <- parseJSON (Object o)
+      pure (KeyCombination k [])
+    proper = withObject "KeyCombination" $ \o -> do
+      k <- o .: "Key"
+      m <- o .: "Mods"
+      pure $ KeyCombination k m
+
+instance ToJSON KeyCombination where
+  toJSON (KeyCombination k m) = object ["Key" .= k, "Mods" .= m]
+
+deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
+deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
+deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings