{-
 *  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 TemplateHaskell #-}

module Simple.UI.Widgets.Container (
    ContainerClass,
    Container,
    castToContainer,
    containerNew,
    widgets,
    layout,
    addTo,
    -- layout
    LayoutClass,
    LayoutData,
    EmptyLayout (..),
    EmptyLayoutData (..),
    layoutDraw,
    layoutComputeSize
) where

import qualified Control.Arrow as Arrow
import Control.Lens ((.=), makeLensesFor)
import Control.Monad
import Control.Monad.IO.Class
import Data.Default.Class

import Simple.UI.Core.Internal.UIApp

import Simple.UI.Core.Attribute
import Simple.UI.Core.Draw
import Simple.UI.Core.ListenerList
import Simple.UI.Widgets.Widget

data EmptyLayout = EmptyLayout
data EmptyLayoutData = EmptyLayoutData

data Container a = Container
    { Container a -> Widget
_containerParent             :: Widget
    , Container a -> AttributeList (Widget, LayoutData a)
_containerWidgets            :: AttributeList (Widget, LayoutData a)
    , Container a -> Attribute a
_containerLayout             :: Attribute a
    }

class LayoutClass w where
    type LayoutData w
    layoutDraw :: ContainerClass c => c w -> Drawing -> Int -> Int -> UIApp u ()
    layoutComputeSize :: ContainerClass c => c w -> UIApp u (Int, Int)

class ContainerClass w where
    castToContainer :: w a -> Container a

    widgets :: w a -> AttributeList (Widget, LayoutData a)
    widgets = Container a -> AttributeList (Widget, LayoutData a)
forall a. Container a -> AttributeList (Widget, LayoutData a)
_containerWidgets (Container a -> AttributeList (Widget, LayoutData a))
-> (w a -> Container a)
-> w a
-> AttributeList (Widget, LayoutData a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w a -> Container a
forall (w :: * -> *) a. ContainerClass w => w a -> Container a
castToContainer

    layout :: w a -> Attribute a
    layout = Container a -> Attribute a
forall a. Container a -> Attribute a
_containerLayout (Container a -> Attribute a)
-> (w a -> Container a) -> w a -> Attribute a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w a -> Container a
forall (w :: * -> *) a. ContainerClass w => w a -> Container a
castToContainer

    addTo :: (WidgetClass u, MonadIO m) => w a -> u -> LayoutData a -> m ()
    addTo w a
c u
w LayoutData a
d = w a
-> (w a -> AttributeList (Widget, LayoutData a))
-> ((u, LayoutData a) -> (Widget, LayoutData a))
-> (u, LayoutData a)
-> m ()
forall (m :: * -> *) s a b.
MonadIO m =>
s -> (s -> AttributeList a) -> (b -> a) -> b -> m ()
add w a
c w a -> AttributeList (Widget, LayoutData a)
forall (w :: * -> *) a.
ContainerClass w =>
w a -> AttributeList (Widget, LayoutData a)
widgets ((u -> Widget) -> (u, LayoutData a) -> (Widget, LayoutData a)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arrow.first u -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget) (u
w, LayoutData a
d)

makeLensesFor [("_containerParent", "containerParent")] ''Container

instance LayoutClass EmptyLayout where
    type LayoutData EmptyLayout = EmptyLayoutData

    layoutDraw :: c EmptyLayout -> Drawing -> Int -> Int -> UIApp u ()
layoutDraw c EmptyLayout
_ Drawing
_ Int
_ Int
_ = () -> UIApp u ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    layoutComputeSize :: c EmptyLayout -> UIApp u (Int, Int)
layoutComputeSize c EmptyLayout
_ = (Int, Int) -> UIApp u (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, Int
1)

instance Default EmptyLayoutData where
    def :: EmptyLayoutData
def = EmptyLayoutData
EmptyLayoutData

instance ContainerClass Container where
    castToContainer :: Container a -> Container a
castToContainer = Container a -> Container a
forall a. a -> a
id

instance WidgetClass (Container a) where
    castToWidget :: Container a -> Widget
castToWidget = Container a -> Widget
forall a. Container a -> Widget
_containerParent

    overrideWidget :: Container a -> State VirtualWidget () -> Container a
overrideWidget = Lens' (Container a) Widget
-> Container a -> State VirtualWidget () -> Container a
forall p w.
WidgetClass p =>
Lens' w p -> w -> State VirtualWidget () -> w
overrideWidgetHelper forall a. Lens' (Container a) Widget
Lens' (Container a) Widget
containerParent

containerNew :: LayoutClass a => a -> UIApp u (Container a)
containerNew :: a -> UIApp u (Container a)
containerNew a
_layout = do
    Container a
container <- a -> UIApp u (Container a)
forall a u. LayoutClass a => a -> UIApp u (Container a)
containerNewOverride a
_layout

    Container a
-> (Container a
    -> ListenerList (Drawing -> Int -> Int -> UIApp' ()))
-> (Drawing -> Int -> Int -> UIApp' ())
-> UIApp u ()
forall w a u. w -> (w -> ListenerList a) -> a -> UIApp u ()
on_ Container a
container Container a -> ListenerList (Drawing -> Int -> Int -> UIApp' ())
forall w.
WidgetClass w =>
w -> ListenerList (Drawing -> Int -> Int -> UIApp' ())
draw ((Drawing -> Int -> Int -> UIApp' ()) -> UIApp u ())
-> (Drawing -> Int -> Int -> UIApp' ()) -> UIApp u ()
forall a b. (a -> b) -> a -> b
$ \Drawing
drawing Int
width Int
height -> do
        Color
fg <- Container a
-> (Container a -> Attribute Color)
-> ReaderT (AppConfig ()) (StateT AppState IO) Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Container a
container Container a -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorForeground
        Color
bg <- Container a
-> (Container a -> Attribute Color)
-> ReaderT (AppConfig ()) (StateT AppState IO) Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Container a
container Container a -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorBackground
        Drawing -> DrawingBuilder () -> UIApp' ()
forall (m :: * -> *) a.
MonadIO m =>
Drawing -> DrawingBuilder a -> m a
drawingRun Drawing
drawing (DrawingBuilder () -> UIApp' ()) -> DrawingBuilder () -> UIApp' ()
forall a b. (a -> b) -> a -> b
$ do
            Color -> Color -> DrawStyle -> DrawingBuilder ()
drawingSetAttrs Color
fg Color
bg DrawStyle
DrawStyleNormal
            DrawingBuilder ()
drawingClear
        Container a -> Drawing -> Int -> Int -> UIApp' ()
forall w (c :: * -> *) u.
(LayoutClass w, ContainerClass c) =>
c w -> Drawing -> Int -> Int -> UIApp u ()
layoutDraw Container a
container Drawing
drawing Int
width Int
height

    Container a
-> (Container a -> ListenerList (Key -> [Modifier] -> UIApp' ()))
-> (Key -> [Modifier] -> UIApp' ())
-> UIApp u ()
forall w a u. w -> (w -> ListenerList a) -> a -> UIApp u ()
on_ Container a
container Container a -> ListenerList (Key -> [Modifier] -> UIApp' ())
forall w.
WidgetClass w =>
w -> ListenerList (Key -> [Modifier] -> UIApp' ())
keyPressed ((Key -> [Modifier] -> UIApp' ()) -> UIApp u ())
-> (Key -> [Modifier] -> UIApp' ()) -> UIApp u ()
forall a b. (a -> b) -> a -> b
$ \Key
key [Modifier]
modifiers -> do
        [(Widget, LayoutData a)]
_widgets <- Container a
-> (Container a -> Attribute [(Widget, LayoutData a)])
-> ReaderT
     (AppConfig ()) (StateT AppState IO) [(Widget, LayoutData a)]
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Container a
container Container a -> Attribute [(Widget, LayoutData a)]
forall (w :: * -> *) a.
ContainerClass w =>
w a -> AttributeList (Widget, LayoutData a)
widgets
        [(Widget, LayoutData a)]
-> ((Widget, LayoutData a) -> UIApp' ()) -> UIApp' ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Widget, LayoutData a)]
_widgets (((Widget, LayoutData a) -> UIApp' ()) -> UIApp' ())
-> ((Widget, LayoutData a) -> UIApp' ()) -> UIApp' ()
forall a b. (a -> b) -> a -> b
$ \(Widget
widget, LayoutData a
_) -> do
            Bool
en <- Widget
-> (Widget -> Attribute Bool)
-> ReaderT (AppConfig ()) (StateT AppState IO) Bool
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Widget
widget Widget -> Attribute Bool
forall w. WidgetClass w => w -> Attribute Bool
enabled
            Bool
v <- Widget
-> (Widget -> Attribute Bool)
-> ReaderT (AppConfig ()) (StateT AppState IO) Bool
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Widget
widget Widget -> Attribute Bool
forall w. WidgetClass w => w -> Attribute Bool
visible
            Bool -> UIApp' () -> UIApp' ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
en Bool -> Bool -> Bool
&& Bool
v) (UIApp' () -> UIApp' ()) -> UIApp' () -> UIApp' ()
forall a b. (a -> b) -> a -> b
$ Widget
-> (Widget -> ListenerList (Key -> [Modifier] -> UIApp' ()))
-> (Key, [Modifier])
-> UIApp' ()
forall a b w u.
Fire a b =>
w -> (w -> ListenerList a) -> b -> UIApp u ()
fire Widget
widget Widget -> ListenerList (Key -> [Modifier] -> UIApp' ())
forall w.
WidgetClass w =>
w -> ListenerList (Key -> [Modifier] -> UIApp' ())
keyPressed (Key
key, [Modifier]
modifiers)

    Container a -> UIApp u (Container a)
forall (m :: * -> *) a. Monad m => a -> m a
return Container a
container

containerNewOverride :: LayoutClass a => a -> UIApp u (Container a)
containerNewOverride :: a -> UIApp u (Container a)
containerNewOverride a
_layout = Container a -> Container a
forall (c :: * -> *) w.
(WidgetClass (c w), LayoutClass w, ContainerClass c) =>
c w -> c w
override (Container a -> Container a)
-> UIApp u (Container a) -> UIApp u (Container a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> UIApp u (Container a)
forall a u. LayoutClass a => a -> UIApp u (Container a)
containerNewDefault a
_layout
  where
    override :: c w -> c w
override c w
container = c w -> State VirtualWidget () -> c w
forall w. WidgetClass w => w -> State VirtualWidget () -> w
overrideWidget c w
container (State VirtualWidget () -> c w) -> State VirtualWidget () -> c w
forall a b. (a -> b) -> a -> b
$ do
        (String -> Identity String)
-> VirtualWidget -> Identity VirtualWidget
Lens' VirtualWidget String
virtualWidgetName ((String -> Identity String)
 -> VirtualWidget -> Identity VirtualWidget)
-> String -> State VirtualWidget ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= String
"container"
        (UIApp' (Int, Int) -> Identity (UIApp' (Int, Int)))
-> VirtualWidget -> Identity VirtualWidget
Lens' VirtualWidget (UIApp' (Int, Int))
virtualWidgetComputeSize ((UIApp' (Int, Int) -> Identity (UIApp' (Int, Int)))
 -> VirtualWidget -> Identity VirtualWidget)
-> UIApp' (Int, Int) -> State VirtualWidget ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= c w -> UIApp' (Int, Int)
forall w (c :: * -> *) u.
(LayoutClass w, ContainerClass c) =>
c w -> UIApp u (Int, Int)
layoutComputeSize c w
container

containerNewDefault :: LayoutClass a => a -> UIApp u (Container a)
containerNewDefault :: a -> UIApp u (Container a)
containerNewDefault a
_layout = do
    Widget
parent <- UIApp u Widget
forall u. UIApp u Widget
widgetNew
    Attribute [(Widget, LayoutData a)]
_widgets <- [(Widget, LayoutData a)]
-> ReaderT
     (AppConfig u)
     (StateT AppState IO)
     (Attribute [(Widget, LayoutData a)])
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew []
    Attribute a
layoutAttr <- a -> ReaderT (AppConfig u) (StateT AppState IO) (Attribute a)
forall (m :: * -> *) a. MonadIO m => a -> m (Attribute a)
attributeNew a
_layout

    Container a -> UIApp u (Container a)
forall (m :: * -> *) a. Monad m => a -> m a
return Container :: forall a.
Widget
-> AttributeList (Widget, LayoutData a)
-> Attribute a
-> Container a
Container
            { _containerParent :: Widget
_containerParent  = Widget
parent
            , _containerWidgets :: Attribute [(Widget, LayoutData a)]
_containerWidgets = Attribute [(Widget, LayoutData a)]
_widgets
            , _containerLayout :: Attribute a
_containerLayout = Attribute a
layoutAttr
            }