fltkhs-demos (empty) → 0.0.0.3
raw patch · 23 files changed
+2152/−0 lines, 23 filesdep +basedep +bytestringdep +directorybuild-type:Customsetup-changed
Dependencies added: base, bytestring, directory, fltkhs, process, stm
Files
- .gitignore +4/−0
- LICENSE +21/−0
- README.md +76/−0
- Setup.hs +3/−0
- fltkhs-demos.cabal +300/−0
- src/Examples/arc.hs +98/−0
- src/Examples/bitmap.hs +151/−0
- src/Examples/boxtype.hs +97/−0
- src/Examples/browser.hs +127/−0
- src/Examples/clock.hs +22/−0
- src/Examples/doublebuffer.hs +101/−0
- src/Examples/make-tree.hs +21/−0
- src/Examples/nativefilechooser-simple-app.hs +92/−0
- src/Examples/pack.hs +73/−0
- src/Examples/table-as-container.hs +113/−0
- src/Examples/table-simple.hs +78/−0
- src/Examples/table-sort.hs +241/−0
- src/Examples/table-spreadsheet-with-keyboard-nav.hs +292/−0
- src/Examples/textdisplay-with-colors.hs +23/−0
- src/Examples/texteditor-simple.hs +15/−0
- src/Examples/threads.hs +87/−0
- src/Examples/tile.hs +69/−0
- src/Examples/tree-simple.hs +48/−0
+ .gitignore view
@@ -0,0 +1,4 @@+.\#*+./+*~+dist/*
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2015 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.md view
@@ -0,0 +1,76 @@+#Fltkhs-demos++These are end-to-end demos of [FLTKHS] [1], a Haskell Binding to the FLTK GUI Library+++Fltkhs-demos aims not only to show off the features of the [fltkhs] [1] but also+serve as a way of learning the API by example. For more thorough documentation+on the [fltkhs] [1] API please see the [FLTKHS module] [2] of that package.++## Introduction++The demos shipped with this package are listed in `fltkhs-demos.cabal` as+separate `Executable` components. Once the package is installed they are+installed to Cabal's standard /bin/ directory (usually ~/.cabal/bin on Linux).++Note that the executables are prefixed with \"fltkhs-\". This is in order to+prevent the demo executables from stomping over applications of the same name+the user might already have installed. Typing:++```+ > fltkhs-<TAB>+```++at the command line should show a complete list of available demos.++Alternatively you can do:++```+ > ls ~/.cabal/bin/fltkhs-*+```++## Learning The API++Most of the demos are exact ports of those shipped in the 'test' directory of+the <http://fltk.org FLTK> distribution. It is hoped the user will study the+Haskell demo code side-by-side with the C++ demo code in order to understand the+API. The section __API Guide__ in the [FLKTHS documentation] [2] covers this in more detail.++## Why is the demo code so un-Haskelly?+For being written in Haskell, the demo code is horrifyingly/amazingly imperative and stateful. Although it may repulse those+who used to pure Haskell idioms it is that way for a reason.++The demo code was never meant to be idiomatic Haskell code but a way of showing as much of the API as possible. The API itself+closely resembles the underlying C++ code which is imperative and stateful. This has the advantage of making the API easier+to learn.++For instance, assuming FLTK was installed from source compare /src/Examples/arc.hs with /test/arc.cxx in the FLTK+source directory. There is quite a bit of correspondence and it is easy to see how the Haskell API functions map to the C++ ones.++## Fast Compilation Flag++This package comes with a Cabal flag `fastCompile` that is enabled by default and speeds up compilation. More information on this flag is available under the __Compilation__ section of the [FLTKHS documentation] [2].++To disable this flag, tell Cabal to ignore it during the `configure` step:++```+cabal configure -f-fastCompile+```++# GHCi++The recommended way to running the REPL in a `fltkhs` application is `cabal repl`. For example to run the `fltkhs-arc` example do:++```+cabal repl fltkhs-arc+```++__NOTE__: For now it only works in GHC 7.8.x. GHC 7.10.x has an unfortunate regression that crashes GHCi because it cannot find symbols in the C library that contains the C++ bindings. This has been fixed in GHC 8. More information is available in the [ticket] [4].+++++ [1]: http://hackage.haskell.org/package/fltkhs/+ [2]: http://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html+ [3]: https://github.com/deech/fltkhs-fluid-hello-world+ [4]: https://ghc.haskell.org/trac/ghc/ticket/10568
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main :: IO ()+main = defaultMain
+ fltkhs-demos.cabal view
@@ -0,0 +1,300 @@+name: fltkhs-demos+version: 0.0.0.3+synopsis: FLTKHS demos. Please scroll to the bottom for more information.+description:+ FLTKHS demos moved to a separate package to keep the core package free of additional dependencies.+license: MIT+license-file: LICENSE+author: Aditya Siram+maintainer: aditya.siram@gmail.com+homepage: http://github.com/deech/fltkhs-demos+-- bug-reports:+-- copyright:+category: UI,Graphics+build-type: Custom+cabal-version: >=1.20+source-repository head+ type: git+ location: http://github.com/deech/fltkhs-demos++Flag FastCompile+ Description: Turn off optimizations for faster compilation+ Manual: True+ Default: True++Executable fltkhs-threads+ Main-Is: threads.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0,+ stm+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-pack+ Main-Is: pack.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ directory >= 1.2.2.0,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-tile+ Main-Is: tile.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ directory,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-nativefilechooser-simple-app+ Main-Is: nativefilechooser-simple-app.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ directory,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-table-as-container+ Main-Is: table-as-container.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-texteditor-simple+ Main-Is: texteditor-simple.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-textdisplay-with-colors+ Main-Is: textdisplay-with-colors.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-doublebuffer+ Main-Is: doublebuffer.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-make-tree+ Main-Is: make-tree.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-tree-simple+ Main-Is: tree-simple.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-table-spreadsheet-with-keyboard-nav+ Main-Is: table-spreadsheet-with-keyboard-nav.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-table-simple+ Main-Is: table-simple.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-table-sort+ Main-Is: table-sort.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0,+ process+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-arc+ Main-Is: arc.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-bitmap+ Main-Is: bitmap.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0,bytestring+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-boxtype+ Main-Is: boxtype.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0,bytestring+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-browser+ Main-Is: browser.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0,+ bytestring+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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-clock+ Main-Is: clock.hs+ Hs-Source-Dirs: src/Examples+ Build-Depends:+ base == 4.*,+ fltkhs >= 0.4.0.0,+ bytestring+ default-language: Haskell2010+ ghc-Options: -Wall -threaded+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0+ if os(windows)+ ghc-Options: -optl-mwindows+ 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/Examples/arc.hs view
@@ -0,0 +1,98 @@+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.FLTKHS+import Data.IORef+import Control.Monad++name :: [String]+name = ["X", "Y", "R", "start", "end", "rotate"]++drawArc :: IORef [Double] -> Ref Widget -> IO ()+drawArc myArgsRef widget = do+ myArgs <- readIORef myArgsRef+ rectangle' <- getRectangle widget+ let (x',y',w',h') = fromRectangle rectangle'+ flcPushClip rectangle'+ flcSetColor dark3Color+ flcRectf rectangle'+ flcPushMatrix+ if (myArgs !! 5 > 0)+ then do+ flcTranslate+ (ByXY+ (ByX ((fromIntegral x') + (fromIntegral w')/2))+ (ByY ((fromIntegral y') + (fromIntegral h')/2)))+ flcRotate (myArgs !! 5)+ flcTranslate+ (ByXY+ (ByX (-((fromIntegral x') + (fromIntegral w')/2)))+ (ByY (-((fromIntegral y') + (fromIntegral h')/2))))+ else return ()+ flcSetColor whiteColor+ flcTranslate (ByXY (ByX (fromIntegral x')) (ByY (fromIntegral $ y')))+ flcBeginComplexPolygon+ flcArcByRadius+ (ByXY (ByX $ myArgs !! 0) (ByY $ myArgs !! 1))+ (myArgs !! 2)+ (myArgs !! 3)+ (myArgs !! 4)+ flcGap+ flcArcByRadius (ByXY (ByX 140) (ByY 140)) 20 0 (-360)+ flcEndComplexPolygon+ flcSetColor redColor+ flcBeginLine+ flcArcByRadius+ (ByXY (ByX $ myArgs !! 0) (ByY $ myArgs !! 1))+ (myArgs !! 2)+ (myArgs !! 3)+ (myArgs !! 4)+ flcEndLine+ flcPopMatrix+ flcPopClip++setIndex :: Int -> [a] -> a -> [a]+setIndex idx' xs x =+ map+ (+ \(i,e) -> if (i == idx')+ then x+ else e+ )+ (zip [0..] xs)++sliderCb :: Ref Widget -> Int -> IORef [Double] -> Ref HorValueSlider -> IO ()+sliderCb widget sliderNumber myArgsRef slider' = do+ v' <- getValue slider'+ modifyIORef myArgsRef (\myArgs' -> setIndex sliderNumber myArgs' v')+ redraw widget++main :: IO ()+main = do+ myArgs' <- newIORef [140, 140, 50, 0, 360,0]+ window' <- doubleWindowNew (Size (Width 300) (Height 500)) Nothing Nothing+ begin window'+ widget <- widgetCustom+ (Rectangle+ (Position (X 10) (Y 10))+ (Size (Width 280) (Height 280)))+ Nothing+ (drawArc myArgs')+ defaultCustomWidgetFuncs+ forM_ (take 6 (zip (iterate ((+) 25) 300) [0..])) $ \(y, sliderNumber') -> do+ s <- horValueSliderNew+ (toRectangle $ (50, y, 240, 25))+ (Just $ name !! sliderNumber')+ case sliderNumber' of+ sliderNumber'' | sliderNumber'' < 3 -> setMinimum s 0 >> setMaximum s 300+ | sliderNumber'' == 5 -> setMinimum s 0 >> setMaximum s 360+ _ -> setMinimum s (-360) >> setMaximum s 360+ setStep s 1+ _ <- readIORef myArgs' >>= \args' -> setValue s (args' !! sliderNumber')+ setAlign s alignLeft+ setCallback s (sliderCb widget sliderNumber' myArgs')+ end window'+ showWidget window'+ _ <- FL.run+ return ()
+ src/Examples/bitmap.hs view
@@ -0,0 +1,151 @@+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.FLTKHS+import Data.IORef+import Control.Monad+import qualified Data.ByteString as B++sorceressWidth :: Int+sorceressWidth = 75++sorceressHeight :: Int+sorceressHeight = 75++sorceressBits :: B.ByteString+sorceressBits = B.pack [+ 0xfc, 0x7e, 0x40, 0x20, 0x90, 0x00, 0x07, 0x80, 0x23, 0x00, 0x00, 0xc6,+ 0xc1, 0x41, 0x98, 0xb8, 0x01, 0x07, 0x66, 0x00, 0x15, 0x9f, 0x03, 0x47,+ 0x8c, 0xc6, 0xdc, 0x7b, 0xcc, 0x00, 0xb0, 0x71, 0x0e, 0x4d, 0x06, 0x66,+ 0x73, 0x8e, 0x8f, 0x01, 0x18, 0xc4, 0x39, 0x4b, 0x02, 0x23, 0x0c, 0x04,+ 0x1e, 0x03, 0x0c, 0x08, 0xc7, 0xef, 0x08, 0x30, 0x06, 0x07, 0x1c, 0x02,+ 0x06, 0x30, 0x18, 0xae, 0xc8, 0x98, 0x3f, 0x78, 0x20, 0x06, 0x02, 0x20,+ 0x60, 0xa0, 0xc4, 0x1d, 0xc0, 0xff, 0x41, 0x04, 0xfa, 0x63, 0x80, 0xa1,+ 0xa4, 0x3d, 0x00, 0x84, 0xbf, 0x04, 0x0f, 0x06, 0xfc, 0xa1, 0x34, 0x6b,+ 0x01, 0x1c, 0xc9, 0x05, 0x06, 0xc7, 0x06, 0xbe, 0x11, 0x1e, 0x43, 0x30,+ 0x91, 0x05, 0xc3, 0x61, 0x02, 0x30, 0x1b, 0x30, 0xcc, 0x20, 0x11, 0x00,+ 0xc1, 0x3c, 0x03, 0x20, 0x0a, 0x00, 0xe8, 0x60, 0x21, 0x00, 0x61, 0x1b,+ 0xc1, 0x63, 0x08, 0xf0, 0xc6, 0xc7, 0x21, 0x03, 0xf8, 0x08, 0xe1, 0xcf,+ 0x0a, 0xfc, 0x4d, 0x99, 0x43, 0x07, 0x3c, 0x0c, 0xf1, 0x9f, 0x0b, 0xfc,+ 0x5b, 0x81, 0x47, 0x02, 0x16, 0x04, 0x31, 0x1c, 0x0b, 0x1f, 0x17, 0x89,+ 0x4d, 0x06, 0x1a, 0x04, 0x31, 0x38, 0x02, 0x07, 0x56, 0x89, 0x49, 0x04,+ 0x0b, 0x04, 0xb1, 0x72, 0x82, 0xa1, 0x54, 0x9a, 0x49, 0x04, 0x1d, 0x66,+ 0x50, 0xe7, 0xc2, 0xf0, 0x54, 0x9a, 0x58, 0x04, 0x0d, 0x62, 0xc1, 0x1f,+ 0x44, 0xfc, 0x51, 0x90, 0x90, 0x04, 0x86, 0x63, 0xe0, 0x74, 0x04, 0xef,+ 0x31, 0x1a, 0x91, 0x00, 0x02, 0xe2, 0xc1, 0xfd, 0x84, 0xf9, 0x30, 0x0a,+ 0x91, 0x00, 0x82, 0xa9, 0xc0, 0xb9, 0x84, 0xf9, 0x31, 0x16, 0x81, 0x00,+ 0x42, 0xa9, 0xdb, 0x7f, 0x0c, 0xff, 0x1c, 0x16, 0x11, 0x00, 0x02, 0x28,+ 0x0b, 0x07, 0x08, 0x60, 0x1c, 0x02, 0x91, 0x00, 0x46, 0x29, 0x0e, 0x00,+ 0x00, 0x00, 0x10, 0x16, 0x11, 0x02, 0x06, 0x29, 0x04, 0x00, 0x00, 0x00,+ 0x10, 0x16, 0x91, 0x06, 0xa6, 0x2a, 0x04, 0x00, 0x00, 0x00, 0x18, 0x24,+ 0x91, 0x04, 0x86, 0x2a, 0x04, 0x00, 0x00, 0x00, 0x18, 0x27, 0x93, 0x04,+ 0x96, 0x4a, 0x04, 0x00, 0x00, 0x00, 0x04, 0x02, 0x91, 0x04, 0x86, 0x4a,+ 0x0c, 0x00, 0x00, 0x00, 0x1e, 0x23, 0x93, 0x04, 0x56, 0x88, 0x08, 0x00,+ 0x00, 0x00, 0x90, 0x21, 0x93, 0x04, 0x52, 0x0a, 0x09, 0x80, 0x01, 0x00,+ 0xd0, 0x21, 0x95, 0x04, 0x57, 0x0a, 0x0f, 0x80, 0x27, 0x00, 0xd8, 0x20,+ 0x9d, 0x04, 0x5d, 0x08, 0x1c, 0x80, 0x67, 0x00, 0xe4, 0x01, 0x85, 0x04,+ 0x79, 0x8a, 0x3f, 0x00, 0x00, 0x00, 0xf4, 0x11, 0x85, 0x06, 0x39, 0x08,+ 0x7d, 0x00, 0x00, 0x18, 0xb7, 0x10, 0x81, 0x03, 0x29, 0x12, 0xcb, 0x00,+ 0x7e, 0x30, 0x28, 0x00, 0x85, 0x03, 0x29, 0x10, 0xbe, 0x81, 0xff, 0x27,+ 0x0c, 0x10, 0x85, 0x03, 0x29, 0x32, 0xfa, 0xc1, 0xff, 0x27, 0x94, 0x11,+ 0x85, 0x03, 0x28, 0x20, 0x6c, 0xe1, 0xff, 0x07, 0x0c, 0x01, 0x85, 0x01,+ 0x28, 0x62, 0x5c, 0xe3, 0x8f, 0x03, 0x4e, 0x91, 0x80, 0x05, 0x39, 0x40,+ 0xf4, 0xc2, 0xff, 0x00, 0x9f, 0x91, 0x84, 0x05, 0x31, 0xc6, 0xe8, 0x07,+ 0x7f, 0x80, 0xcd, 0x00, 0xc4, 0x04, 0x31, 0x06, 0xc9, 0x0e, 0x00, 0xc0,+ 0x48, 0x88, 0xe0, 0x04, 0x79, 0x04, 0xdb, 0x12, 0x00, 0x30, 0x0c, 0xc8,+ 0xe4, 0x04, 0x6d, 0x06, 0xb6, 0x23, 0x00, 0x18, 0x1c, 0xc0, 0x84, 0x04,+ 0x25, 0x0c, 0xff, 0xc2, 0x00, 0x4e, 0x06, 0xb0, 0x80, 0x04, 0x3f, 0x8a,+ 0xb3, 0x83, 0xff, 0xc3, 0x03, 0x91, 0x84, 0x04, 0x2e, 0xd8, 0x0f, 0x3f,+ 0x00, 0x00, 0x5f, 0x83, 0x84, 0x04, 0x2a, 0x70, 0xfd, 0x7f, 0x00, 0x00,+ 0xc8, 0xc0, 0x84, 0x04, 0x4b, 0xe2, 0x2f, 0x01, 0x00, 0x08, 0x58, 0x60,+ 0x80, 0x04, 0x5b, 0x82, 0xff, 0x01, 0x00, 0x08, 0xd0, 0xa0, 0x84, 0x04,+ 0x72, 0x80, 0xe5, 0x00, 0x00, 0x08, 0xd2, 0x20, 0x44, 0x04, 0xca, 0x02,+ 0xff, 0x00, 0x00, 0x08, 0xde, 0xa0, 0x44, 0x04, 0x82, 0x02, 0x6d, 0x00,+ 0x00, 0x08, 0xf6, 0xb0, 0x40, 0x02, 0x82, 0x07, 0x3f, 0x00, 0x00, 0x08,+ 0x44, 0x58, 0x44, 0x02, 0x93, 0x3f, 0x1f, 0x00, 0x00, 0x30, 0x88, 0x4f,+ 0x44, 0x03, 0x83, 0x23, 0x3e, 0x00, 0x00, 0x00, 0x18, 0x60, 0xe0, 0x07,+ 0xe3, 0x0f, 0xfe, 0x00, 0x00, 0x00, 0x70, 0x70, 0xe4, 0x07, 0xc7, 0x1b,+ 0xfe, 0x01, 0x00, 0x00, 0xe0, 0x3c, 0xe4, 0x07, 0xc7, 0xe3, 0xfe, 0x1f,+ 0x00, 0x00, 0xff, 0x1f, 0xfc, 0x07, 0xc7, 0x03, 0xf8, 0x33, 0x00, 0xc0,+ 0xf0, 0x07, 0xff, 0x07, 0x87, 0x02, 0xfc, 0x43, 0x00, 0x60, 0xf0, 0xff,+ 0xff, 0x07, 0x8f, 0x06, 0xbe, 0x87, 0x00, 0x30, 0xf8, 0xff, 0xff, 0x07,+ 0x8f, 0x14, 0x9c, 0x8f, 0x00, 0x00, 0xfc, 0xff, 0xff, 0x07, 0x9f, 0x8d,+ 0x8a, 0x0f, 0x00, 0x00, 0xfe, 0xff, 0xff, 0x07, 0xbf, 0x0b, 0x80, 0x1f,+ 0x00, 0x00, 0xff, 0xff, 0xff, 0x07, 0x7f, 0x3a, 0x80, 0x3f, 0x00, 0x80,+ 0xff, 0xff, 0xff, 0x07, 0xff, 0x20, 0xc0, 0x3f, 0x00, 0x80, 0xff, 0xff,+ 0xff, 0x07, 0xff, 0x01, 0xe0, 0x7f, 0x00, 0xc0, 0xff, 0xff, 0xff, 0x07,+ 0xff, 0x0f, 0xf8, 0xff, 0x40, 0xe0, 0xff, 0xff, 0xff, 0x07, 0xff, 0xff,+ 0xff, 0xff, 0x40, 0xf0, 0xff, 0xff, 0xff, 0x07, 0xff, 0xff, 0xff, 0xff,+ 0x41, 0xf0, 0xff, 0xff, 0xff, 0x07+ ]++data ToggleButtons = ToggleButtons {+ leftb :: Ref ToggleButton,+ rightb :: Ref ToggleButton,+ topb :: Ref ToggleButton,+ bottomb :: Ref ToggleButton,+ insideb :: Ref ToggleButton,+ overb :: Ref ToggleButton,+ inactb :: Ref ToggleButton+ }++buttonCb :: IORef (ToggleButtons, Ref Button, Ref DoubleWindow) -> Ref ToggleButton -> IO ()+buttonCb state' _ =+ do+ (toggleButtons', b, win) <- readIORef state'+ i <- newIORef []+ let addIf :: (ToggleButtons -> Ref ToggleButton) -> AlignType -> IO ()+ addIf b' alignType' = do+ v' <- getValue (b' toggleButtons')+ when v' (modifyIORef i ((++) [alignType']))+ addIf leftb AlignTypeLeft+ addIf rightb AlignTypeRight+ addIf topb AlignTypeTop+ addIf bottomb AlignTypeBottom+ addIf insideb AlignTypeInside+ addIf overb AlignTypeTextOverImage+ readIORef i >>= setAlign b . Alignments+ inactbValue <- getValue (inactb toggleButtons')+ if inactbValue then deactivate b+ else activate b+ redraw win++main :: IO ()+main = do+ window <- doubleWindowNew (Size (Width 400) (Height 400)) Nothing Nothing+ begin window+ button <- buttonNew+ (Rectangle+ (Position (X 140) (Y 160))+ (Size (Width 120) (Height 120)))+ (Just "Bitmap")+ bitmap <- bitmapNew+ (BitmapHs+ sorceressBits+ (Size+ (Width sorceressWidth)+ (Height sorceressHeight)))+ setImage button (Just bitmap)+ leftb' <- toggleButtonNew (Rectangle (Position (X 25) (Y 50)) (Size (Width 50) (Height 25))) (Just "left")+ rightb' <- toggleButtonNew (Rectangle (Position (X 75) (Y 50)) (Size (Width 50) (Height 25))) (Just "right")+ topb' <- toggleButtonNew (Rectangle (Position (X 125) (Y 50)) (Size (Width 50) (Height 25))) (Just "top")+ bottomb' <- toggleButtonNew (Rectangle (Position (X 175) (Y 50)) (Size (Width 50) (Height 25))) (Just "bottom")+ insideb' <- toggleButtonNew (Rectangle (Position (X 225) (Y 50)) (Size (Width 50) (Height 25))) (Just "inside")+ overb' <- toggleButtonNew (Rectangle (Position (X 25) (Y 75)) (Size (Width 100) (Height 25))) (Just "text over")+ inactb' <- toggleButtonNew (Rectangle (Position (X 125) (Y 75)) (Size (Width 100) (Height 25))) (Just "inactive")+ state' <- newIORef ((ToggleButtons leftb' rightb' topb' bottomb' insideb' overb' inactb'),+ button,+ window)+ setCallback leftb' $ buttonCb state'+ setCallback rightb' $ buttonCb state'+ setCallback topb' $ buttonCb state'+ setCallback bottomb' $ buttonCb state'+ setCallback insideb' $ buttonCb state'+ setCallback overb' $ buttonCb state'+ setCallback inactb' $ buttonCb state'+ setResizable window (Just window)+ end window+ showWidget window+ _ <- FL.run+ return ()
+ src/Examples/boxtype.hs view
@@ -0,0 +1,97 @@+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.FLTKHS+import Data.IORef+import Control.Monad++windowWidth :: Int+windowWidth = 200+rowHeight :: Int+rowHeight = 50+numRows :: Int+numRows = 14+bt :: IORef Int -> String -> Boxtype -> Bool -> IO ()+bt n label' boxtype' square' = do+ n' <- readIORef n+ let (quotient',remainder') = quotRem n' 4+ modifyIORef n (+ 1)+ b' <- boxNewWithBoxtype+ boxtype'+ (Rectangle+ (Position (X (remainder' * windowWidth + 10)) (Y (quotient' * rowHeight + 10)))+ (Size+ (Width $ if square' then rowHeight - 20 else windowWidth - 20)+ (Height $ rowHeight - 20)))+ label'+ setLabelsize b' (FontSize 11)+ when square' $ setAlign b' alignRight+main :: IO ()+main = do+ window <- doubleWindowNew+ (Size (Width $ windowWidth * 4) (Height $ numRows * rowHeight))+ Nothing+ Nothing+ setBox window FlatBox+ FL.getSystemColors+ setColor window (Color 12)+ n' <- newIORef 0+ begin window+ bt n' "NoBox" NoBox False+ bt n' "FlatBox" FlatBox False+ modifyIORef n' (+ 2)+ bt n' "UpBox" UpBox False+ bt n' "DownBox" DownBox False+ bt n' "UpFrame" UpFrame False+ bt n' "DownFrame" DownFrame False+ bt n' "ThinUpBox" ThinUpBox False+ bt n' "ThinDownBox" ThinDownBox False+ bt n' "ThinUpFrame" ThinUpFrame False+ bt n' "ThinDownFrame" ThinDownFrame False+ bt n' "EngravedBox" EngravedBox False+ bt n' "EmbossedBox" EmbossedBox False+ bt n' "EngravedFrame" EngravedFrame False+ bt n' "EmbossedFrame" EmbossedFrame False+ bt n' "BorderBox" BorderBox False+ bt n' "ShadowBox" ShadowBox False+ bt n' "BorderFrame" BorderFrame False+ bt n' "ShadowFrame" ShadowFrame False+ bt n' "RoundedBox" RoundedBox False+ bt n' "RshadowBox" RshadowBox False+ bt n' "RoundedFrame" RoundedFrame False+ bt n' "RFlatBox" RFlatBox False+ bt n' "RoundUpBox" RoundUpBox False+ bt n' "RoundDownBox" RoundDownBox False+ bt n' "DiamondUpBox" DiamondUpBox False+ bt n' "DiamondDownBox" DiamondDownBox False+ bt n' "OvalBox" OvalBox False+ bt n' "OshadowBox" OshadowBox False+ bt n' "OvalFrame" OvalFrame False+ bt n' "FloatBox" FloatBox False+ bt n' "PlasticUpBox" PlasticUpBox False+ bt n' "PlasticDownBox" PlasticDownBox False+ bt n' "PlasticUpFrame" PlasticUpFrame False+ bt n' "PlasticDownFrame" PlasticDownFrame False+ bt n' "PlasticThinUpBox" PlasticThinUpBox False+ bt n' "PlasticThinDownBox" PlasticThinDownBox False+ modifyIORef n' (+ 2)+ bt n' "PlasticRoundUpBox" PlasticRoundUpBox False+ bt n' "PlasticRoundDownBox" PlasticRoundDownBox False+ modifyIORef n' (+ 2)+ bt n' "GtkUpBox" GtkUpBox False+ bt n' "GtkDownBox" GtkDownBox False+ bt n' "GtkUpFrame" GtkUpFrame False+ bt n' "GtkDownFrame" GtkDownFrame False+ bt n' "GtkThinUpBox" GtkThinUpBox False+ bt n' "GtkThinDownBox" GtkThinDownBox False+ bt n' "GtkThinUpFrame" GtkThinUpFrame False+ bt n' "GtkThinDownFrame" GtkThinDownFrame False+ bt n' "GtkRoundUpBox" GtkRoundUpBox False+ bt n' "GtkRoundDownBox" GtkRoundDownBox False+ bt n' "FreeBoxtype" FreeBoxtype False+ setResizable window (Just window)+ end window+ showWidget window+ _ <- FL.run+ return ()
+ src/Examples/browser.hs view
@@ -0,0 +1,127 @@+{-+This is a test of how the browser draws lines.+This is a second line.+This is a third.++That was a blank line above this.++@r@_Right justify+@c@_Center justify+@_Left justify++@bBold text+@iItalic text+@b@iBold Italic+@fFixed width+@f@bBold Fixed+@f@iItalic Fixed+@f@i@bBold Italic Fixed+@lLarge+@l@bLarge bold+@sSmall+@s@bSmall bold+@s@iSmall italic+@s@i@bSmall italic bold+@uunderscore+@C1RED+@C2Green+@C4Blue++ You should try different browser types:+ Fl_Browser+ Fl_Select_Browser+ Fl_Hold_Browser+ Fl_Multi_Browser+-}++module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.FLTKHS+import Control.Monad+import System.Environment++data CallbackType = Top | Middle | Bottom | Visible | Browser+bCb :: Ref SelectBrowser -> IO ()+bCb browser' = FL.eventClicks >>= setValue browser'++showCb :: CallbackType -> Ref IntInput -> Ref SelectBrowser -> IO ()+showCb buttontype' field' browser' = do+ line' <- getValue field'+ if (null line')+ then print "Please enter a number in the text field before clicking on the buttons."+ else do+ let lineNumber' = read line'+ case buttontype' of+ Top -> setTopline browser' lineNumber'+ Bottom -> setBottomline browser' lineNumber'+ Middle -> setMiddleline browser' lineNumber'+ _ -> makeVisible browser' lineNumber'++swapCb :: Ref SelectBrowser -> Ref Button -> IO ()+swapCb browser' _ =+ do+ browserSize' <- getSize browser'+ linesSelected' <- filterM (selected browser') [0..(browserSize' - 1)]+ case linesSelected' of+ (l1:l2:_) -> swap browser' l1 l2+ (l1:[]) -> swap browser' l1 (-1)+ _ -> swap browser' (-1) (-1)++sortCb :: Ref SelectBrowser -> Ref Button -> IO ()+sortCb browser' _ = sortWithSortType browser' SortAscending++btypeCb :: Ref SelectBrowser -> Ref Choice -> IO ()+btypeCb browser' btype' = do+ numLines' <- getSize browser'+ forM_ [1..(numLines' - 1)] (\l -> select browser' l False)+ _ <- select browser' 1 False -- leave focus box on first line+ choice' <- getText btype'+ case choice' of+ "Normal" -> setType browser' NormalBrowserType+ "Select" -> setType browser' SelectBrowserType+ "Hold" -> setType browser' HoldBrowserType+ "Multi" -> setType browser' MultiBrowserType+ _ -> return ()+ redraw browser'++main :: IO ()+main = do+ args <- getArgs+ if (null args) then print "Enter the path to a text file as an argument. As an example use this file (./src/Examples/browser.hs) to see what Fl_Browser can do."+ else do+ let fname = head args+ window <- doubleWindowNew (Size (Width 560) (Height 400)) Nothing (Just fname)+ browser' <- selectBrowserNew (Rectangle (Position (X 0) (Y 0)) (Size (Width 560) (Height 350))) Nothing+ setType browser' MultiBrowserType+ setCallback browser' bCb+ loadStatus' <- load browser' fname+ if (loadStatus' == 0)+ then print ("Can't load " ++ fname)+ else do+ setPosition browser' 0+ field <- intInputNew (toRectangle (55,350,505,25)) (Just "Line #:")+ setCallback field (\_ -> showCb Browser field browser')+ top' <- buttonNew (toRectangle (0,375,80,25)) (Just "Top")+ setCallback top' (\_ -> showCb Top field browser')+ bottom' <- buttonNew (toRectangle (80,375,80,25)) (Just "Bottom")+ setCallback bottom' (\_ -> showCb Bottom field browser')+ middle' <- buttonNew (toRectangle (160,375,80,25)) (Just "Middle")+ setCallback middle' (\_ -> showCb Middle field browser')+ visible' <- buttonNew (toRectangle (240,375,80,25)) (Just "Make Vis.")+ setCallback visible' (\_ -> showCb Visible field browser')+ swap' <- buttonNew (toRectangle (320,375,80,25)) (Just "Swap")+ setCallback swap' $ swapCb browser'+ setTooltip swap' "Swaps two selected lines\n(Use CTRL-click to select two lines)"+ sort' <- buttonNew (toRectangle (400,375,80,25)) (Just "Sort")+ setCallback sort' (sortCb browser')+ btype <- choiceNew (toRectangle (480,375,80,25)) Nothing+ addName btype "Normal"+ addName btype "Select"+ addName btype "Hold"+ addName btype "Multi"+ setCallback btype $ btypeCb browser'+ _ <- setValue btype (MenuItemByIndex (MenuItemIndex 3))+ setResizable window (Just browser')+ showWidget window+ _ <- FL.run+ return ()
+ src/Examples/clock.hs view
@@ -0,0 +1,22 @@+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.FLTKHS++main :: IO ()+main = do+ w1 <- doubleWindowNew (Size (Width 220) (Height 220)) Nothing (Just "clock")+ begin w1+ c1 <- clockNew (toRectangle (0,0,220,220)) Nothing+ setResizable w1 (Just c1)+ end w1+ w2 <- doubleWindowNew (Size (Width 220) (Height 220)) Nothing (Just "Rounded Clock")+ begin w2+ c2 <- clockNew (toRectangle (0,0,220,220)) Nothing+ setResizable w2 (Just c2)+ end w2+ setXclass w1 "Fl_Clock"+ setXclass w2 "Fl_Clock"+ showWidget w1+ showWidget w2+ _ <- FL.run+ return ()
+ src/Examples/doublebuffer.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+module Main where+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 Control.Monad+import Data.IORef++star :: Int -> Int -> Double -> IO ()+star w h n = do+ flcPushMatrix+ flcTranslate (ByXY (ByX (fromIntegral w / 2)) (ByY (fromIntegral h /2)))+ flcScaleWithY (ByXY (ByX (fromIntegral w / 2)) (ByY (fromIntegral h /2)))+ forM_ [0..n] $ \i -> do+ forM_ [(i+1)..n] $ \j -> do+ let i_vertex :: Double = 2 * pi * i/n + 0.1+ j_vertex :: Double = 2 * pi * j/n + 0.1+ flcBeginLine+ flcVertex (ByXY (ByX $ cos i_vertex) (ByY $ sin i_vertex))+ flcVertex (ByXY (ByX $ cos j_vertex) (ByY $ sin j_vertex))+ flcEndLine+ flcPopMatrix++sliderCb :: IORef (Double,Double) -> (Double -> (Double,Double) -> (Double,Double))-> Ref HorSlider -> IO ()+sliderCb sides' sidesf' slider' = do+ v' <- getValue slider'+ modifyIORef sides' (sidesf' v')+ (Just p') <- getParent slider'+ redraw p'++badDraw :: IORef (Double,Double) -> Int -> Int -> ((Double,Double) -> Double) -> IO ()+badDraw sides w h which' = do+ flcSetColor blackColor >> flcRectf (toRectangle (0,0,w,h))+ flcSetColor whiteColor >> readIORef sides >>= star w h . which'+++drawWindow :: IORef (Double, Double) ->+ ((Double, Double) -> Double) ->+ Ref Window ->+ IO ()+drawWindow sides' whichf' w' = do+ ww' <- getW w'+ wh' <- getH w'+ badDraw sides' ww' wh' whichf'+ c' <- getChild w' (0 :: Int)+ maybe (return ()) (drawChild w') (c' :: Maybe (Ref Widget))++main :: IO ()+main = do+ visual' <- FL.visual ModeDouble+ if (not visual') then print "Xdbe not supported, faking double buffer with pixmaps.\n" else return ()+ sides' <- newIORef (20,20)+ w01 <- windowNew (toSize (420,420)) Nothing (Just "Fl_Single_Window")+ setBox w01 FlatBox+ begin w01+ w1 <- singleWindowCustom+ (Size (Width 400) (Height 400))+ (Just (Position (X 10) (Y 10)))+ (Just "Single Window")+ (Just (\w -> drawWindow sides' fst (safeCast w)))+ defaultCustomWidgetFuncs+ defaultCustomWindowFuncs+ setBox w1 FlatBox+ setColor w1 blackColor+ setResizable w1 (Just w1)+ begin w1+ slider0 <- horSliderNew (toRectangle (20,370,360,25)) Nothing+ range slider0 2 30+ setStep slider0 1+ _ <- readIORef sides' >>= setValue slider0 . fst+ setCallback slider0 (sliderCb sides' (\v (_,s2) -> (v, s2)))+ end w1+ end w01+ w02 <- windowNew (Size (Width 420) (Height 420)) Nothing (Just "Fl_Double_Window")+ setBox w02 FlatBox+ begin w02+ w2 <- doubleWindowCustom+ (Size (Width 400) (Height 400))+ (Just $ Position (X 10) (Y 10))+ (Just "Fl_Double_Window")+ (Just (\w -> drawWindow sides' snd (safeCast w)))+ defaultCustomWidgetFuncs+ defaultCustomWindowFuncs+ setBox w2 FlatBox+ setColor w2 blackColor+ setResizable w2 (Just w2)+ begin w2+ slider1 <- horSliderNew (toRectangle $ (20,370,360,25)) Nothing+ range slider1 2 30+ setStep slider1 1+ _ <- readIORef sides' >>= setValue slider1 . fst+ setCallback slider1 (sliderCb sides' (\v (s1,_) -> (s1,v)))+ end w2+ end w02+ showWidget w01+ showWidget w1+ showWidget w02+ showWidget w2+ _ <- FL.run+ return ()
+ src/Examples/make-tree.hs view
@@ -0,0 +1,21 @@+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS+import Control.Monad++main :: IO ()+main = do+ win' <- windowNew (Size (Width 500) (Height 500)) Nothing (Just "FLTK Tree Window")+ begin win'+ tree' <- treeNew (toRectangle (50,50,200,200)) (Just "Tree")+ rootLabel tree' "Root Label With Items"+ prefs' <- treePrefsNew+ forM_ [0..(9 :: Int)] $ \_ -> do+ item' <- treeItemNew prefs'+ setLabel item' "test"+ addAt tree' "test" item'+ end win'+ showWidget win'+ _ <- FL.run+ return ()
+ src/Examples/nativefilechooser-simple-app.hs view
@@ -0,0 +1,92 @@+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.FLTKHS+import System.Directory+import System.Exit++openFile :: FilePath -> IO ()+openFile fp = print $ "Open '" ++ fp ++ "''"++saveFile :: FilePath -> IO ()+saveFile fp = do+ print $ "Saving '" ++ fp ++ "'"+ exists' <- doesFileExist fp+ if not exists'+ then writeFile fp "Hello world.\n"+ else return ()++openCb :: Ref NativeFileChooser -> Ref MenuItem -> IO ()+openCb fc _ = do+ setTitle fc "Open"+ res' <- showWidget fc+ case res' of+ NativeFileChooserPicked -> do+ f' <- getFilename fc+ case f' of+ (Just f'') -> do+ setPresetFile fc f''+ openFile f''+ _ -> return ()+ _ -> return ()++saveAsCb :: Ref NativeFileChooser -> Ref MenuItem -> IO ()+saveAsCb fc _ = do+ setTitle fc "Open"+ res' <- showWidget fc+ case res' of+ NativeFileChooserPicked -> do+ f' <- getFilename fc+ case f' of+ (Just f'') -> do+ setPresetFile fc f''+ saveFile f''+ _ -> return ()+ _ -> return ()++saveCb :: Ref NativeFileChooser -> Ref MenuItem -> IO ()+saveCb fc w' = do+ f' <- getFilename fc+ case f' of+ Nothing -> saveAsCb fc w'+ (Just f'') -> saveFile f''++quitCb :: Ref MenuItem -> IO ()+quitCb _ = exitSuccess++initializeWindow :: Ref Window -> IO ()+initializeWindow w' = do+ chooser <- nativeFileChooserNew Nothing+ setFilter chooser "Text\t*.txt\n"+ setPresetFile chooser "untitiled.txt"+ begin w'+ menu <- sysMenuBarNew (toRectangle (0,0,400,25)) Nothing+ _ <- add menu "&File/&Open" (Just (KeySequence (ShortcutKeySequence [kb_CommandState] (NormalKeyType 'o')))) (Just (openCb chooser)) (MenuItemFlags [])+ _ <- add menu "&File/&Save" (Just (KeySequence (ShortcutKeySequence [kb_CommandState] (NormalKeyType 's')))) (Just (saveCb chooser)) (MenuItemFlags [])+ _ <- add menu "&File/&Save As" Nothing (Just (saveAsCb chooser)) (MenuItemFlags [])+ _ <- add menu "&File/&Quit" (Just (KeySequence (ShortcutKeySequence [kb_CommandState] (NormalKeyType 'q')))) (Just quitCb) (MenuItemFlags [])+ w_w' <- getW w'+ w_h' <- getH w'+ box' <- boxNew (toRectangle (20,25+20,w_w'-40,w_h'-40-25)) Nothing+ setColor box' (Color 45)+ setBox box' FlatBox+ setAlign box' (Alignments [AlignTypeCenter, AlignTypeInside, AlignTypeWrap])+ setLabel box' $ "This demo shows an example of implementing " +++ "common 'File' menu operations like:\n" +++ " File/Open, File/Save, File/Save As\n" +++ "..using the Fl_Native_File_Chooser widget.\n\n" +++ "Note 'Save' and 'Save As' really *does* create files! " +++ "This is to show how behavior differs when " +++ "files exist vs. do not.";+ setLabelsize box' (FontSize 12)+ end w'++main :: IO ()+main = do+ _ <- FL.setScheme "gtk+"+ app <- windowNew (toSize (400,200)) Nothing (Just "Native File Chooser Example")+ initializeWindow app+ showWidget app+ _ <- FL.run+ return ()
+ src/Examples/pack.hs view
@@ -0,0 +1,73 @@+module Main where+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++type_cb :: Ref Scrolled -> Ref Pack -> PackType -> Ref LightButton -> IO ()+type_cb scrolled pack packType _ = do+ cs <- getArray pack+ mapM_ (\c -> resize c (toRectangle (0,0,25,25))) cs+ rect <- getRectangle scrolled+ resize pack rect+ getParent pack >>=+ maybe (return ())+ (\p' -> redraw p' >> setType pack packType >> redraw pack)++spacing_cb :: Ref Scrolled -> Ref Pack -> Ref HorValueSlider -> IO ()+spacing_cb scrolled pack slider = do+ spacing <- getValue slider+ setSpacing pack (truncate spacing)+ redraw scrolled++main :: IO ()+main = do+ w <- doubleWindowNew (Size (Width 360) (Height 370)) Nothing Nothing+ scrolled <- scrolledNew (toRectangle (10,10,340,285)) Nothing+ begin scrolled+ pack <- packNew (toRectangle $ (10,10,340,285)) Nothing+ setBox pack DownFrame+ begin pack+ _ <- buttonNew (toRectangle (35, 35, 25, 25)) (Just "b1")+ _ <- buttonNew (toRectangle (45, 45, 25, 25)) (Just "b2")+ _ <- buttonNew (toRectangle (55, 55, 25, 25)) (Just "b3")+ _ <- buttonNew (toRectangle (65, 65, 25, 25)) (Just "b4")+ _ <- buttonNew (toRectangle (75, 75, 25, 25)) (Just "b5")+ _ <- buttonNew (toRectangle (85, 85, 25, 25)) (Just "b6")+ _ <- buttonNew (toRectangle (95, 95, 25, 25)) (Just "b7")+ _ <- buttonNew (toRectangle (105, 105, 25, 25)) (Just "b8")+ _ <- buttonNew (toRectangle (115, 115, 25, 25)) (Just "b9")+ _ <- buttonNew (toRectangle (125, 125, 25, 25)) (Just "b10")+ _ <- buttonNew (toRectangle (135, 135, 25, 25)) (Just "b11")+ _ <- buttonNew (toRectangle (145, 145, 25, 25)) (Just "b12")+ _ <- buttonNew (toRectangle (155, 155, 25, 25)) (Just "b13")+ _ <- buttonNew (toRectangle (165, 165, 25, 25)) (Just "b14")+ _ <- buttonNew (toRectangle (175, 175, 25, 25)) (Just "b15")+ _ <- buttonNew (toRectangle (185, 185, 25, 25)) (Just "b16")+ _ <- buttonNew (toRectangle (195, 195, 25, 25)) (Just "b17")+ _ <- buttonNew (toRectangle (205, 205, 25, 25)) (Just "b18")+ _ <- buttonNew (toRectangle (215, 215, 25, 25)) (Just "b19")+ _ <- buttonNew (toRectangle (225, 225, 25, 25)) (Just "b20")+ _ <- buttonNew (toRectangle (235, 235, 25, 25)) (Just "b21")+ _ <- buttonNew (toRectangle (245, 245, 25, 25)) (Just "b22")+ _ <- buttonNew (toRectangle (255, 255, 25, 25)) (Just "b23")+ _ <- buttonNew (toRectangle (265, 265, 25, 25)) (Just "b24")+ end pack+ setResizable w (Just w)+ end scrolled+ lb1 <- lightButtonNew (toRectangle (10, 305, 165, 25)) (Just "HORIZONTAL")+ setType lb1 RadioButtonType+ setCallback lb1 (type_cb scrolled pack PackHorizontal)+ lb2 <- lightButtonNew (toRectangle(185, 305, 165, 25)) (Just "VERTICAL")+ setType lb2 RadioButtonType+ _ <- setValue lb2 True+ setCallback lb2 (type_cb scrolled pack PackVertical)+ vs <- horValueSliderNew (toRectangle (100, 335, 250, 25)) (Just "Spacing: ")+ setAlign vs (Alignments [AlignTypeLeft])+ range vs 0 30+ setStep vs 1+ setCallback vs (spacing_cb scrolled pack)+ end w+ showWidget w+ _ <- FL.run+ return ()
+ src/Examples/table-as-container.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.FLTKHS++buttonCb :: Ref LightButton -> IO ()+buttonCb lightButton = do+ l' <- getLabel lightButton+ print $ "BUTTON: " ++ l'++setTableSize :: Ref Table -> Int -> Int -> IO ()+setTableSize t' nr' nc' = do+ clear t'+ setRows t' nr'+ setCols t' nc'+ begin t'+ let (rowCols :: [(Int,Int)]) = [(r',c') | r' <- [0..(nr'-1)], c' <- [0..(nc'-1)]]+ mapM_+ (\(_r,_c) -> do+ cellRectangle <- findCell t' ContextTable (TableCoordinate (Row _r) (Column _c))+ case cellRectangle of+ Just cellRectangle' ->+ if (odd _c)+ then do+ let s = (show _r) ++ "." ++ (show _c)+ input_ <- inputNew cellRectangle' Nothing Nothing+ _ <- setValue input_ s Nothing+ return ()+ else+ do+ let s = (show _r) ++ "/" ++ (show _c)+ butt <- lightButtonNew cellRectangle' (Just s)+ setAlign butt (Alignments [AlignTypeCenter, AlignTypeInside])+ setCallback butt buttonCb+ _ <- setValue butt ((_r+_c*2) `mod` 4 == 0)+ return ()+ Nothing -> return ()+ )+ rowCols+ end t'++drawCell :: Ref Table -> TableContext -> TableCoordinate -> Rectangle -> IO ()+drawCell t' tcontext' (TableCoordinate (Row tr') (Column tc')) r' =+ case tcontext' of+ ContextStartPage -> flcSetFont helvetica (FontSize 12)+ ContextRCResize -> do+ rows' <- getRows t'+ cols' <- getCols t'+ let (rowCols :: [(Int,Int)]) = [(_r,_c) | _r <- [0..(rows'-1)], _c <- [0..(cols'-1)]]+ mapM_+ (\((i::Int), (_r',_c')) -> do+ children' <- children t'+ if (i >= children')+ then return ()+ else do+ cellRectangle <- findCell t' ContextTable (TableCoordinate (Row _r') (Column _c'))+ case cellRectangle of+ Just cellRectangle' -> do+ child' <- getChild t' i+ maybe (return ()) (\c -> resize c cellRectangle') child'+ Nothing -> return ()+ )+ (zip [0..] rowCols)+ initSizes t'+ ContextRowHeader -> do+ flcPushClip r'+ let s = "Row " ++ (show tr')+ headerColor <- getRowHeaderColor t'+ flcDrawBox ThinUpBox r' headerColor+ flcSetColor blackColor+ flcDrawInBox s r' (Alignments [AlignTypeCenter]) Nothing Nothing+ flcPopClip+ ContextColHeader -> do+ flcPushClip r'+ let s = "Column " ++ (show tc')+ headerColor <- getColHeaderColor t'+ flcDrawBox ThinUpBox r' headerColor+ flcSetColor blackColor+ flcDrawInBox s r' (Alignments [AlignTypeCenter]) Nothing Nothing+ flcPopClip+ _ -> return ()+initializeTable :: Ref Table -> IO ()+initializeTable t = do+ begin t+ setColHeader t True+ setColResize t True+ setColHeaderHeight t 25+ setRowHeader t True+ setRowResize t True+ setRowHeaderWidth t 80+ end t+main :: IO ()+main = do+ win <- doubleWindowNew (toSize (940,500)) Nothing (Just "table as container")+ win_w <- getW win+ win_h <- getH win+ begin win+ table <- tableCustom+ (toRectangle (20,20,win_w-40,win_h-40))+ (Just "FLTK widget table")+ Nothing+ drawCell+ defaultCustomWidgetFuncs+ defaultCustomTableFuncs+ initializeTable table+ setTableSize table 50 50+ end win+ setResizable win (Just table)+ showWidget win+ _ <- FL.run+ return ()
+ src/Examples/table-simple.hs view
@@ -0,0 +1,78 @@+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.FLTKHS+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++maxRows :: Int+maxRows = 30+maxCols :: Int+maxCols = 26+tableData :: [[Int]]+tableData =+ let rowIndices = [0 .. (maxRows - 1)]+ colIndices = [0 .. (maxCols - 1)]+ in+ map (\r -> map (\c -> 1000 + (r * 1000) + c) colIndices) rowIndices+drawHeader :: Ref Table -> String -> Rectangle -> IO ()+drawHeader table s rectangle = do+ flcPushClip rectangle+ rhc <- getRowHeaderColor table+ flcDrawBox ThinUpBox rectangle rhc+ flcSetColor blackColor+ flcDrawInBox s rectangle alignCenter Nothing Nothing+ flcPopClip+drawData :: Ref Table -> String -> Rectangle -> IO ()+drawData table s rectangle = do+ flcPushClip rectangle+ flcSetColor whiteColor >> flcRectf rectangle+ flcSetColor gray0Color >> flcDrawInBox s rectangle alignCenter Nothing Nothing+ color' <- getColor table+ flcSetColor color' >> flcRect rectangle+ flcPopClip+drawCell :: Ref Table -> TableContext -> TableCoordinate -> Rectangle -> IO ()+drawCell table context (TableCoordinate (Row row) (Column col)) rectangle = do+ case context of+ ContextStartPage -> flcSetFont helvetica (FontSize 16)+ ContextColHeader ->+ let a = fromEnum 'A'+ currentLetter :: Char+ currentLetter = (toEnum $ fromEnum a + col)+ in+ drawHeader table [currentLetter] rectangle+ ContextRowHeader -> drawHeader table (show row) rectangle+ ContextCell -> drawData table (show $ tableData !! row !! col) rectangle+ _ -> return ()+initializeTable :: Ref Table -> IO ()+initializeTable table = do+ begin table+ setRows table maxRows+ setRowHeader table True+ setRowHeightAll table 20+ setRowResize table False+ setCols table maxCols+ setColHeader table True+ setColWidthAll table 80+ setColResize table True+ end table+main :: IO ()+main = do+ window <- doubleWindowNew+ (Size (Width 900) (Height 400))+ Nothing+ (Just "Simple Table")+ begin window+ table <- tableCustom+ (Rectangle+ (Position (X 10) (Y 10))+ (Size (Width 880) (Height 380)))+ Nothing+ Nothing+ drawCell+ defaultCustomWidgetFuncs+ defaultCustomTableFuncs+ initializeTable table+ setResizable window (Just table)+ end window+ showWidget window+ _ <- FL.run+ return ()
+ src/Examples/table-sort.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE CPP #-}+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Control.Monad+import Graphics.UI.FLTK.LowLevel.FLTKHS+import Data.IORef+import Data.List+import Data.Function+import System.Process+dirCommand :: ([Char], [[Char]])+dirHeaders :: [[Char]]+#ifdef mingw32_HOST_OS+dirCommand = ("dir", [])+dirHeaders = ["Perms", "#L", "Own", "Group", "Size", "Date", "", "", "Filename"]+#else+dirCommand = ("ls", ["-l"])+dirHeaders = ["Date", "Time", "Size", "Filename", "", "", "", "", ""]+#endif+margin :: Int+margin = 20+headerFontFace :: Font+headerFontFace = helveticaBold+headerFontSize :: FontSize+headerFontSize = FontSize 16+rowFontFace :: Font+rowFontFace = helvetica+rowFontSize :: FontSize+rowFontSize = FontSize 16++data TableState = TableState {+ sortReverse :: IORef Bool,+ sortLastCol :: IORef Int,+ rowData :: IORef [[String]]+ }++drawSortArrow :: Rectangle -> Bool -> IO ()+drawSortArrow (Rectangle (Position (X x') (Y y')) (Size (Width w') (Height h'))) sortReverse' =+ let xlft = x' + (w'-6) - 8+ xctr = x' + (w'-6) - 4+ xrit = x' + (w'-6) - 0+ ytop = y' + (truncate ((fromIntegral h' / 2) :: Double)) - 4+ ybot = y' + (truncate ((fromIntegral h' / 2) :: Double)) + 4+ in+ if sortReverse'+ then do+ flcSetColor whiteColor+ flcLine (Position (X xrit) (Y ytop)) (Position (X xctr) (Y ybot))+ flcSetColorWithC 41+ flcLine (Position (X xlft) (Y ytop)) (Position (X xrit) (Y ytop))+ flcLine (Position (X xlft) (Y ytop)) (Position (X xctr) (Y ybot))+ else do+ flcSetColor whiteColor+ flcLine (Position (X xrit) (Y ybot)) (Position (X xctr) (Y ybot))+ flcLine (Position (X xrit) (Y ybot)) (Position (X xlft) (Y ybot))+ flcSetColorWithC 41+ flcLine (Position (X xlft) (Y ybot)) (Position (X xctr) (Y ytop))++drawCell :: TableState -> Ref TableRow -> TableContext -> TableCoordinate -> Rectangle -> IO ()+drawCell tableState table tc (TableCoordinate (Row row') (Column col')) rectangle' =+ let (x',y',w',h') = fromRectangle rectangle'+ in do+ sortReverse' <- readIORef (sortReverse tableState)+ sortLastCol' <- readIORef (sortLastCol tableState)+ rowData' <- readIORef (rowData tableState)+ numCols <- getCols table+ numRows <- getRows table+ if (row' < numRows && col' < numCols)+ then case tc of+ ContextColHeader -> do+ flcPushClip rectangle'+ flcDrawBox ThinUpBox rectangle' backgroundColor+ if (col' < 9)+ then do+ flcSetColor blackColor+ flcDrawInBox+ (dirHeaders !! col')+ (toRectangle ((x'+2),y',w',h'))+ alignLeft+ Nothing+ Nothing+ if (col' == sortLastCol')+ then drawSortArrow rectangle' sortReverse'+ else return ()+ else return ()+ flcPopClip+ ContextCell -> do+ flcPushClip rectangle'+ bgColor <- do+ isSelected' <- getRowSelected table row'+ case isSelected' of+ Right is' -> if is'+ then getSelectionColor table+ else return whiteColor+ Left _ -> error $ "Row: " ++ (show row') ++ " is out of range."+ flcSetColor bgColor+ flcRectf rectangle'+ flcSetFont rowFontFace rowFontSize+ flcSetColor blackColor+ let currentRow = rowData' !! row'+ flcDrawInBox+ (indexOr "" col' currentRow)+ (toRectangle $ (x'+2,y',w',h'))+ alignLeft+ Nothing+ Nothing+ flcSetColor light2Color+ flcRect rectangle'+ flcPopClip+ _ -> return ()+ else return ()+setIndex :: Int -> [a] -> (a -> a) -> [a]+setIndex idx' xs f =+ map+ (+ \(i,e) -> if (i == idx')+ then f e+ else e+ )+ (zip [0..] xs)++indexOr :: a -> Int -> [a] -> a+indexOr fallback idx xs =+ if (idx < length xs)+ then xs !! idx+ else fallback++eventCallback :: TableState -> Ref TableRow -> IO ()+eventCallback tableState table = do+ (Column col') <- callbackCol table+ context' <- callbackContext table+ case context' of+ ContextColHeader -> do+ event' <- FL.event+ mouseButton' <- FL.eventButton+ if (event' == Release && mouseButton' == Mouse_Left)+ then do+ sortLastCol' <- readIORef (sortLastCol tableState)+ if (sortLastCol' == col')+ then readIORef (sortReverse tableState) >>= writeIORef (sortReverse tableState) . toggle+ else writeIORef (sortReverse tableState) False+ sortReverse' <- readIORef (sortReverse tableState)+ rowData' <- readIORef (rowData tableState) >>= return . zip [(0 :: Int)..]+ let sorted = sortBy (compare `on` (indexOr "" col'. snd)) rowData'+ writeIORef+ (rowData tableState)+ (if sortReverse'+ then (reverse $ map snd sorted)+ else map snd sorted)+ writeIORef (sortLastCol tableState) col'+ redraw table+ else return ()+ _ -> return ()+ where toggle True = False+ toggle False = True++autowidth :: Ref TableRow -> Int -> [[String]] -> IO ()+autowidth table pad rowData' = do+ flcSetFont headerFontFace headerFontSize+ mapM_+ (\(colNum, colName) -> do+ (Size (Width w') _) <- flcMeasure colName True True+ setColWidth table (Column colNum) (w' + pad)+ )+ (zip [0 ..] dirHeaders)+ flcSetFont rowFontFace rowFontSize+ mapM_+ (\row' -> do+ mapM_+ (\(colIdx,col) -> do+ (Size (Width wc') _) <- flcMeasure col True True+ colWidth' <- getColWidth table (Column colIdx)+ if (wc' + pad > colWidth')+ then setColWidth table (Column colIdx) (wc' + pad)+ else return ()+ )+ (zip [0..] row')+ )+ rowData'+ -- need to do { table_resized(); redraw(); }+ -- but table_resized() is unexposed.+ -- setting the row_header flag induces this.+ getRowHeader table >>= setRowHeader table++resize_window :: Ref DoubleWindow -> Ref TableRow -> IO ()+resize_window window table = do+ let width = (4 :: Int)+ numCols <- getCols table+ colWidthTotal <- liftM sum $ mapM (getColWidth table . Column) [0..(numCols - 1)]+ let totalWidth = width + colWidthTotal + (margin * 2)+ appWidth <- FL.w+ if (totalWidth < 200 || totalWidth > appWidth)+ then return ()+ else do+ x' <- getX window+ y' <- getY window+ h' <- getH window+ resize window $ toRectangle (x',y',totalWidth,h')++main :: IO ()+main = do+ window <- doubleWindowNew+ (Size (Width 900) (Height 500))+ Nothing+ (Just "Table Sorting")+ windowW <- getW window+ windowH <- getH window+ rows <- uncurry readProcess dirCommand "" >>= return . map words . lines+ rowData' <- newIORef rows+ sortReverse' <- newIORef False+ sortLastCol' <- newIORef (-1)+ let tableState = TableState sortReverse' sortLastCol' rowData'+ begin window+ table <- tableRowNew+ (Rectangle+ (Position (X margin) (Y margin))+ (Size (Width $ windowW - margin * 2)+ (Height $ windowH - margin * 2)))+ Nothing+ Nothing+ (drawCell tableState)+ defaultCustomWidgetFuncs+ defaultCustomTableFuncs+ setColHeader table True+ setColResize table True+ setSelectionColor table yellowColor+ setWhen table [WhenRelease]+ readIORef rowData' >>= setRows table . length+ readIORef rowData' >>= setCols table . maximum . map length+ setRowHeightAll table 18+ readIORef rowData' >>= autowidth table 20+ setTooltip table "Click on column headings to toggle column sorting"+ setColor table whiteColor+ setCallback table (eventCallback tableState)+ end window+ setResizable window (Just table)+ resize_window window table+ _ <- showWidget window+ _ <- FL.run+ return ()
@@ -0,0 +1,292 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where+import Data.IORef+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++maxCols, maxRows :: Int+maxCols = 26+maxRows = 500++data SpreadsheetProperties =+ SpreadsheetProperties+ {+ rowEdit :: Int+ , colEdit :: Int+ , sLeftTop :: TableCoordinate+ , sRightBottom :: TableCoordinate+ , values :: [[Int]]+ }++setIndex :: Int -> (a -> a) -> [a] -> [a]+setIndex idx' f xs =+ map+ (+ \(i,e) -> if (i == idx')+ then f e+ else e+ )+ (zip [0..] xs)++setValueHide :: IORef SpreadsheetProperties -> Ref Table -> Ref IntInput -> IO ()+setValueHide sp' table' intInput' = do+ props' <- readIORef sp'+ inputValue' <- getValue intInput' >>= return . read+ let updatedValues' = setIndex+ (rowEdit props')+ (setIndex+ (colEdit props')+ (const inputValue'))+ (values props')+ updatedProperties' = props' {+ values = updatedValues'+ }+ writeIORef sp' updatedProperties'+ hide intInput'+ window' <- getWindow table'+ maybe (return ()) (\w' -> setCursor w' CursorDefault ) window'++startEditing :: IORef SpreadsheetProperties -> Ref IntInput -> Ref Table -> Int -> Int -> IO ()+startEditing props' intInput' table' row' col' = do+ modifyIORef props' (\p' -> p' {rowEdit = row', colEdit = col'})+ _p <- readIORef props'+ setSelection table' (rowEdit _p) (colEdit _p) (rowEdit _p) (colEdit _p)+ rectangle' <- findCell table' ContextCell (TableCoordinate (Row (rowEdit _p)) (Column (colEdit _p)))+ case rectangle' of+ Just rect' -> do+ resize intInput' rect'+ let cellContents = (values _p) !! (rowEdit _p) !! (colEdit _p)+ _ <- setValue intInput' (show cellContents) Nothing+ _ <- setPosition intInput' 0 (Just (length $ show cellContents))+ showWidget intInput'+ _ <- takeFocus intInput'+ return ()+ _ -> return ()++doneEditing :: IORef SpreadsheetProperties -> Ref IntInput -> Ref Table -> IO ()+doneEditing props' intInput' table' = do+ _p <- readIORef props'+ visible' <- getVisible intInput'+ if visible'+ then setValueHide props' table' intInput'+ else return ()++eventCallback :: IORef SpreadsheetProperties -> Ref IntInput -> Ref Table -> IO ()+eventCallback props' intInput' table' = do+ _p <- readIORef props'+ (Row r') <- callbackRow table'+ (Column c') <- callbackCol table'+ context' <- callbackContext table'+ numRows' <- getRows table'+ numCols' <- getCols table'+ case context' of+ ContextCell -> do+ event' <- FL.event+ case event' of+ Push -> do+ doneEditing props' intInput' table'+ if (r' /= (numRows' -1) && c' /= (numCols' -1))+ then startEditing props' intInput' table' r' c'+ else return ()+ return ()+ Keydown -> do+ eventKey' <- FL.eventKey+ if (eventKey' == (SpecialKeyType Kb_Escape))+ then return ()+ else if (r' == numRows' - 1 || c' == numCols' -1)+ then return ()+ else do+ doneEditing props' intInput' table'+ setSelection table' r' c' r' c'+ startEditing props' intInput' table' r' c'+ newEvent <- FL.event+ if (newEvent == Keydown)+ then handle intInput' newEvent >> return ()+ else return ()+ return ()+ _ -> return ()+ _c -> if (any (== _c) [ContextTable, ContextRowHeader, ContextColHeader])+ then doneEditing props' intInput' table'+ else return ()++setBySlider :: Ref ValueSlider -> Ref Table -> (Ref Table -> Int -> IO ()) -> IO ()+setBySlider slider' table' f = do+ v' <- getValue slider'+ f table' (truncate $ v'+1)+ redraw table'++setColsCb :: Ref Table -> Ref ValueSlider -> IO ()+setColsCb table' slider' = setBySlider slider' table' setCols++setRowsCb :: Ref Table -> Ref ValueSlider -> IO ()+setRowsCb table' slider' = setBySlider slider' table' setRows++drawCell :: IORef SpreadsheetProperties -> Ref IntInput -> Ref Table -> TableContext -> TableCoordinate -> Rectangle -> IO ()+drawCell props' intInput' table' context' (TableCoordinate (Row row') (Column col')) rectangle' = do+ _p <- readIORef props'+ numRows' <- getRows table'+ numCols' <- getCols table'+ case context' of+ ContextStartPage -> do+ (p1,p2) <- getSelection table'+ modifyIORef props' (\p -> p {sLeftTop = p1, sRightBottom = p2})+ ContextColHeader -> do+ flcSetFont helveticaBold (FontSize 14)+ flcPushClip rectangle'+ getColHeaderColor table' >>= flcDrawBox ThinUpBox rectangle'+ flcSetColor blackColor+ if (col' == numCols' - 1)+ then flcDrawInBox "TOTAL" rectangle' alignCenter Nothing Nothing+ else flcDrawInBox [toEnum $ fromEnum 'A' + col'] rectangle' alignCenter Nothing Nothing+ flcPopClip+ ContextRowHeader -> do+ flcSetFont helveticaBold (FontSize 14)+ flcPushClip rectangle'+ getRowHeaderColor table' >>= flcDrawBox ThinUpBox rectangle'+ flcSetColor blackColor+ if (row' == numRows' - 1)+ then flcDrawInBox "TOTAL" rectangle' alignCenter Nothing Nothing+ else flcDrawInBox (show $ row' + 1) rectangle' alignCenter Nothing Nothing+ flcPopClip+ ContextCell-> do+ visible' <- getVisible intInput'+ let (TableCoordinate (Row sTop') (Column sLeft')) = sLeftTop _p+ (TableCoordinate (Row sBottom') (Column sRight')) = sRightBottom _p+ if (row' == (rowEdit _p) && col' == (colEdit _p) && visible')+ then return ()+ else do+ if (row' >= sTop' && row' <= sBottom' && col' >= sLeft' && col' <= sRight')+ then flcDrawBox ThinUpBox rectangle' yellowColor+ else if (col' < numCols' - 1 && row' < numRows' - 1)+ then do+ selected' <- isSelected table' (TableCoordinate (Row row') (Column col'))+ flcDrawBox ThinUpBox rectangle' (if selected' then yellowColor else whiteColor)+ else flcDrawBox ThinUpBox rectangle' (Color 0xbbddbb00)+ flcPushClip rectangle'+ flcSetColor blackColor+ if (col' == numCols' - 1 || row' == numRows' - 1)+ then do+ flcSetFont helveticaBold (FontSize 14)+ let shownValues = map (take (numCols'- 1)) $ take (numRows' -1) (values _p)+ let s' = if (col' == numCols' - 1 && row' == numRows' - 1)+ then (show . sum . map sum) shownValues+ else if (col' == numCols' - 1)+ then (show $ sum $ shownValues !! row')+ else if (row' == numRows' - 1)+ then (show . sum . map (\r -> r !! col')) shownValues+ else ""+ let (x',y',w',h') = fromRectangle rectangle'+ flcDrawInBox s' (toRectangle (x'+3,y'+3,w'-6,h'-6)) alignRight Nothing Nothing+ else do+ flcSetFont helvetica (FontSize 14)+ let s' = show $ (values _p) !! row' !! col'+ let (x',y',w',h') = fromRectangle rectangle'+ flcDrawInBox s' (toRectangle (x'+3,y'+3,w'-6,h'-6)) alignRight Nothing Nothing+ flcPopClip+ ContextRCResize -> do+ visible' <- getVisible intInput'+ if (not visible')+ then return ()+ else do+ cellRectangle' <- findCell table' ContextTable (TableCoordinate (Row row') (Column col'))+ case cellRectangle' of+ Just cr' -> if (cr' == rectangle')+ then return ()+ else resize intInput' cr'+ Nothing -> return ()+ _ -> return ()++main :: IO ()+main = do+ FL.setOption FL.OptionArrowFocus True+ win' <- doubleWindowNew+ (Size (Width 922) (Height 382))+ Nothing+ (Just "Fl_Table Spreadsheet with Keyboard Navigation")+ winWidth' <- getW win'+ winHeight' <- getH win'+ let values' =+ map+ (\r' ->+ map+ (\c' -> (r'+2) * (c'+3))+ [0 .. (maxCols -1)]+ )+ [0.. (maxRows - 1)]+ props' <- newIORef $+ SpreadsheetProperties+ 0+ 0+ (TableCoordinate (Row 0) (Column 0))+ (TableCoordinate (Row 0) (Column 0))+ values'+ let tableWidth' = winWidth' - 80+ tableHeight' = winHeight' - 80+ intInput' <- intInputNew+ (toRectangle+ (+ (truncate $ ((fromIntegral tableWidth' / 2) :: Double)),+ (truncate $ ((fromIntegral tableHeight' / 2) :: Double)),+ 0,+ 0+ )+ )+ Nothing+ hide intInput'+ setWhen intInput' [WhenEnterKeyAlways]+ setMaximumSize intInput' 5++ spreadsheet' <- tableCustom+ (toRectangle (20,20,tableWidth', tableHeight'))+ Nothing+ Nothing+ (drawCell props' intInput')+ defaultCustomWidgetFuncs+ defaultCustomTableFuncs+ whens' <- getWhen spreadsheet'+ setWhen spreadsheet' $ [WhenNotChanged] ++ whens'+ setSelection spreadsheet' 0 0 0 0+ setCallback intInput' (setValueHide props' spreadsheet')+ setCallback spreadsheet' (eventCallback props' intInput')+ setTooltip spreadsheet' "Use keyboard to navigate cells:\n Arrow keys or Tab/Shift-Tab"+ -- Table rows+ setRowHeader spreadsheet' True+ setRowHeaderWidth spreadsheet' 70+ setRowResize spreadsheet' True+ setRows spreadsheet' 11+ setRowHeightAll spreadsheet' 25+ -- Table cols+ setColHeader spreadsheet' True+ setColHeaderHeight spreadsheet' 25+ setColResize spreadsheet' True+ setCols spreadsheet' 11+ setColWidthAll spreadsheet' 70++ begin win'+ -- Rows slider+ setRows' <- valueSliderNew (toRectangle (winWidth'-40,20,20,winHeight'-80)) Nothing+ setType setRows' VertNiceSliderType+ bounds setRows' 2 (fromIntegral maxRows)+ setStep setRows' 1+ numRows' <- getRows spreadsheet'+ _ <- setValue setRows' (fromIntegral $ numRows'-1)+ setCallback setRows' (setRowsCb spreadsheet')+ setWhen setRows' [WhenChanged]+ clearVisibleFocus setRows'+ -- Cols slider+ setCols' <- valueSliderNew (toRectangle (20,winHeight'-40,winWidth'-80,20)) Nothing+ setType setCols' HorNiceSliderType+ bounds setCols' 2 (fromIntegral maxCols)+ setStep setCols' 1+ numCols' <- getCols spreadsheet'+ _ <- setValue setCols' (fromIntegral $ numCols'-1)+ setCallback setCols' (setColsCb spreadsheet')+ setWhen setCols' [WhenChanged]+ clearVisibleFocus setCols'+ end win'+ setResizable win' (Just spreadsheet')+ showWidget win'+ _ <- FL.run+ return ()
+ src/Examples/textdisplay-with-colors.hs view
@@ -0,0 +1,23 @@+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.FLTKHS+main :: IO ()+main = do+ let stes = [(StyleTableEntry (Just redColor) (Just courier) (Just $ FontSize 18)),+ (StyleTableEntry (Just darkYellowColor) (Just courier) (Just $ FontSize 18)),+ (StyleTableEntry (Just darkGreenColor) (Just courier) (Just $ FontSize 18)),+ (StyleTableEntry (Just blueColor) (Just courier) (Just $ FontSize 18))]+ win <- windowNew (toSize (640,480)) Nothing (Just $ "Simple Text Display With Colors")+ disp <- textDisplayNew (toRectangle (20,20,640-40,480-40)) Nothing+ tbuff <- textBufferNew Nothing Nothing+ sbuff <- textBufferNew Nothing Nothing+ setBuffer disp (Just tbuff)+ highlightData disp sbuff (indexStyleTableEntries stes) Nothing+ setText tbuff "Red Line 1\nYel Line 2\nGrn Line 3\nBlu Line 4\nRed Line 5\nYel Line 6\nGrn Line 7\nBlu Line 8\n"+ setText sbuff "AAAAAAAAAA\nBBBBBBBBBB\nCCCCCCCCCC\nDDDDDDDDDD\nAAAAAAAAAA\nBBBBBBBBBB\nCCCCCCCCCC\nDDDDDDDDDD\n"+ setResizable win (Just disp)+ showWidget win+ _ <- FL.run+ return ()
+ src/Examples/texteditor-simple.hs view
@@ -0,0 +1,15 @@+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS++main :: IO ()+main = do+ win <- doubleWindowNew (toSize (640,480)) Nothing (Just "Simple Fl_Text_Editor")+ buff <- textBufferNew Nothing Nothing+ edit <- textEditorNew (toRectangle (20,20,(640-40),(480-40))) Nothing+ setBuffer edit (Just buff)+ showWidget win+ setText buff "line 0\nline 1\nline 2\nline 3\nline 4\nline 5\nline 6\nline 7\nline 8\nline 9\nline 10\nline 11\nline 12\nline 13\nline 14\nline 15\nline 16\nline 17\nline 18\nline 19\nline 20\nline 21\nline 22\nline 23\n"+ _ <- FL.run+ return ()
+ src/Examples/threads.hs view
@@ -0,0 +1,87 @@+-- This example shows how to run a CPU-intensive thread in the+-- background while keeping the UI responsive. All FLTK calls are+-- done on the main thread.+--+-- Press the "start background thread" button to start the+-- CPU-intensive thread. Then observe that clicking the "increment"+-- button remains responsive.++module Main where++import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception (evaluate)+import Control.Monad+import Data.IORef++main :: IO ()+main = do+ -- Set up the window and widgets.+ w <- windowNew (Size (Width 260) (Height 110)) Nothing Nothing+ startButton <- buttonNew (Rectangle (Position (X 15) (Y 10)) (Size (Width 230) (Height 25))) (Just "start background thread")+ b <- outputNew (Rectangle (Position (X 135) (Y 40)) (Size (Width 110) (Height 25))) (Just "primes ") (Just FlNormalOutput)+ button <- buttonNew (Rectangle (Position (X 15) (Y 75)) (Size (Width 110) (Height 25))) (Just "increment")+ counter <- outputNew (Rectangle (Position (X 135) (Y 75)) (Size (Width 110) (Height 25))) Nothing (Just FlNormalOutput)+ clearVisibleFocus b+ clearVisibleFocus counter++ -- The communication channel between the CPU-heavy thread and the+ -- main thread.+ c <- newTChanIO++ -- When the start button is pressed, start the CPU-heavy thread.+ setCallback startButton $ \_ -> do+ void $ forkIO $ computationThread c++ -- Start the click counter at zero.+ counterRef <- newIORef (0 :: Integer)+ _ <- setValue counter (show (0 :: Integer)) Nothing++ -- When the button is pressed, increment the counter and update the+ -- label.+ setCallback button $ \_ -> do+ modifyIORef counterRef (+1)+ x <- readIORef counterRef+ void $ setValue counter (show x) Nothing++ -- Every so often, check for messages from our worker thread.+ FL.addTimeout 0.025 (tick b c)++ -- Start the UI.+ showWidget w+ _ <- FL.run+ return ()++-- Check for a message from our worker thread. If there is a message,+-- gobble all the messages up and set the label to the contents on the+-- most recent message.+tick :: Ref Output -> TChan Integer -> IO ()+tick b c = do+ mx <- atomically $ tryReadTChan c+ case mx of+ Nothing -> return ()+ Just x -> inner x+ FL.repeatTimeout 0.025 (tick b c)+ where inner x = do+ mx <- atomically $ tryReadTChan c+ case mx of+ Nothing -> void $ setValue b (show x) Nothing+ Just x' -> inner x'+++-- Very slow prime-testing predicate.+isPrime :: Integer -> Bool+isPrime 1 = False+isPrime x = not $ any (\y -> x `mod` y == 0) [2..x-1]++-- Write prime numbers to a channel forever.+computationThread :: TChan Integer -> IO ()+computationThread channel = do+ let primes = filter isPrime [1000000..]+ forM_ primes $ \p -> do+ _ <- evaluate p+ atomically $ writeTChan channel p
+ src/Examples/tile.hs view
@@ -0,0 +1,69 @@+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.FLTKHS+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++main :: IO ()+main = do+ window <- doubleWindowNew (Size (Width 300) (Height 300)) Nothing Nothing+ setBox window NoBox+ _ <- setResizable window (Just window)+ tile <- tileNew (toRectangle (0,0,300,300)) Nothing+ box0 <- boxNew (toRectangle (0,0,150,150)) (Just "0")+ setBox box0 DownBox+ setColor box0 (Color 9)+ setLabelsize box0 (FontSize 36)+ setAlign box0 (Alignments [AlignTypeClip])++ w1 <- doubleWindowNew (Size (Width 150) (Height 150)) (Just (Position (X 150) (Y 0))) Nothing+ begin w1+ setBox w1 NoBox+ box1 <- boxNew (toRectangle (0,0,150,150)) (Just "1\nThis is a child window")+ setBox box1 DownBox+ setColor box1 (Color 19)+ setLabelsize box1 (FontSize 18)+ setAlign box1 (Alignments [AlignTypeClip, AlignTypeInside, AlignTypeWrap])+ _ <- setResizable w1 (Just box1)+ end w1++ box2a <- boxNew (toRectangle (0,150,70,150)) (Just "2a")+ setBox box2a DownBox+ setColor box2a (Color 12)+ setLabelsize box2a (FontSize 36)+ setAlign box2a (Alignments [AlignTypeClip])++ box2b <- boxNew (toRectangle (70,150,80,150)) (Just "2b")+ setBox box2b DownBox+ setColor box2b (Color 13)+ setLabelsize box2b (FontSize 36)+ setAlign box2b (Alignments [AlignTypeClip])++ box3a <- boxNew (toRectangle (150,150,150,70)) (Just "3a")+ setBox box3a DownBox+ setColor box3a (Color 12)+ setLabelsize box3a (FontSize 36)+ setAlign box3a (Alignments [AlignTypeClip])++ box3b <- boxNew (toRectangle (150,(150+70),150,80)) (Just "3b")+ setBox box3b DownBox+ setColor box3b (Color 13)+ setLabelsize box3b (FontSize 36)+ setAlign box3b (Alignments [AlignTypeClip])++ -- create the symmetrical resize box with dx and dy pixels distance, resp.+ -- from the borders of the Fl_Tile widget+ let dx = 20+ let dy = 20+ tileX <- getX tile+ tileY <- getY tile+ tileW <- getW tile+ tileH <- getH tile+ r <- boxNew (toRectangle ((tileX+dx), (tileY+dy), (tileW-(2*dx)), (tileH-(2*dy)))) Nothing+ _ <- setResizable tile (Just r)+ end tile+ end window++ _ <- showWidget w1+ _ <- showWidget window+ _ <- FL.run+ return ()
+ src/Examples/tree-simple.hs view
@@ -0,0 +1,48 @@+module Main where+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS++treeCallback :: Ref Tree -> IO ()+treeCallback tree' = do+ (Just item') <- getCallbackItem tree'+ reason' <- getCallbackReason tree'+ label' <- getLabel item'+ case reason' of+ TreeReasonSelected -> do+ (Just path') <- itemPathname tree' item'+ print $ "TreeCallback: Item selected =" ++ label' ++ "Full pathname=" ++ path' ++ "\n"+ TreeReasonDeselected ->+ print $ "TreeCallback: Item deselected =" ++ label' ++ "\n"+ TreeReasonOpened ->+ print $ "TreeCallback: Item opened =" ++ label' ++ "\n"+ TreeReasonClosed ->+ print $ "TreeCallback: Item closed =" ++ label' ++ "\n"+ _ -> print ""+main :: IO ()+main = do+ _ <- FL.setScheme "gtk+"+ window <- windowNew (toSize (250,400)) Nothing (Just "Simple Tree")+ begin window+ windowWidth' <- getW window+ windowHeight' <- getH window+ tree <- treeNew (toRectangle (10,10,windowWidth' - 20,windowHeight' - 20)) Nothing+ setShowroot tree False+ _ <- add tree "Flintstones/Fred"+ _ <- add tree "Flintstones/Wilma"+ _ <- add tree "Flintstones/Pebbles"+ _ <- add tree "Simpsons/Homer"+ _ <- add tree "Simpsons/Marge"+ _ <- add tree "Simpsons/Bart"+ _ <- add tree "Simpsons/Lisa"+ _ <- add tree "Pathnames/\\/bin"+ _ <- add tree "Pathnames/\\/usr\\/sbin"+ _ <- add tree "Pathnames/C:\\\\Program Files"+ _ <- add tree "Pathnames/C:\\\\Documents and Settings"+ close tree (TreeItemNameLocator (TreeItemName "Simpsons"))+ close tree (TreeItemNameLocator (TreeItemName "Pathnames"))+ setCallback tree treeCallback+ end window+ showWidget window+ _ <- FL.run+ return ()