hets/GUI/GtkLinkTypeChoice.hs

{- |
Module      :  ./GUI/GtkLinkTypeChoice.hs
Description :  Gtk GUI for the selection of linktypes
Copyright   :  (c) Thiemo Wiedemeyer, Uni Bremen 2008
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  raider@informatik.uni-bremen.de
Stability   :  provisional
Portability :  portable

This module provides a GUI for the selection of linktypes.
-}

module GUI.GtkLinkTypeChoice
  (showLinkTypeChoice)
  where

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade

import GUI.GtkUtils
import qualified GUI.Glade.LinkTypeChoice as LinkTypeChoice

import Static.DgUtils

import Control.Monad (filterM)

import Data.IORef
import qualified Data.Map as Map

mapEdgeTypesToNames :: Map.Map String (DGEdgeType, DGEdgeType)
mapEdgeTypesToNames = Map.fromList $ map
  (\ e -> ("cb" ++ getDGEdgeTypeName e, (e, e { isInc = True })))
  (filter (not . isInc) listDGEdgeTypes)

-- | Displays the linktype selection window
showLinkTypeChoice :: IORef [String] -> ([DGEdgeType] -> IO ()) -> IO ()
showLinkTypeChoice ioRefDeselect updateFunction = postGUIAsync $ do
  xml <- getGladeXML LinkTypeChoice.get
  window <- xmlGetWidget xml castToWindow "linktypechoice"
  ok <- xmlGetWidget xml castToButton "btnOk"
  cancel <- xmlGetWidget xml castToButton "btnCancel"
  select <- xmlGetWidget xml castToButton "btnSelect"
  deselect <- xmlGetWidget xml castToButton "btnDeselect"
  invert <- xmlGetWidget xml castToButton "btnInvert"

  deselectEdgeTypes <- readIORef ioRefDeselect
  mapM_ (\ name -> do
          cb <- xmlGetWidget xml castToCheckButton name
          toggleButtonSetActive cb False
        ) deselectEdgeTypes

  let
    edgeMap = mapEdgeTypesToNames
    keys = Map.keys edgeMap
    setAllTo to = mapM_ (\ name -> do
                                cb <- xmlGetWidget xml castToCheckButton name
                                to' <- to cb
                                toggleButtonSetActive cb to'
                              ) keys

  onClicked select $ setAllTo (\ _ -> return True)
  onClicked deselect $ setAllTo (\ _ -> return False)
  onClicked invert $ setAllTo (\ cb -> do
                                selected <- toggleButtonGetActive cb
                                return $ not selected
                              )

  onClicked cancel $ widgetDestroy window

  onClicked ok $ do
    edgeTypeNames <- filterM (\ name -> do
                               cb <- xmlGetWidget xml castToCheckButton name
                               selected <- toggleButtonGetActive cb
                               return $ not selected
                             ) keys
    writeIORef ioRefDeselect edgeTypeNames
    let edgeTypes = foldl (\ eList (e, eI) -> e : eI : eList) []
                           $ map (flip (Map.findWithDefault
                                   (error "GtkLinkTypeChoice: lookup error!"))
                                   edgeMap
                                 ) edgeTypeNames
    forkIO_ $ updateFunction edgeTypes
    widgetDestroy window

  widgetShow window