{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
module TreeCallbacks where
import qualified Data.ByteString.Char8 as C
import Data.IORef
import Data.Maybe
import qualified Graphics.UI.FLTK.LowLevel.FL as FL
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.FLTKHS
import System.IO.Unsafe
import Text.Printf
import Foreign.C.String
import Foreign.C.Types
import Data.Bits
g_cb_counter :: IORef Int
g_cb_counter = unsafePerformIO $ newIORef 0
tree_in :: IORef (Maybe (Ref Input))
tree_in = unsafePerformIO $ newIORef Nothing
tree_but :: IORef (Maybe (Ref Button))
tree_but = unsafePerformIO $ newIORef Nothing
tree_grp :: IORef (Maybe (Ref Group))
tree_grp = unsafePerformIO $ newIORef Nothing
item_id :: IORef Int
item_id = unsafePerformIO $ newIORef 0
helpDialog :: IORef (Maybe (Ref DoubleWindow, Ref TextDisplay, Ref TextBuffer))
helpDialog = unsafePerformIO $ newIORef Nothing
treeCallback :: Ref Tree -> IO ()
treeCallback tree = do
modifyIORef g_cb_counter (\c' -> c' + 1)
item <- getCallbackItem tree
reason <- getCallbackReason tree
let reason_string =
case reason of
TreeReasonNone -> "none"
TreeReasonSelected -> "selected"
TreeReasonDeselected -> "deselected"
TreeReasonOpened -> "opened"
TreeReasonClosed -> "closed"
TreeReasonDragged -> "dragged"
has_changed <- changed tree
case item of
Just i -> do
itemLabel <- getLabel i
printf "TREE CALLBACK: label='%s' reason='%s' changed='%s'" itemLabel reason_string
(show has_changed)
clicks <- FL.eventClicks
if (clicks > 0)
then printf ", clicks=%d\n" (clicks + 1)
else print "\n"
Nothing -> do
printf
"TREE CALLBACK: reason='%s' changed='%s' item=(no item -- probably multiple items were changed at once)\n"
reason_string
(show has_changed)
clearChanged tree
margintop_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
margintop_slider_callback tree slider = do
val <- getValue slider
setMargintop tree (truncate val)
redraw tree
marginleft_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
marginleft_slider_callback tree slider = do
val <- getValue slider
setMarginleft tree (truncate val)
redraw tree
marginbottom_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
marginbottom_slider_callback tree slider = do
deactivate slider
setTooltip slider ("DISABLED.\n" ++ "Set FLTK_ABI_VERSION to 10301 (or higher)\n" ++ "to enable this feature")
linespacing_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
linespacing_slider_callback tree slider = do
val <- getValue slider
setLinespacing tree (truncate val)
redraw tree
usericonmarginleft_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
usericonmarginleft_slider_callback tree slider = do
val <- getValue slider
setUsericonmarginleft tree (truncate val)
redraw tree
labelmarginleft_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
labelmarginleft_slider_callback tree slider = do
val <- getValue slider
setLabelmarginleft tree (truncate val)
redraw tree
widgetmarginleft_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
widgetmarginleft_slider_callback tree slider = do
deactivate slider
setTooltip slider ("DISABLED.\n" ++ "Set FLTK_ABI_VERSION to 10301 (or higher)\n" ++ "to enable this feature")
openchild_marginbottom_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
openchild_marginbottom_slider_callback tree slider = do
val <- getValue slider
setOpenchildMarginbottom tree (truncate val)
redraw tree
connectorwidth_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
connectorwidth_slider_callback tree slider = do
val <- getValue slider
setConnectorwidth tree (truncate val)
return ()
collapseicons_chooser_callback :: Ref Tree -> Ref Choice -> IO ()
collapseicons_chooser_callback tree chooser =
let openXpm =
#ifdef __APPLE__
[
"11 11 3 1",
". c #fefefe",
"# c #444444",
"@ c #000000",
"###########",
"#.........#",
"#.........#",
"#....@....#",
"#....@....#",
"#..@@@@@..#",
"#....@....#",
"#....@....#",
"#.........#",
"#.........#",
"###########"
]
#else
[
"11 11 2 1",
". c None",
"@ c #000000",
"...@.......",
"...@@......",
"...@@@.....",
"...@@@@....",
"...@@@@@...",
"...@@@@@@..",
"...@@@@@...",
"...@@@@....",
"...@@@.....",
"...@@......",
"...@......."
]
#endif
closeXpm =
#ifdef __APPLE__
[
"11 11 3 1",
". c #fefefe",
"# c #444444",
"@ c #000000",
"###########",
"#.........#",
"#.........#",
"#.........#",
"#.........#",
"#..@@@@@..#",
"#.........#",
"#.........#",
"#.........#",
"#.........#",
"###########"
]
#else
[
"11 11 2 1",
". c none",
"@ c #000000",
"...........",
"...........",
"...........",
"...........",
"...........",
"@@@@@@@@@@@",
".@@@@@@@@@.",
"..@@@@@@@..",
"...@@@@@...",
"....@@@....",
".....@....."
]
#endif
in do
val <- getValue chooser
case val of
(MenuItemIndex 0)-> do
setShowcollapse tree True
setOpenicon tree (Nothing :: Maybe (Ref Image))
setCloseicon tree (Nothing :: Maybe (Ref Image))
(MenuItemIndex 1) -> do
setShowcollapse tree True
openPixmap <- pixmapNew (PixmapHs openXpm)
setOpenicon tree (Just openPixmap)
closePixmap <- pixmapNew (PixmapHs closeXpm)
setCloseicon tree (Just closePixmap)
(MenuItemIndex 2) -> setShowcollapse tree False
_ -> return ()
connectorstyle_chooser_callback :: Ref Tree -> Ref Choice -> IO ()
connectorstyle_chooser_callback tree chooser = do
val <- getValue chooser
case val of
(MenuItemIndex 0) -> setConnectorstyle tree TreeConnectorNone
(MenuItemIndex 1) -> setConnectorstyle tree TreeConnectorDotted
(MenuItemIndex 2) -> setConnectorstyle tree TreeConnectorSolid
_ -> return ()
set_connectorstyle_chooser :: Ref Choice -> TreeConnector -> IO ()
set_connectorstyle_chooser chooser connectorStyle =
case connectorStyle of
TreeConnectorNone -> setValue chooser (MenuItemByIndex (MenuItemIndex 0)) >> return ()
TreeConnectorDotted -> setValue chooser (MenuItemByIndex (MenuItemIndex 1)) >> return ()
TreeConnectorSolid -> setValue chooser (MenuItemByIndex (MenuItemIndex 2)) >> return ()
selectmode_chooser_callback :: Ref Tree -> Ref Choice -> IO ()
selectmode_chooser_callback tree chooser = do
val <- getValue chooser
let mode = case val of
(MenuItemIndex 0) -> TreeSelectNone
(MenuItemIndex 1) -> TreeSelectSingle
(MenuItemIndex 2) -> TreeSelectMulti
(MenuItemIndex 3) -> TreeSelectSingleDraggable
(MenuItemIndex _) -> TreeSelectSingle
setSelectmode tree mode
reselectmode_chooser_callback :: Ref Tree -> Ref Choice -> IO ()
reselectmode_chooser_callback _ chooser = do
deactivate chooser
setTooltip chooser ("DISABLED.\n" ++ "Set FLTK_ABI_VERSION to 10301 (or higher)\n" ++ "to enable this feature")
whenmode_chooser_callback :: Ref Tree -> Ref Choice -> IO ()
whenmode_chooser_callback tree chooser = do
val <- getValue chooser
let whenMode = case val of
(MenuItemIndex 0) -> WhenRelease
(MenuItemIndex 1) -> WhenChanged
(MenuItemIndex 2) -> WhenNever
(MenuItemIndex _) -> WhenRelease
setWhen tree [whenMode]
set_tree_showroot :: Ref Tree -> Ref CheckButton -> IO ()
set_tree_showroot tree button = getValue button >>= setShowroot tree
radio_button_deactivate_callback :: Ref Window -> Ref CheckButton -> IO ()
radio_button_deactivate_callback window button = do
deactivate button
setTooltip button ("DISABLED.\n" ++ "Set FLTK_ABI_VERSION to 10301 (or higher)\n" ++ "to enable this feature")
redraw window
goto_next_selected_item :: Ref Tree -> Ref Button -> IO ()
goto_next_selected_item tree _ = do
item <- nextSelectedItem tree
maybe (return ()) (showItemTop tree) item
goto_next_selected_item_bottom :: Ref Tree -> Ref Button -> IO ()
goto_next_selected_item_bottom tree _ = do
item <- nextSelectedItem tree
maybe (return ()) (showItemBottom tree) item
goto_next_selected_item_middle :: Ref Tree -> Ref Button -> IO ()
goto_next_selected_item_middle tree _ = do
item <- nextSelectedItem tree
maybe (return ()) (showItemMiddle tree) item
openall_button_callback :: Ref Tree -> Ref Button -> IO ()
openall_button_callback tree button = do
item <- getFirst tree
go item
redraw tree
where
go :: Maybe (Ref TreeItem) -> IO ()
go Nothing = return ()
go (Just i) = do
children <- hasChildren i
if children then open i else return ()
next tree >>= go
insertabove_button_callback :: Ref Tree -> Ref Button -> IO ()
insertabove_button_callback tree button = do
item <- getFirst tree
go item
redraw tree
where
go :: Maybe (Ref TreeItem) -> IO ()
go Nothing = return ()
go (Just i) = do
selected <- isSelected tree (TreeItemPointerLocator (TreeItemPointer i))
if selected
then do
insertAbove tree i "AaaAaa"
insertAbove tree i "BbbBbb"
insertAbove tree i "CccCcc"
return ()
else return ()
next tree >>= go
assignUserIcons :: Ref Tree -> Ref CheckButton -> IO ()
assignUserIcons tree button = do
first <- getFirst tree
go first
redraw tree
where
go :: Maybe (Ref TreeItem) -> IO ()
go Nothing = return ()
go (Just i) = do
val <- getValue button
if val
then do
children <- hasChildren i
if children
then pixmapNew (PixmapHs folderXpm) >>= setUsericon i . Just
else pixmapNew (PixmapHs documentXpm) >>= setUsericon i . Just
else setUsericon i (Nothing :: Maybe (Ref Image))
folderXpm =
[
"11 11 3 1",
". c None",
"x c #d8d833",
"@ c #808011",
"...........",
".....@@@@..",
"....@xxxx@.",
"@@@@@xxxx@@",
"@xxxxxxxxx@",
"@xxxxxxxxx@",
"@xxxxxxxxx@",
"@xxxxxxxxx@",
"@xxxxxxxxx@",
"@xxxxxxxxx@",
"@@@@@@@@@@@"
]
documentXpm =
[
"11 11 3 1",
". c None",
"x c #d8d8f8",
"@ c #202060",
".@@@@@@@@@.",
".@xxxxxxx@.",
".@xxxxxxx@.",
".@xxxxxxx@.",
".@xxxxxxx@.",
".@xxxxxxx@.",
".@xxxxxxx@.",
".@xxxxxxx@.",
".@xxxxxxx@.",
".@xxxxxxx@.",
".@@@@@@@@@."
]
tree_button_cb :: Ref Tree -> Ref Button -> IO ()
tree_button_cb tree button = do
button_label <- getLabel button
cw <- if (button_label == "ccc button")
then return (Just (safeCast button :: Ref Widget))
else getParent button >>= return . maybe Nothing (Just . safeCast)
case cw of
Just cw' -> do
cwh <- getH cw'
cwx <- getX cw'
cwy <- getY cw'
cww <- getW cw'
let newHeight = if (cwh + 10 > 50) then 20 else cwh + 10
resize cw' (toRectangle (cwx, cwy, cww, newHeight))
redraw tree
printf "'%s' button pushed (height=%d)\n" button_label newHeight
rebuildTree :: Ref Tree -> Ref CheckButton -> Ref Button -> IO ()
rebuildTree tree button _ = do
clear tree
_ <- add tree "Aaa"
_ <- add tree "Bbb"
_ <- add tree "Ccc"
_ <- add tree "Ddd"
_ <- add tree "Bbb/child-01"
_ <- add tree "Bbb/child-01/111"
_ <- add tree "Bbb/child-01/222"
_ <- add tree "Bbb/child-01/333"
_ <- add tree "Bbb/child-02"
_ <- add tree "Bbb/child-03"
_ <- add tree "Bbb/child-04"
bbChild02 <- findItem tree "Bbb/child-02"
maybe (return ())
(\child -> do
input <- readIORef tree_in
case input of
Nothing -> do
begin tree
newIn <- inputNew (toRectangle (1,1,100,1)) (Just "Input Test") Nothing
writeIORef tree_in (Just newIn)
setLabelsize newIn (FontSize 10)
setTextsize newIn (FontSize 10)
setAlign newIn alignRight
setTooltip newIn ("Fl_Input inside tree.\n" ++
"The widget's label 'Fl_Input test' should appear to the widget's right.")
setWidget child (Just newIn)
end tree
_ -> setWidget child input)
bbChild02
bbChild03 <- findItem tree "Bbb/child-03"
maybe (return ())
(\child -> do
tree_button <- readIORef tree_but
case tree_button of
Nothing -> do
begin tree
newButton <- buttonNew (toRectangle (1,1,140,1)) (Just "ccc button")
writeIORef tree_but (Just newButton)
setLabelsize newButton (FontSize 10)
setCallback newButton (tree_button_cb tree)
setTooltip newButton ("Button inside tree.\n" ++
"If 'Item h() from widget' enabled, " ++
"pressing button enlarges it.")
setWidget child (Just newButton)
end tree
_ -> setWidget child tree_button)
bbChild03
bbChild04 <- findItem tree "Bbb/child-04"
maybe (return ())
(\child ->
let tipmsg = "A group of two buttons inside the tree.\n" ++
"If 'Item h() from widget' enabled, " ++
"pressing either button enlarges the group " ++
"and both buttons together."
in
do
tree_group <- readIORef tree_grp
case tree_group of
Nothing -> do
begin tree
newGroup <- groupNew (toRectangle (100,100,140,18)) Nothing
writeIORef tree_grp (Just newGroup)
setColor newGroup whiteColor
grpX <- getX newGroup
grpY <- getY newGroup
begin newGroup
abut <- buttonNew (toRectangle (grpX, grpY + 2, 65,15)) (Just "D1")
setLabelsize abut (FontSize 10)
setCallback abut (tree_button_cb tree)
bbut <- buttonNew (toRectangle (grpX + 75, grpY + 2, 65,15)) (Just "D2")
setLabelsize bbut (FontSize 10)
setCallback bbut (tree_button_cb tree)
end newGroup
setResizable newGroup (Just newGroup)
setWidget child (Just newGroup)
end tree
Just _ -> setWidget child tree_group
)
bbChild04
setSortorder tree TreeSortNone
add tree "Ascending" >>= maybe (return ()) close
setSortorder tree TreeSortAscending
add tree "Ascending/Zzz"
add tree "Ascending/Xxx"
add tree "Ascending/Aaa"
add tree "Ascending/Bbb"
add tree "Ascending/Yyy"
add tree "Ascending/Ccc"
setSortorder tree TreeSortNone
add tree "Descending" >>= maybe (return ()) close
setSortorder tree TreeSortDescending
add tree "Descending/Zzz"
add tree "Descending/Xxx"
add tree "Descending/Aaa"
add tree "Descending/Bbb"
add tree "Descending/Yyy"
add tree "Descending/Ccc"
setSortorder tree TreeSortNone
add tree "Long Line" >>= maybe (return ()) close
add tree "Long Line/The quick brown fox jumped over the lazy dog. 0123456789"
add tree "Long Line/Longer Line"
add tree "Long Line/Longer Line/The quick brown fox jumped over the lazy dog. ---------------- 0123456789"
mapM_ (\t ->
let s :: String
s = printf "500 Items/item %04d" ((t + 1) :: Int)
in add tree s)
[0 .. 499]
close tree (TreeItemNameLocator (TreeItemName "500 Items"))
assignUserIcons tree button
redraw tree
showpathname_button_callback :: Ref Tree -> Ref Button -> IO ()
showpathname_button_callback tree button = do
item <- firstSelectedItem tree
maybe (flMessage "No item was selected")
(\i -> do
path <- itemPathname tree i
case path of
Just p -> do
l <- getLabel i >>= \s -> return (if (null s) then "???" else s)
flMessage (printf "Pathname for '%s' is: \"%s\"" l p)
Nothing -> flMessage "itemPathname returned Nothing (NOT FOUND)")
item
closeall_button_callback :: Ref Tree -> Ref Button -> IO ()
closeall_button_callback tree button = do
first <- getFirst tree
go first
redraw tree
where
go :: Maybe (Ref TreeItem) -> IO ()
go Nothing = return ()
go (Just i) = do
children <- hasChildren i
root <- isRoot i
if ((not root) && children)
then close i
else return ()
clearall_button_callback :: Ref Tree -> Ref Button -> IO ()
clearall_button_callback tree _ = do
clear tree
redraw tree
testcallbackflag_button_callback :: Ref Tree -> Ref Button -> IO ()
testcallbackflag_button_callback tree button = do
root' <- root tree
print "--- Checking docallback of\n"
case root' of
Nothing -> return ()
Just root'' -> do
let rootItemLocator = TreeItemPointerLocator (TreeItemPointer root'')
let rootNameLocator = TreeItemNameLocator (TreeItemName "ROOT")
writeIORef g_cb_counter 0
closeAndCallback tree rootItemLocator False
readIORef g_cb_counter >>= \c -> if (c > 0)
then flAlert("FAILED 'OFF' TEST\n closeAndCallback item false triggered cb!")
else return ()
writeIORef g_cb_counter 0
openAndCallback tree rootItemLocator False
readIORef g_cb_counter
>>= \c -> if (c > 0)
then flAlert("FAILED 'OFF' TEST\n openAndCallback item false triggered cb!")
else return ()
writeIORef g_cb_counter 0
openToggleAndCallback tree root'' False
readIORef g_cb_counter
>>= \c -> if (c > 0)
then flAlert("FAILED 'OFF' TEST\n openToggleAndCallback item false triggered cb!")
else return ()
writeIORef g_cb_counter 0
closeAndCallback tree rootNameLocator False
readIORef g_cb_counter
>>= \c -> if (c > 0)
then flAlert("FAILED 'OFF' TEST\n closeAndCallback path False triggered cb!")
else return ()
writeIORef g_cb_counter 0
openAndCallback tree rootNameLocator False
readIORef g_cb_counter
>>= \c -> if (c > 0)
then flAlert("FAILED 'OFF' TEST\n openAndCallback path False triggered cb!")
else return ()
openAndCallback tree rootItemLocator False
writeIORef g_cb_counter 0
deselectAndCallback tree rootItemLocator False
readIORef g_cb_counter
>>= \c -> if (c > 0)
then flAlert("FAILED 'OFF' TEST\n deselectAndCallback item false triggered cb!")
else return ()
writeIORef g_cb_counter 0
selectAndCallback tree rootItemLocator False
readIORef g_cb_counter
>>= \c -> if (c > 0)
then flAlert("FAILED 'OFF' TEST\n selectAndCallback item false triggered cb!")
else return ()
writeIORef g_cb_counter 0
selectToggleAndCallback tree root'' False
readIORef g_cb_counter
>>= \c -> if (c > 0)
then flAlert("FAILED 'OFF' TEST\n selectToggleAndCallback item false triggered cb!")
else return ()
writeIORef g_cb_counter 0
deselectAndCallback tree rootNameLocator False
readIORef g_cb_counter
>>= \c -> if (c > 0)
then flAlert("FAILED 'OFF' TEST\n deselectAndCallback path False triggered cb!")
else return ()
writeIORef g_cb_counter 0
selectAndCallback tree rootNameLocator False
readIORef g_cb_counter
>>= \c -> if (c > 0)
then flAlert("FAILED 'OFF' TEST\n selectAndCallback path False triggered cb!")
else return ()
deselectAndCallback tree rootItemLocator False
writeIORef g_cb_counter 0
closeAndCallback tree rootItemLocator True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n closeAndCallback item True did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
openAndCallback tree rootItemLocator True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n openAndCallback item True did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
openToggleAndCallback tree root'' True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n openToggleAndCallback item True did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
openAndCallback tree rootItemLocator True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n openAndCallback [2] item True did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
closeAndCallback tree rootItemLocator True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n closeAndCallback [2] item True did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
openAndCallback tree rootNameLocator True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n openAndCallback path True did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
closeAndCallback tree rootNameLocator True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n closeAndCallback path True did not trigger cb!")
else return ()
openAndCallback tree rootItemLocator False
writeIORef g_cb_counter 0
selectAndCallback tree rootItemLocator True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n selectAndCallback item True did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
deselectAndCallback tree rootItemLocator True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n deselectAndCallback item True did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
selectToggleAndCallback tree root'' True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n selectToggleAndCallback item True did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
deselectAndCallback tree rootNameLocator True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n deselectAndCallback path True did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
selectAndCallback tree rootNameLocator True
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'ON' TEST\n selectAndCallback path True did not trigger cb!")
else return ()
deselectAndCallback tree rootNameLocator False
writeIORef g_cb_counter 0
close tree rootItemLocator
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'DEFAULT' TEST\n close item false did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
open tree rootItemLocator
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'DEFAULT' TEST\n open item false did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
openToggle tree root''
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'DEFAULT' TEST\n openToggle item false did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
open tree rootNameLocator
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'DEFAULT' TEST\n open path did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
close tree rootNameLocator
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'DEFAULT' TEST\n close path did not trigger cb!")
else return ()
openAndCallback tree rootItemLocator False
writeIORef g_cb_counter 0
select tree rootItemLocator
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'DEFAULT' TEST\n select item false did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
deselect tree rootItemLocator
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'DEFAULT' TEST\n deselect item false did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
selectToggle tree root''
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'DEFAULT' TEST\n selectToggle item false did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
deselect tree rootNameLocator
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'DEFAULT' TEST\n deselect path did not trigger cb!")
else return ()
writeIORef g_cb_counter 0
select tree rootNameLocator
readIORef g_cb_counter
>>= \c -> if (c == 0)
then flAlert("FAILED 'DEFAULT' TEST\n select path did not trigger cb!")
else return ()
deselect tree rootNameLocator
flAlert "TEST COMPLETED\n If you didn't see any error dialogs, test PASSED."
testrootshowself_button_callback :: Ref Tree -> Ref Button -> IO ()
testrootshowself_button_callback tree _ = do
root' <- root tree
maybe (return ()) (\root'' -> showSelf root'' Nothing) root'
add20k_button_callback :: Ref Tree -> Ref Button -> IO ()
add20k_button_callback tree _ = do
first <- getFirst tree
go first
redraw tree
where
go :: Maybe (Ref TreeItem) -> IO ()
go Nothing = return ()
go (Just i) = do
selected <- isSelected i
root' <- root tree
if selected
then do
parent' <- getParent i >>= maybe (return root') (return . Just)
maybe (return ())
(\p' -> do
mapM_ (\item_id' -> let s :: String
s = printf "Item #%d" ((item_id' :: Int) + 1)
in
add tree s)
[0 .. 19999]
modifyIORef item_id (\i -> i + 20000))
parent'
else next i >>= go
getMatchingItems :: Ref Tree -> (Ref TreeItem -> IO Bool) -> IO [Ref TreeItem]
getMatchingItems tree pred = do
first <- getFirst tree
go first pred []
where
go :: Maybe (Ref TreeItem) -> (Ref TreeItem -> IO Bool) -> [Ref TreeItem] -> IO [Ref TreeItem]
go Nothing _ accum = return accum
go (Just i) pred accum = do
passes <- pred i
next' <- next i
if passes
then go next' pred (accum ++ [i])
else go next' pred accum
toSelectedItemOrAll :: Ref Tree -> (Ref TreeItem -> IO()) -> IO ()
toSelectedItemOrAll tree f = do
items' <- getMatchingItems tree isSelected
if (null items')
then do
allItems' <- getMatchingItems tree (\_ -> return True)
mapM_ f allItems'
else mapM_ f items'
redraw tree
withFoundItemOrDefault :: Ref Tree ->
(Ref TreeItem -> IO a) ->
(Ref TreeItem -> IO Bool) ->
IO a ->
IO a
withFoundItemOrDefault tree f pred fallback = do
first <- getFirst tree
res <- go first f pred
maybe fallback return res
where
go :: Maybe (Ref TreeItem) -> (Ref TreeItem -> IO a ) -> (Ref TreeItem -> IO Bool) -> IO (Maybe a)
go Nothing _ _ = return Nothing
go (Just i) f pred = do
passes <- pred i
if passes
then f i >>= return . Just
else next i >>= \i' -> go i' f pred
selected_labelfont_choice_callback :: Ref Tree -> Ref Choice -> IO ()
selected_labelfont_choice_callback tree chooser = do
(MenuItemIndex idx) <- getValue chooser
toSelectedItemOrAll tree (\i -> setLabelfont i (Font idx))
assignTreeFontToButton :: Ref Tree -> Ref Choice -> IO ()
assignTreeFontToButton tree chooser = do
(Font fontNumber) <- getItemLabelfont tree
setValue chooser (MenuItemByIndex (MenuItemIndex fontNumber))
return ()
selected_labelsize_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
selected_labelsize_slider_callback tree slider = do
val <- getValue slider
toSelectedItemOrAll tree (\i -> setLabelsize i (FontSize (truncate val)))
assignTreeLabelsizeToSlider :: Ref Tree -> Ref ValueSlider -> IO ()
assignTreeLabelsizeToSlider tree slider = do
(FontSize size) <- getLabelsize tree
setValue slider (fromIntegral size)
return ()
editColor :: Color -> IO (Maybe Color)
editColor val = do
(r,g,b) <- FL.getColorRgb val
rgb <- flcColorChooser
"Choose Color"
(Words (r,g,b))
Nothing
case rgb of
(Just (Words rgb'@(r',g',b'))) ->
rgbColorWithRgb rgb' >>= return . Just
_ -> return Nothing
getSelectedItemFgColor :: Ref Tree -> IO Color
getSelectedItemFgColor tree =
withFoundItemOrDefault tree getLabelfgcolor isSelected (getItemLabelfgcolor tree)
getSelectedItemBgColor :: Ref Tree -> IO Color
getSelectedItemBgColor tree =
withFoundItemOrDefault tree getLabelbgcolor isSelected (getItemLabelbgcolor tree)
all_labelfgcolor_button_callback :: Ref Tree -> Ref Button -> IO ()
all_labelfgcolor_button_callback tree button = do
fgColor <- getSelectedItemFgColor tree
newColor <- editColor fgColor
maybe (return ())
(\color' -> toSelectedItemOrAll tree (\i -> setLabelfgcolor i color'))
newColor
all_labelbgcolor_button_callback :: Ref Tree -> Ref Button -> IO ()
all_labelbgcolor_button_callback tree button = do
bgColor <- getSelectedItemBgColor tree
newColor <- editColor bgColor
maybe (return ())
(\color' -> toSelectedItemOrAll tree (\i -> setLabelbgcolor i color'))
newColor
deactivate_toggle_callback :: Ref Tree -> Ref LightButton -> IO ()
deactivate_toggle_callback tree button = do
toggleValue <- getValue button
toSelectedItemOrAll tree (\i -> activateWith i (not toggleValue))
bold_toggle_callback :: Ref Tree -> Ref LightButton -> IO ()
bold_toggle_callback tree button = do
toggleValue <- getValue button
toSelectedItemOrAll tree (\i -> setLabelfont i (if toggleValue then helveticaBold else helvetica))
showselected_button_callback :: Ref Tree -> Ref Button -> IO ()
showselected_button_callback tree button = do
print "--- SELECTED ITEMS\n"
items' <- getMatchingItems tree isSelected
mapM_ (\i -> getLabel i >>= \l -> printf "\t%s\n" (if (null l) then "???" else l)) items'
clearselected_button_callback :: Ref Tree -> Ref Button -> IO ()
clearselected_button_callback tree button = do
items' <- getMatchingItems tree isSelected
mapM_ (\i -> remove tree i >> return ()) items'
swapselected_button_callback :: Ref Tree -> Ref Button -> IO ()
swapselected_button_callback tree button = do
items' <- getMatchingItems tree isSelected
case items' of
(a':b':[]) -> do
pa' <- getParent a'
pb' <- getParent b'
if (isNothing pa' || isNothing pb')
then flAlert "Could not get the parent."
else if (pa' /= pb')
then flAlert "The two selected items must be siblings."
else swapChildrenByTreeItem (fromJust pa') a' b' >> return ()
is' | length is' > 2 -> flAlert "Too many items selected. (must select only two)"
| length is' < 1 -> flAlert "Too few items selected. (you must select two)"
| otherwise -> return ()
setLabelfontFromTree :: Ref Tree -> Ref Choice -> IO ()
setLabelfontFromTree tree chooser = do
(Font f) <- getLabelfont tree
setValue chooser (MenuItemByIndex (MenuItemIndex f))
redraw tree
labelfont_choice_callback :: Ref Tree -> Ref Window -> Ref Choice -> IO ()
labelfont_choice_callback tree window chooser = do
(MenuItemIndex val) <- getValue chooser
setLabelfont tree (Font val)
redraw window
item_labelfont_choice_callback :: Ref Tree -> Ref Choice -> IO ()
item_labelfont_choice_callback tree chooser = do
(MenuItemIndex val) <- getValue chooser
setLabelfont tree (Font val)
redraw tree
labelsize_slider_callback :: Ref Tree -> Ref Window -> Ref ValueSlider -> IO ()
labelsize_slider_callback tree window slider = do
val <- getValue slider
setLabelsize tree (FontSize (truncate val))
redraw window
selectall_button_callback :: Ref Tree -> Ref Button -> IO ()
selectall_button_callback tree button = do
selectAllAndCallback tree Nothing False
redraw tree
deselectall_button_callback :: Ref Tree -> Ref Button -> IO ()
deselectall_button_callback tree button = do
deselectAllAndCallback tree Nothing False
redraw tree
nextselected_button_callback :: Ref Tree -> Ref Button -> IO ()
nextselected_button_callback tree button = do
print "--- TEST nextSelectedItemAfterItem\n"
print " Walk down the tree (forwards) \n"
first' <- firstSelectedItem tree
walkDown first'
print " Walk up the tree (backwards) \n"
last' <- lastSelectedItem tree
walkUp last'
where
walkDown :: Maybe (Ref TreeItem) -> IO ()
walkDown Nothing = return ()
walkDown (Just i) = do
next' <- nextSelectedItemAfterItem tree i (Just SearchDirectionDown)
l' <- getLabel i
printf " Selected item: %s\n" (if (null l') then "<nolabel>" else l')
walkDown next'
walkUp :: Maybe (Ref TreeItem) -> IO ()
walkUp Nothing = return ()
walkUp (Just i) = do
next' <- nextSelectedItemAfterItem tree i (Just SearchDirectionUp)
l' <- getLabel i
printf " Selected item: %s\n" (if (null l') then "<nolabel>" else l')
walkUp next'
selectPath :: Ref Tree -> String -> Ref LightButton -> IO ()
selectPath tree path button = do
i <- findItem tree path
case i of
Nothing -> flAlert $ "FAIL: Couldn't find item " ++ (show path) ++ "???"
(Just i') -> do
onoff <- getValue button
if onoff
then select tree (TreeItemPointerLocator (TreeItemPointer i')) >> return ()
else deselect tree (TreeItemPointerLocator (TreeItemPointer i')) >> return ()
selectChildrenWithPath :: Ref Tree -> String -> Ref LightButton -> IO ()
selectChildrenWithPath tree path button = do
i <- findItem tree path
case i of
Nothing -> flAlert $ "FAIL: Couldn't find item " ++ (show path) ++ "???"
(Just _) -> do
onoff <- getValue button
if onoff
then selectAllAndCallback tree i True
else deselectAllAndCallback tree i True
tree_scrollbar_size_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
tree_scrollbar_size_slider_callback tree slider = do
v <- getValue slider
setScrollbarSize tree (truncate v)
redraw tree
scrollbar_size_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
scrollbar_size_slider_callback tree slider = getValue slider >>= FL.setScrollbarSize . truncate >> redraw tree
item_labelsize_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()
item_labelsize_slider_callback tree slider = do
v <- getValue slider
setLabelsize tree (FontSize (truncate v))
redraw tree
updateColorChips ::
Ref Button ->
Ref Button ->
Ref Button ->
Ref Button ->
Ref Button ->
Ref Button ->
Ref Button ->
Ref Tree ->
Ref Window ->
IO ()
updateColorChips
color_button
labelcolor_button
selection_color_button
item_labelfgcolor_button
item_labelbgcolor_button
all_labelfgcolor_button
all_labelbgcolor_button
tree
window = do
getColor tree >>= setColor color_button
getLabelcolor tree >>= setColor labelcolor_button
getSelectionColor tree >>= setColor selection_color_button
getItemLabelfgcolor tree >>= setColor item_labelfgcolor_button
getItemLabelbgcolor tree >>= setColor item_labelbgcolor_button
getItemLabelfgcolor tree >>= setColor all_labelfgcolor_button
getItemLabelbgcolor tree >>= setColor all_labelbgcolor_button
redraw window
updateColor :: Ref Tree -> (Ref Tree -> IO Color) -> (Ref Button -> Color -> IO ()) -> (Ref Tree -> Color -> IO ()) -> Ref Window -> Ref Button -> IO ()
updateColor tree colorGetter buttonColorSetter treeColorSetter window button = do
v <- colorGetter tree
res <- editColor v
maybe (return ())
(\c -> do
buttonColorSetter button c
treeColorSetter tree c
redraw window
)
res
color_button_callback :: Ref Tree -> IO () -> Ref Button -> IO ()
color_button_callback tree _updateColorChips button = do
v <- getColor tree
res <- editColor v
maybe (return ())
(\c -> do
setColor tree c
_updateColorChips
redraw tree
)
res
x_item_labelbgcolor_button_callback :: Ref Tree -> IO () -> Ref Button -> IO ()
x_item_labelbgcolor_button_callback tree _updateColorChips _ = do
setItemLabelbgcolor tree (Color 0xffffffff)
_updateColorChips
redraw tree
testsuggs_button_callback :: Ref Button -> IO ()
testsuggs_button_callback button =
let helpmsg = "CHILD WIDGET SIZING TESTS\n" ++
"=========================\n" ++
" 1) Start program\n" ++
" 2) Click the 'ccc button' and D1/D2 buttons.\n" ++
" Their sizes should not change.\n" ++
" 3) Click the 'Item h() from widget' checkbox.\n" ++
" 4) Click the 'ccc button' and D1/D2 buttons.\n" ++
" Their sizes should change, getting larger vertically.\n" ++
" This validates that widget's size can affect the tree.\n" ++
" 5) Disable the checkbox, widgets should resize back to the\n" ++
" size of the other items.\n" ++
" 6) Hit ^A to select all items\n" ++
" 7) Under 'Selected Items', drag the 'Label Size' slider around.\n" ++
" All the item's height should change, as well as child widgets.\n" ++
" 8) Put Label Size' slider back to normal\n" ++
"\n" ++
"CHILD WIDGET + LABEL ITEM DRAWING TESTS\n" ++
"=======================================\n" ++
" 1) Start program\n" ++
" 2) Click 'Show label + widget'.\n" ++
" The widgets should all show item labels to their left.\n" ++
" 3) Disable same, item labels should disappear,\n" ++
" showing the widgets in their place.\n" ++
"\n" ++
"COLORS\n" ++
"======\n" ++
" 1) Start program\n" ++
" 2) Change 'Tree Fonts+Colors' -> color()\n" ++
" 3) Entire tree's background color will change, including items.\n" ++
" 4) Change the 'Tree Fonts + Colors -> item_labelbgcolor()'\n" ++
" 6) Click the '111' item to select it.\n" ++
" 7) Click 'Test Operations -> Insert Above'\n" ++
" New items should appear above the selected item using the new color.\n" ++
" This color will be different from the background color.\n" ++
" 8) Change the 'Tree Fonts+Colors' -> color()\n" ++
" The entire tree's bg should change, except the new items.\n" ++
" 9) Click the Tree Fonts+Colors -> item_labelbgcolor() 'X' button.\n" ++
" This resets item_labelbgcolor() to the default 'transparent' color (0xffffffff)\n" ++
" 10) Again, click the 'Insert Above' button.\n" ++
" New items will be created in the background color, and changing the color()\n" ++
" should affect the new items too.\n" ++
"\n" ++
"SCROLLING\n" ++
"=========\n" ++
" 1) Open '500 items' and 'Long Line' so that both scrollbars appear:\n" ++
" * The 'focus box' for the selected item should not be clipped\n" ++
" horizontally by the vertical scrollbar.\n" ++
" * Resizing the window horizontally should resize the focus box\n" ++
" * Scrolling vertically/horizontally should show reveal all\n" ++
" edges of the tree. One *exception* is the widget label\n" ++
" to the right of the 'ccc button'; labels aren't part\n" ++
" of the widget, and therefore don't affect scroll tabs\n" ++
" 2) Scroll vertical scroller to the middle of the tree\n" ++
" 3) Left click and drag up/down to extend the selection:\n" ++
" * Selection should autoscroll if you drag off the top/bottom\n" ++
" * Selection should work *even* if you drag horizontally\n" ++
" off the window edge; moving up/down outside the window\n" ++
" should continue to autoscroll\n" ++
" 4) Click either of the the scrollbar tabs and drag:\n" ++
" * Even if you drag off the scrollbar, the scrollbar\n" ++
" tab should continue to move\n" ++
" * Should continue to work if you drag off the window edge\n" ++
" horizontally drag off the window.\n" ++
" 5) Click 'Bbb' and hit 'Add 20,000', then position the\n" ++
" 'ccc button' so it's partially obscured by a scrollbar tab:\n" ++
" * Clicking the obscured button should work\n" ++
" * Clicking on the tab over the button should not 'click through'\n" ++
" to the button.\n" ++
""
in do
dialog' <- readIORef helpDialog
case dialog' of
Nothing -> do
groupSetCurrent (Nothing :: Maybe (Ref Group))
win <- doubleWindowNew (toSize (600,600)) Nothing (Just "Test Suggestions")
winW <- getW win
winH <- getH win
disp <- textDisplayNew (toRectangle (0,0,winW,winH)) Nothing
buff <- textBufferNew Nothing Nothing
setBuffer disp (Just buff)
setTextfont disp courier
setTextsize disp (FontSize 12)
setText buff helpmsg
end win
writeIORef helpDialog (Just (win, disp, buff))
setResizable win (Just disp) >> showWidget win
Just (win, disp, buff) ->
setResizable win (Just disp) >> showWidget win