-- | A generic data browser. module HTk.Toolkit.GenericBrowser ( newGenericBrowser, GenericBrowser, GBObject(..), GenericBrowserEvent(..), bindGenericBrowserEv ) where import Control.Monad import System.IO.Unsafe import Util.Computation import Events.Events import Events.Channels import Reactor.ReferenceVariables import HTk.Toplevel.HTk import HTk.Kernel.Core import HTk.Toolkit.TreeList as TreeList import qualified HTk.Toolkit.Notepad as Notepad import HTk.Toolkit.Notepad hiding (NotepadEvent(..)) -- | 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)) {-# NOINLINE posRef #-} 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. newGenericBrowser :: (GBObject o, Container par) => par -- ^ the parent widget (which has to be a container -- widget). -> [o] -- ^ the list of top level objects. -> [Config (GenericBrowser o)] -- ^ the list of configuration options for this -- generic browser. -> IO (GenericBrowser o) -- ^ A generic browser. 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 )) +> (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 (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 (Doubleclick obj) -- Notepad rightclick event handler. npItemsRightclick :: GBObject o => GenericBrowser o -> [NotepadItem o] -> IO () npItemsRightclick gb npobjs = do objs <- mapM getItemValue npobjs sendEv gb (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. bindGenericBrowserEv :: GBObject o => GenericBrowser o -- ^ the concerned generic browser. -> IO (Event (GenericBrowserEvent o), IO ()) -- ^ A pair of (event, unbind action). 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 toGUIObject = toGUIObject . container cname _ = "GenericBrowser" -- | Internal. instance GBObject o => Widget (GenericBrowser o)