Label.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 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
    { _labelParent :: Text
    }

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

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

instance LabelClass Label where
    castToLabel = id

instance TextClass Label where
    castToText = _labelParent

instance WidgetClass Label where
    castToWidget = castToWidget . _labelParent

    overrideWidget = overrideWidgetHelper labelParent

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

    _ <- on label draw $ labelDraw label

    return label

labelNewOverride :: Maybe String -> UIApp u Label
labelNewOverride s = override <$> labelNewDefault s
  where
    labelComputeSize label = do
        maybeText <- get label text

        case maybeText of
            Nothing -> return (1, 1)
            Just _text -> do
                let ls = lines _text
                let ws = map length ls

                let w = maximum ws
                let l = length ls

                return ( if w == 0 then 1 else w
                       , if l == 0 then 1 else l
                       )

    override label = overrideWidget label $ do
        virtualWidgetName .= "label"
        virtualWidgetComputeSize .= labelComputeSize label

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

    return Label
        { _labelParent = parent
        }

labelDraw :: Label -> Drawing -> Int -> Int -> UIApp u ()
labelDraw label drawing width height = do
    maybeText <- get label text

    fg <- get label colorForeground
    bg <- get label colorBackground
    style <- get label colorStyle

    drawingRun drawing $ do
        drawingSetAttrs fg bg style
        drawingClear

    forM_ maybeText $ \_text ->
        drawingRun drawing $ do
            let ls = lines _text
            let y = (height - length ls) `div` 2

            _align <- get label align
            forM_ (zip ls [0..]) $ \(l, i) ->
                case _align of
                    TextAlignLeft   -> drawingPutString 0 (y + i) l
                    TextAlignRight  -> drawingPutString (width - length l) (y + i) l
                    TextAlignCenter -> drawingPutString ((width - length l) `div` 2) (y + i) l