diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 969b8bf..b5ef957 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -94,7 +94,7 @@ data BrickState = BrickState keyHandlers :: KeyBindings - -> [ ( Vty.Key + -> [ ( KeyCombination , BrickSettings -> String , BrickState -> EventM String BrickState () ) @@ -131,6 +131,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{}, ..} @@ -147,7 +150,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 @@ -321,12 +324,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 _)) -> - case find (\(key', _, _) -> key' == key) (keyHandlers kb) of + (VtyEvent (Vty.EvKey key mods)) -> + case find (\(keyCombo, _, _) -> keyCombo == KeyCombination key mods) (keyHandlers kb) of Nothing -> put st Just (_, _, handler) -> handler st _ -> put st diff --git a/data/config.yaml b/data/config.yaml index 0659e0c..0abb00e 100644 --- a/data/config.yaml +++ b/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: [] diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 974ff3f..1acd690 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -22,6 +22,7 @@ module GHCup.Types ( module GHCup.Types #if defined(BRICK) , Key(..) + , Modifier(..) #endif ) where @@ -39,14 +40,13 @@ 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 import qualified Data.Text as T import qualified GHC.Generics as GHC import qualified Data.List.NonEmpty as NE -import Data.Foldable (foldMap) #if !defined(BRICK) data Key = KEsc | KChar Char | KBS | KEnter @@ -55,8 +55,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) + -------------------- --[ GHCInfo Tree ]-- @@ -415,47 +421,51 @@ fromSettings Settings{..} (Just KeyBindings{..}) = } data UserKeyBindings = UserKeyBindings - { kUp :: Maybe Key - , kDown :: Maybe Key - , kQuit :: Maybe Key - , kInstall :: Maybe Key - , kUninstall :: Maybe Key - , kSet :: Maybe Key - , kChangelog :: Maybe Key - , kShowAll :: Maybe Key - , kShowAllTools :: Maybe Key + { kUp :: Maybe KeyCombination + , kDown :: Maybe KeyCombination + , kQuit :: Maybe KeyCombination + , kInstall :: Maybe KeyCombination + , kUninstall :: Maybe KeyCombination + , kSet :: Maybe KeyCombination + , kChangelog :: Maybe KeyCombination + , kShowAll :: Maybe KeyCombination + , kShowAllTools :: Maybe KeyCombination } deriving (Show, GHC.Generic) data KeyBindings = KeyBindings - { bUp :: Key - , bDown :: Key - , bQuit :: Key - , bInstall :: Key - , bUninstall :: Key - , bSet :: Key - , bChangelog :: Key - , bShowAllVersions :: Key - , bShowAllTools :: Key + { bUp :: KeyCombination + , bDown :: KeyCombination + , bQuit :: KeyCombination + , bInstall :: KeyCombination + , bUninstall :: KeyCombination + , bSet :: KeyCombination + , bChangelog :: KeyCombination + , bShowAllVersions :: KeyCombination + , 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 - , bDown = KDown - , bQuit = KChar 'q' - , bInstall = KChar 'i' - , bUninstall = KChar 'u' - , bSet = KChar 's' - , bChangelog = KChar 'c' - , bShowAllVersions = KChar 'a' - , bShowAllTools = KChar 't' + { bUp = KeyCombination { key = KUp , mods = [] } + , bDown = KeyCombination { key = KDown , mods = [] } + , bQuit = KeyCombination { key = KChar 'q', mods = [] } + , bInstall = KeyCombination { key = KChar 'i', mods = [] } + , bUninstall = KeyCombination { key = KChar 'u', mods = [] } + , bSet = KeyCombination { key = KChar 's', mods = [] } + , bChangelog = KeyCombination { key = KChar 'c', mods = [] } + , bShowAllVersions = KeyCombination { key = KChar 'a', mods = [] } + , bShowAllTools = KeyCombination { key = KChar 't', mods = [] } } data AppState = AppState diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index ed308ab..3860ba8 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -349,15 +349,13 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Versio deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource 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 = @@ -391,4 +389,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