fltkhs-fluid-demos (empty) → 0.0.0.4
raw patch · 21 files changed
+3117/−0 lines, 21 filesdep +basedep +bytestringdep +fltkhsbuild-type:Customsetup-changed
Dependencies added: base, bytestring, fltkhs
Files
- .gitignore +5/−0
- LICENSE +21/−0
- README.txt +3/−0
- Setup.hs +26/−0
- fltkhs-fluid-demos.cabal +140/−0
- src/FastSlow.fl +50/−0
- src/Inactive.fl +129/−0
- src/Radio.fl +106/−0
- src/Tabs.fl +308/−0
- src/Tree.fl +775/−0
- src/TreeCallbacks.hs +1176/−0
- src/Valuators.fl +207/−0
- src/fluid-fast-slow.hs +13/−0
- src/fluid-inactive.hs +13/−0
- src/fluid-radio.hs +13/−0
- src/fluid-tabs.hs +13/−0
- src/fluid-tree.hs +13/−0
- src/fluid-valuators.hs +13/−0
- stack-repl.yaml +28/−0
- stack-windows.yaml +26/−0
- stack.yaml +39/−0
+ .gitignore view
@@ -0,0 +1,5 @@+dist/*+*.cxx+*.h+src/*.txt+src/Tree.hs
+ LICENSE view
@@ -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.
+ README.txt view
@@ -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).
+ Setup.hs view
@@ -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]+ }
+ fltkhs-fluid-demos.cabal view
@@ -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"
+ src/FastSlow.fl view
@@ -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+ }+}
+ src/Inactive.fl view
@@ -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} {}+}
+ src/Radio.fl view
@@ -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} {}+}
+ src/Tabs.fl view
@@ -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;} {}+}
+ src/Tree.fl view
@@ -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;} {}+}
+ src/TreeCallbacks.hs view
@@ -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 "<nolabel>" else l')+ walkDown next'+ walkUp :: Maybe (Ref TreeItem) -> IO ()+ walkUp Nothing = return ()+ walkUp (Just i) = do+ next' <- nextSelectedItemAfterItem tree i (Just SearchDirectionUp)+ l' <- getLabel i+ printf " Selected item: %s\n" (if (null l') then "<nolabel>" else l')+ walkUp next'++selectPath :: Ref Tree -> String -> Ref LightButton -> IO ()+selectPath tree path button = do+ i <- findItem tree path+ case i of+ Nothing -> flAlert $ "FAIL: Couldn't find item " ++ (show path) ++ "???"+ (Just i') -> do+ onoff <- getValue button+ if onoff+ then select tree (TreeItemPointerLocator (TreeItemPointer i')) >> return ()+ else deselect tree (TreeItemPointerLocator (TreeItemPointer i')) >> return ()++selectChildrenWithPath :: Ref Tree -> String -> Ref LightButton -> IO ()+selectChildrenWithPath tree path button = do+ i <- findItem tree path+ case i of+ Nothing -> flAlert $ "FAIL: Couldn't find item " ++ (show path) ++ "???"+ (Just _) -> do+ onoff <- getValue button+ if onoff+ then selectAllAndCallback tree i True+ else deselectAllAndCallback tree i True+tree_scrollbar_size_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()+tree_scrollbar_size_slider_callback tree slider = do+ v <- getValue slider+ setScrollbarSize tree (truncate v)+ redraw tree+scrollbar_size_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()+scrollbar_size_slider_callback tree slider = getValue slider >>= FL.setScrollbarSize . truncate >> redraw tree++item_labelsize_slider_callback :: Ref Tree -> Ref ValueSlider -> IO ()+item_labelsize_slider_callback tree slider = do+ v <- getValue slider+ setLabelsize tree (FontSize (truncate v))+ redraw tree++updateColorChips ::+ Ref Button ->+ Ref Button ->+ Ref Button ->+ Ref Button ->+ Ref Button ->+ Ref Button ->+ Ref Button ->+ Ref Tree ->+ Ref Window ->+ IO ()+updateColorChips+ color_button+ labelcolor_button+ selection_color_button+ item_labelfgcolor_button+ item_labelbgcolor_button+ all_labelfgcolor_button+ all_labelbgcolor_button+ tree+ window = do+ getColor tree >>= setColor color_button+ getLabelcolor tree >>= setColor labelcolor_button+ getSelectionColor tree >>= setColor selection_color_button+ getItemLabelfgcolor tree >>= setColor item_labelfgcolor_button+ getItemLabelbgcolor tree >>= setColor item_labelbgcolor_button+ getItemLabelfgcolor tree >>= setColor all_labelfgcolor_button+ getItemLabelbgcolor tree >>= setColor all_labelbgcolor_button+ redraw window++updateColor :: Ref Tree -> (Ref Tree -> IO Color) -> (Ref Button -> Color -> IO ()) -> (Ref Tree -> Color -> IO ()) -> Ref Window -> Ref Button -> IO ()+updateColor tree colorGetter buttonColorSetter treeColorSetter window button = do+ v <- colorGetter tree+ res <- editColor v+ maybe (return ())+ (\c -> do+ buttonColorSetter button c+ treeColorSetter tree c+ redraw window+ )+ res++color_button_callback :: Ref Tree -> IO () -> Ref Button -> IO ()+color_button_callback tree _updateColorChips button = do+ v <- getColor tree+ res <- editColor v+ maybe (return ())+ (\c -> do+ setColor tree c+ _updateColorChips+ redraw tree+ )+ res++x_item_labelbgcolor_button_callback :: Ref Tree -> IO () -> Ref Button -> IO ()+x_item_labelbgcolor_button_callback tree _updateColorChips _ = do+ setItemLabelbgcolor tree (Color 0xffffffff)+ _updateColorChips+ redraw tree+testsuggs_button_callback :: Ref Button -> IO ()+testsuggs_button_callback button =+ let helpmsg = "CHILD WIDGET SIZING TESTS\n" +++ "=========================\n" +++ " 1) Start program\n" +++ " 2) Click the 'ccc button' and D1/D2 buttons.\n" +++ " Their sizes should not change.\n" +++ " 3) Click the 'Item h() from widget' checkbox.\n" +++ " 4) Click the 'ccc button' and D1/D2 buttons.\n" +++ " Their sizes should change, getting larger vertically.\n" +++ " This validates that widget's size can affect the tree.\n" +++ " 5) Disable the checkbox, widgets should resize back to the\n" +++ " size of the other items.\n" +++ " 6) Hit ^A to select all items\n" +++ " 7) Under 'Selected Items', drag the 'Label Size' slider around.\n" +++ " All the item's height should change, as well as child widgets.\n" +++ " 8) Put Label Size' slider back to normal\n" +++ "\n" +++ "CHILD WIDGET + LABEL ITEM DRAWING TESTS\n" +++ "=======================================\n" +++ " 1) Start program\n" +++ " 2) Click 'Show label + widget'.\n" +++ " The widgets should all show item labels to their left.\n" +++ " 3) Disable same, item labels should disappear,\n" +++ " showing the widgets in their place.\n" +++ "\n" +++ "COLORS\n" +++ "======\n" +++ " 1) Start program\n" +++ " 2) Change 'Tree Fonts+Colors' -> color()\n" +++ " 3) Entire tree's background color will change, including items.\n" +++ " 4) Change the 'Tree Fonts + Colors -> item_labelbgcolor()'\n" +++ " 6) Click the '111' item to select it.\n" +++ " 7) Click 'Test Operations -> Insert Above'\n" +++ " New items should appear above the selected item using the new color.\n" +++ " This color will be different from the background color.\n" +++ " 8) Change the 'Tree Fonts+Colors' -> color()\n" +++ " The entire tree's bg should change, except the new items.\n" +++ " 9) Click the Tree Fonts+Colors -> item_labelbgcolor() 'X' button.\n" +++ " This resets item_labelbgcolor() to the default 'transparent' color (0xffffffff)\n" +++ " 10) Again, click the 'Insert Above' button.\n" +++ " New items will be created in the background color, and changing the color()\n" +++ " should affect the new items too.\n" +++ "\n" +++ "SCROLLING\n" +++ "=========\n" +++ " 1) Open '500 items' and 'Long Line' so that both scrollbars appear:\n" +++ " * The 'focus box' for the selected item should not be clipped\n" +++ " horizontally by the vertical scrollbar.\n" +++ " * Resizing the window horizontally should resize the focus box\n" +++ " * Scrolling vertically/horizontally should show reveal all\n" +++ " edges of the tree. One *exception* is the widget label\n" +++ " to the right of the 'ccc button'; labels aren't part\n" +++ " of the widget, and therefore don't affect scroll tabs\n" +++ " 2) Scroll vertical scroller to the middle of the tree\n" +++ " 3) Left click and drag up/down to extend the selection:\n" +++ " * Selection should autoscroll if you drag off the top/bottom\n" +++ " * Selection should work *even* if you drag horizontally\n" +++ " off the window edge; moving up/down outside the window\n" +++ " should continue to autoscroll\n" +++ " 4) Click either of the the scrollbar tabs and drag:\n" +++ " * Even if you drag off the scrollbar, the scrollbar\n" +++ " tab should continue to move\n" +++ " * Should continue to work if you drag off the window edge\n" +++ " horizontally drag off the window.\n" +++ " 5) Click 'Bbb' and hit 'Add 20,000', then position the\n" +++ " 'ccc button' so it's partially obscured by a scrollbar tab:\n" +++ " * Clicking the obscured button should work\n" +++ " * Clicking on the tab over the button should not 'click through'\n" +++ " to the button.\n" +++ ""+ in do+ dialog' <- readIORef helpDialog+ case dialog' of+ Nothing -> do+ groupSetCurrent (Nothing :: Maybe (Ref Group))+ win <- doubleWindowNew (toSize (600,600)) Nothing (Just "Test Suggestions")+ winW <- getW win+ winH <- getH win+ disp <- textDisplayNew (toRectangle (0,0,winW,winH)) Nothing+ buff <- textBufferNew Nothing Nothing+ setBuffer disp (Just buff)+ setTextfont disp courier+ setTextsize disp (FontSize 12)+ setText buff helpmsg+ end win+ writeIORef helpDialog (Just (win, disp, buff))+ setResizable win (Just disp) >> showWidget win+ Just (win, disp, buff) ->+ setResizable win (Just disp) >> showWidget win
+ src/Valuators.fl view
@@ -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()<h()}+ callback callback+ tooltip {Vertical Adjuster} xywh {530 35 25 75} labelsize 8+ }+ Fl_Box {} {+ label Fl_Counter+ xywh {300 140 130 120} box ENGRAVED_BOX labelfont 1 align 17+ }+ Fl_Counter {} {+ label 0+ callback callback+ tooltip {Standard Counter} xywh {310 175 110 25} labelsize 8+ }+ Fl_Counter {} {+ label FL_SIMPLE_COUNTER+ callback callback+ tooltip {Simple Counter} xywh {310 215 110 25} type Simple labelsize 8+ }+ Fl_Box {} {+ label Fl_Spinner+ xywh {440 140 130 120} box ENGRAVED_BOX labelfont 1 align 17+ }+ Fl_Spinner int_spinner {+ label FL_INT_INPUT+ xywh {465 176 80 24} labelsize 8 align 2 maximum 1 step 2 value 0+ code0 {setValue int_spinner 5}+ code1 {setMinimum int_spinner (-30)}+ code2 {setMaximum int_spinner 30.0}+ }+ Fl_Spinner float_spinner {+ label FL_FLOAT_INPUT+ xywh {465 216 80 24} type Float labelsize 8 align 2 maximum 1 step 0.01 value 0+ code0 {setValue float_spinner 0.05}+ code1 {setMinimum float_spinner 0.0}+ code2 {setMaximum float_spinner 1.0}+ }+ Fl_Box {} {+ label Fl_Dial+ xywh {300 270 270 105} box ENGRAVED_BOX labelfont 1 align 17+ }+ Fl_Dial standard_dial {+ label 0+ callback callback+ tooltip {Standard Dial} xywh {320 295 65 65} color 10 selection_color 1 labelsize 8+ code0 {setAngles standard_dial (Angle 0) (Angle 315)}+ code1 {setValue standard_dial 0.05}+ }+ Fl_Dial {} {+ label FL_LINE_DIAL+ callback callback+ tooltip {Line Dial} xywh {400 295 65 65} type Line color 10 selection_color 1 labelsize 8 value 0.5+ }+ Fl_Dial fill_dial {+ label FL_FILL_DIAL+ callback callback+ tooltip {Fill Dial} xywh {480 295 65 65} type Fill color 10 selection_color 1 labelsize 8 value 1+ code0 {setAngles fill_dial (Angle 0) (Angle 360)}+ }+ Fl_Box {} {+ label Fl_Roller+ xywh {300 385 150 115} box ENGRAVED_BOX labelfont 1 align 17+ }+ Fl_Roller {} {+ label 0+ callback callback+ tooltip {Vertical Roller} xywh {315 390 20 95} labelsize 8+ }+ Fl_Roller {} {+ label FL_HORIZONTAL+ callback callback+ tooltip {Horizontal Roller} xywh {345 430 90 20} type Horizontal labelsize 8+ }+ Fl_Box {} {+ label {Some widgets have color(FL_GREEN) and color2(FL_RED) to show the areas these effect.}+ xywh {460 385 110 115} box BORDER_FRAME color 0 selection_color 0 labelsize 11 align 128+ }+ }+ code {return window} {selected+ }+}
+ src/fluid-fast-slow.hs view
@@ -0,0 +1,13 @@+module Main where+import FastSlow+import Graphics.UI.FLTK.LowLevel.FLTKHS+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++main :: IO ()+main = do+ w <- make_window+ showWidget w+ _ <- FL.run+ return ()
+ src/fluid-inactive.hs view
@@ -0,0 +1,13 @@+module Main where+import Inactive+import Graphics.UI.FLTK.LowLevel.FLTKHS+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++main :: IO ()+main = do+ w <- make_window+ showWidget w+ _ <- FL.run+ return ()
+ src/fluid-radio.hs view
@@ -0,0 +1,13 @@+module Main where+import Radio+import Graphics.UI.FLTK.LowLevel.FLTKHS+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++main :: IO ()+main = do+ w <- make_window+ showWidget w+ _ <- FL.run+ return ()
+ src/fluid-tabs.hs view
@@ -0,0 +1,13 @@+module Main where+import Tabs+import Graphics.UI.FLTK.LowLevel.FLTKHS+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++main :: IO ()+main = do+ w <- make_window+ showWidget w+ _ <- FL.run+ return ()
+ src/fluid-tree.hs view
@@ -0,0 +1,13 @@+module Main where+import Tree+import Graphics.UI.FLTK.LowLevel.FLTKHS+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++main :: IO ()+main = do+ win <- make_window+ showWidget win+ _ <- FL.run+ return ()
+ src/fluid-valuators.hs view
@@ -0,0 +1,13 @@+module Main where+import Valuators+import Graphics.UI.FLTK.LowLevel.FLTKHS+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++main :: IO ()+main = do+ w <- make_window+ showWidget w+ _ <- FL.run+ return ()
+ stack-repl.yaml view
@@ -0,0 +1,28 @@+# For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md++resolver: lts-2.22++# 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: []++# Override default flag values for local packages and extra-deps+flags: {}++# 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]
+ stack-windows.yaml view
@@ -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]
+ stack.yaml view
@@ -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