uni-htk-2.2.0.0: HTk/Toolkit/GenGUI.hs
-- | A generic graphical user interface.
module HTk.Toolkit.GenGUI (
GenGUI, -- type
newGenGUI, {- :: CItem c => Maybe (GenGUIState c) -> IO (GenGUI c) -}
setStatus, {- :: CItem c => GenGUI c-> String-> IO () -}
clearStatus, {- :: CItem c => GenGUI c-> IO () -}
updateTextArea, {- :: CItem c => GenGUI c-> [MarkupText] -> IO () -}
clearTextArea, {- :: CItem c => GenGUI c-> IO () -}
genGUIMainMenu, {- :: CItem c => GenGUI c-> Menu -}
NewItem(..), -- external object representation
Item, -- internal object representation
Name(..),
CItem(..),
root, {- :: CItem c => GenGUI c -> IO (Item c) -}
openedFolder, {- :: CItem c=> GenGUI c-> IO (Maybe (Item c)) -}
addItem, {- :: CItem c => Item c -> NewItem c -> IO (Item c) -}
children, {- :: CItem c => Item c -> IO [Item c] -}
content, {- :: CItem c => (Item c) -> c -}
GenGUIEvent(..),
bindGenGUIEv, {- :: CItem c => GenGUI c -> -}
{- IO (Event (GenGUIEvent c), IO()) -}
GenGUIState, -- representation of the gui's state
exportGenGUIState, {- :: CItem c => GenGUI c -> IO (GenGUIState c) -}
) where
import Data.List
import Data.Maybe
import Util.Computation
import Events.Events
import Events.Channels
import Events.Synchronized
import Reactor.ReferenceVariables
import HTk.Toplevel.HTk hiding (font)
import qualified HTk.Toplevel.HTk as HTk (font)
import HTk.Toolkit.ScrollBox
import qualified HTk.Toolkit.TreeList as TreeList (obj_val, TreeListEvent(Selected), selected)
import HTk.Toolkit.TreeList hiding (obj_val, TreeListEvent(Selected), selected)
import qualified HTk.Toolkit.Notepad as Notepad (NotepadEvent(Dropped, Doubleclick, Rightclick))
import HTk.Toolkit.Notepad hiding (NotepadEvent(Dropped, Doubleclick, Rightclick))
import HTk.Kernel.Core
import HTk.Toolkit.MarkupText
import HTk.Toolkit.CItem
--------------------------------------------------------------------------
-- external object representation
--------------------------------------------------------------------------
-- | External representation of gengui objects.
data NewItem c =
LeafItem c (Maybe (Position, -- position on notepad
Bool -- selected in notepad
))
| FolderItem c [NewItem c] (Maybe (Bool, -- open in TreeList
-- (recover only)
Bool -- displayed in notepad
))
-- | Gets the name of a newitem object.
getNameFromNewItem :: CItem c => NewItem c -> IO Name
getNameFromNewItem (LeafItem c _) = getName c
getNameFromNewItem (FolderItem c _ _) = getName c
-- | Returns whether the given object is a folder or not.
isNewItemFolder :: CItem c => NewItem c -> Bool
isNewItemFolder (FolderItem _ _ _) = True
isNewItemFolder _ = False
--------------------------------------------------------------------------
-- internal type & functionality
--------------------------------------------------------------------------
-- | internal object representation
data Item c =
IntFolderItem (NewItem c) -- external representation
(Ref [Item c]) -- subitems
| IntLeafItem (NewItem c) -- external representation
(Ref Position) -- position on notepad
(Ref Bool) -- selected on notepad
| Root (Ref [Item c])
-- | Internal.
instance CItem c => Eq (Item c) where
item1 == item2 = content item1 == content item2
-- | Objects must have a name and an icon.
instance CItem c => CItem (Item c) where
-- Gets the object\'s name.
getName = getName . content
-- Gets the object\'s icon.
getIcon = getIcon . content
-- | Returns whether an item is a folder or not.
isItemFolder :: Item c
-- ^ the concerned item.
-> Bool
-- ^ @True@ if the given item is a folder,
-- otherwise @False@.
isItemFolder it@(IntFolderItem _ _) = True
isItemFolder _ = False
-- | Returns whether an item is a folder or not.
isItemLeaf :: Item c -> Bool
isItemLeaf = Prelude.not . isItemFolder
-- | Converts the external object representation to the internal object
-- representation.
toItem :: CItem c => NewItem c -> IO (Item c)
toItem it@(FolderItem _ ch _) =
do
intch <- mapM toItem ch
intchref <- newRef intch
return (IntFolderItem it intchref)
toItem it@(LeafItem _ Nothing) =
do
posref <- newRef (-1, -1)
selref <- newRef False
return (IntLeafItem it posref selref)
toItem it@(LeafItem _ (Just (pos, selected))) =
do
posref <- newRef pos
selref <- newRef selected
return (IntLeafItem it posref selref)
--------------------------------------------------------------------------
-- external handle for root object
--------------------------------------------------------------------------
-- | GenGUI\'s root object.
root :: CItem c => GenGUI c -> IO (Item c)
root gui = return (Root (root_obj gui))
--------------------------------------------------------------------------
-- state import/export
--------------------------------------------------------------------------
-- | The gui\'s state.
type GenGUIState c = [NewItem c]
-- | Exports the gui\'s state.
exportGenGUIState :: CItem c => GenGUI c
-- ^ the concerned GenGUI.
-> IO (GenGUIState c)
-- ^ the gui\'s state.
exportGenGUIState gui =
do
saveNotepadItemStates gui
items <- getRef (root_obj gui)
mopenobj <- getRef (open_obj gui)
export items mopenobj
where export (item@(IntFolderItem (FolderItem c _ _) subitemsref) :
items) mopenobj =
do
subitems <- getRef subitemsref
subnewitems <- export subitems mopenobj
is_open <- isTreeListObjectOpen (treelist gui) item
rest <- export items mopenobj
return (FolderItem c subnewitems
(Just (is_open, Just item == mopenobj)) :
rest)
export (IntLeafItem (LeafItem c _) posref selref : items)
mopenobj =
do
pos <- getRef posref
selected <- getRef selref
rest <- export items mopenobj
return (LeafItem c (Just (pos, selected)) : rest)
export _ _ = return []
--------------------------------------------------------------------------
-- type and constructor
--------------------------------------------------------------------------
-- | The @GenGUI@ datatye.
data GenGUI c =
GenGUI
{ -- the treelist
treelist :: TreeList (Item c),
-- the notepad
notepad :: Notepad (Item c),
-- the markup text container
editor :: Editor,
-- the status bar
status :: Label,
-- GenGUI's main menu
topmenu :: Menu,
-- GenGUI's toplevel window
win :: Toplevel,
-- item displayed in notepad
open_obj :: Ref (Maybe (Item c)),
-- temporary, needed for current stupid placement of notepad items
place :: Ref Position,
-- internal state
root_obj :: Ref [Item c],
-- events
event_queue :: Ref (Maybe (Channel (GenGUIEvent c))),
show_leaves_in_tree :: Bool }
-- -----------------------------------------------------------------------
-- construction
-- -----------------------------------------------------------------------
-- | Constructs a new gui and returns a handler.
newGenGUI :: CItem c => Maybe (GenGUIState c)
-- ^ an optional GenGUI state to recover.
-> Bool
-- ^ @True@ if lleaves should be
-- displayed in the tree list.
-> IO (GenGUI c)
-- ^ A gui.
newGenGUI mstate showLeavesInTree =
do
-- main window
main <- createToplevel [text "GenGUI"]
-- GenGUI menubar
menubar <- createMenu main False []
main # menu menubar
-- references
intstate <- case mstate of
Just state -> do
state <- mapM toItem state
newRef state
Nothing -> newRef []
displayref <- newRef Nothing
-- construct main widgets
let constructTreeListState intend
(newitem@(FolderItem c subnewitems
(Just (open,
selected))) :
newitems) =
do
subtreelistitems <- if open then
constructTreeListState (intend + 1)
subnewitems
else return []
rest <- constructTreeListState intend newitems
item <- toItem newitem
if selected then setRef displayref (Just item) else done
-- side effect: set reference for item displayed in notepad
return ([TreeListExportItem
{ TreeList.obj_val = item,
obj_type =
if (any isNewItemFolder subnewitems) then Node
else Leaf,
open = open,
intend = intend,
TreeList.selected = selected }] ++
subtreelistitems ++ rest)
constructTreeListState intend (_ : newitems) =
constructTreeListState intend newitems
constructTreeListState _ _ = return []
stlab <- newLabel main [text "Welcome", relief Sunken,
HTk.font (Lucida, 12::Int)]
pack stlab [Side AtBottom, PadX 5, PadY 2, Fill X]
treeliststate <-
case mstate of
Just state -> do
tlstate <- constructTreeListState 0 state
return (Just tlstate)
Nothing -> return Nothing
tix <- isTixAvailable
(tl, np, edscr, ed) <-
(if tix then
do
objects_n_editor <- newPanedWindow main Horizontal []
paneh1 <- createPane objects_n_editor [initsize 430] []
paneh2 <- createPane objects_n_editor [initsize 370] []
objects <- newPanedWindow paneh1 Vertical []
panev1 <- createPane objects [initsize 220] []
panev2 <- createPane objects [initsize 220] []
pack objects [Fill Both, Expand On]
pack objects_n_editor [Fill Both, Expand On]
tl <- case treeliststate of
Just state ->
recoverTreeList panev1 (cfun showLeavesInTree) state
[background "white"]
_ -> newTreeList panev1 (cfun showLeavesInTree) []
[background "white"]
pack tl [PadX 5, PadY 5, Fill Both, Expand On]
np <- newNotepad panev2 Scrolled (12, 12) Nothing
[background "white", size (800, 800)]
pack np [PadX 5, PadY 5, Fill Both, Expand On]
(edscr, ed) <- newScrollBox paneh2
(\par -> newEditor par [width 40]) []
pack edscr [PadX 6, PadY 6, Fill Both, Expand On]
return (tl, np, edscr, ed)
else
do
objects <- newFrame main []
pack objects [Side AtLeft, Fill Both, Expand On]
tl <- case treeliststate of
Just state -> recoverTreeList objects
(cfun showLeavesInTree) state
[background "white", size (380, 200)]
_ -> newTreeList objects (cfun showLeavesInTree) []
[background "white", size (380, 200)]
pack tl [PadX 5, PadY 5, Fill Both, Expand On]
np <- newNotepad objects Scrolled (12, 12) Nothing
[size (800, 800), background "white"]
pack np [PadX 5, PadY 5, Fill Both, Expand On]
(edscr, ed) <- newScrollBox main
(\par -> newEditor par [width 40]) []
pack edscr [PadX 5, PadY 5, Fill Both, Expand On]
return (tl, np, edscr, ed))
ed # state Disabled
-- temporary (placement of objects in notepad / TD)
posref <- newRef (0, 0)
-- event queue
evq <- newRef Nothing
-- GenGUI value
let gui = GenGUI { treelist = tl,
notepad = np,
editor = ed,
status = stlab,
topmenu = menubar,
win = main,
open_obj = displayref,
place = posref,
root_obj = intstate,
event_queue = evq,
show_leaves_in_tree = showLeavesInTree }
-- listening events
clipboard_dnd <- newRef ((-1,-1), []) -- drop on editor
clipboard_mov <- newRef ((-1,-1), [], Nothing) -- drop on treelist
(enter_ed, _) <- bind ed [WishEvent [] Enter]
(np_ev, _) <- bindNotepadEv np
(tl_ev, _) <- bindTreeListEv tl
_ <- spawnEvent (forever ((do
ev <- np_ev
always
(case ev of
Selected c ->
npItemSelected gui (c, True)
Deselected c ->
npItemSelected gui (c, False)
Notepad.Dropped inf ->
npDropEvent gui inf
Notepad.Doubleclick inf ->
npDoubleClick gui inf
Notepad.Rightclick inf ->
npRightClick gui inf
ReleaseMovement ev_inf ->
synchronize (notepad gui)
(do
((x1, y1), items1) <-
getRef clipboard_dnd
((x2, y2), items2, mitem) <-
getRef clipboard_mov
(if x1 == xRoot ev_inf &&
y1 == yRoot ev_inf then
do
sendEv gui
(DroppedOnTextArea items1)
undoLastMotion np
else
if x2 == xRoot ev_inf &&
y2 == yRoot ev_inf &&
isJust mitem then
do
let item = fromJust mitem
undoLastMotion (notepad gui)
selected_notepaditems <-
getSelectedItems
(notepad gui)
mapM
(saveNotepadItemState gui)
selected_notepaditems
moveItems gui items2 item
else
do
selected_notepaditems <-
getSelectedItems np
selected_items <-
mapM getItemValue
selected_notepaditems
setRef clipboard_dnd
((xRoot ev_inf,
yRoot ev_inf),
selected_items)
setRef clipboard_mov
((xRoot ev_inf,
yRoot ev_inf),
selected_items, Nothing)))
_ -> done)) +>
(do
ev <- tl_ev
always
(case ev of
TreeList.Selected mobj ->
tlObjectSelected gui mobj
Focused mobjninf ->
tlObjectFocused gui clipboard_mov
mobjninf
)) +>
(do
ev_inf <- enter_ed
always
(do
((x, y), items) <- getRef clipboard_dnd
(if x == xRoot ev_inf &&
y == yRoot ev_inf then
do
sendEv gui (DroppedOnTextArea items)
undoLastMotion np
else
do
selected_notepaditems <-
getSelectedItems np
selected_items <-
mapM getItemValue
selected_notepaditems
setRef clipboard_dnd
((xRoot ev_inf, yRoot ev_inf),
selected_items))))))
ditem <- getRef displayref
case ditem of
Just item ->
tlObjectSelected gui (Just (newTreeListObject item Node))
_ -> done
return gui
--------------------------------------------------------------------------
-- internal event handling
--------------------------------------------------------------------------
-- | Saves the state (position etc.) of the currently displayed notepad
-- items.
saveNotepadItemStates :: CItem c => GenGUI c -> IO ()
saveNotepadItemStates gui =
do
npitems <- getItems (notepad gui)
mapM (saveNotepadItemState gui) npitems
done
-- | Saves the state of a single currently displayed notepad item.
saveNotepadItemState :: CItem c => GenGUI c -> NotepadItem (Item c) ->
IO ()
saveNotepadItemState gui npitem =
do
IntLeafItem _ posref selref <- getItemValue npitem
pos <- getPosition npitem
sel <- isNotepadItemSelected (notepad gui) npitem
setRef posref pos
setRef selref sel
-- | Treelist selection event handler.
tlObjectSelected :: CItem c => GenGUI c ->
Maybe (TreeListObject (Item c)) -> IO ()
tlObjectSelected gui mobj =
let addNotepadItem item@(IntLeafItem _ posref selref) =
do
lastpos <- getRef posref
pos <- case lastpos of
(-1, -1) -> do
pos <- getNewItemPosition gui
setItemPosition item pos
return pos
_ -> return lastpos
npitem <- createNotepadItem item (notepad gui) False
[position pos]
b <- getRef selref
if b then selectAnotherItem (notepad gui) npitem else done
in case mobj of
Nothing -> do
mch <- getRef (event_queue gui)
case mch of
Just ch ->
syncNoWait (send ch (SelectTreeList Nothing))
_ -> done
Just obj ->
do
mch <- getRef (event_queue gui)
case mch of
Just ch ->
syncNoWait (send ch (SelectTreeList
(Just
(getTreeListObjectValue obj))))
_ -> done
synchronize gui (do
saveNotepadItemStates gui
ch <- children (getTreeListObjectValue obj)
clearNotepad (notepad gui)
mapM addNotepadItem
(filter isItemLeaf ch)
updNotepadScrollRegion (notepad gui)
done)
setRef (open_obj gui) (Just (getTreeListObjectValue obj))
-- | Treelist focus event handler.
tlObjectFocused :: CItem c => GenGUI c ->
Ref (Position, [Item c], Maybe (Item c)) ->
(Maybe (TreeListObject (Item c)),
EventInfo) ->
IO ()
tlObjectFocused gui clipboard (mobj, ev_inf) =
do
mch <- getRef (event_queue gui)
case mobj of
Just obj -> do
let item = getTreeListObjectValue obj
((x, y), items, mitem) <- getRef clipboard
(if x == xRoot ev_inf &&
y == yRoot ev_inf &&
isNothing mitem then
do
undoLastMotion (notepad gui)
selected_notepaditems <-
getSelectedItems (notepad gui)
mapM (saveNotepadItemState gui)
selected_notepaditems
moveItems gui items item
else do
case mch of
Just ch ->
do
let item = getTreeListObjectValue obj
syncNoWait
(send ch
(FocusTreeList (Just item)))
_ -> done
selected_notepaditems <-
getSelectedItems (notepad gui)
selected_items <-
mapM getItemValue selected_notepaditems
setRef clipboard
((xRoot ev_inf, yRoot ev_inf),
selected_items, Just item))
_ -> case mch of
Just ch -> syncNoWait (send ch (FocusTreeList Nothing))
_ -> done
-- | Moves the given leaf objects to another folder.
moveItems :: CItem c => GenGUI c -> [Item c] -> Item c -> IO ()
moveItems gui items target@(IntFolderItem _ subitemsref) =
let initItem (IntLeafItem _ posref selref) =
setRef posref (-1, -1) >> setRef selref False
in do
Just ditem@(IntFolderItem _ dsubitemsref) <- getRef (open_obj gui)
(if (ditem == target) then done
else do
dsubitems <- getRef dsubitemsref
setRef dsubitemsref (dsubitems \\ items)
subitems <- getRef subitemsref
mapM initItem items
setRef subitemsref (subitems ++ items)
npitems <- getItems (notepad gui)
mapM (\npitem -> do
item <- getItemValue npitem
let b = any (\item' -> item == item')
items
(if b then
deleteItem (notepad gui) npitem
else done)) npitems
done)
--------------------------------------------------------------------------
-- notepad events
--------------------------------------------------------------------------
-- | Notepad selection event handler.
npItemSelected :: CItem c => GenGUI c -> (NotepadItem (Item c), Bool) ->
IO ()
npItemSelected gui (npitem, b) =
do
mch <- getRef (event_queue gui)
case mch of
Just ch ->
do
item <- getItemValue npitem
syncNoWait (send ch (FocusNotepad (item, b)))
_ -> done
-- | Notepad drop event handler.
npDropEvent :: CItem c => GenGUI c ->
(NotepadItem (Item c),
[NotepadItem (Item c)]) -> IO ()
npDropEvent gui (npitem, npitems) =
do
mch <- getRef (event_queue gui)
case mch of
Just ch -> do
item <- getItemValue npitem
items <- mapM getItemValue npitems
syncNoWait (send ch (Dropped (item, items)))
_ -> done
-- | Notepad double click event handler.
npDoubleClick :: CItem c => GenGUI c -> NotepadItem (Item c) -> IO ()
npDoubleClick gui npitem =
do
mch <- getRef (event_queue gui)
case mch of
Just ch -> do
item <- getItemValue npitem
syncNoWait (send ch (Doubleclick item))
_ -> done
-- | Notepad right click event handler.
npRightClick :: CItem c => GenGUI c -> [NotepadItem (Item c)] -> IO ()
npRightClick gui npitems =
do
mch <- getRef (event_queue gui)
case mch of
Just ch -> do
items <- mapM getItemValue npitems
syncNoWait (send ch (Rightclick items))
_ -> done
--------------------------------------------------------------------------
-- notepad item placement
--------------------------------------------------------------------------
-- | Gets the next free item position on the notepad.
getNewItemPosition :: CItem c => GenGUI c -> IO Position
getNewItemPosition gui = getFreeItemPosition (notepad gui)
-- | Sets the items position reference.
setItemPosition :: CItem c => Item c -> Position -> IO ()
setItemPosition (IntLeafItem _ posref _) pos = setRef posref pos
--------------------------------------------------------------------------
-- exported GenGUI functionality
--------------------------------------------------------------------------
-- | Sets the status label\'s text.
setStatus :: CItem c => GenGUI c-> String-> IO ()
setStatus gui txt = (status gui) # text txt >> done
-- | Clears the status label.
clearStatus :: CItem c => GenGUI c-> IO ()
clearStatus gui = (status gui) # text "" >> done
-- | Displays the given markup text on the editor pane.
updateTextArea :: CItem c => GenGUI c-> [MarkupText] -> IO ()
updateTextArea gui mtxt = (editor gui) # new mtxt >> done
-- | Clears the editor pane.
clearTextArea :: CItem c => GenGUI c-> IO ()
clearTextArea gui = (editor gui) # clear >> done
-- | Gets the gui\'s menu container.
genGUIMainMenu :: CItem c => GenGUI c-> Menu
genGUIMainMenu gui = topmenu gui
-- | Gets the children from a folder item.
children :: CItem c => Item c -> IO [Item c]
children (IntFolderItem _ chref) = getRef chref
children (Root chref) =
do
items <- getRef chref
return items
children _ = return []
-- | Gets the item that is currently open (displayed on notepad).
openedFolder :: CItem c=> GenGUI c-> IO (Maybe (Item c))
openedFolder = getRef . open_obj
-- | Adds a gengui object.
addItem :: CItem c => GenGUI c
-- ^ the concerned gui.
-> Item c
-- ^ the parent (folder) object.
-> NewItem c
-- ^ the external representation of the new object.
-> IO (Item c)
-- ^ the internal representation of the new object.
addItem gui par@(IntFolderItem (FolderItem c _ _) chref) newitem =
synchronize gui
(do
mditem <- getRef (open_obj gui)
ch <- getRef chref
item <- toItem newitem
setRef chref (ch ++ [item])
mch <- getRef (event_queue gui)
case mch of
Just ch -> syncNoWait (send ch (Addition item))
_ -> done
(if (isItemFolder item || show_leaves_in_tree gui) then
do
mkNode (treelist gui) par
nuch <- children item
let nod = if show_leaves_in_tree gui then
if Prelude.not (null nuch) then Node else Leaf
else
if (any isItemFolder nuch) then Node else Leaf
case newitem of
FolderItem c _ _ ->
addTreeListSubObject (treelist gui) par
(newTreeListObject item nod)
LeafItem c _ ->
addTreeListSubObject (treelist gui) par
(newTreeListObject item nod)
else done)
case mditem of
Just ditem -> if ditem == par then
do
pos <- getNewItemPosition gui
setItemPosition item pos
it <- createNotepadItem item (notepad gui) True
[position pos]
done
else done
_ -> done
return item)
addItem gui (Root chref) newitem =
synchronize gui
(do
nm <- getNameFromNewItem newitem
items <- getRef chref
item <- toItem newitem
setRef chref (items ++ [item])
mch <- getRef (event_queue gui)
case mch of
Just ch -> syncNoWait (send ch (Addition item))
_ -> done
(if (isItemFolder item || show_leaves_in_tree gui) then
do
ch <- children item
let nod = if show_leaves_in_tree gui then
if Prelude.not (null ch) then Node else Leaf
else
if (any isItemFolder ch) then Node else Leaf
case newitem of
FolderItem c _ _ ->
addTreeListRootObject (treelist gui)
(newTreeListObject item nod)
LeafItem c _ ->
addTreeListRootObject (treelist gui)
(newTreeListObject item nod)
else done)
return item)
addItem _ _ _ = error "GenGUI (addItem) : called for a leaf"
-- | Returns the @CItem@ content of an item.
content :: CItem c => (Item c) -> c
content (IntFolderItem (FolderItem c _ _) _) = c
content (IntLeafItem (LeafItem c _) _ _) = c
content _ = error "GenGUI (content) : called for root"
--------------------------------------------------------------------------
-- events
--------------------------------------------------------------------------
-- | The @GenGUIEvent@ datatype.
data GenGUIEvent c =
FocusTreeList (Maybe (Item c))
| SelectTreeList (Maybe (Item c))
| FocusNotepad (Item c, Bool) -- what's the Bool?
| Dropped (Item c, [Item c])
| Doubleclick (Item c)
| Rightclick [Item c]
| Addition (Item c)
| DroppedOnTextArea [Item c]
-- | Binds a listener for gengui events to the gengui and returns
-- a corresponding event and an unbind action.
bindGenGUIEv :: CItem c => GenGUI c
-- ^ the concerned gui.
-> IO (Event (GenGUIEvent c), IO())
-- ^ A pair of (event, unbind action).
bindGenGUIEv gui =
do
ch <- newChannel
setRef (event_queue gui) (Just ch)
return (receive ch, setRef (event_queue gui) Nothing)
-- | Sends the given event if bound.
sendEv :: CItem c => GenGUI c -> GenGUIEvent c -> IO ()
sendEv gui ev =
do
mch <- getRef (event_queue gui)
case mch of
Just ch -> syncNoWait (send ch ev)
_ -> done
--------------------------------------------------------------------------
-- treelist children function
--------------------------------------------------------------------------
-- | Makes treelist objects from item.
toTreeListObjects :: CItem c => Bool -> [Item c] ->
IO [TreeListObject (Item c)]
toTreeListObjects showLeavesInTree (it : items) =
do
rest <- toTreeListObjects showLeavesInTree items
ch <- children it
let nod = if showLeavesInTree then
if (any isItemFolder ch) then Node else Leaf
else
if Prelude.not (null ch) then Node else Leaf
return (newTreeListObject it nod : rest)
toTreeListObjects _ _ = return []
-- | The treelists children function.
cfun :: CItem c => Bool -> ChildrenFun (Item c)
cfun showLeavesInTree tlobj =
do
let item = getTreeListObjectValue tlobj
ch <- children item
toTreeListObjects showLeavesInTree (if showLeavesInTree then ch
else filter isItemFolder ch)
--------------------------------------------------------------------------
-- instances
--------------------------------------------------------------------------
-- | Internal.
instance CItem c => Eq (GenGUI c) where
gui1 == gui2 = win gui1 == win gui2
-- | Internal.
instance CItem c => GUIObject (GenGUI c) where
toGUIObject gui = toGUIObject (win gui)
cname _ = "GenGUI"
-- | A @GenGUI@ object can be destroyed.
instance CItem c => Destroyable (GenGUI c) where
-- Destroys a @GenGUI@ object.
destroy = destroy . toGUIObject
-- | A @GenGUI@ object is a window.
instance CItem c => Window (GenGUI c) where
-- Iconifies the gui.
iconify gui = iconify (win gui)
-- Deiconifies the gui.
deiconify gui = deiconify (win gui)
-- Withdraws the gui.
withdraw gui = withdraw (win gui)
-- Puts the gui window on top.
putWinOnTop gui = putWinOnTop (win gui)
-- Puts the gui window at bottom-
putWinAtBottom gui = putWinAtBottom (win gui)
-- | You can synchronize on a gengui object.
instance CItem c => Synchronized (GenGUI c) where
-- Synchronizes on a gengui object.
synchronize gui = synchronize (win gui)