{-
 *  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.Label (
    Label,
    LabelClass,
    castToLabel,
    labelNew,
    text,
    align
) where

import           Control.Lens                  (makeLensesFor, (.=))
import           Control.Monad

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.Text
import           Simple.UI.Widgets.Widget

newtype Label = Label
    { Label -> Text
_labelParent :: Text
    }

makeLensesFor [("_labelParent", "labelParent")] ''Label

class TextClass w => LabelClass w where
    castToLabel :: w -> Label

instance LabelClass Label where
    castToLabel :: Label -> Label
castToLabel = Label -> Label
forall a. a -> a
id

instance TextClass Label where
    castToText :: Label -> Text
castToText = Label -> Text
_labelParent

instance WidgetClass Label where
    castToWidget :: Label -> Widget
castToWidget = Text -> Widget
forall w. WidgetClass w => w -> Widget
castToWidget (Text -> Widget) -> (Label -> Text) -> Label -> Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Text
_labelParent

    overrideWidget :: Label -> State VirtualWidget () -> Label
overrideWidget = Lens' Label Text -> Label -> State VirtualWidget () -> Label
forall p w.
WidgetClass p =>
Lens' w p -> w -> State VirtualWidget () -> w
overrideWidgetHelper Lens' Label Text
Iso' Label Text
labelParent

labelNew :: Maybe String -> UIApp u Label
labelNew :: Maybe String -> UIApp u Label
labelNew Maybe String
s = do
    Label
label <- Maybe String -> UIApp u Label
forall u. Maybe String -> UIApp u Label
labelNewOverride Maybe String
s

    ListenerID
_ <- Label
-> (Label -> ListenerList (Drawing -> Int -> Int -> UIApp' ()))
-> (Drawing -> Int -> Int -> UIApp' ())
-> UIApp u ListenerID
forall w a u. w -> (w -> ListenerList a) -> a -> UIApp u ListenerID
on Label
label Label -> ListenerList (Drawing -> Int -> Int -> UIApp' ())
forall w.
WidgetClass w =>
w -> ListenerList (Drawing -> Int -> Int -> UIApp' ())
draw ((Drawing -> Int -> Int -> UIApp' ()) -> UIApp u ListenerID)
-> (Drawing -> Int -> Int -> UIApp' ()) -> UIApp u ListenerID
forall a b. (a -> b) -> a -> b
$ Label -> Drawing -> Int -> Int -> UIApp' ()
forall u. Label -> Drawing -> Int -> Int -> UIApp u ()
labelDraw Label
label

    Label -> UIApp u Label
forall (m :: * -> *) a. Monad m => a -> m a
return Label
label

labelNewOverride :: Maybe String -> UIApp u Label
labelNewOverride :: Maybe String -> UIApp u Label
labelNewOverride Maybe String
s = Label -> Label
forall w. TextClass w => w -> w
override (Label -> Label) -> UIApp u Label -> UIApp u Label
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String -> UIApp u Label
forall u. Maybe String -> UIApp u Label
labelNewDefault Maybe String
s
  where
    labelComputeSize :: w -> m (Int, Int)
labelComputeSize w
label = do
        Maybe String
maybeText <- w -> (w -> Attribute (Maybe String)) -> m (Maybe String)
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get w
label w -> Attribute (Maybe String)
forall w. TextClass w => w -> Attribute (Maybe String)
text

        case Maybe String
maybeText of
            Maybe String
Nothing -> (Int, Int) -> m (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, Int
1)
            Just String
_text -> do
                let ls :: [String]
ls = String -> [String]
lines String
_text
                let ws :: [Int]
ws = (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls

                let w :: Int
w = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
ws
                let l :: Int
l = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls

                (Int, Int) -> m (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ( if Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
1 else Int
w
                       , if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
1 else Int
l
                       )

    override :: w -> w
override w
label = w -> State VirtualWidget () -> w
forall w. WidgetClass w => w -> State VirtualWidget () -> w
overrideWidget w
label (State VirtualWidget () -> w) -> State VirtualWidget () -> 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
"label"
        (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 ()
.= w -> UIApp' (Int, Int)
forall (m :: * -> *) w.
(MonadIO m, TextClass w) =>
w -> m (Int, Int)
labelComputeSize w
label

labelNewDefault :: Maybe String -> UIApp u Label
labelNewDefault :: Maybe String -> UIApp u Label
labelNewDefault Maybe String
s = do
    Text
parent <- Maybe String -> UIApp u Text
forall u. Maybe String -> UIApp u Text
textNew Maybe String
s

    Label -> UIApp u Label
forall (m :: * -> *) a. Monad m => a -> m a
return Label :: Text -> Label
Label
        { _labelParent :: Text
_labelParent = Text
parent
        }

labelDraw :: Label -> Drawing -> Int -> Int -> UIApp u ()
labelDraw :: Label -> Drawing -> Int -> Int -> UIApp u ()
labelDraw Label
label Drawing
drawing Int
width Int
height = do
    Maybe String
maybeText <- Label
-> (Label -> Attribute (Maybe String))
-> ReaderT (AppConfig u) (StateT AppState IO) (Maybe String)
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Label
label Label -> Attribute (Maybe String)
forall w. TextClass w => w -> Attribute (Maybe String)
text

    Color
fg <- Label
-> (Label -> Attribute Color)
-> ReaderT (AppConfig u) (StateT AppState IO) Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Label
label Label -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorForeground
    Color
bg <- Label
-> (Label -> Attribute Color)
-> ReaderT (AppConfig u) (StateT AppState IO) Color
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Label
label Label -> Attribute Color
forall w. WidgetClass w => w -> Attribute Color
colorBackground
    DrawStyle
style <- Label
-> (Label -> Attribute DrawStyle)
-> ReaderT (AppConfig u) (StateT AppState IO) DrawStyle
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Label
label Label -> Attribute DrawStyle
forall w. WidgetClass w => w -> Attribute DrawStyle
colorStyle

    Drawing -> DrawingBuilder () -> UIApp u ()
forall (m :: * -> *) a.
MonadIO m =>
Drawing -> DrawingBuilder a -> m a
drawingRun Drawing
drawing (DrawingBuilder () -> UIApp u ())
-> DrawingBuilder () -> UIApp u ()
forall a b. (a -> b) -> a -> b
$ do
        Color -> Color -> DrawStyle -> DrawingBuilder ()
drawingSetAttrs Color
fg Color
bg DrawStyle
style
        DrawingBuilder ()
drawingClear

    Maybe String -> (String -> UIApp u ()) -> UIApp u ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
maybeText ((String -> UIApp u ()) -> UIApp u ())
-> (String -> UIApp u ()) -> UIApp u ()
forall a b. (a -> b) -> a -> b
$ \String
_text ->
        Drawing -> DrawingBuilder () -> UIApp u ()
forall (m :: * -> *) a.
MonadIO m =>
Drawing -> DrawingBuilder a -> m a
drawingRun Drawing
drawing (DrawingBuilder () -> UIApp u ())
-> DrawingBuilder () -> UIApp u ()
forall a b. (a -> b) -> a -> b
$ do
            let ls :: [String]
ls = String -> [String]
lines String
_text
            let y :: Int
y = (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

            TextAlign
_align <- Label
-> (Label -> Attribute TextAlign) -> ReaderT Drawing IO TextAlign
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> m a
get Label
label Label -> Attribute TextAlign
forall w. TextClass w => w -> Attribute TextAlign
align
            [(String, Int)]
-> ((String, Int) -> DrawingBuilder ()) -> DrawingBuilder ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([String] -> [Int] -> [(String, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
ls [Int
0..]) (((String, Int) -> DrawingBuilder ()) -> DrawingBuilder ())
-> ((String, Int) -> DrawingBuilder ()) -> DrawingBuilder ()
forall a b. (a -> b) -> a -> b
$ \(String
l, Int
i) ->
                case TextAlign
_align of
                    TextAlign
TextAlignLeft   -> Int -> Int -> String -> DrawingBuilder ()
drawingPutString Int
0 (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) String
l
                    TextAlign
TextAlignRight  -> Int -> Int -> String -> DrawingBuilder ()
drawingPutString (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l) (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) String
l
                    TextAlign
TextAlignCenter -> Int -> Int -> String -> DrawingBuilder ()
drawingPutString ((Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) String
l