GtkUIBuilder.hs

{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2015 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
-}

module Coin.UI.Builder.GtkUIBuilder (
    -- attributes
    widgetAttrs,
    windowAttrs,
    buttonAttrs,
    labelAttrs,
    frameAttrs,
    arrowAttrs,
    entryAttrs,
    gridAttrs,
    containerAttrs,
    globalCss,
    -- containers
    window,
    scrolledWindow,
    frame,
    vbox,
    hbox,
    hPaned,
    vPaned,
    notebook,
    simplePage,
    grid,
    gridAttach,
    -- widgets
    label,
    button,
    buttonFromStock,
    checkButton,
    toggleButton,
    imageFromStock,
    hseparator,
    vseparator,
    entry,
    textview,
    arrow,
    -- some functions
    putWidget,
    packing,
    packingDefault,
    pack,
    packDefault,
    -- re-exports
    uiBuildGtk,
    UIBuilder,
    gridColumnSpacing,
    gridRowSpacing,
    gridColumnHomogeneous,
    gridRowHomogeneous
) where

import qualified Data.Map.Strict as Map
import qualified Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk ( AttrOp(..) )

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State.Strict
import Data.Maybe
import Control.Lens

import Coin.UI.Builder.GtkUIAttributes
import Coin.UI.Builder.GtkUIBuilderState
import Coin.UI.Builder.GtkUIUtils

-- attributes

widgetAttrs :: [AttrOp Gtk.Widget] -> UIBuilder a
widgetAttrs attrs = uiStateAttrs .= WidgetAttrs attrs

windowAttrs :: [AttrOp Gtk.Window] -> UIBuilder a
windowAttrs attrs = uiStateAttrs .= WindowAttrs attrs

buttonAttrs :: [AttrOp Gtk.Button] -> UIBuilder a
buttonAttrs attrs = uiStateAttrs .= ButtonAttrs attrs

labelAttrs :: [AttrOp Gtk.Label] -> UIBuilder a
labelAttrs attrs = uiStateAttrs .= LabelAttrs attrs

frameAttrs :: [AttrOp Gtk.Frame] -> UIBuilder a
frameAttrs attrs = uiStateAttrs .= FrameAttrs attrs

arrowAttrs :: [AttrOp Gtk.Arrow] -> UIBuilder a
arrowAttrs attrs = uiStateAttrs .= ArrowAttrs attrs

entryAttrs :: [AttrOp Gtk.Entry] -> UIBuilder a
entryAttrs attrs = uiStateAttrs .= EntryAttrs attrs

gridAttrs :: [AttrOp Gtk.Grid] -> UIBuilder a
gridAttrs attrs = uiStateAttrs .= GridAttrs attrs

containerAttrs :: [AttrOp Gtk.Container] -> UIBuilder a
containerAttrs attrs = uiStateAttrs .= ContainerAttrs attrs

globalCss :: [String] -> UIBuilder a
globalCss cssText = uiStateCss .= cssText

-- containers

window :: Maybe String -> String -> UIBuilder a -> UIBuilder a
window name title builder = do
    win <- liftIO Gtk.windowNew
    liftIO $ Gtk.set win [ Gtk.windowTitle := title ]
    recordUI builder (Gtk.containerAdd win)
    record name win

scrolledWindow :: Maybe String -> UIBuilder a -> UIBuilder a
scrolledWindow name builder = do
    scrolled <- liftIO $ Gtk.scrolledWindowNew Nothing Nothing
    liftIO $ do
        Gtk.scrolledWindowSetMinContentWidth scrolled 100
        Gtk.scrolledWindowSetMinContentHeight scrolled 100
    recordUI builder (Gtk.containerAdd scrolled)
    record name scrolled

frame :: Maybe String -> Maybe String -> UIBuilder a -> UIBuilder a
frame name text builder = do
    fr <- liftIO Gtk.frameNew
    case text of
        Just text' -> liftIO $ Gtk.frameSetLabel fr text'
        Nothing    -> return ()
    recordUI builder (Gtk.containerAdd fr)
    record name fr

vbox :: Maybe String -> Bool -> Int -> UIBuilder a -> UIBuilder a
vbox name homogeneous spacing builder = do
    box <- liftIO $ Gtk.vBoxNew homogeneous spacing
    recordUI' builder (Gtk.boxPackStart box)
    record name box

hbox :: Maybe String -> Bool -> Int -> UIBuilder a -> UIBuilder a
hbox name homogeneous spacing builder = do
    box <- liftIO $ Gtk.hBoxNew homogeneous spacing
    recordUI' builder (Gtk.boxPackStart box)
    record name box

hPaned :: Maybe String -> UIBuilder a -> UIBuilder a -> UIBuilder a
hPaned name left right = do
    paned <- liftIO Gtk.hPanedNew
    recordUI left  (Gtk.panedAdd1 paned)
    recordUI right (Gtk.panedAdd2 paned)

    liftIO $ do
        child1 <- Gtk.panedGetChild1 paned
        case child1 of
            Just child1' -> do
                Gtk.widgetSetSizeRequest child1' 100 (-1)
                Gtk.set paned [ Gtk.panedChildShrink child1' := False ]
            Nothing ->
                return ()

    record name paned

vPaned :: Maybe String -> UIBuilder a -> UIBuilder a -> UIBuilder a
vPaned name left right = do
    paned <- liftIO Gtk.vPanedNew
    recordUI left  (Gtk.panedAdd1 paned)
    recordUI right (Gtk.panedAdd2 paned)

    liftIO $ do
        child1 <- Gtk.panedGetChild1 paned
        case child1 of
            Just child1' -> do
                Gtk.widgetSetSizeRequest child1' (-1) 100
                Gtk.set paned [ Gtk.panedChildShrink child1' := False ]
            Nothing ->
                return ()

    record name paned

notebook :: Maybe String -> UINotebookBuilder a -> UIBuilder a
notebook name builder = do
    nb <- liftIO Gtk.notebookNew

    builderState <- get
    ui <- liftIO $ execUINotebookBuilder $ do
        uiNSBuilderState .= builderState
        builder

    forM_ (ui^.uiNSList) $ \(textLabel, pageWidget) ->
        void $ liftIO $ Gtk.notebookAppendPageMenu nb pageWidget textLabel textLabel
    uiStateMap %= Map.union (ui^.uiNSMap)
    record name nb

simplePage :: String -> UIBuilder a -> UINotebookBuilder a
simplePage text builder = do
    textLabel <- liftIO $ Gtk.labelNew $ Just text

    builderState <- use uiNSBuilderState
    (hashMap, widgetList) <- liftIO $ uiBuildGtk' builderState builder
    uiNSMap %= Map.union hashMap
    uiNSList <>= [(Gtk.castToWidget textLabel, fromJust $ widgetList^?traverse.wdWidget)]

grid :: Maybe String -> UIGridBuilder a -> UIBuilder a
grid name builder = do
    t <- liftIO Gtk.gridNew

    builderState <- get
    ui <- liftIO $ execUIGridBuilder $ do
        uiGridBuilderState .= builderState
        builder

    uiStateMap %= Map.union (ui^.uiGridMap)
    forM_ (ui^.uiGridList) $ \dta ->
        liftIO $ Gtk.gridAttach
                 t
                 (dta^.uiGridDataWidget)
                 (dta^.uiGridDataLeft)
                 (dta^.uiGridDataRight)
                 (dta^.uiGridDataWidth)
                 (dta^.uiGridDataHeight)
    record name t

gridAttach :: Int -> Int -> Int -> Int -> UIBuilder a -> UIGridBuilder a
gridAttach left right width height builder = do
    builderState <- use uiGridBuilderState
    (hashMap, widgetList) <- liftIO $ uiBuildGtk' builderState builder
    uiGridMap %= Map.union hashMap
    uiGridList <>= [UIGridData
                        { _uiGridDataWidget = fromJust $ widgetList^?traverse.wdWidget
                        , _uiGridDataLeft = left
                        , _uiGridDataRight = right
                        , _uiGridDataWidth = width
                        , _uiGridDataHeight = height
                        }]

-- widgets

label :: Maybe String -> String -> UIBuilder a
label name text = do
    lab <- liftIO $ Gtk.labelNew $ Just text
    record name lab

button :: Maybe String -> String -> UIBuilder a
button name text = do
    b <- liftIO $ Gtk.buttonNewWithLabel text
    record name b

buttonFromStock :: Maybe String -> Gtk.StockId -> UIBuilder a
buttonFromStock name stockID = do
    b <- liftIO $ Gtk.buttonNewFromStock stockID
    record name b

checkButton :: Maybe String -> String -> UIBuilder a
checkButton name text = do
    b <- liftIO $ Gtk.checkButtonNewWithLabel text
    record name b

toggleButton :: Maybe String -> String -> UIBuilder a
toggleButton name text = do
    b <- liftIO $ Gtk.toggleButtonNewWithLabel text
    record name b

imageFromStock :: Maybe String -> Gtk.StockId -> Gtk.IconSize -> UIBuilder a
imageFromStock name stockID size = do
    image <- liftIO $ Gtk.imageNewFromStock stockID size
    record name image

hseparator :: Maybe String -> UIBuilder a
hseparator name = do
    sep <- liftIO Gtk.hSeparatorNew
    record name sep

vseparator :: Maybe String -> UIBuilder a
vseparator name = do
    sep <- liftIO Gtk.vSeparatorNew
    record name sep

entry :: Maybe String -> String -> UIBuilder a
entry name text = do
    e <- liftIO Gtk.entryNew
    liftIO $ Gtk.entrySetText e text
    record name e

textview :: Maybe String -> String -> UIBuilder a
textview name text = do
    t <- liftIO Gtk.textViewNew
    b <- liftIO $ Gtk.textViewGetBuffer t
    liftIO $ Gtk.textBufferSetText b text
    record name t

arrow :: Maybe String -> Gtk.ArrowType -> Gtk.ShadowType -> UIBuilder a
arrow name arrowType shadowType = do
    a <- liftIO $ Gtk.arrowNew arrowType shadowType
    record name a

-- functions

putWidget :: Gtk.WidgetClass cls => cls -> UIBuilder a
putWidget = record Nothing

packing :: Gtk.Packing -> Int -> UIBuilder a
packing packing' padding = uiStatePack .= (packing', padding)

packingDefault :: UIBuilder a
packingDefault = uiStatePack .= _uiStatePack builderStateEmpty

pack :: Gtk.Packing -> Int -> UIBuilder a -> UIBuilder a
pack packing' padding builder = do
    packTmp <- use uiStatePack
    packing packing' padding
    builder
    uiStatePack .= packTmp

packDefault :: UIBuilder a -> UIBuilder a
packDefault builder = do
    let (packing', padding) = _uiStatePack builderStateEmpty
    pack packing' padding builder