module HTk.Toolkit.GenGUI (
GenGUI,
newGenGUI,
setStatus,
clearStatus,
updateTextArea,
clearTextArea,
genGUIMainMenu,
NewItem(..),
Item,
Name(..),
CItem(..),
root,
openedFolder,
addItem,
children,
content,
GenGUIEvent(..),
bindGenGUIEv,
GenGUIState,
exportGenGUIState,
) 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
data NewItem c =
LeafItem c (Maybe (Position,
Bool
))
| FolderItem c [NewItem c] (Maybe (Bool,
Bool
))
getNameFromNewItem :: CItem c => NewItem c -> IO Name
getNameFromNewItem (LeafItem c _) = getName c
getNameFromNewItem (FolderItem c _ _) = getName c
isNewItemFolder :: CItem c => NewItem c -> Bool
isNewItemFolder (FolderItem _ _ _) = True
isNewItemFolder _ = False
data Item c =
IntFolderItem (NewItem c)
(Ref [Item c])
| IntLeafItem (NewItem c)
(Ref Position)
(Ref Bool)
| Root (Ref [Item c])
instance CItem c => Eq (Item c) where
item1 == item2 = content item1 == content item2
instance CItem c => CItem (Item c) where
getName = getName . content
getIcon = getIcon . content
isItemFolder :: Item c
-> Bool
isItemFolder it@(IntFolderItem _ _) = True
isItemFolder _ = False
isItemLeaf :: Item c -> Bool
isItemLeaf = Prelude.not . isItemFolder
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)
root :: CItem c => GenGUI c -> IO (Item c)
root gui = return (Root (root_obj gui))
type GenGUIState c = [NewItem c]
exportGenGUIState :: CItem c => GenGUI c
-> IO (GenGUIState c)
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 []
data GenGUI c =
GenGUI
{
treelist :: TreeList (Item c),
notepad :: Notepad (Item c),
editor :: Editor,
status :: Label,
topmenu :: Menu,
win :: Toplevel,
open_obj :: Ref (Maybe (Item c)),
place :: Ref Position,
root_obj :: Ref [Item c],
event_queue :: Ref (Maybe (Channel (GenGUIEvent c))),
show_leaves_in_tree :: Bool }
newGenGUI :: CItem c => Maybe (GenGUIState c)
-> Bool
-> IO (GenGUI c)
newGenGUI mstate showLeavesInTree =
do
main <- createToplevel [text "GenGUI"]
menubar <- createMenu main False []
main # menu menubar
intstate <- case mstate of
Just state -> do
state <- mapM toItem state
newRef state
Nothing -> newRef []
displayref <- newRef Nothing
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
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
posref <- newRef (0, 0)
evq <- newRef Nothing
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 }
clipboard_dnd <- newRef ((1,1), [])
clipboard_mov <- newRef ((1,1), [], Nothing)
(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
saveNotepadItemStates :: CItem c => GenGUI c -> IO ()
saveNotepadItemStates gui =
do
npitems <- getItems (notepad gui)
mapM (saveNotepadItemState gui) npitems
done
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
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))
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
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)
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
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
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
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
getNewItemPosition :: CItem c => GenGUI c -> IO Position
getNewItemPosition gui = getFreeItemPosition (notepad gui)
setItemPosition :: CItem c => Item c -> Position -> IO ()
setItemPosition (IntLeafItem _ posref _) pos = setRef posref pos
setStatus :: CItem c => GenGUI c-> String-> IO ()
setStatus gui txt = (status gui) # text txt >> done
clearStatus :: CItem c => GenGUI c-> IO ()
clearStatus gui = (status gui) # text "" >> done
updateTextArea :: CItem c => GenGUI c-> [MarkupText] -> IO ()
updateTextArea gui mtxt = (editor gui) # new mtxt >> done
clearTextArea :: CItem c => GenGUI c-> IO ()
clearTextArea gui = (editor gui) # clear >> done
genGUIMainMenu :: CItem c => GenGUI c-> Menu
genGUIMainMenu gui = topmenu gui
children :: CItem c => Item c -> IO [Item c]
children (IntFolderItem _ chref) = getRef chref
children (Root chref) =
do
items <- getRef chref
return items
children _ = return []
openedFolder :: CItem c=> GenGUI c-> IO (Maybe (Item c))
openedFolder = getRef . open_obj
addItem :: CItem c => GenGUI c
-> Item c
-> NewItem c
-> IO (Item c)
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"
content :: CItem c => (Item c) -> c
content (IntFolderItem (FolderItem c _ _) _) = c
content (IntLeafItem (LeafItem c _) _ _) = c
content _ = error "GenGUI (content) : called for root"
data GenGUIEvent c =
FocusTreeList (Maybe (Item c))
| SelectTreeList (Maybe (Item c))
| FocusNotepad (Item c, Bool)
| Dropped (Item c, [Item c])
| Doubleclick (Item c)
| Rightclick [Item c]
| Addition (Item c)
| DroppedOnTextArea [Item c]
bindGenGUIEv :: CItem c => GenGUI c
-> IO (Event (GenGUIEvent c), IO())
bindGenGUIEv gui =
do
ch <- newChannel
setRef (event_queue gui) (Just ch)
return (receive ch, setRef (event_queue gui) Nothing)
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
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 []
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)
instance CItem c => Eq (GenGUI c) where
gui1 == gui2 = win gui1 == win gui2
instance CItem c => GUIObject (GenGUI c) where
toGUIObject gui = toGUIObject (win gui)
cname _ = "GenGUI"
instance CItem c => Destroyable (GenGUI c) where
destroy = destroy . toGUIObject
instance CItem c => Window (GenGUI c) where
iconify gui = iconify (win gui)
deiconify gui = deiconify (win gui)
withdraw gui = withdraw (win gui)
putWinOnTop gui = putWinOnTop (win gui)
putWinAtBottom gui = putWinAtBottom (win gui)
instance CItem c => Synchronized (GenGUI c) where
synchronize gui = synchronize (win gui)