-- ----------------------------------------------------------------------- -- -- $Source: /repository/uni/htk/toolkit/GenericBrowser.hs,v $ -- -- HTk - a GUI toolkit for Haskell - (c) Universitaet Bremen -- -- $Revision: 1.7 $ from $Date: 2002/03/13 11:26:46 $ -- Last modification by $Author: ludi $ -- -- ----------------------------------------------------------------------- --- -- A generic data browser. module GenericBrowser ( newGenericBrowser, GenericBrowser, GBObject(..), GenericBrowserEvent(..), bindGenericBrowserEv ) where import HTk import Core import TreeList import Notepad import CItem import Monad import ReferenceVariables import IOExts(unsafePerformIO) --- -- Browsed data needs to instantiate the class CItem. class CItem o => GBObject o where getChildren :: o -> IO [o] isObjectNode :: o -> IO Bool posRef :: Ref Position posRef = unsafePerformIO (newRef (10, 10)) resetPos :: IO () resetPos = setRef posRef (40, 40) max_x :: Distance max_x = 350 dx :: Distance dx = 60 dy :: Distance dy = 50 getPos :: IO Position getPos = do pos@(x,y) <- getRef posRef let nupos = if (x + dx > max_x) then (40, y + dy) else (x + dx, y) setRef posRef nupos return pos -- ----------------------------------------------------------------------- -- datatype -- ----------------------------------------------------------------------- --- -- The GenericBrowser datatype. data GBObject o => GenericBrowser o = GenericBrowser { container :: Frame, treelist :: TreeList o, notepad :: Notepad o, -- event queue event_queue :: Ref (Maybe (Channel (GenericBrowserEvent o))) } -- ----------------------------------------------------------------------- -- construction -- ----------------------------------------------------------------------- --- -- Constructs a new generic browser and returns a handler. -- @param par - the parent widget (which has to be a container -- - widget). -- @param rootobjs - the list of top level objects. -- @param cnf - the list of configuration options for this -- - generic browser. -- @return result - A generic browser. newGenericBrowser :: (GBObject o, Container par) => par -> [o] -> [Config (GenericBrowser o)] -> IO (GenericBrowser o) newGenericBrowser par rootobjs cnf = do fr <- newFrame par [] let toTreeListObject obj = do --ch <- getChildren obj --let is_node = not (null ch) is_node <- isObjectNode obj return (newTreeListObject obj (if is_node then Node else Leaf)) cfun :: GBObject o => ChildrenFun o cfun tlobj = do ch <- getChildren (getTreeListObjectValue tlobj) ch' <- filterM isObjectNode ch mapM toTreeListObject ch' tl <- newTreeList fr cfun [] [bg "white"] pack tl [Side AtLeft, Fill Both, Expand On] np <- newNotepad fr Scrolled (12, 12) Nothing [bg "white" {-, size (500, 2000)-}] pack np [Side AtRight, Fill Both, Expand On] evq <- newRef Nothing let gb = GenericBrowser { container = fr, treelist = tl, notepad = np, event_queue = evq } foldl (>>=) (return gb) cnf (tl_ev, _) <- bindTreeListEv tl (np_ev, _) <- bindNotepadEv np let listenComponents = (do ev <- tl_ev always (case ev of TreeList.Selected mobj -> tlObjectSelected gb mobj TreeList.Focused (mobj, _) -> tlObjectFocused gb mobj _ -> done)) +> (do ev <- np_ev always (case ev of Notepad.Dropped (npobj, npobjs) -> npItemsDropped gb (npobj, npobjs) Notepad.Selected npobj -> npItemSelected gb npobj Notepad.Deselected npobj -> npItemDeselected gb npobj Notepad.Doubleclick npobj -> npItemDoubleclick gb npobj Notepad.Rightclick npobjs -> npItemsRightclick gb npobjs _ -> done)) spawnEvent (forever listenComponents) rootobjs' <- filterM isObjectNode rootobjs initBrowser gb rootobjs' return gb {- containsSubNodes :: GBObject o => o -> IO Bool containsSubNodes obj = let containsSubNodes' (obj : objs) = do b <- isObjectNode obj if b then return True else containsSubNodes' objs containsSubNodes' _ = return False in do ch <- getChildren obj containsSubNodes' ch -} -- Initializes the browser. initBrowser :: GBObject o => GenericBrowser o -> [o] -> IO () initBrowser gb rootobjs = let addObject obj = do b <- isObjectNode obj if b then addTreeListRootObject (treelist gb) (newTreeListObject obj Node) else done in mapM addObject rootobjs >> done -- Treelist selection event handler. tlObjectSelected :: GBObject o => GenericBrowser o -> Maybe (TreeListObject o) -> IO () tlObjectSelected gb mtlobj = let addObject obj = do pos <- getPos createNotepadItem obj (notepad gb) False [position pos] done in do case mtlobj of Just tlobj -> let obj = getTreeListObjectValue tlobj in do clearNotepad (notepad gb) resetPos sendEv gb (SelectedInTreeList (Just obj)) ch <- getChildren obj ch' <- filterM (\obj -> do b <- isObjectNode obj return (not b)) ch mapM addObject ch' updNotepadScrollRegion (notepad gb) done _ -> sendEv gb (SelectedInTreeList Nothing) -- Treelist focus event handler. tlObjectFocused :: GBObject o => GenericBrowser o -> Maybe (TreeListObject o) -> IO () tlObjectFocused gb mtlobj = case mtlobj of Just tlobj -> let obj = getTreeListObjectValue tlobj in sendEv gb (FocusedInTreeList (Just obj)) _ -> sendEv gb (FocusedInTreeList Nothing) -- Notepad drop event handler. npItemsDropped :: GBObject o => GenericBrowser o -> (NotepadItem o, [NotepadItem o]) -> IO () npItemsDropped gb (npobj, npobjs) = do obj <- getItemValue npobj objs <- mapM getItemValue npobjs sendEv gb (GenericBrowser.Dropped (obj, objs)) -- Notepad selection event handler. npItemSelected :: GBObject o => GenericBrowser o -> NotepadItem o -> IO () npItemSelected gb npobj = do obj <- getItemValue npobj sendEv gb (SelectedInNotepad obj) -- Notepad deselection event handler. npItemDeselected :: GBObject o => GenericBrowser o -> NotepadItem o -> IO () npItemDeselected gb npobj = do obj <- getItemValue npobj sendEv gb (DeselectedInNotepad obj) -- Notepad doubleclick event handler. npItemDoubleclick :: GBObject o => GenericBrowser o -> NotepadItem o -> IO () npItemDoubleclick gb npobj = do obj <- getItemValue npobj sendEv gb (GenericBrowser.Doubleclick obj) -- Notepad rightclick event handler. npItemsRightclick :: GBObject o => GenericBrowser o -> [NotepadItem o] -> IO () npItemsRightclick gb npobjs = do objs <- mapM getItemValue npobjs sendEv gb (GenericBrowser.Rightclick objs) -- ----------------------------------------------------------------------- -- events -- ----------------------------------------------------------------------- data GBObject o => GenericBrowserEvent o = SelectedInTreeList (Maybe o) | FocusedInTreeList (Maybe o) | Dropped (o, [o]) | SelectedInNotepad o | DeselectedInNotepad o | Doubleclick o | Rightclick [o] -- send an event if bound sendEv :: GBObject o => GenericBrowser o -> GenericBrowserEvent o -> IO () sendEv gb ev = do mch <- getRef (event_queue gb) case mch of Just ch -> syncNoWait (send ch ev) _ -> done --- -- Binds a listener for generic browser events to the tree list and -- returns a corresponding event and an unbind action. -- @param np - the concerned generic browser. -- @return result - A pair of (event, unbind action). bindGenericBrowserEv :: GBObject o => GenericBrowser o -> IO (Event (GenericBrowserEvent o), IO ()) bindGenericBrowserEv gb = do ch <- newChannel setRef (event_queue gb) (Just ch) return (receive ch, setRef (event_queue gb) Nothing) -- ----------------------------------------------------------------------- -- instantiations -- ----------------------------------------------------------------------- --- -- Internal. instance GBObject o => GUIObject (GenericBrowser o) where --- -- Internal. toGUIObject = toGUIObject . container --- -- Internal. instance GBObject o => Widget (GenericBrowser o)