{-
 *  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,
    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
    { Widget -> ListenerList (Key -> [Modifier] -> UIApp' ())
_widgetKeyPressed              :: ListenerList (Vty.Key -> [Vty.Modifier]-> UIApp' ())
    , Widget -> ListenerList (Drawing -> Int -> Int -> UIApp' ())
_widgetDraw                    :: ListenerList (Drawing -> Int -> Int -> UIApp' ())
    , Widget -> Attribute Color
_widgetColorForeground         :: Attribute Vty.Color
    , Widget -> Attribute Color
_widgetColorBackground         :: Attribute Vty.Color
    , Widget -> Attribute DrawStyle
_widgetColorStyle              :: Attribute DrawStyle
    , Widget -> Attribute Color
_widgetColorForegroundSelected :: Attribute Vty.Color
    , Widget -> Attribute Color
_widgetColorBackgroundSelected :: Attribute Vty.Color
    , Widget -> Attribute DrawStyle
_widgetColorStyleSelected      :: Attribute DrawStyle
    , Widget -> Attribute Bool
_widgetEnabled                 :: Attribute Bool
    , Widget -> Attribute Bool
_widgetVisible                 :: Attribute Bool
    --
    , Widget -> String
_widgetName        :: String
    , Widget -> UIApp' (Int, Int)
_widgetComputeSize :: UIApp' (Int, Int)
    }

data VirtualWidget = VirtualWidget
    { VirtualWidget -> String
_virtualWidgetName        :: String
    , VirtualWidget -> UIApp' (Int, Int)
_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 = Widget -> ListenerList (Key -> [Modifier] -> UIApp' ())
_widgetKeyPressed (Widget -> ListenerList (Key -> [Modifier] -> UIApp' ()))
-> (w -> Widget)
-> w
-> ListenerList (Key -> [Modifier] -> UIApp' ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

    draw :: w -> ListenerList (Drawing -> Int -> Int -> UIApp' ())
    draw = Widget -> ListenerList (Drawing -> Int -> Int -> UIApp' ())
_widgetDraw (Widget -> ListenerList (Drawing -> Int -> Int -> UIApp' ()))
-> (w -> Widget)
-> w
-> ListenerList (Drawing -> Int -> Int -> UIApp' ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

    colorForeground :: w -> Attribute Vty.Color
    colorForeground = Widget -> Attribute Color
_widgetColorForeground (Widget -> Attribute Color)
-> (w -> Widget) -> w -> Attribute Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

    colorBackground :: w -> Attribute Vty.Color
    colorBackground = Widget -> Attribute Color
_widgetColorBackground (Widget -> Attribute Color)
-> (w -> Widget) -> w -> Attribute Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

    colorStyle :: w -> Attribute DrawStyle
    colorStyle = Widget -> Attribute DrawStyle
_widgetColorStyle (Widget -> Attribute DrawStyle)
-> (w -> Widget) -> w -> Attribute DrawStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

    colorForegroundSelected :: w -> Attribute Vty.Color
    colorForegroundSelected = Widget -> Attribute Color
_widgetColorForegroundSelected (Widget -> Attribute Color)
-> (w -> Widget) -> w -> Attribute Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

    colorBackgroundSelected :: w -> Attribute Vty.Color
    colorBackgroundSelected = Widget -> Attribute Color
_widgetColorBackgroundSelected (Widget -> Attribute Color)
-> (w -> Widget) -> w -> Attribute Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

    colorStyleSelected :: w -> Attribute DrawStyle
    colorStyleSelected = Widget -> Attribute DrawStyle
_widgetColorStyleSelected (Widget -> Attribute DrawStyle)
-> (w -> Widget) -> w -> Attribute DrawStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

    enabled :: w -> Attribute Bool
    enabled = Widget -> Attribute Bool
_widgetEnabled (Widget -> Attribute Bool) -> (w -> Widget) -> w -> Attribute Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

    visible :: w -> Attribute Bool
    visible = Widget -> Attribute Bool
_widgetVisible (Widget -> Attribute Bool) -> (w -> Widget) -> w -> Attribute Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

    name :: w -> String
    name = Widget -> String
_widgetName (Widget -> String) -> (w -> Widget) -> w -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

    computeSize :: w -> UIApp u (Int, Int)
    computeSize = UIApp' (Int, Int) -> UIApp u (Int, Int)
forall a u. UIApp' a -> UIApp u a
liftUIApp' (UIApp' (Int, Int) -> UIApp u (Int, Int))
-> (w -> UIApp' (Int, Int)) -> w -> UIApp u (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Widget -> UIApp' (Int, Int)
_widgetComputeSize (Widget -> UIApp' (Int, Int))
-> (w -> Widget) -> w -> UIApp' (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget

instance WidgetClass Widget where
    castToWidget :: Widget -> Widget
castToWidget = Widget -> Widget
forall a. a -> a
id

    overrideWidget :: Widget -> State VirtualWidget () -> Widget
overrideWidget Widget
widget State VirtualWidget ()
m = Widget
widget
        { _widgetName :: String
_widgetName = VirtualWidget -> String
_virtualWidgetName VirtualWidget
s
        , _widgetComputeSize :: UIApp' (Int, Int)
_widgetComputeSize = VirtualWidget -> UIApp' (Int, Int)
_virtualWidgetComputeSize VirtualWidget
s
        }
      where
        s :: VirtualWidget
s = State VirtualWidget () -> VirtualWidget -> VirtualWidget
forall s a. State s a -> s -> s
execState State VirtualWidget ()
m VirtualWidget :: String -> UIApp' (Int, Int) -> VirtualWidget
VirtualWidget
            { _virtualWidgetName :: String
_virtualWidgetName = Widget -> String
forall w. WidgetClass w => w -> String
name Widget
widget
            , _virtualWidgetComputeSize :: UIApp' (Int, Int)
_virtualWidgetComputeSize = Widget -> UIApp' (Int, Int)
forall w u. WidgetClass w => w -> UIApp u (Int, Int)
computeSize Widget
widget
            }

widgetNew :: UIApp u Widget
widgetNew :: UIApp u Widget
widgetNew = do
    ListenerList (Key -> [Modifier] -> UIApp' ())
p <- ReaderT
  (AppConfig u)
  (StateT AppState IO)
  (ListenerList (Key -> [Modifier] -> UIApp' ()))
forall (m :: * -> *) a. MonadIO m => m (ListenerList a)
listenerNew
    ListenerList (Drawing -> Int -> Int -> UIApp' ())
d <- ReaderT
  (AppConfig u)
  (StateT AppState IO)
  (ListenerList (Drawing -> Int -> Int -> UIApp' ()))
forall (m :: * -> *) a. MonadIO m => m (ListenerList a)
listenerNew
    Attribute Color
fgColor <- Color
-> ReaderT (AppConfig u) (StateT AppState IO) (Attribute Color)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew Color
Vty.white
    Attribute Color
bgColor <- Color
-> ReaderT (AppConfig u) (StateT AppState IO) (Attribute Color)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew Color
Vty.black
    Attribute DrawStyle
style <- DrawStyle
-> ReaderT (AppConfig u) (StateT AppState IO) (Attribute DrawStyle)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew DrawStyle
DrawStyleNormal
    Attribute Color
selFgColor <- Color
-> ReaderT (AppConfig u) (StateT AppState IO) (Attribute Color)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew Color
Vty.white
    Attribute Color
selBgColor <- Color
-> ReaderT (AppConfig u) (StateT AppState IO) (Attribute Color)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew Color
Vty.brightBlack
    Attribute DrawStyle
selStyle <- DrawStyle
-> ReaderT (AppConfig u) (StateT AppState IO) (Attribute DrawStyle)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew DrawStyle
DrawStyleNormal
    Attribute Bool
en <- Bool -> ReaderT (AppConfig u) (StateT AppState IO) (Attribute Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew Bool
True
    Attribute Bool
v <- Bool -> ReaderT (AppConfig u) (StateT AppState IO) (Attribute Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew Bool
True
    Widget -> UIApp u Widget
forall (m :: * -> *) a. Monad m => a -> m a
return Widget :: ListenerList (Key -> [Modifier] -> UIApp' ())
-> ListenerList (Drawing -> Int -> Int -> UIApp' ())
-> Attribute Color
-> Attribute Color
-> Attribute DrawStyle
-> Attribute Color
-> Attribute Color
-> Attribute DrawStyle
-> Attribute Bool
-> Attribute Bool
-> String
-> UIApp' (Int, Int)
-> Widget
Widget
           { _widgetKeyPressed :: ListenerList (Key -> [Modifier] -> UIApp' ())
_widgetKeyPressed = ListenerList (Key -> [Modifier] -> UIApp' ())
p
           , _widgetDraw :: ListenerList (Drawing -> Int -> Int -> UIApp' ())
_widgetDraw = ListenerList (Drawing -> Int -> Int -> UIApp' ())
d
           , _widgetColorForeground :: Attribute Color
_widgetColorForeground = Attribute Color
fgColor
           , _widgetColorBackground :: Attribute Color
_widgetColorBackground = Attribute Color
bgColor
           , _widgetColorStyle :: Attribute DrawStyle
_widgetColorStyle = Attribute DrawStyle
style
           , _widgetColorForegroundSelected :: Attribute Color
_widgetColorForegroundSelected = Attribute Color
selFgColor
           , _widgetColorBackgroundSelected :: Attribute Color
_widgetColorBackgroundSelected = Attribute Color
selBgColor
           , _widgetColorStyleSelected :: Attribute DrawStyle
_widgetColorStyleSelected = Attribute DrawStyle
selStyle
           , _widgetEnabled :: Attribute Bool
_widgetEnabled = Attribute Bool
en
           , _widgetVisible :: Attribute Bool
_widgetVisible = Attribute Bool
v
           , _widgetName :: String
_widgetName = String
"widget"
           , _widgetComputeSize :: UIApp' (Int, Int)
_widgetComputeSize = (Int, Int) -> UIApp' (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, Int
1)
           }

overrideHelper :: WidgetClass p => (p -> State s () -> p) -> Lens' w p -> w -> State s () -> w
overrideHelper :: (p -> State s () -> p) -> Lens' w p -> w -> State s () -> w
overrideHelper p -> State s () -> p
overrideFunc Lens' w p
parentLens w
widget State s ()
f = w
widget w -> (w -> w) -> w
forall a b. a -> (a -> b) -> b
& (p -> Identity p) -> w -> Identity w
Lens' w p
parentLens ((p -> Identity p) -> w -> Identity w) -> p -> w -> w
forall s t a b. ASetter s t a b -> b -> s -> t
.~ p -> State s () -> p
overrideFunc p
parent State s ()
f
  where
    parent :: p
parent = w
widget w -> Getting p w p -> p
forall s a. s -> Getting a s a -> a
^. Getting p w p
Lens' w p
parentLens

overrideWidgetHelper :: WidgetClass p => Lens' w p -> w -> State VirtualWidget () -> w
overrideWidgetHelper :: Lens' w p -> w -> State VirtualWidget () -> w
overrideWidgetHelper = (p -> State VirtualWidget () -> p)
-> Lens' w p -> w -> State VirtualWidget () -> w
forall p s w.
WidgetClass p =>
(p -> State s () -> p) -> Lens' w p -> w -> State s () -> w
overrideHelper p -> State VirtualWidget () -> p
forall w. WidgetClass w => w -> State VirtualWidget () -> w
overrideWidget

connectColorsTo :: (WidgetClass w, WidgetClass v) => w -> v -> UIApp u ()
connectColorsTo :: w -> v -> UIApp u ()
connectColorsTo (w -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget -> Widget
widget) (v -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget -> Widget
vidget) = do
    Widget -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorForeground Widget
widget Attribute Color -> Attribute Color -> UIApp u ()
forall (m :: * -> *) a.
MonadIO m =>
Attribute a -> Attribute a -> m ()
`connectAttrTo` Widget -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorForeground Widget
vidget
    Widget -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorBackground Widget
widget Attribute Color -> Attribute Color -> UIApp u ()
forall (m :: * -> *) a.
MonadIO m =>
Attribute a -> Attribute a -> m ()
`connectAttrTo` Widget -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorBackground Widget
vidget
    Widget -> Attribute DrawStyle
forall w. WidgetClass w => w -> Attribute DrawStyle
colorStyle Widget
widget Attribute DrawStyle -> Attribute DrawStyle -> UIApp u ()
forall (m :: * -> *) a.
MonadIO m =>
Attribute a -> Attribute a -> m ()
`connectAttrTo` Widget -> Attribute DrawStyle
forall w. WidgetClass w => w -> Attribute DrawStyle
colorStyle Widget
vidget
    Widget -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorForegroundSelected Widget
widget Attribute Color -> Attribute Color -> UIApp u ()
forall (m :: * -> *) a.
MonadIO m =>
Attribute a -> Attribute a -> m ()
`connectAttrTo` Widget -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorForegroundSelected Widget
vidget
    Widget -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorBackgroundSelected Widget
widget Attribute Color -> Attribute Color -> UIApp u ()
forall (m :: * -> *) a.
MonadIO m =>
Attribute a -> Attribute a -> m ()
`connectAttrTo` Widget -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorBackgroundSelected Widget
vidget
    Widget -> Attribute DrawStyle
forall w. WidgetClass w => w -> Attribute DrawStyle
colorStyleSelected Widget
widget Attribute DrawStyle -> Attribute DrawStyle -> UIApp u ()
forall (m :: * -> *) a.
MonadIO m =>
Attribute a -> Attribute a -> m ()
`connectAttrTo` Widget -> Attribute DrawStyle
forall w. WidgetClass w => w -> Attribute DrawStyle
colorStyleSelected Widget
vidget

setColors :: WidgetClass w => w -> (Vty.Color, Vty.Color, DrawStyle, Vty.Color, Vty.Color, DrawStyle) -> UIApp u ()
setColors :: w
-> (Color, Color, DrawStyle, Color, Color, DrawStyle) -> UIApp u ()
setColors w
widget (Color
foreground, Color
background, DrawStyle
style, Color
selForeground, Color
selBackground, DrawStyle
selStyle) = do
    w -> (w -> Attribute Color) -> Color -> UIApp u ()
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> a -> m ()
set w
widget w -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorForeground Color
foreground
    w -> (w -> Attribute Color) -> Color -> UIApp u ()
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> a -> m ()
set w
widget w -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorBackground Color
background
    w -> (w -> Attribute DrawStyle) -> DrawStyle -> UIApp u ()
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> a -> m ()
set w
widget w -> Attribute DrawStyle
forall w. WidgetClass w => w -> Attribute DrawStyle
colorStyle  DrawStyle
style
    w -> (w -> Attribute Color) -> Color -> UIApp u ()
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> a -> m ()
set w
widget w -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorForegroundSelected Color
selForeground
    w -> (w -> Attribute Color) -> Color -> UIApp u ()
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> a -> m ()
set w
widget w -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorBackgroundSelected Color
selBackground
    w -> (w -> Attribute DrawStyle) -> DrawStyle -> UIApp u ()
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> a -> m ()
set w
widget w -> Attribute DrawStyle
forall w. WidgetClass w => w -> Attribute DrawStyle
colorStyleSelected DrawStyle
selStyle

getColors :: WidgetClass w => w -> UIApp u (Vty.Color, Vty.Color, DrawStyle, Vty.Color, Vty.Color, DrawStyle)
getColors :: w -> UIApp u (Color, Color, DrawStyle, Color, Color, DrawStyle)
getColors w
widget = do
    Color
foreground <- w
-> (w -> Attribute Color)
-> ReaderT (AppConfig u) (StateT AppState IO) Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get w
widget w -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorForeground
    Color
background <- w
-> (w -> Attribute Color)
-> ReaderT (AppConfig u) (StateT AppState IO) Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get w
widget w -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorBackground
    DrawStyle
style <- w
-> (w -> Attribute DrawStyle)
-> ReaderT (AppConfig u) (StateT AppState IO) DrawStyle
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get w
widget w -> Attribute DrawStyle
forall w. WidgetClass w => w -> Attribute DrawStyle
colorStyle
    Color
selForeground <- w
-> (w -> Attribute Color)
-> ReaderT (AppConfig u) (StateT AppState IO) Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get w
widget w -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorForegroundSelected
    Color
selBackground <- w
-> (w -> Attribute Color)
-> ReaderT (AppConfig u) (StateT AppState IO) Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get w
widget w -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorBackgroundSelected
    DrawStyle
selStyle <- w
-> (w -> Attribute DrawStyle)
-> ReaderT (AppConfig u) (StateT AppState IO) DrawStyle
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get w
widget w -> Attribute DrawStyle
forall w. WidgetClass w => w -> Attribute DrawStyle
colorStyleSelected
    (Color, Color, DrawStyle, Color, Color, DrawStyle)
-> UIApp u (Color, Color, DrawStyle, Color, Color, DrawStyle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Color
foreground, Color
background, DrawStyle
style, Color
selForeground, Color
selBackground, DrawStyle
selStyle)