{-# LANGUAGE TemplateHaskell #-}
module Simple.UI.Widgets.SimpleMenuItem (
SimpleMenuItem,
SimpleMenuItemClass,
castToSimpleMenuItem,
simpleMenuItemNew,
menuItemChar,
menuItemActivate,
activated
) where
import Control.Lens (makeLensesFor, (.=))
import qualified Graphics.Vty as Vty
import Control.Monad
import Simple.UI.Core.Attribute
import Simple.UI.Core.ListenerList
import Simple.UI.Core.UIApp
import Simple.UI.Layouts.FillLayout
import Simple.UI.Widgets.Container
import Simple.UI.Widgets.Label
import Simple.UI.Widgets.Properties.Selected
import Simple.UI.Widgets.Text
import Simple.UI.Widgets.Widget
data SimpleMenuItem = SimpleMenuItem
{ _simpleMenuItemParent :: Widget
, _simpleMenuItemChar :: Char
, _simpleMenuItemActivated :: ListenerList (UIApp' ())
, _simpleMenuItemSelected :: Attribute Bool
}
makeLensesFor [("_simpleMenuItemParent", "simpleMenuItemParent")] ''SimpleMenuItem
class WidgetClass w => SimpleMenuItemClass w where
castToSimpleMenuItem :: w -> SimpleMenuItem
menuItemChar :: w -> Char
menuItemChar = _simpleMenuItemChar . castToSimpleMenuItem
activated :: w -> ListenerList (UIApp' ())
activated = _simpleMenuItemActivated . castToSimpleMenuItem
menuItemActivate :: w -> UIApp u ()
menuItemActivate item = fire (castToSimpleMenuItem item) activated ()
instance WidgetClass SimpleMenuItem where
castToWidget = _simpleMenuItemParent
overrideWidget = overrideWidgetHelper simpleMenuItemParent
instance SimpleMenuItemClass SimpleMenuItem where
castToSimpleMenuItem = id
instance HasSelected SimpleMenuItem where
selected = _simpleMenuItemSelected
simpleMenuItemNew :: Char -> String -> UIApp u SimpleMenuItem
simpleMenuItemNew c s = do
a <- listenerNew
_layout <- fillLayoutHorizontalNew
container <- containerNew _layout
l1 <- labelNew $ Just $ " [" ++ [c] ++ "] "
l2 <- labelNew $ Just $ s ++ " "
set l2 align TextAlignLeft
addTo container l1 def { fillLayoutHExpand = False }
addTo container l2 def
sel <- attributeNew False
let _simpleMenuItem = SimpleMenuItem
{ _simpleMenuItemParent = castToWidget container
, _simpleMenuItemChar = c
, _simpleMenuItemActivated = a
, _simpleMenuItemSelected = sel
}
let simpleMenuItem = overrideWidget _simpleMenuItem $
virtualWidgetName .= "simplemenuitem"
simpleMenuItem `connectColorsTo` l1
simpleMenuItem `connectColorsTo` l2
on_ l1 draw $ \_ _ _ -> labelSetColor simpleMenuItem l1
on_ l2 draw $ \_ _ _ -> labelSetColor simpleMenuItem l2
on_ simpleMenuItem keyPressed $ \key _ ->
when (Vty.KChar c == key) $ fire simpleMenuItem activated ()
return simpleMenuItem
where
labelSetColor simpleMenuItem label = do
(fg, bg, style) <- selectedGetColors simpleMenuItem
set label colorForeground fg
set label colorBackground bg
set label colorStyle style