CheckList.hs

{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2016 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.CheckList (
    CheckListWidget,
    checkListNew,
    checkListAppend,
    checkListClear,
    checkListGetSelected,
    checkListGetSelectionIndex,
    checkListSetSelectionIndex
) where

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

import qualified Data.Text as T

import Control.Monad
import Data.Foldable
import Data.IORef

import Coin.Locale.Translate
import Coin.UI.Builder.GtkUIBuilder

data CheckListWidget a = CheckListWidget {
    checkListRoot     :: Gtk.Widget,
    checkListStore    :: Gtk.ListStore (Bool, T.Text),
    checkListOriginal :: IORef [a],
    checkListSelected :: IORef [Int],
    checkListToText   :: a -> T.Text
}

instance Gtk.GObjectClass (CheckListWidget a) where
    toGObject = Gtk.toGObject . checkListRoot
    unsafeCastGObject = undefined

instance Gtk.WidgetClass (CheckListWidget a)

reserved :: Int
reserved = 2

checkListNew :: String -> (a -> T.Text) -> IO (CheckListWidget a)
checkListNew name toText = do
    store <- Gtk.listStoreNew []
    treeView <- Gtk.treeViewNewWithModel store
    Gtk.treeViewSetHeadersVisible treeView False

    col1 <- Gtk.treeViewColumnNew
    col2 <- Gtk.treeViewColumnNew

    cell1 <- Gtk.cellRendererToggleNew
    Gtk.cellRendererToggleSetRadio cell1 False
    cell2 <- Gtk.cellRendererTextNew

    Gtk.cellLayoutSetAttributes col1 cell1 store $ \(x, _) -> [ Gtk.cellToggleActive := x ]
    Gtk.cellLayoutSetAttributes col2 cell2 store $ \(_, x) -> [ Gtk.cellText := x ]

    Gtk.treeViewColumnPackStart col1 cell1 True
    Gtk.treeViewColumnPackStart col2 cell2 True

    forM_ [col1, col2] $ Gtk.treeViewAppendColumn treeView

    (_, root) <- uiBuildGtk $
        vbox Nothing False 2 $ do
            pack Gtk.PackNatural 2 $ do
                labelAttrs [ Gtk.miscXalign := 0.0 ]
                label Nothing $ " " ++ name
            scrolledWindow Nothing $ putWidget treeView

    selectedList <- newIORef []
    originalList <- newIORef []
    let checkList = CheckListWidget root store originalList selectedList toText

    checkListClear checkList

    void $ Gtk.on cell1 Gtk.cellToggled $ \s -> do
        let i = read s
        (selected, _) <- Gtk.listStoreGetValue store i
        if | i == 0    -> if selected then
                              checkListLoadState checkList
                          else do
                              checkListSaveState checkList
                              checkListSelectAll checkList
                              checkListModifySelection checkList 0 $ const True
           | i == 1    -> if selected then
                              checkListLoadState checkList
                          else do
                              checkListSaveState checkList
                              checkListDeselectAll checkList
                              checkListModifySelection checkList 1 $ const True
           | otherwise -> do
                              checkListModifySelection checkList 0 $ const False
                              checkListModifySelection checkList 1 $ const False
                              checkListModifySelection checkList i not

    return checkList

checkListSaveState :: CheckListWidget a -> IO ()
checkListSaveState checkList = do
    indexes <- checkListGetSelectionIndex checkList
    modifyIORef' (checkListSelected checkList) $ const indexes

checkListLoadState :: CheckListWidget a -> IO ()
checkListLoadState checkList = do
    indexes <- readIORef $ checkListSelected checkList
    checkListSetSelectionIndex checkList indexes

checkListModifySelection :: CheckListWidget a -> Int -> (Bool -> Bool) -> IO ()
checkListModifySelection checkList i f = do
    (selected, text) <- Gtk.listStoreGetValue (checkListStore checkList) i
    Gtk.listStoreSetValue (checkListStore checkList) i (f selected, text)

checkListDeselectAll :: CheckListWidget a -> IO ()
checkListDeselectAll checkList = do
    size <- Gtk.listStoreGetSize $ checkListStore checkList
    forM_ [0 .. size - 1] $ \k -> checkListModifySelection checkList k $ const False

checkListSelectAll :: CheckListWidget a -> IO ()
checkListSelectAll checkList = do
    size <- Gtk.listStoreGetSize $ checkListStore checkList
    forM_ [0 .. size - 1] $ \k -> checkListModifySelection checkList k $ const True
    checkListModifySelection checkList 0 $ const False
    checkListModifySelection checkList 1 $ const False

checkListGetSelected :: CheckListWidget a -> IO [a]
checkListGetSelected checkList = do
    indexes <- checkListGetSelectionIndex checkList
    elements <- readIORef $ checkListOriginal checkList
    forM indexes $ \i -> return $ elements !! i

checkListSetSelectionIndex :: CheckListWidget a -> [Int] -> IO ()
checkListSetSelectionIndex checkList indexes = do
    checkListDeselectAll checkList
    forM_ indexes $ \k -> checkListModifySelection checkList (k + reserved) $ const True

checkListGetSelectionIndex :: CheckListWidget a -> IO [Int]
checkListGetSelectionIndex checkList = do
    size <- Gtk.listStoreGetSize $ checkListStore checkList
    foldrM (\i acc -> do
                (sel, _) <- Gtk.listStoreGetValue (checkListStore checkList) i
                if sel then
                    return (i - reserved: acc)
                else
                    return acc)
           []
           [reserved .. size - 1]

checkListAppend' :: CheckListWidget a -> Bool -> T.Text -> IO ()
checkListAppend' checkList toggle text = void $ Gtk.listStoreAppend (checkListStore checkList) (toggle, text)

checkListAppend :: CheckListWidget a -> Bool -> a -> IO ()
checkListAppend checkList toggle entity = do
    checkListAppend' checkList toggle (checkListToText checkList entity)
    modifyIORef' (checkListOriginal checkList) (++[entity])

checkListClear :: CheckListWidget a -> IO ()
checkListClear checkList = do
    Gtk.listStoreClear $ checkListStore checkList
    checkListAppend' checkList False (T.pack $ __"Select all")
    checkListAppend' checkList False (T.pack $ __"Deselect all")