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

119 lines
4.2 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
import GHCup.Types ( AppState(AppState, keyBindings), KeyCombination(KeyCombination) )
import GHCup.Brick.Common ( Name(..), Mode(..))
import qualified GHCup.Brick.Common as Common
import GHCup.Brick.BrickState (BrickState(..), appState, mode, appKeys, appSettings)
import qualified GHCup.Brick.Attributes as Attributes
import qualified GHCup.Brick.Widgets.Navigation as Navigation
import qualified GHCup.Brick.Widgets.Tutorial as Tutorial
import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo
import qualified GHCup.Brick.Actions as Actions
import Brick
( BrickEvent(VtyEvent),
App(..),
AttrMap,
EventM,
Widget(..),
(<=>))
import qualified Brick
import Control.Monad.Reader
( void, MonadIO(liftIO) )
import Data.List ( find, intercalate)
import Data.IORef (readIORef)
import Prelude hiding ( appendFile )
import qualified Graphics.Vty as Vty
import Optics.State (use)
import Optics.State.Operators ( (.=))
import Optics.Operators ((^.))
import qualified Data.Text as T
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]
-- InstallPopUp -> [drawCompilePopUp (st ^. popUp), navg]
-- | 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
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
-- InstallPopUp -> compilePopUpHandler ev