{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Simple.UI.Widgets.Widget (
WidgetClass,
Widget,
castToWidget,
overrideWidget,
overrideWidgetHelper,
overrideHelper,
widgetNew,
connectColorsTo,
keyPressed,
draw,
colorForeground,
colorBackground,
colorStyle,
colorForegroundSelected,
colorBackgroundSelected,
colorStyleSelected,
enabled,
visible,
name,
computeSize,
setColors,
getColors,
virtualWidgetName,
virtualWidgetComputeSize
) where
import qualified Graphics.Vty as Vty
import Control.Lens (Lens', makeLenses, (&), (.~),
(^.))
import Control.Monad.State.Strict (State, execState)
import Simple.UI.Core.Attribute
import Simple.UI.Core.Draw
import Simple.UI.Core.Internal.UIApp
import Simple.UI.Core.ListenerList
data Widget = Widget
{ _widgetKeyPressed :: ListenerList (Vty.Key -> [Vty.Modifier]-> UIApp' ())
, _widgetDraw :: ListenerList (Drawing -> Int -> Int -> UIApp' ())
, _widgetColorForeground :: Attribute Vty.Color
, _widgetColorBackground :: Attribute Vty.Color
, _widgetColorStyle :: Attribute DrawStyle
, _widgetColorForegroundSelected :: Attribute Vty.Color
, _widgetColorBackgroundSelected :: Attribute Vty.Color
, _widgetColorStyleSelected :: Attribute DrawStyle
, _widgetEnabled :: Attribute Bool
, _widgetVisible :: Attribute Bool
, _widgetName :: String
, _widgetComputeSize :: UIApp' (Int, Int)
}
data VirtualWidget = VirtualWidget
{ _virtualWidgetName :: String
, _virtualWidgetComputeSize :: UIApp' (Int, Int)
}
makeLenses ''VirtualWidget
class WidgetClass w where
castToWidget :: w -> Widget
overrideWidget :: w -> State VirtualWidget () -> w
keyPressed :: w -> ListenerList (Vty.Key -> [Vty.Modifier]-> UIApp' ())
keyPressed = _widgetKeyPressed . castToWidget
draw :: w -> ListenerList (Drawing -> Int -> Int -> UIApp' ())
draw = _widgetDraw . castToWidget
colorForeground :: w -> Attribute Vty.Color
colorForeground = _widgetColorForeground . castToWidget
colorBackground :: w -> Attribute Vty.Color
colorBackground = _widgetColorBackground . castToWidget
colorStyle :: w -> Attribute DrawStyle
colorStyle = _widgetColorStyle . castToWidget
colorForegroundSelected :: w -> Attribute Vty.Color
colorForegroundSelected = _widgetColorForegroundSelected . castToWidget
colorBackgroundSelected :: w -> Attribute Vty.Color
colorBackgroundSelected = _widgetColorBackgroundSelected . castToWidget
colorStyleSelected :: w -> Attribute DrawStyle
colorStyleSelected = _widgetColorStyleSelected . castToWidget
enabled :: w -> Attribute Bool
enabled = _widgetEnabled . castToWidget
visible :: w -> Attribute Bool
visible = _widgetVisible . castToWidget
name :: w -> String
name = _widgetName . castToWidget
computeSize :: w -> UIApp u (Int, Int)
computeSize = liftUIApp' . _widgetComputeSize . castToWidget
instance WidgetClass Widget where
castToWidget = id
overrideWidget widget m = widget
{ _widgetName = _virtualWidgetName s
, _widgetComputeSize = _virtualWidgetComputeSize s
}
where
s = execState m VirtualWidget
{ _virtualWidgetName = name widget
, _virtualWidgetComputeSize = computeSize widget
}
widgetNew :: UIApp u Widget
widgetNew = do
p <- listenerNew
d <- listenerNew
fgColor <- attributeNew Vty.white
bgColor <- attributeNew Vty.black
style <- attributeNew DrawStyleNormal
selFgColor <- attributeNew Vty.white
selBgColor <- attributeNew Vty.brightBlack
selStyle <- attributeNew DrawStyleNormal
en <- attributeNew True
v <- attributeNew True
return Widget
{ _widgetKeyPressed = p
, _widgetDraw = d
, _widgetColorForeground = fgColor
, _widgetColorBackground = bgColor
, _widgetColorStyle = style
, _widgetColorForegroundSelected = selFgColor
, _widgetColorBackgroundSelected = selBgColor
, _widgetColorStyleSelected = selStyle
, _widgetEnabled = en
, _widgetVisible = v
, _widgetName = "widget"
, _widgetComputeSize = return (1, 1)
}
overrideHelper :: WidgetClass p => (p -> State s () -> p) -> Lens' w p -> w -> State s () -> w
overrideHelper overrideFunc parentLens widget f = widget & parentLens .~ overrideFunc parent f
where
parent = widget ^. parentLens
overrideWidgetHelper :: WidgetClass p => Lens' w p -> w -> State VirtualWidget () -> w
overrideWidgetHelper = overrideHelper overrideWidget
connectColorsTo :: (WidgetClass w, WidgetClass v) => w -> v -> UIApp u ()
connectColorsTo (castToWidget -> widget) (castToWidget -> vidget) = do
colorForeground widget `connectAttrTo` colorForeground vidget
colorBackground widget `connectAttrTo` colorBackground vidget
colorStyle widget `connectAttrTo` colorStyle vidget
colorForegroundSelected widget `connectAttrTo` colorForegroundSelected vidget
colorBackgroundSelected widget `connectAttrTo` colorBackgroundSelected vidget
colorStyleSelected widget `connectAttrTo` colorStyleSelected vidget
setColors :: WidgetClass w => w -> (Vty.Color, Vty.Color, DrawStyle, Vty.Color, Vty.Color, DrawStyle) -> UIApp u ()
setColors widget (foreground, background, style, selForeground, selBackground, selStyle) = do
set widget colorForeground foreground
set widget colorBackground background
set widget colorStyle style
set widget colorForegroundSelected selForeground
set widget colorBackgroundSelected selBackground
set widget colorStyleSelected selStyle
getColors :: WidgetClass w => w -> UIApp u (Vty.Color, Vty.Color, DrawStyle, Vty.Color, Vty.Color, DrawStyle)
getColors widget = do
foreground <- get widget colorForeground
background <- get widget colorBackground
style <- get widget colorStyle
selForeground <- get widget colorForegroundSelected
selBackground <- get widget colorBackgroundSelected
selStyle <- get widget colorStyleSelected
return (foreground, background, style, selForeground, selBackground, selStyle)