hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Improve key handling in TUI, fixes #875

Browse Source
This commit is contained in:
Julian Ospald
2023-10-21 20:20:59 +08:00
parent d14526059b
commit 452ca8cca2
4 changed files with 71 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files

68
lib/GHCup/Types.hs
View File

@@ -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

21
lib/GHCup/Types/JSON.hs
View File

@@ -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