MultiList.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.Widgets.MultiList (
    MultiListWidget,
    multiListNew,
    multiListButtonNew,
    multiListButtonShow,
    multiListButtonOnActivated,
    multiListOptionClear,
    multiListOptionAdd,
    multiListOptionAdd',
    multiListOptionSetCursor,
    multiListOptionGetCursor,
    multiListOptionToList
) where

import qualified System.Glib.Types as Gtk
import qualified Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk ( AttrOp(..) )

import Control.Monad
import Data.IORef

import Coin.UI.Widgets.SimpleListView
import Coin.UI.Utils.CssUtils

data MultiListData = MultiListData {
    multiListButton      :: Gtk.Button,
    multiListWindow      :: Gtk.ScrolledWindow,
    multiListView        :: SimpleListView,
    multiListConnections :: IORef [Gtk.ConnectId SimpleListView]
}

data MultiListWidget = MultiListWidget {
    multiListContainer :: Gtk.VBox,
    multiListWidgets   :: IORef [MultiListData],
    multiListCounter   :: IORef Int
}

instance Gtk.GObjectClass MultiListWidget where
    toGObject = Gtk.toGObject . multiListContainer
    unsafeCastGObject = undefined

instance Gtk.WidgetClass MultiListWidget

multiListNew :: IO MultiListWidget
multiListNew = do
    box <- Gtk.vBoxNew False 0
    widgets <- newIORef []
    counter <- newIORef 0
    return $ MultiListWidget box widgets counter

multiListButtonNew :: MultiListWidget -> String -> IO Int
multiListButtonNew multiList text = do
    let buttonCss =
           [ "button {"
           , "    padding: 5px;"
           , "    border-radius: 8px;"
           , "    font-weight: bold;"
           , "}"
           ]

    index <- readIORef $ multiListCounter multiList

    button <- Gtk.buttonNew
    Gtk.set button [ Gtk.buttonLabel := text, Gtk.buttonXalign := 0.0, cssStyle := buttonCss]
    void $ Gtk.on button Gtk.buttonActivated $ multiListButtonShow multiList index
    listView <- simpleListViewNew []

    let vbox = multiListContainer multiList
    Gtk.boxPackStart vbox button Gtk.PackNatural 0

    scrolledWindow <- Gtk.scrolledWindowNew Nothing Nothing
    Gtk.scrolledWindowAddWithViewport scrolledWindow listView

    Gtk.boxPackStart vbox scrolledWindow Gtk.PackGrow 0

    connections <- newIORef []
    modifyIORef' (multiListWidgets multiList) $ \w ->
        w ++ [MultiListData button scrolledWindow listView connections]

    modifyIORef' (multiListCounter multiList) (+1)

    return index

multiListButtonShow :: MultiListWidget -> Int -> IO ()
multiListButtonShow multiList index = do
    widgets <- readIORef $ multiListWidgets multiList
    forM_ widgets $ \d -> Gtk.widgetHide $ multiListWindow d
    let d = widgets !! index
    Gtk.widgetShow $ multiListWindow d

multiListButtonOnActivated :: MultiListWidget -> Int -> IO () -> IO ()
multiListButtonOnActivated multiList index action = do
    widgets <- readIORef $ multiListWidgets multiList
    let d = widgets !! index
    void $ Gtk.on (multiListButton d) Gtk.buttonActivated action

multiListOptionClear :: MultiListWidget -> Int -> IO ()
multiListOptionClear multiList index = do
    widgets <- readIORef $ multiListWidgets multiList
    let d = widgets !! index

    connections <- readIORef $ multiListConnections d
    forM_ connections Gtk.signalDisconnect
    modifyIORef' (multiListConnections d) $ const []

    simpleListViewClear $ multiListView d

multiListOptionAdd' :: MultiListWidget -> Int -> [(String, IO ())] -> IO ()
multiListOptionAdd' multiList index tuples =
    forM_ tuples $ \(text, action) -> multiListOptionAdd multiList index text action

multiListOptionAdd :: MultiListWidget -> Int -> String -> IO () -> IO ()
multiListOptionAdd multiList index text action = do
    widgets <- readIORef $ multiListWidgets multiList
    let d = widgets !! index
    let list = multiListView d
    listIndex <- simpleListViewAppend list text
    connID <- Gtk.on list Gtk.cursorChanged $ do
        (path, _) <- Gtk.treeViewGetCursor list
        when (path == [listIndex]) $ do
            forM_ widgets $ \dta ->
                when (list /= multiListView dta) $ do
                    selection <- Gtk.treeViewGetSelection $ multiListView dta
                    Gtk.treeViewSetCursor (multiListView dta) [] Nothing
                    Gtk.treeSelectionUnselectAll selection
            action

    modifyIORef' (multiListConnections d) (connID:)

multiListOptionSetCursor :: MultiListWidget -> Int -> Int -> IO ()
multiListOptionSetCursor multiList buttonIndex listIndex = do
    widgets <- readIORef $ multiListWidgets multiList
    let d = widgets !! buttonIndex
    let list = multiListView d
    multiListButtonShow multiList buttonIndex
    Gtk.treeViewSetCursor list [listIndex] Nothing

multiListOptionGetCursor :: MultiListWidget -> IO (Maybe (Int, Int))
multiListOptionGetCursor multiList = do
    widgets <- readIORef $ multiListWidgets multiList

    foldM (\rval (idx, widget) ->
               case rval of
                   Just _  -> return rval
                   Nothing -> do
                       (path, _) <- Gtk.treeViewGetCursor $ multiListView widget
                       case path of
                           [path'] -> return $ Just (idx, path')
                           _       -> return Nothing
          )
          Nothing
          (zip [0..] widgets)

multiListOptionToList :: MultiListWidget -> Int -> IO [String]
multiListOptionToList multiList index = do
    widgets <- readIORef $ multiListWidgets multiList
    let d = widgets !! index
    simpleListViewToList $ multiListView d