-- | HTk\'s /TreeList/ module. module HTk.Toolkit.TreeList ( newTreeList, {- :: (Container par, Eq a) => par -> ChildrenFun a -> [TreeListObject a] -> [Config (TreeList a)] -> IO (TreeList a) -} TreeList, bindTreeListEv, {- :: TreeList c -> IO (Event (TreeListEvent c), IO ()) -} TreeListEvent(..), removeTreeListObject, {- :: Eq a=> TreeList a-> a-> IO () -} updateTreeList, {- :: Eq a => TreeList a -> IO () -} addTreeListRootObject, {- :: Eq a => TreeList a -> TreeListObject a -> IO () -} addTreeListSubObject, {- :: Eq a => TreeList a -> a -> TreeListObject a -> IO () -} newTreeListObject, {- :: Eq a => a -> TreeListObjectType -> TreeListObject a -} TreeListObject, TreeListObjectType(..), isLeaf, {- :: Eq a => TreeList a -> a -> IO (Maybe Bool) -} isNode, {- :: Eq a => TreeList a -> a -> IO (Maybe Bool) -} mkLeaf, {- :: Eq a => TreeList a -> a -> IO () -} mkNode, {- :: Eq a => TreeList a -> a -> IO () -} getTreeListObjectValue, {- :: TreeListObject a -> a -} getTreeListObjectType, {- :: TreeListObject a -> TreeListObjectType -} isTreeListObjectOpen, ChildrenFun, {- type ChildrenFun a = TreeListObject a -> IO [TreeListObject a] -} setImage, setTreeListObjectName, TreeListExportItem(..), TreeListState, exportTreeListState, importTreeListState, recoverTreeList, module HTk.Toolkit.CItem ) where import Data.Maybe import System.IO.Unsafe import Util.Computation import Events.Events import Events.Channels import Events.Synchronized import Reactor.ReferenceVariables import HTk.Toplevel.HTk import HTk.Toolkit.ScrollBox import Data.List import HTk.Kernel.Core import HTk.Toolkit.CItem import HTk.Toolkit.Name -- internal options intendation = 19 lineheight = 20 cwidth = 15 -- ----------------------------------------------------------------------- -- ----------------------------------------------------------------------- -- tree lists -- ----------------------------------------------------------------------- -- ----------------------------------------------------------------------- -- ----------------------------------------------------------------------- -- basic types -- ----------------------------------------------------------------------- data StateEntry a = StateEntry (TREELISTOBJECT a) -- object Bool -- open: True / closed: False Int -- intendation [a] -- ids of previously open subobjects for reopen deriving Eq -- | The @ChildrenFun@ type. type ChildrenFun a = TreeListObject a -> IO [TreeListObject a] -- | The @TreeList@ datatype. data CItem c => TreeList c = TreeList { -- main canvas cnv :: Canvas, -- scrollbox scrollbox :: (ScrollBox Canvas), -- treelist state internal_state :: (Ref [StateEntry c]), -- node children function cfun :: (ChildrenFun c), -- selected object selected_object :: (Ref (Maybe (TREELISTOBJECT c))), -- tree list event queue event_queue :: Ref (Maybe (Channel (TreeListEvent c))), -- clean up on destruction clean_up :: Ref [IO ()] } -- ----------------------------------------------------------------------- -- tree list construction -- ----------------------------------------------------------------------- -- | Constructs a new tree list. newTreeList :: (Container par, CItem a) => par -- ^ the parent widget, which has to be a container widget. -> ChildrenFun a -- ^ the tree list\'s children function. -> [TreeListObject a] -- ^ the initial list of tree list objects. -> [Config (TreeList a)] -- ^ the list of configuration options for this tree list. -> IO (TreeList a) -- ^ A tree list. newTreeList par cfun objs cnf = do (scr, cnv) <- newScrollBox par (\p -> newCanvas p []) [] stateref <- newRef [] selref <- newRef Nothing evq <- newRef Nothing cleanup <- newRef [] let treelist = TreeList { cnv = cnv, scrollbox = scr, internal_state = stateref, cfun = cfun, selected_object = selref, event_queue = evq, clean_up = cleanup } foldl (>>=) (return treelist) cnf rootobjs <- mapM (\ (TreeListObject (val, objtype)) -> do nm <- getName val mkTreeListObject treelist val (objtype == Node) False [name nm]) objs let toStateEntry obj = StateEntry obj False 0 [] setRef stateref (map toStateEntry rootobjs) let setImg obj = do pho <- getIcon (val obj) obj_img obj # photo pho mapM setImg rootobjs (if not(null rootobjs) then do packTreeListObject (head rootobjs) True (5, 5) let packObjs :: CItem a => Position -> [TREELISTOBJECT a] -> IO () packObjs (x, y) (obj : objs) = packTreeListObject obj False (x, y) >> packObjs (x, y + Distance lineheight) objs packObjs _ _ = done packObjs (5, 5 + Distance lineheight) (tail rootobjs) updScrollRegion cnv stateref else done) (press, ub) <- bindSimple cnv (ButtonPress (Just 1)) death <- newChannel let listenCnv :: Event () listenCnv = (press >> always (deselect treelist) >> listenCnv) +> receive death _ <- spawnEvent listenCnv setRef cleanup [ub, syncNoWait (send death ())] return treelist -- | Binds a listener for tree list events to the tree list and returns -- a corresponding event and an unbind action. bindTreeListEv :: CItem c => TreeList c -- ^ the concerned tree list. -> IO (Event (TreeListEvent c), IO ()) -- ^ A pair of (event, unbind action). bindTreeListEv tl = do ch <- newChannel setRef (event_queue tl) (Just ch) return (receive ch, setRef (event_queue tl) Nothing) -- | The @TreeListEvent@ datatype. data TreeListEvent c = Selected (Maybe (TreeListObject c)) | Focused (Maybe (TreeListObject c), EventInfo) -- event info needed for drag & drop in GenGUI -- send an event if bound sendEv :: CItem c => TreeList c -> TreeListEvent c -> IO () sendEv tl ev = do mch <- getRef (event_queue tl) case mch of Just ch -> syncNoWait (send ch ev) _ -> done -- | Constructs a new tree list recovering a previously saved state. recoverTreeList :: (Container par, CItem a) => par -- ^ the parent widget, which has to be a container widget. -> ChildrenFun a -- ^ the tree list\'s children function. -> TreeListState a -- ^ the state to recover. -> [Config (TreeList a)] -- ^ the list of configuration options for this tree list. -> IO (TreeList a) -- ^ A tree list. recoverTreeList par cfun st cnf = do (scr, cnv) <- newScrollBox par (\p -> newCanvas p []) [] stateref <- newRef [] selref <- newRef Nothing evq <- newRef Nothing cleanup <- newRef [] let tl = TreeList { cnv = cnv, scrollbox = scr, internal_state = stateref, cfun = cfun, selected_object = selref, event_queue = evq, clean_up = cleanup } foldl (>>=) (return tl) cnf state <- mkEntries tl st setRef stateref state let (StateEntry root _ _ _) = head state pho <- getIcon (val root) obj_img root # photo pho packTreeListObject root True (5, 5) let mselexp = find (\ exportitem -> selected exportitem) st case mselexp of Just selexp -> let (Just (StateEntry obj _ _ _)) = find (\ (StateEntry obj' _ _ _) -> val obj' == obj_val selexp) state in obj_nm obj # fg "white" >> obj_nm obj # bg "blue" >> setRef selref (Just obj) _ -> done insertObjects tl (5 + Distance intendation, 5) (toObjects (tail state)) updScrollRegion cnv stateref (press, ub) <- bindSimple cnv (ButtonPress (Just 1)) death <- newChannel let listenCnv :: Event () listenCnv = (press >> always (deselect tl) >> listenCnv) +> receive death _ <- spawnEvent listenCnv setRef cleanup [ub, syncNoWait (send death ())] return tl -- | Deletes all objects from the tree list. clearTreeList :: CItem c => TreeList c -- ^ the concerned tree list. -> IO () -- ^ None. clearTreeList tl = do state <- getRef (internal_state tl) mapM (\ (StateEntry obj _ _ _) -> removeObject obj) state setRef (internal_state tl) [] getObjectFromTreeList :: CItem a => TreeList a -> a -> IO (Maybe (TREELISTOBJECT a, Bool)) getObjectFromTreeList tl objval = do state <- getRef (internal_state tl) let msentry = find (entryEqualsObject objval) state case msentry of Just sentry@(StateEntry obj _ _ _) -> return (Just (obj, head state == sentry)) _ -> return Nothing where entryEqualsObject :: CItem a => a -> StateEntry a -> Bool entryEqualsObject objval (StateEntry obj _ _ _) = objval == val obj -- | Checks for a given tree list object value if the corresponding -- object is a node. isNode :: CItem a => TreeList a -- ^ the concerned tree list. -> a -- ^ the concerned tree list object value. -> IO (Maybe Bool) -- ^ @Nothing@ if no corresponding object is -- found, otherwise @Just True@ if -- the corresponding object is a node, otherwise -- @Just False@. isNode tl val = do mobj <- getObjectFromTreeList tl val return (case mobj of Just (obj, _) -> Just (is_node obj) _ -> Nothing) -- | Checks for a given tree list object value if the corresponding -- object is a leaf. isLeaf :: CItem a => TreeList a -- ^ the concerned tree list. -> a -- ^ the concerned tree list object value. -> IO (Maybe Bool) -- ^ @Nothing@ if no corresponding object is -- found, otherwise @Just True@ if -- the corresponding object is a leaf, otherwise -- @Just False@. isLeaf tl val = do mnode <- isNode tl val case mnode of Just b -> return (Just (not b)) _ -> return Nothing -- | Converts the corresponding object to a given tree list object value -- to a node. mkNode :: CItem a => TreeList a -- ^ the concerned tree list. -> a -- ^ the concerned treelist object\'s value. -> IO () -- ^ None. mkNode tl val = do mleaf <- isLeaf tl val case mleaf of Just True -> do Just (obj, isroot) <- getObjectFromTreeList tl val nm <- getTreeListObjectName obj [(x, y)] <- getCoord (embedded_win obj) removeObject obj nuobj <- mkTreeListObject tl val True False [name nm] objectChanged tl obj nuobj pho <- getIcon val obj_img nuobj # photo pho packTreeListObject nuobj isroot (x - 15, y) _ -> done -- | Converts the corresponding object to a given tree list object value -- to a leaf. mkLeaf :: CItem a => TreeList a -- ^ the concerned tree list. -> a -- ^ the concerned tree list object\'s value. -> IO () -- ^ None. mkLeaf tl val = do mnode <- isNode tl val case mnode of Just True -> do Just (obj, isroot) <- getObjectFromTreeList tl val Just (ch, _) <- getChildrenAndUpper tl val (if null ch then done else error "TreeList (mkLeaf) : node is not empty") nm <- getTreeListObjectName obj [(x, y)] <- getCoord (embedded_win obj) removeObject obj nuobj <- mkTreeListObject tl val False False [name nm] objectChanged tl obj nuobj pho <- getIcon val obj_img nuobj # photo pho packTreeListObject nuobj isroot (x - 15, y) _ -> done -- | Removes the corresponding objects to a given tree list object value -- from the tree list. removeTreeListObject :: CItem a => TreeList a -- ^ the concerned tree list. -> a -- ^ the concerned tree list object\'s value. -> IO () -- ^ None. removeTreeListObject tl val = do mobj <- getObjectFromTreeList tl val case mobj of Just (obj, _) -> do mch <- getChildrenAndUpper tl val case mch of Just (ch, upper) -> do mapM removeObject (obj : ch) done _ -> done _ -> done getChildrenAndUpper :: CItem a => TreeList a -> a -> IO (Maybe ([TREELISTOBJECT a], [TREELISTOBJECT a])) getChildrenAndUpper tl objval = let getChildrenAndUpper' :: CItem a => a -> [StateEntry a] -> Maybe ([TREELISTOBJECT a], [TREELISTOBJECT a]) getChildrenAndUpper' objval ((StateEntry obj _ intend _) : ents) = if val obj == objval then Just (getChildrenAndUpper'' ents intend []) else getChildrenAndUpper' objval ents getChildrenAndUpper' _ _ = Nothing getChildrenAndUpper'' :: CItem a => [StateEntry a] -> Int -> [TREELISTOBJECT a] -> ([TREELISTOBJECT a], [TREELISTOBJECT a]) getChildrenAndUpper'' ((StateEntry obj _ intend' _) : ents) intend ch = if intend' > intend then getChildrenAndUpper'' ents intend (ch ++ [obj]) else (ch, map (\ (StateEntry obj _ _ _) -> obj) ents) in do state <- getRef (internal_state tl) return (getChildrenAndUpper' objval state) objectChanged :: CItem a => TreeList a -> TREELISTOBJECT a -> TREELISTOBJECT a -> IO () objectChanged tl obj nuobj = let objectChanged' (ent@(StateEntry obj' isopen intend sub) : ents) = if obj == obj' then StateEntry nuobj isopen intend sub : objectChanged' ents else ent : objectChanged' ents objectChanged' _ = [] in do state <- getRef (internal_state tl) setRef (internal_state tl) (objectChanged' state) -- | Updates the tree list by recalling the children function for all opened -- objects. updateTreeList :: CItem a => TreeList a -- ^ the concerned tree list. -> IO () -- ^ None. updateTreeList tl = synchronize tl (do state <- getRef (internal_state tl) let (StateEntry root isopen _ _) = (head state) if isopen then pressed root >> pressed root else done) -- ----------------------------------------------------------------------- -- adding of objects (while running) -- ----------------------------------------------------------------------- -- | Adds a subobject to a tree list object. addTreeListSubObject :: CItem a => TreeList a -- ^ the concerned tree list. -> a -- ^ the parent object\'s value. -> TreeListObject a -- ^ the new tree list object to add. -> IO () -- ^ None. addTreeListSubObject tl parval obj@(TreeListObject (objval, objtype)) = synchronize tl (do state <- getRef (internal_state tl) (if visibleAndOpen state parval then do nm <- getName objval (lowerobj, upperobj, parintend, y) <- sep state parval intobj <- mkTreeListObject tl objval (objtype == Node) False [name nm] setRef (internal_state tl) (lowerobj ++ [StateEntry intobj False (parintend + 1) []] ++ upperobj) mapM (shiftObject lineheight) upperobj pho <- getIcon objval obj_img intobj # photo pho let (StateEntry obj _ _ _) = last lowerobj packTreeListObject intobj False (5 + Distance ((parintend + 1) * intendation), y + Distance lineheight) updScrollRegion (cnv tl) (internal_state tl) else done)) where visibleAndOpen :: CItem a => [StateEntry a] -> a -> Bool visibleAndOpen state parval = let msentry = find (\ (StateEntry obj _ _ _) -> val obj == parval) state in case msentry of Just (StateEntry obj isopen _ _) -> isopen _ -> False sep :: CItem a => [StateEntry a] -> a -> IO ([StateEntry a], [StateEntry a], Int, Distance) sep sentries parval = sep1 sentries parval [] sep1 :: CItem a => [StateEntry a] -> a -> [StateEntry a] -> IO ([StateEntry a], [StateEntry a], Int, Distance) sep1 (ent@(StateEntry obj _ intend _) : ents) parval lower = if val obj == parval then do [(_, y)] <- getCoord (embedded_win obj) sep2 ents intend (lower ++ [ent]) y else sep1 ents parval (lower ++ [ent]) sep2 :: CItem a => [StateEntry a] -> Int -> [StateEntry a] -> Distance -> IO ([StateEntry a], [StateEntry a], Int, Distance) sep2 (ent@(StateEntry obj _ intend' _) : ents) intend lower _ = case ents of [] -> do [(_, y)] <- getCoord (embedded_win obj) return (lower ++ [ent], [], intend, y) _ -> if intend' > intend then sep2 ents intend (lower ++ [ent]) 0 else do [(_, y)] <- getCoord (embedded_win obj) return (lower, ent : ents, intend, y - Distance lineheight) sep2 _ intend lower y = return (lower, [], intend, y) -- | Adds a toplevel tree list object. addTreeListRootObject :: CItem a => TreeList a -- ^ the concerned tree list. -> TreeListObject a -- ^ the tree list object to add. -> IO () -- ^ None. addTreeListRootObject tl obj@(TreeListObject (val, objtype)) = synchronize tl (do nm <- getName val tlobj <- mkTreeListObject tl val (objtype == Node) False [name nm] pho <- getIcon val obj_img tlobj # photo pho objs <- getRef (internal_state tl) setRef (internal_state tl) (objs ++ [StateEntry tlobj False 0 []]) packTreeListObject tlobj (length objs == 0) (5, 5 + Distance (length objs * lineheight)) updScrollRegion (cnv tl) (internal_state tl)) startObjectInteractor :: CItem a => TREELISTOBJECT a -> IO () startObjectInteractor obj = do (press, ub) <- bindSimple (plusminus obj) (ButtonPress (Just 1)) addUnbindAction obj ub death <- newChannel let listenObject :: Event () listenObject = (press >> always (pressed obj) >> listenObject) +> (receive death) _ <- spawnEvent listenObject addUnbindAction obj (syncNoWait (send death ())) done addUnbindAction :: CItem a => TREELISTOBJECT a -> IO () -> IO () addUnbindAction obj ub = do ubs <- getRef (ub_acts obj) setRef (ub_acts obj) (ub : ubs) vLineLength :: CItem c => TREELISTOBJECT c -> IO Distance vLineLength obj = do state <- getRef (internal_state (treelist obj)) return(start obj (reverse state)) where start :: CItem a => TREELISTOBJECT a -> [StateEntry a] -> Distance start obj (StateEntry obj' _ intend _ : sentries) = if obj' == obj then inner intend 0 sentries else start obj sentries inner :: CItem a => Int -> Int -> [StateEntry a] -> Distance inner intend n (StateEntry obj _ intend' _ : sentries) = if intend' <= intend then (Distance (n * lineheight) + Distance (if (is_node obj) then lineheight - 13 else lineheight - 9)) else inner intend (n + 1) sentries inner _ _ _ = Distance (lineheight - 13) -- packs an (internal) tree list object packTreeListObject :: CItem a => TREELISTOBJECT a -> Bool -> Position -> IO () packTreeListObject obj isroot pos@(x, y) = let hline = (selHLine (obj_lines obj)) vline = (selVLine (obj_lines obj)) in do embedded_win obj # coord [(x + 15, y)] dist <- vLineLength obj (if (is_node obj) then do plusminus obj # position (x, y + 5) hline # coord [(x + 9, y + 9), (x + 13, y + 9)] if not isroot then vline # coord [(x + 4, y + 5), (x + 4, y - dist)] >> done else done else do hline # coord [(x + 4, y + 9), (x + 13, y + 9)] (if not isroot then vline # coord [(x + 4, y + 9), (x + 4, y - dist)] >> done else done) done) if (is_node obj) then startObjectInteractor obj else done -- ----------------------------------------------------------------------- -- TreeList instances -- ----------------------------------------------------------------------- -- | Internal. instance CItem c => GUIObject (TreeList c) where toGUIObject tl = toGUIObject (scrollbox tl) cname _ = "TreeList" -- | A tree list can be destroyed. instance CItem c => Destroyable (TreeList c) where -- Destroys a tree list. destroy = destroy . toGUIObject -- | A tree list has standard widget properties -- (concerning focus, cursor). instance CItem c => Widget (TreeList c) -- | You can synchronize on a tree list. instance CItem c => Synchronized (TreeList c) where -- Synchronizes on a tree list. synchronize = synchronize . toGUIObject -- | A tree list has a configureable border. instance CItem c => HasBorder (TreeList c) -- | A tree list has a configureale background colour. instance CItem c => HasColour (TreeList c) where legalColourID tl = hasBackGroundColour (cnv tl) setColour tl cid col = setColour (cnv tl) cid col >> return tl getColour tl cid = getColour (cnv tl) cid -- | A tree list has a configureable size. instance CItem c => HasSize (TreeList c) where width s tl = (cnv tl) # width s >> return tl getWidth tl = getWidth (cnv tl) height s tl = (cnv tl) # height s >> return tl getHeight tl = getHeight (cnv tl) -- ----------------------------------------------------------------------- -- ----------------------------------------------------------------------- -- tree list objects -- ----------------------------------------------------------------------- -- ----------------------------------------------------------------------- -- ----------------------------------------------------------------------- -- basic types -- ----------------------------------------------------------------------- -- | The @TreeListObjectType@ datatype. data TreeListObjectType = Node | Leaf deriving Eq -- | The @TreeListObject@ datatype. newtype TreeListObject a = TreeListObject (a, TreeListObjectType) data CItem a => TREELISTOBJECT a = -- internal representation TREELISTOBJECT { val :: a, -- value treelist :: TreeList a, -- parent is_node :: Bool, -- true if node plusminus :: ImageItem, -- plusminus obj_lines :: (Line, Line), -- lines obj_img :: Label, -- object image obj_nm :: Label, -- object name embedded_win :: EmbeddedCanvasWin, -- main frame ub_acts :: Ref [IO ()] } -- unbind actions -- ----------------------------------------------------------------------- -- construction of tree list objects -- ----------------------------------------------------------------------- -- | Constructs a new tree list object. newTreeListObject :: CItem a => a -- ^ the object\'s value. -> TreeListObjectType -- ^ the object\'s type (node or leaf). -> TreeListObject a -- ^ A tree list object. newTreeListObject val objtype = TreeListObject (val, objtype) -- ----------------------------------------------------------------------- -- exported functionality on tree list objects -- ----------------------------------------------------------------------- -- | Selector for the value of a tree list object. getTreeListObjectValue :: TreeListObject a -- ^ the concerned tree list object. -> a -- ^ The given object\'s value. getTreeListObjectValue obj@(TreeListObject (val, _)) = val -- | Selector for the type of a tree list object (node or leaf). getTreeListObjectType :: TreeListObject a -- ^ the concerned tree list object. -> TreeListObjectType -- ^ The object\'s type (node or leaf). getTreeListObjectType obj@(TreeListObject (_, objtype)) = objtype -- | True, if the object with the given value is currently opened in the -- tree list. isTreeListObjectOpen :: CItem c => TreeList c -- ^ the concerned tree list. -> c -- ^ the concerned object\'s value. -> IO Bool -- ^ @True@, if the object with the given value -- is currently opened in the tree list, otherwise -- @False@. isTreeListObjectOpen tl v = synchronize tl (do state <- getRef (internal_state tl) let msentry = find (\ (StateEntry obj _ _ _) -> v == val obj) state case msentry of Just (StateEntry _ b _ _) -> return b Nothing -> return False) -- | (Re-)sets the image of a tree list object. setImage :: CItem a => TreeList a -- ^ the concerned tree list. -> a -- ^ the concerned object\'s value. -> Image -- ^ the image to set. -> IO () -- ^ None. setImage tl objval img = do state <- getRef (internal_state tl) setImage' state objval img where setImage' :: CItem a => [StateEntry a] -> a -> Image -> IO () setImage' ((StateEntry obj _ _ _) : ents) val' img = if val obj == val' then obj_img obj # photo img >> done else setImage' ents val' img setImage' _ _ _ = done -- | (Re-)sets the name of a tree list object. setTreeListObjectName :: CItem a => TreeList a -- ^ the concerned tree list. -> a -- ^ the concerned object\'s value. -> Name -- ^ the name to set. -> IO () -- ^ None. setTreeListObjectName tl objval nm = do state <- getRef (internal_state tl) setName state objval where setName :: CItem a => [StateEntry a] -> a -> IO () setName ((StateEntry obj _ _ _) : ents) val' = if val obj == val' then do -- nm <- getName (val obj) obj_nm obj # text (full nm) >> done else setName ents val' setName _ _ = done -- ----------------------------------------------------------------------- -- internal functionality on tree list objects -- ----------------------------------------------------------------------- -- shifts a displayed object by dy pixels (vertical) shiftObject :: CItem c => Int -> StateEntry c -> IO () shiftObject dy (StateEntry obj _ _ _) = do (if (is_node obj) then moveItem (plusminus obj) 0 (Distance dy) >> done else done) moveItem (selHLine (obj_lines obj)) 0 (Distance dy) moveItem (selVLine (obj_lines obj)) 0 (Distance dy) coords <- getCoord (selVLine (obj_lines obj)) hlinelength <- vLineLength obj (let (x, y) = selLower coords in (selVLine (obj_lines obj)) # coord [(x, y), (x, y - hlinelength - if (is_node obj) then 5 else 9)]) moveItem (embedded_win obj) 0 (Distance dy) -- selects the lowest position from a list of positions selLower :: Coord -> Position selLower coords = selLower' (head coords) (tail coords) where selLower' :: Position -> Coord -> Position selLower' l@(_, yl) (c@(_, y) : cs) = if y > yl then selLower' c cs else selLower' l cs selLower' l _ = l -- updates the scroll region updScrollRegion :: CItem a => Canvas -> Ref [StateEntry a] -> IO () updScrollRegion cnv stateref = do state <- getRef stateref updScrollRegion' cnv 0 0 state where updScrollRegion' :: CItem a => Canvas -> Distance -> Distance -> [StateEntry a] -> IO () updScrollRegion' cnv x y ((StateEntry obj _ _ _) : sentries) = do Just (_, _, x', y') <- bbox cnv (embedded_win obj) updScrollRegion' cnv (max x x') (max y y') sentries updScrollRegion' cnv x y _ = (cnv # scrollRegion ((0, 0), (x, y))) >> done -- inserts objects into the treelist insertObjects :: CItem a => TreeList a -> Position -> [(Int, Bool, TREELISTOBJECT a)] -> IO () insertObjects tl (x, y) chobjs = do state <- getRef (internal_state tl) insertObjects' (cnv tl) (x, y + Distance lineheight) chobjs where insertObjects' :: CItem a => Canvas -> Position -> [(Int, Bool, TREELISTOBJECT a)] -> IO () insertObjects' cnv (x, y) ((i, b, obj) : objs) = do pho <- getIcon (val obj) obj_img obj # photo pho packTreeListObject obj False (5 + Distance (i * intendation), y) insertObjects' cnv (x, y + Distance lineheight) objs insertObjects' _ (x, y) _ = done -- removes an object from the treelist removeObject :: CItem a => TREELISTOBJECT a -> IO () removeObject obj = do ubs <- getRef (ub_acts obj) mapM id ubs destroy (embedded_win obj) if (is_node obj) then destroy (plusminus obj) else done destroy (selHLine (obj_lines obj)) destroy (selVLine (obj_lines obj)) setRef (ub_acts obj) [] done -- gets information about a tree list object -- (intendation, object open or not, ids of previously open subobjects) getObjInfo :: CItem a => TREELISTOBJECT a -> [StateEntry a] -> IO (Int, Bool, [a]) getObjInfo obj (StateEntry obj' isopen i prevopen : entries) = if obj == obj' then return (i, isopen, prevopen) else getObjInfo obj entries -- constructs a state entry mkEntry :: CItem a => (Int, Bool, TREELISTOBJECT a) -> StateEntry a mkEntry (i, b, obj) = StateEntry obj b i [] -- gets the displayed children of a tree list object getChildren :: CItem a => [StateEntry a] -> TREELISTOBJECT a -> IO ([TREELISTOBJECT a], [a]) getChildren state obj = getChildren' state obj (-1) [] [] where getChildren' :: CItem a => [StateEntry a] -> TREELISTOBJECT a -> Int -> [TREELISTOBJECT a] -> [a] -> IO ([TREELISTOBJECT a], [a]) getChildren' (st@(StateEntry obj' isopen intend _) : es) obj i objs opensubobjvals = if (i == -1 && obj /= obj') then getChildren' es obj i objs opensubobjvals else if (obj == obj') then getChildren' es obj intend objs opensubobjvals else if intend > i then if isopen then getChildren' es obj i (obj' : objs) (val obj' : opensubobjvals) else getChildren' es obj i (obj' : objs) opensubobjvals else return (objs, opensubobjvals) getChildren' _ _ _ objs opensubobjvals = return (objs, opensubobjvals) -- reopens previously open sub-objects of a tree list object -- (used while opening) reopenSubObjects :: CItem a => ChildrenFun a -> [a] -> [(Int, TREELISTOBJECT a)] -> IO [(Int, Bool, TREELISTOBJECT a)] reopenSubObjects c_fun prevopen ((i, tlobj) : objs) = if elem (val tlobj) prevopen then do plusminus tlobj # photo minusImg ch <- c_fun (TreeListObject (val tlobj, if (is_node tlobj) then Node else Leaf)) thisobjch <- mkTreeListObjects (treelist tlobj) ch (i + 1) prevopen chobjs <- reopenSubObjects c_fun prevopen thisobjch rest <- reopenSubObjects c_fun prevopen objs return (((i, True, tlobj) : chobjs) ++ rest) else do rest <- reopenSubObjects c_fun prevopen objs return ((i, False, tlobj) : rest) reopenSubObjects _ _ _ = return [] -- event handler (buttonpress) pressed :: CItem c => TREELISTOBJECT c -> IO () pressed obj = synchronize (treelist obj) (do state <- getRef (internal_state (treelist obj)) c <- getCoord (embedded_win obj) index <- return ((fromJust (elemIndex obj (map (\ (StateEntry obj _ _ _) -> obj) state))) + 1) (i, isopen, prevopen) <- getObjInfo obj state (if isopen then do -- close plusminus obj # photo plusImg (children, opensubobjvals) <- getChildren state obj mapM removeObject children setRef (internal_state (treelist obj)) (take (index - 1) state ++ [StateEntry obj False i opensubobjvals] ++ drop (index + length children) state) mapM (shiftObject (-(length children) * lineheight)) (drop (index + length children) state) done else do -- open plusminus obj # photo minusImg ch <- (cfun (treelist obj)) (TreeListObject (val obj, if (is_node obj) then Node else Leaf)) thisobjch <- mkTreeListObjects (treelist obj) ch (i + 1) prevopen chobjs <- reopenSubObjects (cfun (treelist obj)) prevopen thisobjch setRef (internal_state (treelist obj)) (take (index - 1) state ++ [StateEntry obj True i []] ++ map mkEntry chobjs ++ drop index state) mapM (shiftObject ((length chobjs) * lineheight)) (drop index state) insertObjects (treelist obj) (head c) chobjs done) updScrollRegion (cnv (treelist obj)) (internal_state (treelist obj))) -- selects objects and send the concerned event selectObject :: CItem c => TreeList c -> TREELISTOBJECT c -> IO () selectObject tl obj = do unmarkSelectedObject tl setRef (selected_object tl) (Just obj) obj_nm obj # fg "white" obj_nm obj # bg "blue" sendEv tl (Selected (Just (TreeListObject (val obj, if (is_node obj) then Node else Leaf)))) done -- deselects an object deselect :: CItem c => TreeList c -> IO () deselect tl = do unmarkSelectedObject tl setRef (selected_object tl) Nothing sendEv tl (Selected Nothing) -- syncNoWait (send (selection_ch tl) Nothing) done -- unmarks the sekected object unmarkSelectedObject :: CItem c => TreeList c -> IO () unmarkSelectedObject tl = do sel <- getRef (selected_object tl) case sel of Just obj -> do obj_nm obj # fg "black" obj_nm obj # bg "white" done _ -> done -- True for a selected object isSelectedTreeList :: CItem c => TreeList c -> TREELISTOBJECT c -> IO Bool isSelectedTreeList tl obj = do sel <- getRef (selected_object tl) case sel of Just s -> return (s == obj) _ -> return False -- constructs the internal representation of new tree list objects mkTreeListObjects :: CItem a => TreeList a -> [TreeListObject a] -> Int -> [a] -> IO [(Int, TREELISTOBJECT a)] mkTreeListObjects tl objs i prevopen = mapM (mk tl i prevopen) objs where mk :: CItem a => TreeList a -> Int -> [a] -> TreeListObject a -> IO (Int, TREELISTOBJECT a) mk tl i prevopen (TreeListObject (val, objtype)) = do nm <- getName val obj <- mkTreeListObject tl val (if objtype == Node then True else False) (elem val prevopen) [name nm] return (i, obj) -- constructs the internal representation of a single tree list object mkTreeListObject :: CItem a => TreeList a -> a -> Bool -> Bool -> [Config (TREELISTOBJECT a)] -> IO (TREELISTOBJECT a) mkTreeListObject tl val isnode isopen cnf = do box <- newHBox (cnv tl) [background "white"] drawnstuff <- do hline <- createLine (cnv tl) [coord [(-200, -200), (-200, -200)]] vline <- createLine (cnv tl) [coord [(-200, -200), (-200, -200)]] return (hline, vline) plusminus <- createImageItem (cnv tl) [coord [(-200, -200)], canvAnchor NorthWest, photo (if isopen then minusImg else plusImg)] img <- newLabel box [background "white"] pack img [Side AtLeft] txt <- newLabel box [background "white", font (Lucida, 12::Int)] pack txt [Side AtRight] emb <- createEmbeddedCanvasWin (cnv tl) box [coord [(-200, -200)], canvAnchor NorthWest] unbind_actions <- newRef [] let obj = TREELISTOBJECT { val = val, treelist = tl, is_node = isnode, plusminus = plusminus, obj_lines = drawnstuff, obj_img = img, obj_nm = txt, embedded_win = emb, ub_acts = unbind_actions } foldl (>>=) (return obj) cnf (enterTxt, ub) <- bind txt [WishEvent [] Enter] addUnbindAction obj ub death <- newChannel addUnbindAction obj (syncNoWait (send death ())) (leaveTxt, ub) <- bind txt [WishEvent [] Leave] addUnbindAction obj ub (pressTxt, ub) <- bindSimple txt (ButtonPress (Just 1)) addUnbindAction obj ub let listenObject :: Event () listenObject = (pressTxt >> always (selectObject tl obj) >> listenObject) +> (do ev_inf <- leaveTxt always (do b <- isSelectedTreeList tl obj if b then done else txt # bg "white" >> txt # fg "black" >> done sendEv tl (Focused (Nothing, ev_inf))) listenObject) +> (do ev_inf <- enterTxt always (do b <- isSelectedTreeList tl obj if b then done else txt # bg "grey" >> txt # fg "white" >> done sendEv tl (Focused (Just (TreeListObject (val, if isnode then Node else Leaf)), ev_inf))) listenObject) +> receive death _ <- spawnEvent listenObject return obj -- selector for the horizontal line of an (internal) tree list object selHLine :: (Line, Line) -> Line selHLine (hline, _) = hline -- selector for the vertical line of an (internal) tree list object selVLine :: (Line, Line) -> Line selVLine (_, vline) = vline -- ----------------------------------------------------------------------- -- internal tree list object instances -- ----------------------------------------------------------------------- instance CItem a => Eq (TREELISTOBJECT a) where obj1 == obj2 = obj_nm obj1 == obj_nm obj2 instance CItem a => GUIObject (TREELISTOBJECT a) where toGUIObject obj = toGUIObject (embedded_win obj) cname _ = "TREELISTOBJECT" instance CItem a => HasPhoto (TREELISTOBJECT a) where photo i obj = obj_img obj # photo i >> return obj getPhoto obj = getPhoto (obj_img obj) name :: CItem a => Name -> Config (TREELISTOBJECT a) name nm obj = obj_nm obj # text (full nm) >> return obj getTreeListObjectName :: CItem a => TREELISTOBJECT a -> IO Name getTreeListObjectName obj = do nm <- getName (val obj) return nm -- ----------------------------------------------------------------------- -- state import / export -- ----------------------------------------------------------------------- -- | Imports a previously saved tree list state. importTreeListState :: CItem a => TreeList a -- ^ the concerned tree list. -> TreeListState a -- ^ the state to import. -> IO () -- ^ None. importTreeListState tl st = synchronize tl (do clearTreeList tl state <- mkEntries tl st setRef (internal_state tl) state let StateEntry root _ _ _ = head state packTreeListObject root True (5, 5) pho <- getIcon (val root) obj_img root # photo pho insertObjects tl (5 + Distance intendation, 5) (toObjects (tail state)) updScrollRegion (cnv tl) (internal_state tl)) toObjects :: [StateEntry a] -> [(Int, Bool, TREELISTOBJECT a)] toObjects (StateEntry obj isopen intend _ : ents) = (intend, isopen, obj) : toObjects ents toObjects _ = [] mkEntries :: CItem a => TreeList a -> TreeListState a -> IO [StateEntry a] mkEntries tl (i : is) = do nm <- getName (obj_val i) obj <- mkTreeListObject tl (obj_val i) (if obj_type i == Node then True else False) (open i) [name nm] rest <- mkEntries tl is return (StateEntry obj (open i) (intend i) [] : rest) mkEntries _ _ = return [] data TreeListExportItem a = TreeListExportItem { obj_val :: a, obj_type :: TreeListObjectType, open :: Bool, -- ignored if leaf intend :: Int, selected :: Bool } -- yet ignored, multiple -- selections to come ... type TreeListState a = [TreeListExportItem a] -- | Exports the tree list\'s state. exportTreeListState :: CItem c => TreeList c -- ^ the concerned tree list. -> IO (TreeListState c) -- ^ The tree list\'s state. exportTreeListState tl = synchronize tl (do state <- getRef (internal_state tl) exportTreeListState' tl state) where exportTreeListState' :: CItem c => TreeList c -> [StateEntry c] -> IO (TreeListState c) exportTreeListState' tl (StateEntry obj open intendation _ : ents) = do sel <- isSelectedTreeList tl obj rest <- exportTreeListState' tl ents return (TreeListExportItem { obj_val = val obj, obj_type = if (is_node obj) then Node else Leaf, open = open, intend = intendation, selected = sel} : rest) exportTreeListState' _ _ = return [] -- ----------------------------------------------------------------------- -- images -- ----------------------------------------------------------------------- plusImg :: Image plusImg = unsafePerformIO (newImage [imgData GIF "R0lGODlhCQAJAJEAAP///9Dc4H6LjwAAACwAAAAACQAJAEACFJSPiTHdYYIcEopKZax1s35NINcVADs="]) {-# NOINLINE plusImg #-} minusImg :: Image minusImg = unsafePerformIO (newImage [imgData GIF "R0lGODlhCQAJAJEAAP///9Dc4H6LjwAAACwAAAAACQAJAEACEZSPiTHdYYKcUNAZb9Vb5ysUADs="]) {-# NOINLINE minusImg #-}