Better aesth for context menu

This commit is contained in:
Luis Morillo 2024-02-28 17:11:00 +01:00
parent 32c2cd2efa
commit 40f94fa016
2 changed files with 46 additions and 25 deletions

View File

@ -150,6 +150,14 @@ fieldHelpMsgL = lens g s
where g (MenuField {..})= fieldInput ^. inputHelpL
s (MenuField{..}) msg = MenuField {fieldInput = fieldInput & inputHelpL .~ msg , ..}
-- | How to draw a field given a formater
drawField :: Formatter n -> Bool -> MenuField s n -> Widget n
drawField amp focus (MenuField { fieldInput = FieldInput {..}, ..}) =
let input = inputRender focus fieldStatus inputHelp inputState (amp focus)
in if focus
then Brick.visible input
else input
instance Brick.Named (MenuField s n) n where
getName :: MenuField s n -> n
getName entry = entry & fieldName
@ -330,12 +338,6 @@ drawMenu menu =
<+> Brick.txt " to go back"
]
where
drawField amp focus (MenuField { fieldInput = FieldInput {..}, ..}) =
let input = inputRender focus fieldStatus inputHelp inputState (amp focus)
in if focus
then Brick.visible input
else input
fieldLabels = [field & fieldLabel | field <- menu ^. menuFieldsL]
buttonLabels = [button & fieldLabel | button <- menu ^. menuButtonsL]
allLabels = fieldLabels ++ buttonLabels

View File

@ -6,20 +6,25 @@ import Brick (
Widget (..), BrickEvent, EventM,
)
import Data.Function ((&))
import qualified GHCup.Brick.Common as Common
import qualified GHCup.Brick.Widgets.Menu as Menu
import Prelude hiding (appendFile)
import qualified Data.Text as T
import Data.Versions (prettyVer)
import GHCup (ListResult (..))
import GHCup.List ( ListResult(..) )
import GHCup.Types (KeyCombination, Tool (..))
import qualified GHCup.Brick.Common as Common
import qualified GHCup.Brick.Widgets.Menu as Menu
import GHCup.Brick.Common (Name (..))
import GHCup.Brick.Widgets.Menu (Menu)
import GHCup.Types (KeyCombination, Tool (..))
import qualified Brick.Widgets.Core as Brick
import qualified Brick.Widgets.Border as Border
import qualified Brick.Focus as F
import Brick.Widgets.Core ((<+>))
import Optics (to)
import Optics.Operators ((.~), (^.))
import Optics.Optic ((%))
import Data.Foldable (foldl')
type ContextMenu = Menu ListResult Name
@ -33,7 +38,7 @@ create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons []
compileButton =
Menu.createButtonField (MenuElement Common.CompilieButton)
& Menu.fieldLabelL .~ "Compile"
& Menu.fieldHelpMsgL .~ "Compile tool from source (to be implemented)"
& Menu.fieldHelpMsgL .~ "Compile tool from source"
buttons =
case lTool lr of
GHC -> [advInstallButton, compileButton]
@ -41,19 +46,33 @@ create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons []
_ -> [advInstallButton]
draw :: ContextMenu -> Widget Name
draw ctx =
draw menu =
Common.frontwardLayer
("Context Menu for " <> tool_str <> " " <> prettyVer (lVer $ ctx ^. Menu.menuStateL))
(Menu.drawMenu ctx)
where
tool_str :: T.Text
tool_str =
case ctx ^. Menu.menuStateL % to lTool of
GHC -> "GHC"
GHCup -> "GHCup"
Cabal -> "Cabal"
HLS -> "HLS"
Stack -> "Stack"
("Context Menu for " <> tool_str <> " " <> prettyVer (lVer $ menu ^. Menu.menuStateL))
$ Brick.vBox
[ Brick.vBox buttonWidgets
, Brick.txt " "
, Brick.padRight Brick.Max $
Brick.txt "Press "
<+> Common.keyToWidget (menu ^. Menu.menuExitKeyL)
<+> Brick.txt " to go back"
]
where
buttonLabels = [button & Menu.fieldLabel | button <- menu ^. Menu.menuButtonsL]
maxWidth = foldl' max 5 (fmap Brick.textWidth buttonLabels)
buttonAmplifiers =
let buttonAsWidgets = fmap Menu.renderAslabel buttonLabels
in fmap (\f b -> ((Menu.leftify (maxWidth + 10) . Border.border $ f b) <+>) ) buttonAsWidgets
drawButtons = fmap Menu.drawField buttonAmplifiers
buttonWidgets = zipWith (F.withFocusRing (menu ^. Menu.menuFocusRingL)) drawButtons (menu ^. Menu.menuButtonsL)
tool_str =
case menu ^. Menu.menuStateL % to lTool of
GHC -> "GHC"
GHCup -> "GHCup"
Cabal -> "Cabal"
HLS -> "HLS"
Stack -> "Stack"
handler :: BrickEvent Name e -> EventM Name ContextMenu ()
handler = Menu.handlerMenu