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

{-# 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 qualified GHCup.Brick.Actions as Actions
import qualified GHCup.Brick.Attributes as Attributes
import GHCup.Brick.BrickState (BrickState (..), advanceInstallMenu, appKeys, appSettings, appState, contextMenu, mode, compileGHCMenu, compileHLSMenu)
import GHCup.Brick.Common (Mode (..), Name (..))
import qualified GHCup.Brick.Common as Common
import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo
import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu
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

import GHCup.Types (AppState (AppState, keyBindings), KeyCombination (KeyCombination))

import qualified Brick.Focus as F
import Brick (
  App (..),
  AttrMap,
  BrickEvent (VtyEvent),
  EventM,
  Widget (..),
  (<=>),
 )
import qualified Brick
import Control.Monad.Reader (
  MonadIO (liftIO),
  void,
 )
import Data.IORef (readIORef)
import Data.List (find, intercalate)
import Prelude hiding (appendFile)

import qualified Graphics.Vty as Vty

import qualified Data.Text as T

import Optics.Getter (to)
import Optics.Operators ((^.))
import Optics.Optic ((%))
import Optics.State (use)
import Optics.State.Operators ((.=))
import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC
import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS

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]
       ContextPanel -> [ContextMenu.draw (st ^. contextMenu), navg]
       AdvanceInstallPanel -> [AdvanceInstall.draw (st ^. advanceInstallMenu), navg]
       CompileGHCPanel     -> [CompileGHC.draw (st ^. compileGHCMenu), navg]
       CompileHLSPanel     -> [CompileHLS.draw (st ^. compileHLSMenu), 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

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 ()
    (VtyEvent (Vty.EvKey k m), Just n) 
      |  k == exitKey 
          && m == mods 
          && n `elem` [Menu.fieldName button | button <- buttons]
      -> mode .= Navigation
    (VtyEvent (Vty.EvKey Vty.KEnter []),  Just (Common.MenuElement Common.AdvanceInstallButton) ) -> mode .= Common.AdvanceInstallPanel
    (VtyEvent (Vty.EvKey Vty.KEnter []),  Just (Common.MenuElement Common.CompileGHCButton) ) -> mode .= Common.CompileGHCPanel
    (VtyEvent (Vty.EvKey Vty.KEnter []),  Just (Common.MenuElement Common.CompileHLSButton) ) -> mode .= Common.CompileHLSPanel
    _ -> Common.zoom contextMenu $ ContextMenu.handler ev
-- 
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
    (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do
        let iopts = ctx ^. Menu.menuStateL
        Actions.withIOAction $ Actions.installWithOptions iopts
    _ -> Common.zoom advanceInstallMenu $ AdvanceInstall.handler ev

compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState ()
compileGHCHandler ev = do
  ctx <- use compileGHCMenu 
  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
    (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do
        let iopts = ctx ^. Menu.menuStateL
        Actions.withIOAction $ Actions.compileGHC iopts
    _ -> Common.zoom compileGHCMenu $ CompileGHC.handler ev


compileHLSHandler :: BrickEvent Name e -> EventM Name BrickState ()
compileHLSHandler ev = do
  ctx <- use compileHLSMenu 
  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 compileHLSMenu $ CompileHLS.handler ev

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
    ContextPanel -> contextMenuHandler ev
    AdvanceInstallPanel -> advanceInstallHandler ev
    CompileGHCPanel     -> compileGHCHandler ev
    CompileHLSPanel     -> compileHLSHandler ev