{- |
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