Widget.hs

{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2017 Piotr Borek
 *
 *  Distributed under the terms of the GPL (GNU Public License)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}
{-# LANGUAGE RankNTypes      #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns    #-}

module Simple.UI.Widgets.Widget (
    WidgetClass,
    Widget,
    castToWidget,
    overrideWidget,
    overrideWidgetHelper,
    overrideHelper,
    widgetNew,
    connectColorsTo,
    keyPressed,
    widgetInitialized,
    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 (unless)
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' ())
    , _widgetInitialized             :: ListenerList (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
    , _widgetInitializedFlag         :: 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

    widgetInitialized :: w -> ListenerList (UIApp' ())
    widgetInitialized = _widgetInitialized . 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
    i <- 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
    inited <- attributeNew False

    let widget = Widget
           { _widgetKeyPressed = p
           , _widgetDraw = d
           , _widgetInitialized = i
           , _widgetColorForeground = fgColor
           , _widgetColorBackground = bgColor
           , _widgetColorStyle = style
           , _widgetColorForegroundSelected = selFgColor
           , _widgetColorBackgroundSelected = selBgColor
           , _widgetColorStyleSelected = selStyle
           , _widgetEnabled = en
           , _widgetVisible = v
           , _widgetName = "widget"
           , _widgetComputeSize = return (1, 1)
           , _widgetInitializedFlag = inited
           }

    on_ widget draw $ \_ _ _ -> do
        initedFlag <- get widget _widgetInitializedFlag
        unless initedFlag $ do
            set widget _widgetInitializedFlag True
            fire widget _widgetInitialized ()

    return widget

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)