diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +dist/* +*.cxx +*.h +src/*.txt +src/Tree.hs diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2013 Aditya Siram + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.txt b/README.txt new file mode 100644 --- /dev/null +++ b/README.txt @@ -0,0 +1,3 @@ +Examples of building Haskell applications using the Fluid GUI builder to generate Haskell code. + +This package requires the latest version of FLTKHS (http://hackage.haskell.org/package/fltkhs). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,26 @@ +module Main (main) where + +import Distribution.Simple +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription +import System.FilePath +import Debug.Trace + +main :: IO () +main = defaultMainWithHooks (simpleUserHooks { hookedPreProcessors = [("fl", ppFluidToHaskell)] }) + +fluidToHaskellProgram :: Program +fluidToHaskellProgram = + (simpleProgram "fltkhs-fluidtohs") { programFindVersion = (\_ _ -> return Nothing) } + +ppFluidToHaskell :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppFluidToHaskell bi lbi = + PreProcessor + { platformIndependent = True + , runPreProcessor = \(inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) verbosity -> do + (fluidToHaskellProg, _) <- requireProgram verbosity fluidToHaskellProgram (withPrograms lbi) + rawSystemProgram verbosity fluidToHaskellProg + ["--output-dir=" ++ outBaseDir, inBaseDir inRelativeFile] + } diff --git a/fltkhs-fluid-demos.cabal b/fltkhs-fluid-demos.cabal new file mode 100644 --- /dev/null +++ b/fltkhs-fluid-demos.cabal @@ -0,0 +1,140 @@ +name : fltkhs-fluid-demos +version : 0.0.0.4 +synopsis : Fltkhs Fluid Demos +description: + Examples of using Fluid with FLTKHS +license : MIT +license-file : LICENSE +author : Aditya Siram +build-type: Custom +maintainer: aditya.siram@gmail.com +homepage: http://github.com/deech/fltkhs-fluid-demos +category: UI,Graphics +cabal-version: >=1.20 +source-repository head + type: git + location: http://github.com/deech/fltkhs-fluid-demos + +Flag FastCompile + Description: Turn off optimizations for faster compilation + Manual: True + Default: True + +Executable fltkhs-fluid-radio + Main-Is: fluid-radio.hs + Hs-Source-Dirs: src/ + Build-Depends: + base == 4.*, + bytestring, + fltkhs >= 0.4.0.3 + default-language: Haskell2010 + default-extensions: FlexibleContexts + ghc-Options: -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + Other-Modules: Radio + if os(windows) + ghc-Options: -optl-mwindows + if os(darwin) + ghc-Options: -pgml g++ "-optl-Wl,-lfltkc" + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-fluid-tabs + Main-Is: fluid-tabs.hs + Hs-Source-Dirs: src/ + Build-Depends: + base == 4.*, + bytestring, + fltkhs >= 0.4.0.3 + default-language: Haskell2010 + default-extensions: FlexibleContexts + ghc-Options: -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + Other-Modules: Tabs + if os(windows) + ghc-Options: -optl-mwindows + if os(darwin) + ghc-Options: -pgml g++ "-optl-Wl,-lfltkc" + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-fluid-valuators + Main-Is: fluid-valuators.hs + Hs-Source-Dirs: src/ + Build-Depends: + base == 4.*, + bytestring, + fltkhs >= 0.4.0.3 + default-language: Haskell2010 + default-extensions: FlexibleContexts, AllowAmbiguousTypes + ghc-Options: -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + Other-Modules: Valuators + if os(windows) + ghc-Options: -optl-mwindows + if os(darwin) + ghc-Options: -pgml g++ "-optl-Wl,-lfltkc" + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-fluid-inactive + Main-Is: fluid-inactive.hs + Hs-Source-Dirs: src/ + Build-Depends: + base == 4.*, + bytestring, + fltkhs >= 0.4.0.3 + default-language: Haskell2010 + ghc-Options: -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + Other-Modules: Inactive + if os(windows) + ghc-Options: -optl-mwindows + if os(darwin) + ghc-Options: -pgml g++ "-optl-Wl,-lfltkc" + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-fluid-fast-slow + Main-Is: fluid-fast-slow.hs + Hs-Source-Dirs: src/ + Build-Depends: + base == 4.*, + bytestring, + fltkhs >= 0.4.0.3 + default-language: Haskell2010 + ghc-Options: -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + Other-Modules: FastSlow + if os(windows) + ghc-Options: -optl-mwindows + if os(darwin) + ghc-Options: -pgml g++ "-optl-Wl,-lfltkc" + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-fluid-tree + Main-Is: fluid-tree.hs + Hs-Source-Dirs: src/ + Build-Depends: + base == 4.*, + bytestring, + fltkhs >= 0.4.0.3 + default-language: Haskell2010 + ghc-Options: -threaded + if os(windows) + ghc-Options: -optl-mwindows + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + Other-Modules: + Tree, + TreeCallbacks + if os(darwin) + ghc-Options: -pgml g++ "-optl-Wl,-lfltkc" + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" diff --git a/src/FastSlow.fl b/src/FastSlow.fl new file mode 100644 --- /dev/null +++ b/src/FastSlow.fl @@ -0,0 +1,50 @@ +# data file for the Fltk User Interface Designer (fluid) +version 1.0303 +header_name {.h} +code_name {.cxx} +Function {make_window(IO (Ref Window))} {open +} { + Fl_Window window {open + xywh {397 202 315 440} type Double resizable visible + } { + Fl_Slider control { + label {move +this} + xywh {90 200 30 200} + code0 {setWhen control [WhenChanged, WhenRelease, WhenNotChanged]} + } + Fl_Slider fast { + label {fast +redraw} + xywh {140 200 30 200} + code0 {setOutput fast} + } + Fl_Slider slow { + label {slow +redraw} + xywh {190 200 30 200} + code0 {setOutput slow} + } + Fl_Box {} { + label {The left slider has changed[WhenChanged, WhenRelease, WhenNotChanged] so it produces a callback on both drag and release mouse events. +The middle slider (representing a widget with low overhead) is changed on every mouse movement. +The right slider (representing a widget with high overhead) is only updated when the mouse is released, by checking if FL.pushed is zero.} + xywh {10 10 300 180} box DOWN_BOX color 53 selection_color 47 labelfont 4 labelsize 12 align 148 + } + } + code {let { control_callback :: Ref Slider -> IO (); + control_callback slider = + do { + v <- getValue slider; + setValue fast v; + pushed_ <- FL.pushed; + case pushed_ of { + Nothing -> setValue slow v >> return (); + _ -> return (); + } + } + }} {} + code {setCallback control control_callback} {} + code {return window} {selected + } +} diff --git a/src/Inactive.fl b/src/Inactive.fl new file mode 100644 --- /dev/null +++ b/src/Inactive.fl @@ -0,0 +1,129 @@ +# data file for the Fltk User Interface Designer (fluid) +version 1.0303 +header_name {.h} +code_name {.cxx} +Function {make_window(IO (Ref Window))} {open +} { + code {let { inactive_callback :: Ref Group -> Ref Button -> IO (); + inactive_callback group _ = deactivate group; + active_callback :: Ref Group -> Ref Button -> IO (); + active_callback group _ = activate group; + }} {} + Fl_Window window {open + xywh {390 200 420 365} type Double resizable visible + } { + Fl_Group the_group { + label {activate()/deactivate() called on this Fl_Group} open + xywh {25 25 375 295} box ENGRAVED_FRAME align 17 resizable + } { + Fl_Button {} { + label button + xywh {50 50 105 25} + } + Fl_Light_Button light_button { + label {light button} + xywh {50 80 105 25} align 16 + code0 {setValue light_button True} + } + Fl_Group {} { + label {Child group} open + xywh {50 130 105 125} box DOWN_FRAME + } { + Fl_Check_Button {} { + label red + xywh {50 170 105 25} type Radio down_box DIAMOND_DOWN_BOX selection_color 1 labelcolor 1 + } + Fl_Check_Button {} { + label green + xywh {50 190 105 25} type Radio down_box DIAMOND_DOWN_BOX selection_color 2 labelcolor 2 + } + Fl_Check_Button {} { + label blue + xywh {50 210 105 25} type Radio down_box DIAMOND_DOWN_BOX selection_color 4 labelcolor 4 + } + Fl_Check_Button {} { + label white + xywh {50 230 105 25} type Radio down_box DIAMOND_DOWN_BOX selection_color 55 labelcolor 55 + } + Fl_Check_Button {} { + label check + xywh {50 130 105 25} down_box DOWN_BOX + } + Fl_Round_Button {} { + label round + xywh {50 150 105 25} down_box ROUND_DOWN_BOX + } + } + Fl_Slider slider { + label Fl_Slider selected + xywh {165 50 24 205} + code0 {setValue slider 0.5} + } + Fl_Input input { + xywh {195 50 195 30} + code0 {staticValue input "Input" Nothing} + } + Fl_Menu_Button {} { + label menu open + xywh {245 90 130 30} + } { + MenuItem {} { + label item + xywh {0 0 100 20} + } + MenuItem {} { + label item + xywh {10 10 100 20} + } + MenuItem {} { + label item + xywh {20 20 100 20} + } + MenuItem {} { + label item + xywh {30 30 100 20} + } + MenuItem {} { + label item + xywh {40 40 100 20} + } + } + Fl_Value_Output {} { + label {value:} + xywh {245 130 130 30} maximum 10000 step 1 textfont 5 textsize 24 textcolor 4 + } + Fl_Box {} { + label Fl_Box + xywh {245 170 140 50} box EMBOSSED_FRAME labeltype SHADOW_LABEL labelfont 3 labelsize 38 + } + Fl_Scrollbar {} { + label scrollbar + xywh {40 274 180 20} type Horizontal + } + Fl_Roller {} { + label roller + xywh {235 230 25 65} + } + Fl_Dial {} { + label dial + xywh {275 235 50 50} + } + Fl_Clock {} { + label clock + xywh {335 235 50 50} + } + } + Fl_Button active_button { + label active + callback {(active_callback the_group)} + xywh {25 330 185 25} type Radio + code0 {setValue active_button True} + } + Fl_Button {} { + label inactive + callback {(inactive_callback the_group)} + xywh {220 330 180 25} type Radio + } + } + code {return window} {} +} diff --git a/src/Radio.fl b/src/Radio.fl new file mode 100644 --- /dev/null +++ b/src/Radio.fl @@ -0,0 +1,106 @@ +# data file for the Fltk User Interface Designer (fluid) +version 1.0303 +header_name {.h} +code_name {.cxx} +Function {button_cb((Parent a Button) => Ref Output -> Ref a -> IO ())} {open return_type {cb_info b} +} { + code {do { + bl <- getLabel (safeCast b :: Ref Button); + bv <- getValue (safeCast b :: Ref Button); + let { msg = "Label: '" ++ bl ++ "'Value: " ++ (show bv) }; + setValue cb_info msg Nothing; + redraw cb_info; + }} {selected + } +} + +Function {make_window(IO (Ref Window))} {open +} { + Fl_Window window {open + xywh {461 67 365 210} type Double visible + } { + Fl_Button button_A1 { + label {&Fl_Button A1} + tooltip {Normal button (callback called only when released)} xywh {20 10 160 30} labelsize 13 + } + Fl_Button button_A2 { + label {Fl_Button &A2} + tooltip {Normal button with callback called when changed (push and released)} xywh {20 44 160 30} labelsize 13 when 1 + } + Fl_Return_Button button_B { + label {Fl_Return_Button &B} + tooltip {Button with Return key as default shortcut} xywh {20 78 160 30} labelsize 13 + } + Fl_Light_Button button_C { + label {Fl_Light_Button &C} + tooltip {Button with toggle state and a visual indicator of the current state} xywh {20 113 160 30} labelsize 13 + } + Fl_Check_Button button_D { + label {Fl_Check_Button &D} + tooltip {Check button with toggle state} xywh {20 148 160 30} down_box DOWN_BOX labelsize 13 + } + Fl_Round_Button button_E { + label {Fl_Round_Button &E} + tooltip {Round Button with toggle state} xywh {20 178 160 30} down_box ROUND_DOWN_BOX labelsize 13 + } + Fl_Group {} {open + xywh {190 10 70 120} box THIN_UP_FRAME + } { + Fl_Round_Button button_1 { + label {radio &1} + tooltip {Radio button, only one button is set at a time, in the corresponding group.} xywh {190 10 70 30} type Radio down_box ROUND_DOWN_BOX + } + Fl_Round_Button button_2 { + label {radio &2} + tooltip {Radio button, only one button is set at a time, in the corresponding group.} xywh {190 40 70 30} type Radio down_box ROUND_DOWN_BOX + } + Fl_Round_Button button_3 { + label {radio &3} + tooltip {Radio button, only one button is set at a time, in the corresponding group.} xywh {190 70 70 30} type Radio down_box ROUND_DOWN_BOX + } + Fl_Round_Button button_4 { + label {radio &4} + tooltip {Radio button, only one button is set at a time, in the corresponding group.} xywh {190 100 70 30} type Radio down_box ROUND_DOWN_BOX + } + } + Fl_Group {} {open + xywh {270 10 90 120} box THIN_UP_BOX + } { + Fl_Button button_radio_1 { + label radio + tooltip {Custom look button, only one button is set at a time, in the corresponding group.} xywh {280 20 20 20} type Radio selection_color 1 align 8 + } + Fl_Button button_radio_2 { + label radio + tooltip {Custom look button, only one button is set at a time, in the corresponding group.} xywh {280 45 20 20} type Radio selection_color 1 align 8 + } + Fl_Button button_radio_3 { + label radio + tooltip {Custom look button, only one button is set at a time, in the corresponding group.} xywh {280 70 20 20} type Radio selection_color 1 align 8 + } + Fl_Button button_radio_4 { + label radio + tooltip {Custom look button, only one button is set at a time, in the corresponding group.} xywh {280 95 20 20} type Radio selection_color 1 align 8 + } + } + Fl_Output cb_info { + label {callback:} + xywh {190 148 170 62} type Multiline align 133 textsize 12 + } + } + code {setCallback button_A1 (button_cb cb_info); +setCallback button_A2 (button_cb cb_info); +setCallback button_B (button_cb cb_info); +setCallback button_C (button_cb cb_info); +setCallback button_D (button_cb cb_info); +setCallback button_E (button_cb cb_info); +setCallback button_1 (button_cb cb_info); +setCallback button_2 (button_cb cb_info); +setCallback button_3 (button_cb cb_info); +setCallback button_4 (button_cb cb_info); +setCallback button_radio_1 (button_cb cb_info); +setCallback button_radio_2 (button_cb cb_info); +setCallback button_radio_3 (button_cb cb_info); +setCallback button_radio_4 (button_cb cb_info);} {} + code {return window} {} +} diff --git a/src/Tabs.fl b/src/Tabs.fl new file mode 100644 --- /dev/null +++ b/src/Tabs.fl @@ -0,0 +1,308 @@ +# data file for the Fltk User Interface Designer (fluid) +version 1.0303 +header_name {.h} +code_name {.cxx} +decl {import System.Exit} {selected private local +} + +Function {make_window(IO (Ref Window))} {open +} { + code {let { message_button_callback :: Ref Button -> IO (); + message_button_callback _ = + flMessage ("Test to see if this modal window prevents you from " + ++ "changing the tabs. It should."); + test_event_blocking_callback :: Ref Button -> IO (); + test_event_blocking_callback _ = + flMessage "Make sure you cannot change the tabs while this modal window is up"; + first_button_callback :: Ref Wizard -> Ref Button -> IO (); + first_button_callback wizard _ = do { + c <- getChild wizard 0; + maybe (return ()) + (setValue wizard . Just) + c; + }; + prev_button_callback :: Ref Wizard -> Ref Button -> IO (); + prev_button_callback wizard _ = prev wizard; + next_button_callback :: Ref Wizard -> Ref Button -> IO (); + next_button_callback wizard _ = next wizard; + last_button_callback :: Ref Wizard -> Ref Button -> IO (); + last_button_callback wizard _ = do { + cs <- getArray wizard; + if (null cs) + then return (); + else setValue wizard (Just (cs !! (length cs - 1))); + } + }} {} + Fl_Window foo_window { + label {Comparison of Fl_Tab (left) vs. Fl_Wizard (right)} open + xywh {423 205 640 335} type Double resizable visible + } { + Fl_Box {} { + label {class Fl_Tabs} + xywh {95 0 130 35} labeltype ENGRAVED_LABEL labelfont 1 + } + Fl_Tabs {} {open + tooltip {the various index cards test different aspects of the Fl_Tabs widget} xywh {10 35 300 205} selection_color 4 labelcolor 7 resizable + } { + Fl_Group {} { + label {Label&1} open + tooltip {this Tab tests correct keyboard navigation between text input fields} xywh {10 60 300 180} selection_color 1 resizable + } { + Fl_Input {} { + label {input:} + tooltip {This is the first input field} xywh {60 80 240 40} + } + Fl_Input {} { + label {input2:} + xywh {60 120 240 30} + } + Fl_Input {} { + label {input3:} + xywh {60 150 240 80} + } + } + Fl_Group {} { + label {tab&2} open + tooltip {tab2 tests among other things the cooperation of modal windows and tabs} xywh {10 60 300 180} selection_color 2 hide + } { + Fl_Button message_button { + label button1 + callback message_button_callback + xywh {20 90 100 30} + } + Fl_Input {} { + label {input in box2} + xywh {140 130 100 30} + } + Fl_Button {} { + label {This is stuff inside the Fl_Group "tab2"} + xywh {30 170 260 30} + } + Fl_Button {} { + label {Test event blocking by modal window} + callback test_event_blocking_callback + xywh {30 200 260 30} + } + } + Fl_Group {} { + label {tab&3} open + tooltip {tab3 checks for correct keyboard navigation} xywh {10 60 300 180} selection_color 3 hide + } { + Fl_Button {} { + label button2 + xywh {20 90 60 80} + } + Fl_Button {} { + label button + xywh {80 90 60 80} + } + Fl_Button {} { + label button + xywh {140 90 60 80} + } + } + Fl_Group {} { + label {&tab4} open + tooltip {this tab show the issue of indicating a selcted tab if the tab layouts are very similar} xywh {10 60 300 180} selection_color 5 labeltype ENGRAVED_LABEL labelfont 2 hide + } { + Fl_Button {} { + label button2 + xywh {20 80 60 110} + } + Fl_Button {} { + label button + xywh {80 80 60 110} + } + Fl_Button {} { + label button + xywh {140 80 60 110} + } + } + Fl_Group {} { + label {@fileprint &print} open + tooltip {tab5 verifies if visibility requests are handled correctly} xywh {10 60 300 180} hide + } { + Fl_Button {} { + label button2 + tooltip {button2 has a different tooltp than tab5} xywh {20 75 60 80} + } + Fl_Button {} { + label button + xywh {90 75 60 80} + } + Fl_Clock {} { + label {Make sure this clock does not use processor time when this tab is hidden or window is iconized} + xywh {160 75 100 100} box OSHADOW_BOX color 238 selection_color 0 labelfont 8 labelsize 10 align 130 + } + Fl_Group {} {open + xywh {20 175 40 55} box THIN_DOWN_BOX color 173 align 16 + class Fl_Window + } {} + Fl_Group {} { + label {subwindows:} open + xywh {65 175 40 55} box THIN_DOWN_BOX color 167 + class Fl_Window + } {} + Fl_Group {} {open + xywh {110 175 40 55} box THIN_DOWN_BOX color 239 align 16 + class Fl_Window + } {} + } + } + Fl_Box {} { + label {class Fl_Wizard} + xywh {410 0 130 35} labeltype ENGRAVED_LABEL labelfont 1 + } + Fl_Wizard wWizard {open + xywh {325 60 300 180} + } { + Fl_Group {} { + label Label1 open + tooltip {this Tab tests correct keyboard navigation between text input fields} xywh {325 60 300 180} selection_color 1 hide resizable + } { + Fl_Input {} { + label {input:} + tooltip {This is the first input field} xywh {375 80 240 40} + } + Fl_Input {} { + label {input2:} + xywh {375 120 240 30} + } + Fl_Input {} { + label {input3:} + xywh {375 150 240 80} + } + } + Fl_Group {} { + label tab2 open + tooltip {tab2 tests among other things the cooperation of modal windows and tabs} xywh {325 60 300 180} selection_color 2 hide + } { + Fl_Button {} { + label button1 + callback message_button_callback + xywh {335 90 100 30} + } + Fl_Input {} { + label {input in box2} + xywh {455 130 100 30} + } + Fl_Button {} { + label {This is stuff inside the Fl_Group "tab2"} + xywh {345 170 260 30} + } + Fl_Button {} { + label {Test event blocking by modal window} + callback test_event_blocking_callback + xywh {345 200 260 30} + } + } + Fl_Group {} { + label tab3 open + tooltip {tab3 checks for correct keyboard navigation} xywh {325 60 300 180} selection_color 3 hide + } { + Fl_Button {} { + label button2 + xywh {335 90 60 80} + } + Fl_Button {} { + label button + xywh {395 90 60 80} + } + Fl_Button {} { + label button + xywh {455 90 60 80} + } + } + Fl_Group {} { + label tab4 open + tooltip {this tab show the issue of indicating a selcted tab if the tab layouts are very similar} xywh {325 60 300 180} selection_color 5 labelfont 2 hide + } { + Fl_Button {} { + label button2 + xywh {335 80 60 110} + } + Fl_Button {} { + label button + xywh {395 80 60 110} + } + Fl_Button {} { + label button + xywh {455 80 60 110} + } + } + Fl_Group {} { + label { tab5 } open + tooltip {tab5 verifies if visibility requests are handled correctly} xywh {325 60 300 180} labeltype ENGRAVED_LABEL + } { + Fl_Button {} { + label button2 + tooltip {button2 has a different tooltp than tab5} xywh {335 75 60 80} + } + Fl_Button {} { + label button + xywh {405 75 60 80} + } + Fl_Clock {} { + label {Make sure this clock does not use processor time when this tab is hidden or window is iconized} + xywh {475 75 100 100} box OSHADOW_BOX color 238 selection_color 0 labelfont 8 labelsize 10 align 130 + } + Fl_Group {} {open + xywh {335 175 40 55} box THIN_DOWN_BOX color 173 align 16 + class Fl_Window + } {} + Fl_Group {} { + label {subwindows:} open + xywh {380 175 40 55} box THIN_DOWN_BOX color 167 + class Fl_Window + } {} + Fl_Group {} {open + xywh {425 175 40 55} box THIN_DOWN_BOX color 239 align 16 + class Fl_Window + } {} + } + } + Fl_Group {} {open + xywh {410 245 130 25} + } { + Fl_Button {} { + label {@|<} + callback {(first_button_callback wWizard)} + tooltip {go to first page [Home]} xywh {410 245 30 25} shortcut 0xff50 + } + Fl_Button {} { + label {@<} + callback {(prev_button_callback wWizard)} + tooltip {go to previous page [left arrow]} xywh {440 245 30 25} shortcut 0xff51 + } + Fl_Button {} { + label {@>} + callback {(next_button_callback wWizard)} + tooltip {go to next page in wizard [right arrow]} xywh {480 245 30 25} shortcut 0xff53 + } + Fl_Button {} { + label {@>|} + callback {(last_button_callback wWizard)} + tooltip {go to last page [End]} xywh {510 245 30 25} shortcut 0xff57 + } + } + Fl_Input {} { + label {inputA:} + xywh {60 255 130 25} + } + Fl_Input {} { + label {inputB:} + xywh {60 285 250 25} + } + Fl_Button {} { + label cancel + callback {(const (exitWith (ExitFailure 1)))} + xywh {475 295 70 30} + } + Fl_Return_Button {} { + label OK + callback {(const (exitWith ExitSuccess))} + xywh {555 295 70 30} + } + } + code {return foo_window;} {} +} diff --git a/src/Tree.fl b/src/Tree.fl new file mode 100644 --- /dev/null +++ b/src/Tree.fl @@ -0,0 +1,775 @@ +# data file for the Fltk User Interface Designer (fluid) +version 1.0303 +header_name {.h} +code_name {.cxx} +decl {import TreeCallbacks} {private local +} + +decl {import Data.IORef} {private local +} + +Function {make_window(IO ( Ref Window))} {open +} { + Fl_Window window { + label tree open + xywh {115 293 1045 580} type Double visible + } { + Fl_Group tree { + label Tree + callback treeCallback open + tooltip {Test tree} xywh {15 22 320 539} box DOWN_BOX color 55 selection_color 15 + class Fl_Tree + } {} + Fl_Group widget_group {open + xywh {350 5 681 615} + code0 {setResizable widget_group (Nothing :: Maybe (Ref Widget))} + } { + Fl_Box {} { + label {Tree Globals} + tooltip {These controls only affect the selected items. If no items are selected, all existing items in tree are modified.} xywh {350 23 330 389} box GTK_DOWN_BOX color 47 labelsize 12 align 1 + } + Fl_Value_Slider margintop_slider { + label {margintop()} + callback {(margintop_slider_callback tree)} + tooltip {Changes the top margin for the tree widget} xywh {505 40 155 16} type Horizontal color 46 selection_color 1 labelsize 10 align 4 textsize 9 + code0 {getMargintop tree >>= setValue margintop_slider . fromIntegral;} + code1 {range margintop_slider 0.0 100.0;} + code2 {setStep margintop_slider 1.0;} + } + Fl_Value_Slider marginleft_slider { + label {marginleft()} + callback {(marginleft_slider_callback tree)} + tooltip {Changes the left margin for the tree widget} xywh {505 60 155 16} type Horizontal color 46 selection_color 1 labelsize 10 align 4 textsize 9 + code0 {getMarginleft tree >>= setValue marginleft_slider . fromIntegral ;} + code1 {range marginleft_slider 0.0 200.0;} + code2 {setStep marginleft_slider 1.0;} + } + Fl_Value_Slider marginbottom_slider { + label {marginbottom()} + user_data tree + callback {(marginbottom_slider_callback tree)} + tooltip {Changes the bottom margin for the tree +Sets how far beyond bottom of tree you can scroll} xywh {505 80 155 16} type Horizontal color 46 selection_color 1 labelsize 10 align 4 textsize 9 + code0 {setValue marginbottom_slider 0.0;} + code1 {range marginbottom_slider 0.0 275.0;} + code2 {setStep marginbottom_slider 1.0;} + code3 {doCallback marginbottom_slider;} + } + Fl_Value_Slider linespacing_slider { + label {linespacing()} + callback {(linespacing_slider_callback tree)} + tooltip {Changes the spacing between items in the tree} xywh {505 100 155 16} type Horizontal color 46 selection_color 1 labelsize 10 align 4 textsize 9 + code0 {getLinespacing tree >>= setValue linespacing_slider . fromIntegral} + code1 {range linespacing_slider 0.0 100.0} + code2 {setStep linespacing_slider 1.0} + } + Fl_Value_Slider usericonmarginleft_slider { + label {usericonmarginleft()} + user_data tree + callback {(usericonmarginleft_slider_callback tree)} + tooltip {Changes the left margin for the user icons (if any)} xywh {505 120 155 16} type Horizontal color 46 selection_color 1 labelsize 10 align 4 textsize 9 + code0 {getUsericonmarginleft tree >>= setValue usericonmarginleft_slider . fromIntegral} + code1 {range usericonmarginleft_slider 0.0 100.0} + code2 {setStep usericonmarginleft_slider 1.0} + } + Fl_Value_Slider labelmarginleft_slider { + label {labelmarginleft()} + user_data tree + callback {(labelmarginleft_slider_callback tree)} + tooltip {Changes the left margin for the item label} xywh {505 140 155 16} type Horizontal color 46 selection_color 1 labelsize 10 align 4 textsize 9 + code0 {getLabelmarginleft tree >>= setValue labelmarginleft_slider . fromIntegral} + code1 {range labelmarginleft_slider 0.0 100.0} + code2 {setStep labelmarginleft_slider 1.0} + } + Fl_Value_Slider widgetmarginleft_slider { + label {widgetmarginleft()} + user_data tree + callback {(widgetmarginleft_slider_callback tree)} + tooltip {Changes the margin to the left of child FLTK widget() +"Show label + widget" must be 'on' for this to take effect, i.e. +item_draw_mode(FL_TREE_ITEM_DRAW_LABEL_AND_WIDGET)} xywh {505 160 155 16} type Horizontal color 46 selection_color 1 labelsize 10 align 4 textsize 9 + code0 {setValue widgetmarginleft_slider 0} + code1 {range widgetmarginleft_slider 0.0 100.0} + code2 {setStep widgetmarginleft_slider 1.0} + code3 {doCallback widgetmarginleft_slider} + } + Fl_Value_Slider openchild_marginbottom_slider { + label {openchild_marginbottom()} + user_data tree + callback {(openchild_marginbottom_slider_callback tree)} + tooltip {Changes the vertical space below an open child tree} xywh {505 180 155 16} type Horizontal color 46 selection_color 1 labelsize 10 align 4 textsize 9 + code0 {getOpenchildMarginbottom tree >>= setValue openchild_marginbottom_slider . fromIntegral} + code1 {range openchild_marginbottom_slider 0.0 100.0} + code2 {setStep openchild_marginbottom_slider 1.0} + } + Fl_Value_Slider connectorwidth_slider { + label {connectorwidth()} + user_data tree + callback {(connectorwidth_slider_callback tree)} + tooltip {Tests Fl_Tree::connectorwidth()} xywh {505 199 155 16} type Horizontal color 46 selection_color 1 labelsize 11 align 4 textsize 9 + code0 {getConnectorwidth tree >>= setValue connectorwidth_slider . fromIntegral} + code1 {range connectorwidth_slider 0.0 100.0} + code2 {setStep connectorwidth_slider 1.0} + code3 {setColor connectorwidth_slider (Color 46); setSelectionColor connectorwidth_slider redColor} + } + Fl_Choice collapseicons_chooser { + label {Collapse icons} + callback {(collapseicons_chooser_callback tree)} open selected + tooltip {Tests Fl_Tree::openicon(), Fl_Tree::closeicon() and Fl_Tree::showcollapse().} xywh {520 225 140 21} down_box BORDER_BOX labelsize 12 textsize 11 + } { + MenuItem {} { + label Normal + xywh {10 10 36 21} labelsize 12 + } + MenuItem {} { + label Custom + xywh {20 20 36 21} labelsize 12 + } + MenuItem {} { + label Off + xywh {30 30 36 21} labelsize 12 + } + } + Fl_Choice connectorstyle_chooser { + label {Line style} + callback {(connectorstyle_chooser_callback tree)} open + tooltip {Tests Fl_Tree::connectorstyle() bit flags} xywh {520 249 140 21} down_box BORDER_BOX labelsize 12 textsize 11 + code0 {(getConnectorstyle tree >>= set_connectorstyle_chooser connectorstyle_chooser)} + } { + MenuItem {} { + label None + xywh {40 40 36 21} labelsize 12 + } + MenuItem {} { + label Dotted + xywh {20 20 36 21} labelsize 12 + } + MenuItem {} { + label Solid + xywh {30 30 36 21} labelsize 12 + } + } + Fl_Choice selectmode_chooser { + label {Selection Mode} open + tooltip {Tests Fl_Tree::selectmode() +Sets how Fl_Tree handles mouse selection of tree items. + NONE -- Not selectable by keyboard/mouse + SINGLE -- Only one item at a time selectable by keyboard/mouse + MULTI -- Multiple items selectable} xywh {520 273 140 21} down_box BORDER_BOX labelsize 12 textsize 11 + callback {(selectmode_chooser_callback tree)} + code0 {setValue selectmode_chooser (MenuItemByIndex (MenuItemIndex 2))} + code1 {selectmode_chooser_callback tree selectmode_chooser} + } { + MenuItem {} { + label None + xywh {40 40 36 21} labelsize 12 + } + MenuItem {} { + label Single + xywh {50 50 36 21} labelsize 12 + } + MenuItem {} { + label Multi + xywh {60 60 36 21} labelsize 12 + } + MenuItem {} { + label {Single + drag} + xywh {70 70 36 21} labelsize 12 + } + } + Fl_Choice reselectmode_chooser { + label {Item Reselect Mode} + callback {(reselectmode_chooser_callback tree)} + tooltip {Tests Fl_Tree::item_reselect_mode(). +Enables 'reselect' events. +These happen when someone selects an item already selected +(mouse drags or multi-clicks)} xywh {520 297 140 21} down_box BORDER_BOX labelsize 12 textsize 11 + code0 {setValue reselectmode_chooser (MenuItemByIndex (MenuItemIndex 1))} + code1 {doCallback reselectmode_chooser} + } { + MenuItem {} { + label {Selectable Once} + xywh {50 50 36 21} labelsize 12 + } + MenuItem {} { + label {Selectable Always} + xywh {60 60 36 21} labelsize 12 + } + } + Fl_Choice whenmode_chooser { + label When + callback {(whenmode_chooser_callback tree)} + tooltip {Sets when() the tree's callback is invoked} xywh {520 323 140 21} down_box BORDER_BOX labelsize 12 textsize 11 + code0 {setValue whenmode_chooser (MenuItemByIndex (MenuItemIndex 1))} + code1 {whenmode_chooser_callback tree whenmode_chooser} + } { + MenuItem {} { + label Changed + xywh {50 50 36 21} labelsize 12 + } + MenuItem {} { + label Released + xywh {60 60 36 21} labelsize 12 + } + MenuItem {} { + label Never + xywh {70 70 36 21} labelsize 12 + } + } + Fl_Check_Button usericon_radio { + label {Enable user icons?} + user_data tree + callback {(assignUserIcons tree)} + tooltip {Tests Fl_Tree_Item::usericon()} xywh {485 355 20 16} down_box DOWN_BOX labelsize 11 align 7 + code0 {setValue usericon_radio True} + } + Fl_Check_Button showroot_radio { + label {Show root?} + user_data tree + callback {(set_tree_showroot tree)} + tooltip {Tests tree->showroot();} xywh {485 372 20 16} down_box DOWN_BOX labelsize 11 align 7 + code0 {getShowroot tree >>= setValue showroot_radio} + } + Fl_Check_Button visiblefocus_checkbox { + label {Visible focus?} + user_data tree + callback {(set_tree_showroot tree)} + tooltip {Toggles the tree's visible_focus() box} xywh {485 389 20 16} down_box DOWN_BOX labelsize 11 align 7 + code0 {getVisibleFocus tree >>= setValue visiblefocus_checkbox} + } + Fl_Check_Button labelandwidget_radio { + label {Show label + widget} + callback {(radio_button_deactivate_callback window)} + tooltip {Tests Fl_Tree::item_draw_mode(FL_TREE_ITEM_DRAW_LABEL_AND_WIDGET) +Enables both label and widget() for display. +When enabled, widget should appear to the right of the item's label. +By default, the widget() is shown in place of the item's label.} xywh {645 356 20 16} down_box DOWN_BOX labelsize 11 align 7 + code0 {setValue labelandwidget_radio False} + code1 {doCallback labelandwidget_radio} + } + Fl_Check_Button itemheightfromwidget_radio { + label {Item h() from widget} + callback {(radio_button_deactivate_callback window)} + tooltip {Tests Fl_Tree::item_draw_mode(FL_TREE_ITEM_HEIGHT_FROM_WIDGET) +If enabled, item's height will track the widget()'s height. +When enabled, click 'ccc' or 'D1/D2' buttons to test.} xywh {645 371 20 16} down_box DOWN_BOX labelsize 11 align 7 + code0 {setValue itemheightfromwidget_radio False} + code1 {doCallback itemheightfromwidget_radio} + } + Fl_Box {} { + label {Test Operations} + tooltip {These controls only affect the defaults for new items that are created. These test the Fl_Tree_Prefs methods.} xywh {350 435 330 125} box GTK_DOWN_BOX color 47 labelsize 12 align 1 + } + Fl_Box showitem_box { + label {show_item() +} + xywh {370 460 70 82} box GTK_DOWN_BOX labelsize 11 align 1 + } + Fl_Button {} { + label Show + callback {(goto_next_selected_item tree)} + tooltip {Tests show_item() with no position specified. +Makes the selected item visible IF it is off-screen. +No change made if it is not off-screen.} xywh {385 469 40 17} labelsize 11 + } + Fl_Button {} { + label Top + callback {(goto_next_selected_item tree)} + tooltip {Test show_item_top(). +Scrolls selected item to the top of the display +(only works if scrollbar showing) +To use: +1) open '500 items' +2) select item 0010 +3) Hit Top/Mid/Bot} xywh {385 486 40 16} labelsize 11 + } + Fl_Button {} { + label Mid + callback {(goto_next_selected_item_middle tree)} + tooltip {Tests show_item_middle(). +Scrolls the selected item to the middle of the display +To use: + 1) open '500 items' + 2) select 'item 0010' + 3) Hit Top/Mid/Bot} xywh {385 502 40 16} labelsize 11 + } + Fl_Button {} { + label Bot + callback {(goto_next_selected_item_bottom tree)} + tooltip {Tests show_item_bottom(). +Scrolls the selected item to the bottom of the display +To use: + 1) open '500 items' + 2) select 'item 0010' + 3) Hit Top/Mid/Bot} xywh {385 518 40 16} labelsize 11 + } + Fl_Button openall_button { + label {Open All} + callback {(openall_button_callback tree)} + tooltip {Opens all nodes that have children} xywh {470 451 95 16} labelsize 9 + } + Fl_Button insertabove_button { + label {Insert Above} + callback {(insertabove_button_callback tree)} + tooltip {Inserts three items above the selected items} xywh {470 491 95 16} labelsize 9 + } + Fl_Button rebuildtree_button { + label {Rebuild Tree} + callback {(rebuildTree tree usericon_radio)} + tooltip {Rebuilds the tree with defaults} xywh {470 511 95 16} labelsize 9 + } + Fl_Button showpathname_button { + label {Show Pathname} + callback {(showpathname_button_callback tree)} + tooltip {Tests Fl_Tree::item_pathname() +Show the pathname for the selected item.} xywh {470 531 95 16} labelsize 9 + } + Fl_Button closeall_button { + label {Close All} + callback {(closeall_button_callback tree)} + tooltip {Closes all nodes that have children +(doesn't affect 'root')} xywh {570 451 95 16} labelsize 9 + } + Fl_Button clearall_button { + label {Clear All} + callback {(clearall_button_callback tree)} + tooltip {Tests Fl_Tree::clear(). +Clears all items} xywh {570 471 95 16} labelsize 9 + } + Fl_Button testcallbackflag_button { + label {Test Callback Flag} + callback {(testcallbackflag_button_callback tree)} + tooltip {Test the 'docallback' argument can disable callbacks.} xywh {570 491 95 16} labelsize 9 + } + Fl_Button testrootshowself_button { + label {Root Show Self} + callback {(testrootshowself_button_callback tree)} + tooltip {Test the root->'show_self() method to show the entire tree on stdout} xywh {570 511 95 16} labelsize 9 + } + Fl_Button add20k_button { + label {Add 20,000} + callback {(add20k_button_callback tree)} + tooltip {Adds 20,000 items to the selected item's parent} xywh {570 531 95 16} labelsize 9 + } + Fl_Box {} { + label {Selected Items} + tooltip {These controls only affect the selected items. If no items are selected, all existing items in tree are modified.} xywh {696 23 335 246} box GTK_DOWN_BOX color 47 labelsize 12 align 1 + } + Fl_Choice selected_labelfont_choice { + label {Fl_Tree_Item::labelfont()} + callback {(selected_labelfont_choice_callback tree)} + tooltip {Tests Fl_Tree_Item::labelfont(); +Changes the font for the selected items's labels. +If none selected, all are changed.} xywh {863 31 140 21} down_box BORDER_BOX labelsize 11 textsize 11 + code0 {assignTreeFontToButton tree selected_labelfont_choice} + } { + MenuItem {} { + label Helvetica + xywh {30 30 36 21} labelsize 12 + } + MenuItem {} { + label {Helvetica Bold} + xywh {40 40 36 21} labelsize 12 + } + MenuItem {} { + label {Helvetica Italic} + xywh {55 55 36 21} labelsize 12 + } + MenuItem {} { + label {Helvetica Bold Italic} + xywh {60 60 36 21} labelsize 12 + } + MenuItem {} { + label Courier + xywh {70 70 36 21} labelsize 12 + } + MenuItem {} { + label {Courier Bold} + xywh {80 80 36 21} labelsize 12 + } + MenuItem {} { + label {Courier Italic} + xywh {65 65 36 21} labelsize 12 + } + MenuItem {} { + label {Courier Bold Italic} + xywh {70 70 36 21} labelsize 12 + } + MenuItem {} { + label Times + xywh {80 80 36 21} labelsize 12 + } + MenuItem {} { + label {Times Bold} + xywh {90 90 36 21} labelsize 12 + } + MenuItem {} { + label {Times Italic} + xywh {75 75 36 21} labelsize 12 + } + MenuItem {} { + label {Times Bold Italic} + xywh {80 80 36 21} labelsize 12 + } + MenuItem {} { + label Symbol + xywh {90 90 36 21} labelsize 12 + } + MenuItem {} { + label Screen + xywh {100 100 36 21} labelsize 12 + } + MenuItem {} { + label {Screen bold} + xywh {85 85 36 21} labelsize 12 + } + MenuItem {} { + label {Zapf Dingbats} + xywh {90 90 36 21} labelsize 12 + } + } + Fl_Value_Slider selected_labelsize_slider { + label {Fl_Tree_Item::labelsize()} + user_data tree + callback {(selected_labelsize_slider_callback tree)} + tooltip {Tests Fl_Tree_Item::labelsize(); +Changes the font size of the selected items's labels. +If none selected, all are changed.} xywh {863 55 140 16} type Horizontal color 46 selection_color 1 labelsize 11 align 4 textsize 12 + code0 {assignTreeLabelsizeToSlider tree selected_labelsize_slider} + code1 {range selected_labelsize_slider 2.0 200.0} + code2 {setStep selected_labelsize_slider 1.0} + code3 {setColor selected_labelsize_slider (Color 46); setSelectionColor selected_labelsize_slider redColor} + } + Fl_Button all_labelfgcolor_button { + label {Fl_Tree_Item::labelfgcolor()} + callback {(all_labelfgcolor_button_callback tree)} + tooltip {Sets the Fl_Tree_Item::labelfgcolor() for the selected items. If none selected, all are changed.} xywh {863 81 16 16} box DOWN_BOX labelsize 11 align 7 + code0 {getSelectedItemFgColor tree >>= setColor all_labelfgcolor_button} + } + Fl_Button all_labelbgcolor_button { + label {Fl_Tree_Item::labelbgcolor()} + callback {(all_labelbgcolor_button_callback tree)} + tooltip {Sets the Fl_Tree_Item::labelbgcolor() for the selected items. If none selected, all are changed.} xywh {863 99 16 16} box DOWN_BOX labelsize 11 align 7 + code0 {getSelectedItemBgColor tree >>= setColor all_labelbgcolor_button} + } + Fl_Light_Button deactivate_toggle { + label { Deactivate} + callback {(deactivate_toggle_callback tree)} + tooltip {Toggle the deactivation state of the selected items. +If none are selected, all are set.} xywh {769 134 95 16} selection_color 1 labelsize 9 + } + Fl_Light_Button bold_toggle { + label { Bold Font} + callback {(bold_toggle_callback tree)} + tooltip {Toggles bold font for selected items +If nothing selected, all are changed} xywh {769 154 95 16} selection_color 1 labelsize 9 + } + Fl_Button showselected_button { + label {Show Selected} + callback {(showselected_button_callback tree)} + tooltip {Clears the selected items} xywh {864 134 95 16} labelsize 9 + } + Fl_Button clearselected_button { + label {Remove Selected} + callback {(clearselected_button_callback tree)} + tooltip {Removes the selected items} xywh {864 154 95 16} labelsize 9 + } + Fl_Button swapselected_button { + label {Swap Selected} + callback {(swapselected_button_callback tree)} + tooltip {Tests the Fl_Tree_Item::swap_children() method +Swaps two selected items (items must be siblings)} xywh {864 174 95 16} labelsize 9 + } + Fl_Button selectall_button { + label {Select All} + callback {(selectall_button_callback tree)} + tooltip {Selects all items in the tree} xywh {724 199 95 16} labelsize 9 + } + Fl_Button deselectall_button { + label {Deselect All} + callback {(deselectall_button_callback tree)} + tooltip {Deselects all items in the tree} xywh {724 219 95 16} labelsize 9 + } + Fl_Button nextselected_button { + label {next_selected()} + callback {(nextselected_button_callback tree)} + tooltip {Tests the Fl_Tree::next_selected() function} xywh {723 239 95 16} labelsize 9 + } + Fl_Light_Button bbbselect_toggle { + label { Select Bbb} + callback {(selectPath tree "/Bbb")} + tooltip {Toggle selection of just the /Bbb item +(Not children)} xywh {819 199 95 16} selection_color 1 labelsize 9 + } + Fl_Light_Button bbbselect2_toggle { + label { Select Bbb+} + callback {(selectChildrenWithPath tree "/Bbb")} + tooltip {Toggle selection of the /Bbb item and its children} xywh {819 219 95 16} selection_color 1 labelsize 9 + } + Fl_Light_Button bbbchild02select_toggle { + label { Toggle child-02} + callback {(selectPath tree "/Bbb/child-02")} + tooltip {Toggle the single item "/Bbb/child-02" using the item's "pathname".} xywh {819 239 95 16} selection_color 1 labelsize 9 + } + Fl_Light_Button rootselect_toggle { + label {Select ROOT} + callback {(selectPath tree "/ROOT")} + tooltip {Toggle selection of the ROOT item} xywh {914 199 95 16} selection_color 1 labelsize 9 + } + Fl_Light_Button rootselect2_toggle { + label {Select ROOT+} + callback {(selectChildrenWithPath tree "/ROOT")} + tooltip {Toggle selection of the ROOT item and all children} xywh {914 219 95 16} selection_color 1 labelsize 9 + } + Fl_Box {} { + label {Tree Fonts + Colors} + tooltip {These controls only affect the selected items. If no items are selected, all existing items in tree are modified.} xywh {695 298 335 186} box GTK_DOWN_BOX color 47 labelsize 12 align 1 + } + Fl_Choice labelfont_choice { + label {labelfont()} + callback {(labelfont_choice_callback tree window)} + tooltip {Sets the default font used for new items created. Does NOT affect existing items.} xywh {848 314 140 21} down_box BORDER_BOX labelsize 12 textsize 12 + code0 {setLabelfontFromTree tree labelfont_choice} + } { + MenuItem {} { + label Helvetica + xywh {35 35 36 21} labelsize 12 + } + MenuItem {} { + label {Helvetica Bold} + xywh {45 45 36 21} labelsize 12 + } + MenuItem {} { + label {Helvetica Italic} + xywh {60 60 36 21} labelsize 12 + } + MenuItem {} { + label {Helvetica Bold Italic} + xywh {65 65 36 21} labelsize 12 + } + MenuItem {} { + label Courier + xywh {75 75 36 21} labelsize 12 + } + MenuItem {} { + label {Courier Bold} + xywh {85 85 36 21} labelsize 12 + } + MenuItem {} { + label {Courier Italic} + xywh {70 70 36 21} labelsize 12 + } + MenuItem {} { + label {Courier Bold Italic} + xywh {75 75 36 21} labelsize 12 + } + MenuItem {} { + label Times + xywh {85 85 36 21} labelsize 12 + } + MenuItem {} { + label {Times Bold} + xywh {95 95 36 21} labelsize 12 + } + MenuItem {} { + label {Times Italic} + xywh {80 80 36 21} labelsize 12 + } + MenuItem {} { + label {Times Bold Italic} + xywh {85 85 36 21} labelsize 12 + } + MenuItem {} { + label Symbol + xywh {95 95 36 21} labelsize 12 + } + MenuItem {} { + label Screen + xywh {105 105 36 21} labelsize 12 + } + MenuItem {} { + label {Screen bold} + xywh {90 90 36 21} labelsize 12 + } + MenuItem {} { + label {Zapf Dingbats} + xywh {95 95 36 21} labelsize 12 + } + } + Fl_Value_Slider labelsize_slider { + label {labelsize()} + user_data tree + callback {(labelsize_slider_callback tree window)} + tooltip {Sets the font size for the tree's label(). +This is also the font size that will be used to draw the items IF their size hasn't been set with Fl_Tree_Item::labelsize() or Fl_Tree::item_labelsize()} xywh {848 338 140 16} type Horizontal color 46 selection_color 1 labelsize 12 align 4 textsize 12 + code0 {(do { (FontSize s) <- getLabelsize tree; setValue labelsize_slider (fromIntegral s) })} + code1 {range labelsize_slider 1.0 50.0} + code2 {setStep labelsize_slider 1.0} + code3 {setColor labelsize_slider (Color 46); setSelectionColor labelsize_slider redColor} + } + Fl_Choice item_labelfont_choice { + label {Item_labelfont()} + callback {(item_labelfont_choice_callback tree)} + tooltip {Sets the default font used for new items created. +.Also affects any items whose font has NOT specifically been set with item->labelfont().} xywh {848 358 140 21} down_box BORDER_BOX labelsize 12 textsize 12 + code0 {setLabelfontFromTree tree item_labelfont_choice} + } { + MenuItem {} { + label Helvetica + xywh {25 25 36 21} labelsize 12 + } + MenuItem {} { + label {Helvetica Bold} + xywh {35 35 36 21} labelsize 12 + } + MenuItem {} { + label {Helvetica Italic} + xywh {50 50 36 21} labelsize 12 + } + MenuItem {} { + label {Helvetica Bold Italic} + xywh {55 55 36 21} labelsize 12 + } + MenuItem {} { + label Courier + xywh {65 65 36 21} labelsize 12 + } + MenuItem {} { + label {Courier Bold} + xywh {75 75 36 21} labelsize 12 + } + MenuItem {} { + label {Courier Italic} + xywh {60 60 36 21} labelsize 12 + } + MenuItem {} { + label {Courier Bold Italic} + xywh {65 65 36 21} labelsize 12 + } + MenuItem {} { + label Times + xywh {75 75 36 21} labelsize 12 + } + MenuItem {} { + label {Times Bold} + xywh {85 85 36 21} labelsize 12 + } + MenuItem {} { + label {Times Italic} + xywh {70 70 36 21} labelsize 12 + } + MenuItem {} { + label {Times Bold Italic} + xywh {75 75 36 21} labelsize 12 + } + MenuItem {} { + label Symbol + xywh {85 85 36 21} labelsize 12 + } + MenuItem {} { + label Screen + xywh {95 95 36 21} labelsize 12 + } + MenuItem {} { + label {Screen bold} + xywh {80 80 36 21} labelsize 12 + } + MenuItem {} { + label {Zapf Dingbats} + xywh {85 85 36 21} labelsize 12 + } + } + Fl_Value_Slider item_labelsize_slider { + label {item_labelsize()} + user_data tree + callback {(item_labelsize_slider_callback tree)} + tooltip {Sets the default font size used for new items created. +.Also affects any items whose font size has NOT specifically been set with item->labelsize().} xywh {848 383 140 16} type Horizontal color 46 selection_color 1 labelsize 12 align 4 textsize 12 + code0 {(do { (FontSize s) <- getLabelsize tree; setValue item_labelsize_slider (fromIntegral s) })} + code1 {range item_labelsize_slider 1.0 50.0} + code2 {setStep item_labelsize_slider 1.0} + code3 {setColor item_labelsize_slider (Color 46); setSelectionColor item_labelsize_slider redColor} + } + Fl_Button labelcolor_button { + label {labelcolor()} + tooltip {Changes Fl_Tree::labelcolor(). +This affects the text color of the widget's label.} xywh {813 414 16 16} box DOWN_BOX labelsize 11 align 7 + code0 {getLabelcolor tree >>= setColor labelcolor_button} + } + Fl_Button color_button { + label {color()} + tooltip {Changes Fl_Tree::color(). +This affects the background color of the widget. It also affects the bg color of newly created items *if* Fl_Tree::item_labelbgcolor() hasn't been changed.} xywh {813 433 16 16} box DOWN_BOX labelsize 11 align 7 + code0 {getLabelcolor tree >>= setColor color_button} + } + Fl_Button selection_color_button { + label {selection_color()} + tooltip {Sets the Fl_Tree::selection_color(). +This affects the item's colors when they're selected.} xywh {813 452 16 16} box DOWN_BOX labelsize 11 align 7 + code0 {getLabelcolor tree >>= setColor selection_color_button} + } + Fl_Button item_labelfgcolor_button { + label {item_labelfgcolor()} + tooltip {Sets the default label fg color for newly created items.} xywh {973 414 16 16} box DOWN_BOX labelsize 12 align 7 + code0 {getLabelcolor tree >>= setColor item_labelfgcolor_button} + } + Fl_Button item_labelbgcolor_button { + label {item_labelbgcolor()} + tooltip {Sets the default label bg color for newly created items. When set, this overrides the default behavior of using Fl_Tree::color().} xywh {973 433 16 16} box DOWN_BOX labelsize 12 align 7 + code0 {getLabelcolor tree >>= setColor item_labelbgcolor_button} + } + Fl_Button x_item_labelbgcolor_button { + label X + tooltip {Make the bgcolor 'transparent' (0xffffffff)} xywh {993 433 16 16} labelsize 10 align 16 + } + Fl_Button testsuggs_button { + label {Test Suggestions} + callback testsuggs_button_callback + tooltip {Suggestions on how to do tests} xywh {935 554 95 16} labelsize 9 + } + Fl_Value_Slider tree_scrollbar_size_slider { + label {Fl_Tree::scrollbar_size()} + callback {(tree_scrollbar_size_slider_callback tree)} + tooltip {Tests Fl_Tree::scrollbar_size() effects on tree clipping. +The value is normally 0, which causes Fl_Tree to use the global Fl::scrollbar_size() instead.} xywh {835 499 180 16} type Horizontal color 46 selection_color 1 labelsize 11 align 4 textsize 9 + code0 {getScrollbarSize tree >>= setValue tree_scrollbar_size_slider . fromIntegral} + code1 {range tree_scrollbar_size_slider 1.0 30.0} + code2 {setStep tree_scrollbar_size_slider 1.0} + code3 {setColor tree_scrollbar_size_slider (Color 46); setSelectionColor item_labelsize_slider redColor} + } + Fl_Value_Slider scrollbar_size_slider { + label {Fl::scrollbar_size()} + callback {(scrollbar_size_slider_callback tree)} + tooltip {Tests Fl::scrollbar_size() effects on tree clipping} xywh {835 519 180 16} type Horizontal color 46 selection_color 1 labelsize 11 align 4 textsize 9 + code0 {FL.scrollbarSize >>= setValue scrollbar_size_slider . fromIntegral} + code1 {range scrollbar_size_slider 5.0 30.0} + code2 {setStep scrollbar_size_slider 1.0} + code3 {setColor scrollbar_size_slider (Color 46); setSelectionColor scrollbar_size_slider redColor} + } + } + Fl_Box resizer_box { + xywh {0 263 15 14} + } + } + code {let { updateColorChips_ = updateColorChips color_button labelcolor_button selection_color_button item_labelfgcolor_button item_labelbgcolor_button all_labelfgcolor_button all_labelbgcolor_button tree window }} {} + code {setCallback color_button (color_button_callback tree updateColorChips_)} {} + code {setCallback labelcolor_button (updateColor tree getLabelcolor setColor setLabelcolor window)} {} + code {setCallback selection_color_button (updateColor tree getSelectionColor setColor setSelectionColor window)} {} + code {setCallback item_labelfgcolor_button (updateColor tree getItemLabelfgcolor setColor setItemLabelfgcolor window)} {} + code {setCallback item_labelbgcolor_button (updateColor tree getItemLabelbgcolor setColor setItemLabelbgcolor window)} {} + code {setCallback x_item_labelbgcolor_button (x_item_labelbgcolor_button_callback tree updateColorChips_)} {} + code {rootLabel tree "ROOT"; +rebuildTree tree usericon_radio color_button; +setResizable window (Just tree); +winW <- getW window; +winH <- getH window; +sizeRange window winW winH; +when_ <- getWhen tree; +case when_ of { + (WhenRelease : []) -> setValue whenmode_chooser (MenuItemByIndex (MenuItemIndex 1)) >> return (); + (WhenChanged : []) -> setValue whenmode_chooser (MenuItemByIndex (MenuItemIndex 2)) >> return (); + (WhenNever : []) -> setValue whenmode_chooser (MenuItemByIndex (MenuItemIndex 0)) >> return (); + _ -> return (); +};} {} + code {return window;} {} +} diff --git a/src/TreeCallbacks.hs b/src/TreeCallbacks.hs new file mode 100644 --- /dev/null +++ b/src/TreeCallbacks.hs @@ -0,0 +1,1176 @@ +{-# 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 "" 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 "" 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 diff --git a/src/Valuators.fl b/src/Valuators.fl new file mode 100644 --- /dev/null +++ b/src/Valuators.fl @@ -0,0 +1,207 @@ +# data file for the Fltk User Interface Designer (fluid) +version 1.0303 +header_name {.h} +code_name {.cxx} +Function {callback((Parent a Valuator) => Ref a -> IO ())} {open return_type valuator +} { + code {v <- getValue (safeCast valuator :: Ref Valuator); +print ((show v) ++ " \\r");} {} +} + +Function {make_window(IO (Ref Window))} {open +} { + Fl_Window window { + label {Valuator classes, showing values for type()} open + xywh {400 199 580 510} type Double color 43 selection_color 43 visible + } { + Fl_Box {} { + label Fl_Slider + xywh {10 10 280 210} box ENGRAVED_BOX labelfont 1 align 17 + } + Fl_Slider {} { + label 0 + callback callback + tooltip {Vertical Slider} xywh {30 45 20 145} selection_color 1 labelsize 8 align 1 + } + Fl_Slider {} { + label FL_VERT_FILL_SLIDER + callback callback + xywh {70 55 20 145} type {Vert Fill} selection_color 1 labelsize 8 + } + Fl_Slider {} { + label FL_VERT_NICE_SLIDER + callback callback + xywh {105 45 20 145} type {Vert Knob} box FLAT_BOX color 10 selection_color 1 labelsize 8 align 1 + } + Fl_Slider {} { + label FL_HORIZONTAL + callback callback + xywh {140 80 130 20} type Horizontal selection_color 1 labelsize 8 + } + Fl_Slider {} { + label FL_HOR_FILL_SLIDER + callback callback + xywh {140 120 130 20} type {Horz Fill} selection_color 1 labelsize 8 + } + Fl_Slider {} { + label FL_HOR_NICE_SLIDER + callback callback + xywh {140 160 130 20} type {Horz Knob} box FLAT_BOX color 10 selection_color 1 labelsize 8 + } + Fl_Box {} { + label Fl_Value_Slider + xywh {10 230 280 210} box ENGRAVED_BOX labelfont 1 align 17 + } + Fl_Value_Slider {} { + label 0 + callback callback + tooltip {Value Slider} xywh {30 260 30 145} selection_color 1 labelsize 8 align 1 + } + Fl_Value_Slider {} { + label FL_VERT_FILL_SLIDER + callback callback + xywh {70 275 30 140} type {Vert Fill} selection_color 1 labelsize 8 + } + Fl_Value_Slider {} { + label FL_VERT_NICE_SLIDER + callback callback + xywh {110 260 20 145} type {Vert Knob} box FLAT_BOX color 10 selection_color 1 labelsize 8 align 1 + } + Fl_Value_Slider {} { + label FL_HOR_SLIDER + callback callback + xywh {140 290 130 20} type Horizontal selection_color 1 labelsize 8 + } + Fl_Value_Slider {} { + label FL_HOR_FILL_SLIDER + callback callback + xywh {140 330 130 20} type {Horz Fill} selection_color 1 labelsize 8 + } + Fl_Value_Slider {} { + label FL_HOR_NICE_SLIDER + callback callback + xywh {140 370 130 20} type {Horz Knob} box FLAT_BOX color 10 selection_color 1 labelsize 8 + } + Fl_Box {} { + label Fl_Value_Input + xywh {10 450 135 50} box ENGRAVED_BOX labelfont 1 align 17 + } + Fl_Value_Input {} { + label 0 + callback callback + tooltip {Value Input} xywh {30 470 105 25} labelsize 8 maximum 100 step 0.1 + } + Fl_Box {} { + label Fl_Value_Output + xywh {155 450 135 50} box ENGRAVED_BOX labelfont 1 align 17 + } + Fl_Value_Output {} { + label 0 + callback callback + tooltip {Value Output} xywh {170 470 105 25} labelsize 8 maximum 100 step 0.1 + } + Fl_Box {} { + label { Fl_Scrollbar} + xywh {300 10 130 120} box ENGRAVED_BOX labelfont 1 align 21 + } + Fl_Scrollbar horizontal_scroll_bar { + label FL_HORIZONTAL + callback callback + tooltip {Horizontal Scrollbar} xywh {305 65 95 20} type Horizontal labelsize 8 maximum 100 + code0 {setValue horizontal_scroll_bar 20} + } + Fl_Scrollbar {} { + label 0 + callback callback + tooltip {Vertical Scrollbar} xywh {400 20 20 105} labelsize 8 align 1 maximum 100 + } + Fl_Box {} { + label Fl_Adjuster + xywh {440 10 130 120} box ENGRAVED_BOX labelfont 1 align 17 + } + Fl_Adjuster {} { + label {w()>h()} + callback callback + tooltip {Horizontal Adjuster} xywh {450 60 75 25} labelsize 8 + } + Fl_Adjuster {} { + label {w()= 0.1.4.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] diff --git a/stack-windows.yaml b/stack-windows.yaml new file mode 100644 --- /dev/null +++ b/stack-windows.yaml @@ -0,0 +1,26 @@ +# For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md + +resolver: lts-3.16 + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: + fltkhs-fluid-demos: + fastcompile: true + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 0.1.4.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,39 @@ +# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-5.3 + +# Local packages, usually specified by relative directory name +packages: +- '.' + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: +- fltkhs-0.4.0.2 +- text-1.2.2.0 + +# Override default flag values for local packages and extra-deps +flags: + fltkhs-fluid-demos: + fastcompile: true + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 1.0.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] + +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor