ghcup-hs/lib-tui/GHCup/Brick/App.hs

164 lines
5.9 KiB
Haskell
Raw Normal View History

2024-01-10 06:14:59 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-
This module defines the brick App. The pattern is very simple:
- Pattern match on the Mode
- Dispatch drawing/events to the corresponding widget/s
In general each widget should know how to draw itself and how to handle its own events, so this
module should only contain:
- how to draw non-widget information. For example the footer
- how to change between modes (widgets aren't aware of the whole application state)
-}
module GHCup.Brick.App where
2024-02-28 09:29:39 +00:00
import qualified GHCup.Brick.Actions as Actions
2024-01-10 06:14:59 +00:00
import qualified GHCup.Brick.Attributes as Attributes
2024-02-28 09:29:39 +00:00
import GHCup.Brick.BrickState (BrickState (..), advanceInstallMenu, appKeys, appSettings, appState, contextMenu, mode)
import GHCup.Brick.Common (Mode (..), Name (..))
import qualified GHCup.Brick.Common as Common
2024-01-10 06:14:59 +00:00
import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo
2024-02-28 08:37:17 +00:00
import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu
2024-02-28 09:29:39 +00:00
import qualified GHCup.Brick.Widgets.Navigation as Navigation
import qualified GHCup.Brick.Widgets.Tutorial as Tutorial
import qualified GHCup.Brick.Widgets.Menu as Menu
import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall
2024-01-10 06:14:59 +00:00
2024-02-28 09:29:39 +00:00
import GHCup.Types (AppState (AppState, keyBindings), KeyCombination (KeyCombination))
import qualified Brick.Focus as F
import Brick (
App (..),
AttrMap,
BrickEvent (VtyEvent),
EventM,
Widget (..),
(<=>),
)
2024-01-10 06:14:59 +00:00
import qualified Brick
2024-02-28 09:29:39 +00:00
import Control.Monad.Reader (
MonadIO (liftIO),
void,
)
import Data.IORef (readIORef)
import Data.List (find, intercalate)
import Prelude hiding (appendFile)
2024-01-10 06:14:59 +00:00
2024-02-28 09:29:39 +00:00
import qualified Graphics.Vty as Vty
2024-01-10 06:14:59 +00:00
import qualified Data.Text as T
2024-02-28 08:37:17 +00:00
2024-02-28 09:29:39 +00:00
import Optics.Getter (to)
import Optics.Operators ((^.))
import Optics.Optic ((%))
import Optics.State (use)
import Optics.State.Operators ((.=))
2024-01-10 06:14:59 +00:00
app :: AttrMap -> AttrMap -> App BrickState () Name
app attrs dimAttrs =
App { appDraw = drawUI dimAttrs
, appHandleEvent = eventHandler
, appStartEvent = return ()
, appAttrMap = const attrs
, appChooseCursor = Brick.showFirstCursor
}
drawUI :: AttrMap -> BrickState -> [Widget Name]
drawUI dimAttrs st =
let
footer = Brick.withAttr Attributes.helpAttr
. Brick.txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. fmap (\(KeyCombination key mods, pretty_setting, _)
-> intercalate "+" (Common.showKey key : (Common.showMod <$> mods)) <> ":" <> pretty_setting (st ^. appSettings)
)
$ Actions.keyHandlers (st ^. appKeys)
navg = Navigation.draw dimAttrs (st ^. appState) <=> footer
in case st ^. mode of
Navigation -> [navg]
Tutorial -> [Tutorial.draw, navg]
KeyInfo -> [KeyInfo.draw (st ^. appKeys), navg]
2024-02-28 08:37:17 +00:00
ContextPanel -> [ContextMenu.draw (st ^. contextMenu), navg]
2024-02-28 09:29:39 +00:00
AdvanceInstallPanel -> [AdvanceInstall.draw (st ^. advanceInstallMenu), navg]
2024-01-10 06:14:59 +00:00
-- | On q, go back to navigation.
-- On Enter, to go to tutorial
keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState ()
keyInfoHandler ev = case ev of
VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation
VtyEvent (Vty.EvKey Vty.KEnter _ ) -> mode .= Tutorial
_ -> pure ()
-- | On q, go back to navigation. Else, do nothing
tutorialHandler :: BrickEvent Name e -> EventM Name BrickState ()
tutorialHandler ev =
case ev of
VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation
_ -> pure ()
-- | Tab/Arrows to navigate.
navigationHandler :: BrickEvent Name e -> EventM Name BrickState ()
navigationHandler ev = do
AppState { keyBindings = kb } <- liftIO $ readIORef Actions.settings'
case ev of
inner_event@(VtyEvent (Vty.EvKey key _)) ->
case find (\(key', _, _) -> key' == KeyCombination key []) (Actions.keyHandlers kb) of
Just (_, _, handler) -> handler
Nothing -> void $ Common.zoom appState $ Navigation.handler inner_event
inner_event -> Common.zoom appState $ Navigation.handler inner_event
2024-02-28 08:37:17 +00:00
contextMenuHandler :: BrickEvent Name e -> EventM Name BrickState ()
contextMenuHandler ev = do
ctx <- use contextMenu
let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
buttons = ctx ^. Menu.menuButtonsL
(KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
case (ev, focusedElement) of
(_ , Nothing) -> pure ()
2024-02-28 09:29:39 +00:00
(VtyEvent (Vty.EvKey k m), Just n)
2024-02-28 08:37:17 +00:00
| k == exitKey
&& m == mods
&& n `elem` [Menu.fieldName button | button <- buttons]
-> mode .= Navigation
2024-02-28 09:29:39 +00:00
(VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.AdvanceInstallButton) ) -> mode .= Common.AdvanceInstallPanel
2024-02-28 08:37:17 +00:00
(VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.CompilieButton) ) -> pure ()
_ -> Common.zoom contextMenu $ ContextMenu.handler ev
2024-02-28 09:29:39 +00:00
--
advanceInstallHandler :: BrickEvent Name e -> EventM Name BrickState ()
advanceInstallHandler ev = do
ctx <- use advanceInstallMenu
let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
buttons = ctx ^. Menu.menuButtonsL
(KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
case (ev, focusedElement) of
(_ , Nothing) -> pure ()
(VtyEvent (Vty.EvKey k m), Just n)
| k == exitKey
&& m == mods
&& n `elem` [Menu.fieldName button | button <- buttons]
-> mode .= ContextPanel
_ -> Common.zoom advanceInstallMenu $ AdvanceInstall.handler ev
2024-01-10 06:14:59 +00:00
eventHandler :: BrickEvent Name e -> EventM Name BrickState ()
eventHandler ev = do
m <- use mode
case m of
KeyInfo -> keyInfoHandler ev
Tutorial -> tutorialHandler ev
Navigation -> navigationHandler ev
2024-02-28 08:37:17 +00:00
ContextPanel -> contextMenuHandler ev
2024-02-28 09:29:39 +00:00
AdvanceInstallPanel -> advanceInstallHandler ev