fltkhs 0.2.0.2 → 0.3.0.0
raw patch · 25 files changed
+274/−110 lines, 25 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Graphics.UI.FLTK.LowLevel.Table: [drawCellCustom] :: CustomTableFuncs a -> Maybe (Ref a -> TableContext -> TableCoordinate -> Rectangle -> IO ())
- Graphics.UI.FLTK.LowLevel.Widget: [drawCustom] :: CustomWidgetFuncs a -> Maybe (Ref a -> IO ())
+ Graphics.UI.FLTK.LowLevel.Box: boxCustom :: Rectangle -> Maybe String -> Maybe (Ref Box -> IO ()) -> Maybe (CustomWidgetFuncs Box) -> IO (Ref Box)
+ Graphics.UI.FLTK.LowLevel.Box: boxCustomWithBoxtype :: Boxtype -> Rectangle -> String -> Maybe (Ref Box -> IO ()) -> Maybe (CustomWidgetFuncs Box) -> IO (Ref Box)
+ Graphics.UI.FLTK.LowLevel.Browser: browserCustom :: Rectangle -> Maybe String -> Maybe (Ref Browser -> IO ()) -> Maybe (CustomWidgetFuncs Browser) -> IO (Ref Browser)
+ Graphics.UI.FLTK.LowLevel.MenuPrim: menu_Custom :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs MenuPrim) -> IO (Ref MenuPrim)
+ Graphics.UI.FLTK.LowLevel.Valuator: valuatorCustom :: Rectangle -> Maybe String -> Maybe (Ref Valuator -> IO ()) -> Maybe (CustomWidgetFuncs Valuator) -> IO (Ref Valuator)
- Graphics.UI.FLTK.LowLevel.Box: boxNew :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs Box) -> IO (Ref Box)
+ Graphics.UI.FLTK.LowLevel.Box: boxNew :: Rectangle -> Maybe String -> IO (Ref Box)
- Graphics.UI.FLTK.LowLevel.Box: boxNewWithBoxtype :: Boxtype -> Rectangle -> String -> Maybe (CustomWidgetFuncs Box) -> IO (Ref Box)
+ Graphics.UI.FLTK.LowLevel.Box: boxNewWithBoxtype :: Boxtype -> Rectangle -> String -> IO (Ref Box)
- Graphics.UI.FLTK.LowLevel.Browser: browserNew :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs Browser) -> IO (Ref Browser)
+ Graphics.UI.FLTK.LowLevel.Browser: browserNew :: Rectangle -> Maybe String -> IO (Ref Browser)
- Graphics.UI.FLTK.LowLevel.Button: buttonCustom :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs Button) -> IO (Ref Button)
+ Graphics.UI.FLTK.LowLevel.Button: buttonCustom :: Rectangle -> Maybe String -> Maybe (Ref Button -> IO ()) -> Maybe (CustomWidgetFuncs Button) -> IO (Ref Button)
- Graphics.UI.FLTK.LowLevel.DoubleWindow: doubleWindowCustom :: Size -> Maybe Position -> Maybe String -> CustomWidgetFuncs DoubleWindow -> CustomWindowFuncs DoubleWindow -> IO (Ref DoubleWindow)
+ Graphics.UI.FLTK.LowLevel.DoubleWindow: doubleWindowCustom :: Size -> Maybe Position -> Maybe String -> Maybe (Ref DoubleWindow -> IO ()) -> CustomWidgetFuncs DoubleWindow -> CustomWindowFuncs DoubleWindow -> IO (Ref DoubleWindow)
- Graphics.UI.FLTK.LowLevel.GlWindow: glWindowCustom :: Size -> Maybe Position -> Maybe String -> CustomWidgetFuncs GlWindow -> CustomWindowFuncs GlWindow -> IO (Ref GlWindow)
+ Graphics.UI.FLTK.LowLevel.GlWindow: glWindowCustom :: Size -> Maybe Position -> Maybe String -> Maybe (Ref GlWindow -> IO ()) -> CustomWidgetFuncs GlWindow -> CustomWindowFuncs GlWindow -> IO (Ref GlWindow)
- Graphics.UI.FLTK.LowLevel.MenuPrim: menu_New :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs MenuPrim) -> IO (Ref MenuPrim)
+ Graphics.UI.FLTK.LowLevel.MenuPrim: menu_New :: Rectangle -> Maybe String -> IO (Ref MenuPrim)
- Graphics.UI.FLTK.LowLevel.SingleWindow: singleWindowCustom :: Size -> Maybe Position -> Maybe String -> CustomWidgetFuncs SingleWindow -> CustomWindowFuncs SingleWindow -> IO (Ref SingleWindow)
+ Graphics.UI.FLTK.LowLevel.SingleWindow: singleWindowCustom :: Size -> Maybe Position -> Maybe String -> Maybe (Ref SingleWindow -> IO ()) -> CustomWidgetFuncs SingleWindow -> CustomWindowFuncs SingleWindow -> IO (Ref SingleWindow)
- Graphics.UI.FLTK.LowLevel.Table: CustomTableFuncs :: Maybe (Ref a -> TableContext -> TableCoordinate -> Rectangle -> IO ()) -> Maybe (Ref a -> IO ()) -> Maybe (Ref a -> Int -> IO ()) -> Maybe (Ref a -> Int -> IO ()) -> CustomTableFuncs a
+ Graphics.UI.FLTK.LowLevel.Table: CustomTableFuncs :: Maybe (Ref a -> IO ()) -> Maybe (Ref a -> Int -> IO ()) -> Maybe (Ref a -> Int -> IO ()) -> CustomTableFuncs a
- Graphics.UI.FLTK.LowLevel.Table: fillCustomTableFunctionStruct :: (Parent a Table) => Ptr () -> CustomTableFuncs a -> IO ()
+ Graphics.UI.FLTK.LowLevel.Table: fillCustomTableFunctionStruct :: (Parent a Table) => Ptr () -> Maybe (Ref a -> TableContext -> TableCoordinate -> Rectangle -> IO ()) -> CustomTableFuncs a -> IO ()
- Graphics.UI.FLTK.LowLevel.Table: tableCustom :: Rectangle -> Maybe String -> CustomWidgetFuncs Table -> CustomTableFuncs Table -> IO (Ref Table)
+ Graphics.UI.FLTK.LowLevel.Table: tableCustom :: Rectangle -> Maybe String -> Maybe (Ref Table -> IO ()) -> (Ref Table -> TableContext -> TableCoordinate -> Rectangle -> IO ()) -> CustomWidgetFuncs Table -> CustomTableFuncs Table -> IO (Ref Table)
- Graphics.UI.FLTK.LowLevel.Table: tableCustomFunctionStruct :: (Parent a Widget, Parent b Table) => CustomWidgetFuncs a -> CustomTableFuncs b -> IO (Ptr ())
+ Graphics.UI.FLTK.LowLevel.Table: tableCustomFunctionStruct :: (Parent a Widget, Parent b Table) => Maybe (Ref a -> IO ()) -> Maybe (Ref b -> TableContext -> TableCoordinate -> Rectangle -> IO ()) -> CustomWidgetFuncs a -> CustomTableFuncs b -> IO (Ptr ())
- Graphics.UI.FLTK.LowLevel.TableRow: tableRowNew :: Rectangle -> Maybe String -> CustomWidgetFuncs TableRow -> CustomTableFuncs TableRow -> IO (Ref TableRow)
+ Graphics.UI.FLTK.LowLevel.TableRow: tableRowNew :: Rectangle -> Maybe String -> Maybe (Ref TableRow -> IO ()) -> (Ref TableRow -> TableContext -> TableCoordinate -> Rectangle -> IO ()) -> CustomWidgetFuncs TableRow -> CustomTableFuncs TableRow -> IO (Ref TableRow)
- Graphics.UI.FLTK.LowLevel.Valuator: valuatorNew :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs Valuator) -> IO (Ref Valuator)
+ Graphics.UI.FLTK.LowLevel.Valuator: valuatorNew :: Rectangle -> Maybe String -> IO (Ref Valuator)
- Graphics.UI.FLTK.LowLevel.Widget: CustomWidgetFuncs :: Maybe (Ref a -> IO ()) -> Maybe (Ref a -> Event -> IO Int) -> Maybe (Ref a -> Rectangle -> IO ()) -> Maybe (Ref a -> IO ()) -> Maybe (Ref a -> IO ()) -> CustomWidgetFuncs a
+ Graphics.UI.FLTK.LowLevel.Widget: CustomWidgetFuncs :: Maybe (Ref a -> Event -> IO Int) -> Maybe (Ref a -> Rectangle -> IO ()) -> Maybe (Ref a -> IO ()) -> Maybe (Ref a -> IO ()) -> CustomWidgetFuncs a
- Graphics.UI.FLTK.LowLevel.Widget: customWidgetFunctionStruct :: (Parent a Widget) => CustomWidgetFuncs a -> IO (Ptr ())
+ Graphics.UI.FLTK.LowLevel.Widget: customWidgetFunctionStruct :: (Parent a Widget) => Maybe (Ref a -> IO ()) -> CustomWidgetFuncs a -> IO (Ptr ())
- Graphics.UI.FLTK.LowLevel.Widget: fillCustomWidgetFunctionStruct :: (Parent a Widget) => Ptr () -> CustomWidgetFuncs a -> IO ()
+ Graphics.UI.FLTK.LowLevel.Widget: fillCustomWidgetFunctionStruct :: (Parent a Widget) => Ptr () -> Maybe (Ref a -> IO ()) -> CustomWidgetFuncs a -> IO ()
- Graphics.UI.FLTK.LowLevel.Widget: widgetMaker :: (Parent a Widget) => Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs a) -> (Int -> Int -> Int -> Int -> IO (Ptr ())) -> (Int -> Int -> Int -> Int -> String -> IO (Ptr ())) -> (Int -> Int -> Int -> Int -> Ptr () -> IO (Ptr ())) -> (Int -> Int -> Int -> Int -> String -> Ptr () -> IO (Ptr ())) -> IO (Ref a)
+ Graphics.UI.FLTK.LowLevel.Widget: widgetMaker :: (Parent a Widget) => Rectangle -> Maybe String -> Maybe (Ref a -> IO ()) -> Maybe (CustomWidgetFuncs a) -> (Int -> Int -> Int -> Int -> IO (Ptr ())) -> (Int -> Int -> Int -> Int -> String -> IO (Ptr ())) -> (Int -> Int -> Int -> Int -> Ptr () -> IO (Ptr ())) -> (Int -> Int -> Int -> Int -> String -> Ptr () -> IO (Ptr ())) -> IO (Ref a)
- Graphics.UI.FLTK.LowLevel.Window: fillCustomWidgetFunctionStruct :: (Parent a Widget) => Ptr () -> CustomWidgetFuncs a -> IO ()
+ Graphics.UI.FLTK.LowLevel.Window: fillCustomWidgetFunctionStruct :: (Parent a Widget) => Ptr () -> Maybe (Ref a -> IO ()) -> CustomWidgetFuncs a -> IO ()
- Graphics.UI.FLTK.LowLevel.Window: windowCustom :: Size -> Maybe Position -> Maybe String -> CustomWidgetFuncs Window -> CustomWindowFuncs Window -> IO (Ref Window)
+ Graphics.UI.FLTK.LowLevel.Window: windowCustom :: Size -> Maybe Position -> Maybe String -> Maybe (Ref Window -> IO ()) -> CustomWidgetFuncs Window -> CustomWindowFuncs Window -> IO (Ref Window)
- Graphics.UI.FLTK.LowLevel.Window: windowMaker :: (Parent a Window, Parent b Widget) => Size -> Maybe Position -> Maybe String -> CustomWidgetFuncs b -> CustomWindowFuncs a -> (Int -> Int -> Ptr () -> IO (Ptr ())) -> (Int -> Int -> String -> Ptr () -> IO (Ptr ())) -> (Int -> Int -> Int -> Int -> Ptr () -> IO (Ptr ())) -> (Int -> Int -> Int -> Int -> String -> Ptr () -> IO (Ptr ())) -> IO (Ref a)
+ Graphics.UI.FLTK.LowLevel.Window: windowMaker :: (Parent a Window, Parent b Widget) => Size -> Maybe Position -> Maybe String -> Maybe (Ref b -> IO ()) -> CustomWidgetFuncs b -> CustomWindowFuncs a -> (Int -> Int -> Ptr () -> IO (Ptr ())) -> (Int -> Int -> String -> Ptr () -> IO (Ptr ())) -> (Int -> Int -> Int -> Int -> Ptr () -> IO (Ptr ())) -> (Int -> Int -> Int -> Int -> String -> Ptr () -> IO (Ptr ())) -> IO (Ref a)
Files
- CMakeLists.txt +11/−14
- fltkhs.cabal +44/−1
- src/Examples/boxtype.hs +0/−1
- src/Examples/doublebuffer.hs +4/−6
- src/Examples/nativefilechooser-simple-app.hs +1/−1
- src/Examples/table-as-container.hs +3/−3
- src/Examples/table-simple.hs +3/−3
- src/Examples/table-sort.hs +3/−3
- src/Examples/table-spreadsheet-with-keyboard-nav.hs +3/−3
- src/Examples/tile.hs +7/−7
- src/Fluid/Generate.hs +0/−2
- src/Graphics/UI/FLTK/LowLevel/Box.chs +31/−6
- src/Graphics/UI/FLTK/LowLevel/Browser.chs +14/−2
- src/Graphics/UI/FLTK/LowLevel/Button.chs +8/−2
- src/Graphics/UI/FLTK/LowLevel/DoubleWindow.chs +10/−2
- src/Graphics/UI/FLTK/LowLevel/FLTKHS.hs +32/−0
- src/Graphics/UI/FLTK/LowLevel/GlWindow.chs +10/−7
- src/Graphics/UI/FLTK/LowLevel/MenuPrim.chs +15/−4
- src/Graphics/UI/FLTK/LowLevel/SingleWindow.chs +10/−2
- src/Graphics/UI/FLTK/LowLevel/Table.chs +18/−10
- src/Graphics/UI/FLTK/LowLevel/TableRow.chs +3/−3
- src/Graphics/UI/FLTK/LowLevel/Valuator.chs +13/−2
- src/Graphics/UI/FLTK/LowLevel/Widget.chs +16/−15
- src/Graphics/UI/FLTK/LowLevel/Window.chs +13/−8
- src/TestPrograms/TestCall.hs +2/−3
CMakeLists.txt view
@@ -1,33 +1,30 @@ CMAKE_MINIMUM_REQUIRED(VERSION 2.6) PROJECT(fltkc)-find_file(HAVE_FLTK_Z ${FLTK_HOME}/lib/libfltk_z.a)-find_file(HAVE_FLTK_JPEG ${FLTK_HOME}/lib/libfltk_jpeg.a)-find_file(HAVE_FLTK_PNG ${FLTK_HOME}/lib/libfltk_png.a)--if(HAVE_FLTK_Z)- SET(FLTK_Z HAVE_FLTK_Z)+if(EXISTS "${FLTK_HOME}/lib/libfltk_z.a")+ SET(FLTK_Z "${FLTK_HOME}/lib/libfltk_z.a") else() find_library(HAVE_Z z)- SET(FLTK_Z HAVE_Z)+ SET(FLTK_Z "${HAVE_Z}") endif() -if(HAVE_FLTK_JPEG)- SET(FLTK_JPEG HAVE_FLTK_JPEG)+if(EXISTS "${FLTK_HOME}/lib/libfltk_jpeg.a")+ SET(FLTK_JPEG "${FLTK_HOME}/lib/libfltk_jpeg.a") else() find_library(HAVE_JPEG jpeg)- SET(FLTK_JPEG HAVE_JPEG)+ SET(FLTK_JPEG "${HAVE_JPEG}") endif() -if(HAVE_FLTK_PNG)- SET(FLTK_PNG HAVE_FLTK_PNG)+if(EXISTS "${FLTK_HOME}/lib/libfltk_png.a")+ SET(FLTK_PNG "${FLTK_HOME}/lib/libfltk_png.a") else() find_library(HAVE_PNG png)- SET(FLTK_PNG HAVE_PNG)+ SET(FLTK_PNG "${HAVE_PNG}") endif() -SET(FLTKCONFIGCOMMAND "${FLTK_HOME}/lib/libfltk.a ${FLTK_HOME}/lib/libfltk_gl.a ${FLTK_HOME}/lib/libfltk_images.a ${FLTK_JPEG} ${FLTK_Z} ${FLTK_PNG} ${FLTK_HOME}/lib/libfltk_forms.a")+SET(FLTKCONFIGCOMMAND "${FLTK_HOME}/lib/libfltk.a ${FLTK_HOME}/lib/libfltk_gl.a ${FLTK_HOME}/lib/libfltk_images.a ${FLTK_PNG} ${FLTK_JPEG} ${FLTK_Z} ${FLTK_HOME}/lib/libfltk_forms.a") SET(FLTKCONFIGCOMMAND "${FLTKCONFIGCOMMAND} -mwindows -lglu32 -lopengl32 -lole32 -luuid -lcomctl32")+MESSAGE("${FLTKCONFIGCOMMAND}") CONFIGURE_FILE(${CMAKE_CURRENT_SOURCE_DIR}/fltkhs.buildinfo.in ${CMAKE_CURRENT_SOURCE_DIR}/fltkhs.buildinfo) FIND_PACKAGE(OpenGL REQUIRED)
fltkhs.cabal view
@@ -1,5 +1,5 @@ name : fltkhs-version : 0.2.0.2+version : 0.3.0.0 synopsis : FLTK bindings description: Low level bindings for the FLTK GUI toolkit.@@ -128,6 +128,11 @@ if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" +Flag FastCompile+ Description: Turn off optimizations for faster compilation+ Manual: True+ Default: True+ Executable fltkhs-pack Main-Is: pack.hs Hs-Source-Dirs: src/Examples@@ -137,6 +142,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -149,6 +156,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -161,6 +170,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -172,6 +183,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -183,6 +196,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -194,6 +209,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -205,6 +222,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -216,6 +235,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -227,6 +248,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -238,6 +261,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -249,6 +274,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -260,6 +287,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -271,6 +300,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -283,6 +314,8 @@ process default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -294,6 +327,8 @@ fltkhs default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -305,6 +340,8 @@ fltkhs,bytestring default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -316,6 +353,8 @@ fltkhs,bytestring default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -328,6 +367,8 @@ bytestring default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" @@ -340,5 +381,7 @@ bytestring default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300+ if impl(ghc >= 7.10) && flag(FastCompile)+ ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 if !os(darwin) ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"
src/Examples/boxtype.hs view
@@ -25,7 +25,6 @@ (Width $ if square' then rowHeight - 20 else windowWidth - 20) (Height $ rowHeight - 20))) label'- Nothing setLabelsize b' (FontSize 11) when square' $ setAlign b' alignRight main :: IO ()
src/Examples/doublebuffer.hs view
@@ -58,9 +58,8 @@ (Size (Width 400) (Height 400)) (Just (Position (X 10) (Y 10))) (Just "Single Window")- defaultCustomWidgetFuncs {- drawCustom = (Just $ (\w -> drawWindow sides' fst (safeCast w)))- }+ (Just (\w -> drawWindow sides' fst (safeCast w)))+ defaultCustomWidgetFuncs defaultCustomWindowFuncs setBox w1 FlatBox setColor w1 blackColor@@ -80,9 +79,8 @@ (Size (Width 400) (Height 400)) (Just $ Position (X 10) (Y 10)) (Just "Fl_Double_Window")- defaultCustomWidgetFuncs {- drawCustom = Just (\w -> drawWindow sides' snd (safeCast w))- }+ (Just (\w -> drawWindow sides' snd (safeCast w)))+ defaultCustomWidgetFuncs defaultCustomWindowFuncs setBox w2 FlatBox setColor w2 blackColor
src/Examples/nativefilechooser-simple-app.hs view
@@ -68,7 +68,7 @@ _ <- 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 Nothing+ 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])
src/Examples/table-as-container.hs view
@@ -100,10 +100,10 @@ table <- tableCustom (toRectangle (20,20,win_w-40,win_h-40)) (Just "FLTK widget table")+ Nothing+ drawCell defaultCustomWidgetFuncs- (defaultCustomTableFuncs{- drawCellCustom = (Just drawCell)- })+ defaultCustomTableFuncs initializeTable table setTableSize table 50 50 end win
src/Examples/table-simple.hs view
@@ -66,10 +66,10 @@ (Position (X 10) (Y 10)) (Size (Width 880) (Height 380))) Nothing+ Nothing+ drawCell defaultCustomWidgetFuncs- defaultCustomTableFuncs {- drawCellCustom = (Just drawCell)- }+ defaultCustomTableFuncs initializeTable table setResizable window (Just table) end window
src/Examples/table-sort.hs view
@@ -218,10 +218,10 @@ (Size (Width $ windowW - margin * 2) (Height $ windowH - margin * 2))) Nothing+ Nothing+ (drawCell tableState) defaultCustomWidgetFuncs- (defaultCustomTableFuncs {- drawCellCustom = Just $ drawCell tableState- })+ defaultCustomTableFuncs setColHeader table True setColResize table True setSelectionColor table yellowColor
@@ -241,10 +241,10 @@ spreadsheet' <- tableCustom (toRectangle (20,20,tableWidth', tableHeight')) Nothing+ Nothing+ (drawCell props' intInput') defaultCustomWidgetFuncs- defaultCustomTableFuncs {- drawCellCustom = (Just $ drawCell props' intInput')- }+ defaultCustomTableFuncs whens' <- getWhen spreadsheet' setWhen spreadsheet' $ [WhenNotChanged] ++ whens' setSelection spreadsheet' 0 0 0 0
src/Examples/tile.hs view
@@ -9,7 +9,7 @@ setBox window NoBox _ <- setResizable window (Just window) tile <- tileNew (toRectangle (0,0,300,300)) Nothing- box0 <- boxNew (toRectangle (0,0,150,150)) (Just "0") Nothing+ box0 <- boxNew (toRectangle (0,0,150,150)) (Just "0") setBox box0 DownBox setColor box0 (Color 9) setLabelsize box0 (FontSize 36)@@ -18,7 +18,7 @@ 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") Nothing+ 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)@@ -26,25 +26,25 @@ _ <- setResizable w1 (Just box1) end w1 - box2a <- boxNew (toRectangle (0,150,70,150)) (Just "2a") Nothing+ 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") Nothing+ 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") Nothing+ 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") Nothing+ box3b <- boxNew (toRectangle (150,(150+70),150,80)) (Just "3b") setBox box3b DownBox setColor box3b (Color 13) setLabelsize box3b (FontSize 36)@@ -58,7 +58,7 @@ tileY <- getY tile tileW <- getW tile tileH <- getH tile- r <- boxNew (toRectangle ((tileX+dx), (tileY+dy), (tileW-(2*dx)), (tileH-(2*dy)))) Nothing Nothing+ r <- boxNew (toRectangle ((tileX+dx), (tileY+dy), (tileW-(2*dx)), (tileH-(2*dy)))) Nothing _ <- setResizable tile (Just r) end tile end window
src/Fluid/Generate.hs view
@@ -98,8 +98,6 @@ ["-- Fl_Table " ++ (maybe "" id name) ++ " " ++ (show posSize)] | flClassName == "MenuItem" || flClassName == "Submenu" = [(maybe "_ <- " (\n -> n ++ " <- ") name) ++ "menuItemNew"]- | flClassName == "Fl_Browser" || flClassName == "Fl_Box" =- [typicalConstructorG name posSize hsConstructor ++ " Nothing"] | flClassName == "Fl_Window" = let (x,y,w,h) = posSize in [(maybe "_ <- " (\n -> n ++ " <- ") name) ++
src/Graphics/UI/FLTK/LowLevel/Box.chs view
@@ -4,7 +4,9 @@ ( -- * Constructor boxNew,- boxNewWithBoxtype+ boxNewWithBoxtype,+ boxCustom,+ boxCustomWithBoxtype -- * Hierarchy -- -- $hierarchy@@ -32,26 +34,49 @@ {# fun Fl_OverriddenBox_New as overriddenBoxNew' { `Int',`Int',`Int',`Int', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_Box_New_WithBoxtype as boxNewWithBoxtype' {cFromEnum `Boxtype', `Int',`Int',`Int',`Int',unsafeToCString `String'} -> `Ptr ()' id #} {# fun Fl_OverriddenBox_New_WithBoxtype as overriddenBoxNewWithBoxtype' {cFromEnum `Boxtype', `Int',`Int',`Int',`Int',unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #}-boxNew :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs Box) -> IO (Ref Box)-boxNew rectangle l' funcs' =++boxCustom :: Rectangle -- ^ The bounds of this box+ -> Maybe String -- ^ Optional label+ -> Maybe (Ref Box -> IO ()) -- ^ Optional custom box drawing function+ -> Maybe (CustomWidgetFuncs Box) -- ^ Optional widget overrides+ -> IO (Ref Box)+boxCustom rectangle l' draw' funcs' = widgetMaker rectangle l'+ draw' funcs' boxNew' boxNewWithLabel' overriddenBoxNew' overriddenBoxNewWithLabel' -boxNewWithBoxtype :: Boxtype -> Rectangle -> String -> Maybe (CustomWidgetFuncs Box) -> IO (Ref Box)-boxNewWithBoxtype boxtype' rectangle' l' funcs' =+boxCustomWithBoxtype :: Boxtype -> Rectangle -> String -> Maybe (Ref Box -> IO ()) -> Maybe (CustomWidgetFuncs Box) -> IO (Ref Box)+boxCustomWithBoxtype boxtype' rectangle' l' draw' funcs' = let (x_pos, y_pos, width, height) = fromRectangle rectangle' in case funcs' of Just fs -> do- ptr <- customWidgetFunctionStruct fs+ ptr <- customWidgetFunctionStruct draw' fs overriddenBoxNewWithBoxtype' boxtype' x_pos y_pos width height l' (castPtr ptr) >>= toRef Nothing -> boxNewWithBoxtype' boxtype' x_pos y_pos width height l' >>= toRef+++boxNew :: Rectangle -> Maybe String -> IO (Ref Box)+boxNew rectangle l' =+ let (x_pos, y_pos, width, height) = fromRectangle rectangle+ in case l' of+ Nothing -> boxNew' x_pos y_pos width height >>=+ toRef+ Just l -> boxNewWithLabel' x_pos y_pos width height l >>=+ toRef++boxNewWithBoxtype :: Boxtype -> Rectangle -> String -> IO (Ref Box)+boxNewWithBoxtype boxtype' rectangle' l' =+ let (x_pos, y_pos, width, height) = fromRectangle rectangle'+ in+ boxNewWithBoxtype' boxtype' x_pos y_pos width height l' >>=+ toRef {#fun Fl_Box_handle as boxHandle' { id `Ptr ()', id `CInt' } -> `Int' #} instance (impl ~ (Event -> IO Int)) => Op (Handle ()) Box orig impl where
src/Graphics/UI/FLTK/LowLevel/Browser.chs view
@@ -4,6 +4,7 @@ ( -- * Constructor browserNew,+ browserCustom -- * Hierarchy -- -- $hierarchy@@ -30,16 +31,27 @@ {# fun Fl_Browser_New_WithLabel as browserNewWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `String'} -> `Ptr ()' id #} {# fun Fl_OverriddenBrowser_New_WithLabel as overriddenBrowserNewWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenBrowser_New as overriddenBrowserNew' { `Int',`Int',`Int',`Int', id `Ptr ()'} -> `Ptr ()' id #}-browserNew :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs Browser) -> IO (Ref Browser)-browserNew rectangle l' funcs' =+browserCustom :: Rectangle -> Maybe String -> Maybe (Ref Browser -> IO ()) -> Maybe (CustomWidgetFuncs Browser) -> IO (Ref Browser)+browserCustom rectangle l' draw' funcs' = widgetMaker rectangle l'+ draw' funcs' browserNew' browserNewWithLabel' overriddenBrowserNew' overriddenBrowserNewWithLabel'++browserNew :: Rectangle -> Maybe String -> IO (Ref Browser)+browserNew rectangle l' =+ let (x_pos, y_pos, width, height) = fromRectangle rectangle+ in case l' of+ Nothing -> browserNew' x_pos y_pos width height >>=+ toRef+ Just l -> browserNewWithLabel' x_pos y_pos width height l >>=+ toRef+ {#fun Fl_Browser_handle as browserHandle' { id `Ptr ()', id `CInt' } -> `Int' #} instance (impl ~ (Event -> IO Int)) => Op (Handle ()) Browser orig impl where
src/Graphics/UI/FLTK/LowLevel/Button.chs view
@@ -33,11 +33,16 @@ {# fun Fl_Button_New_WithLabel as widgetNewWithLabel' { `Int',`Int',`Int',`Int', unsafeToCString `String'} -> `Ptr ()' id #} {# fun Fl_OverriddenButton_New_WithLabel as overriddenWidgetNewWithLabel' { `Int',`Int',`Int',`Int', unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenButton_New as overriddenWidgetNew' { `Int',`Int',`Int',`Int', id `Ptr ()'} -> `Ptr ()' id #}-buttonCustom :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs Button) -> IO (Ref Button)-buttonCustom rectangle l' funcs' =+buttonCustom :: Rectangle -- ^ The bounds of this button+ -> Maybe String -- ^ The button label+ -> Maybe (Ref Button -> IO ()) -- ^ Optional custom drawing function+ -> Maybe (CustomWidgetFuncs Button) -- ^ Optional custom widget functions+ -> IO (Ref Button)+buttonCustom rectangle l' draw' funcs' = widgetMaker rectangle l'+ draw' funcs' widgetNew' widgetNewWithLabel'@@ -49,6 +54,7 @@ widgetMaker rectangle l'+ Nothing Nothing widgetNew' widgetNewWithLabel'
src/Graphics/UI/FLTK/LowLevel/DoubleWindow.chs view
@@ -31,12 +31,19 @@ {# fun Fl_OverriddenDouble_Window_NewXY as overriddenWindowNewXY' {`Int',`Int', `Int', `Int', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenDouble_Window_NewXY_WithLabel as overriddenWindowNewXYWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenDouble_Window_New_WithLabel as overriddenWindowNewWithLabel' { `Int',`Int', unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #}-doubleWindowCustom :: Size -> Maybe Position -> Maybe String -> CustomWidgetFuncs DoubleWindow -> CustomWindowFuncs DoubleWindow -> IO (Ref DoubleWindow)-doubleWindowCustom size position title customWidgetFuncs' customWindowFuncs' =+doubleWindowCustom :: Size -- ^ Size of this window+ -> Maybe Position -- ^ Optional position of this window+ -> Maybe String -- ^ Optional label+ -> Maybe (Ref DoubleWindow -> IO ()) -- ^ Optional table drawing routine+ -> CustomWidgetFuncs DoubleWindow -- ^ Custom widget overrides+ -> CustomWindowFuncs DoubleWindow -- ^ Custom window overrides+ -> IO (Ref DoubleWindow)+doubleWindowCustom size position title draw' customWidgetFuncs' customWindowFuncs' = windowMaker size position title+ draw' customWidgetFuncs' customWindowFuncs' overriddenWindowNew'@@ -50,6 +57,7 @@ size position title+ Nothing (defaultCustomWidgetFuncs :: CustomWidgetFuncs DoubleWindow) (defaultCustomWindowFuncs :: CustomWindowFuncs DoubleWindow) overriddenWindowNew'
src/Graphics/UI/FLTK/LowLevel/FLTKHS.hs view
@@ -36,6 +36,10 @@ -- -- $APIGuide + -- * Slow Compilation Issues+ --+ -- $Compilation+ -- * Core Types module Graphics.UI.FLTK.LowLevel.Fl_Types, -- * Widgets@@ -636,6 +640,34 @@ -- being able to get at the default implementation out-weighs the trap the user might fall into. If this becomes a pervasive problem the author is -- open to removing this functionality. --++-- $Compilation+--+-- As described above, the API emulates multiple dispatch using type-level programming and typeclasseses. While this is makes for a nice API it has also+-- slowed down compilation of executables much more than expected. This is especially true in the GHC 7.10.x series in which the step where GHC specialises typeclass+-- function calls to concrete types has apparently taken a *huge* compile-time performance hit.+--+-- To clarify the time taken to compile the library itself has not changed, but applications that use the library to create executables are taking a lot+-- longer (almost 3x compared to GHC 7.8.x) to compile. To further emphasize, there does not appear to be any runtime performance issues. This is only a+-- compile time problem.+--+-- To preserve the user's and the author's sanity a flag `fastCompile` has been introduced to this package and to the <http://hackage.haskell.org/fltkhs-fluid-examples fltkhs-fluid-examples>.+-- This flag which tells the compiler to skip the specialising step when compiling executables, dramatically decreases compile time but also bloats the resulting executable size and+-- probably makes runtime performance much slower. In this package and <http://hackage.haskell.org/fltkhs-fluid-examples fltkhs-fluid-examples> it is enabled by default, since the executables are just+-- demos that are not meant to show off performance. To disable this flag, tell Cabal to ignore it during the `configure` step:+--+-- @+-- cabal configure -f-fastCompile+-- @+--+-- In the <https://github.com/deech/fltkhs-hello-world fltkhs> and the <https://github.com/deech/fltkhs-fluid-hello-world fltkhs-fluid> project skeletons this flag is /disabled/ by+-- default to provide the best runtime performance. To enable the flag for a smoother development workflow, tell Cabal to enable it during the `configure` step:+--+-- @+-- cabal configure -f fastCompile+-- @++ -- =File Layout -- @ -- Root
src/Graphics/UI/FLTK/LowLevel/GlWindow.chs view
@@ -31,17 +31,19 @@ {# fun Fl_OverriddenGl_Window_NewXY as overriddenWindowNewXY' {`Int',`Int', `Int', `Int', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenGl_Window_NewXY_WithLabel as overriddenWindowNewXYWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenGl_Window_New_WithLabel as overriddenWindowNewWithLabel' { `Int',`Int', unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #}-glWindowCustom :: Size ->- Maybe Position ->- Maybe String ->- CustomWidgetFuncs GlWindow ->- CustomWindowFuncs GlWindow ->- IO (Ref GlWindow)-glWindowCustom size position title customWidgetFuncs' customWindowFuncs' =+glWindowCustom :: Size -- ^ The size of this window+ -> Maybe Position -- ^ The position of this window+ -> Maybe String -- ^ The window label+ -> Maybe (Ref GlWindow -> IO ()) -- ^ Optional custom drawing function+ -> CustomWidgetFuncs GlWindow -- ^ other custom widget functions+ -> CustomWindowFuncs GlWindow -- ^ Other custom window functions+ -> IO (Ref GlWindow)+glWindowCustom size position title draw' customWidgetFuncs' customWindowFuncs' = windowMaker size position title+ draw' customWidgetFuncs' customWindowFuncs' overriddenWindowNew'@@ -54,6 +56,7 @@ size position title+ Nothing (defaultCustomWidgetFuncs :: CustomWidgetFuncs GlWindow) (defaultCustomWindowFuncs :: CustomWindowFuncs GlWindow) overriddenWindowNew'
src/Graphics/UI/FLTK/LowLevel/MenuPrim.chs view
@@ -2,7 +2,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.UI.FLTK.LowLevel.MenuPrim (- menu_New+ menu_New,+ menu_Custom -- * Hierarchy -- -- $hierarchy@@ -31,17 +32,28 @@ {# fun Fl_Menu__New_WithLabel as widgetNewWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `String'} -> `Ptr ()' id #} {# fun Fl_OverriddenMenu__New_WithLabel as overriddenWidgetNewWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenMenu__New as overriddenWidgetNew' { `Int',`Int',`Int',`Int', id `Ptr ()'} -> `Ptr ()' id #}-menu_New :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs MenuPrim) -> IO (Ref MenuPrim)-menu_New rectangle l' funcs' =+menu_Custom :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs MenuPrim) -> IO (Ref MenuPrim)+menu_Custom rectangle l' funcs' = widgetMaker rectangle l'+ Nothing funcs' widgetNew' widgetNewWithLabel' overriddenWidgetNew' overriddenWidgetNewWithLabel' +menu_New :: Rectangle -> Maybe String -> IO (Ref MenuPrim)+menu_New rectangle l' =+ let (x_pos, y_pos, width, height) = fromRectangle rectangle+ in case l' of+ Nothing -> widgetNew' x_pos y_pos width height >>=+ toRef+ Just l -> widgetNewWithLabel' x_pos y_pos width height l >>=+ toRef++ {# fun Fl_Menu__Destroy as widgetDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #} instance (impl ~ (IO ())) => Op (Destroy ()) MenuPrim orig impl where runOp _ _ menu_ = swapRef menu_ $@@ -119,7 +131,6 @@ {# fun Fl_Menu__global as global' { id `Ptr ()' } -> `()' #} instance (impl ~ ( IO ())) => Op (Global ()) MenuPrim orig impl where runOp _ _ menu_ = withRef menu_ $ \menu_Ptr -> global' menu_Ptr-{# fun Fl_Menu__menu as menu' { id `Ptr ()' } -> `Ptr ()' id #} {# fun Fl_Menu__get_menu_item_by_index as getMenuItemByIndex' { id `Ptr ()', id `CInt' } -> `Ptr ()' id #} instance (impl ~ ( IO [(Maybe (Ref MenuItem))])) => Op (GetMenu ()) MenuPrim orig impl where runOp _ _ menu_ = withRef menu_ $ \menu_Ptr -> do
src/Graphics/UI/FLTK/LowLevel/SingleWindow.chs view
@@ -30,12 +30,19 @@ {# fun Fl_OverriddenSingle_Window_NewXY as overriddenWindowNewXY' {`Int',`Int', `Int', `Int', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenSingle_Window_NewXY_WithLabel as overriddenWindowNewXYWithLabel' { `Int',`Int',`Int',`Int', unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenSingle_Window_New_WithLabel as overriddenWindowNewWithLabel' { `Int',`Int', unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #}-singleWindowCustom :: Size -> Maybe Position -> Maybe String -> CustomWidgetFuncs SingleWindow -> CustomWindowFuncs SingleWindow -> IO (Ref SingleWindow)-singleWindowCustom size position title customWidgetFuncs' customWindowFuncs' =+singleWindowCustom :: Size -- ^ Size of this window+ -> Maybe Position -- ^ Optional position of this window+ -> Maybe String -- ^ Optional label+ -> Maybe (Ref SingleWindow -> IO ()) -- ^ Optional custom drawing function+ -> CustomWidgetFuncs SingleWindow -- ^ Custom widget overrides+ -> CustomWindowFuncs SingleWindow -- ^ Custom window overrides+ -> IO (Ref SingleWindow)+singleWindowCustom size position title draw' customWidgetFuncs' customWindowFuncs' = windowMaker size position title+ draw' customWidgetFuncs' customWindowFuncs' overriddenWindowNew'@@ -49,6 +56,7 @@ size position title+ Nothing (defaultCustomWidgetFuncs :: CustomWidgetFuncs SingleWindow) (defaultCustomWindowFuncs :: CustomWindowFuncs SingleWindow) overriddenWindowNew'
src/Graphics/UI/FLTK/LowLevel/Table.chs view
@@ -84,45 +84,53 @@ data CustomTableFuncs a = CustomTableFuncs {- drawCellCustom :: Maybe (Ref a -> TableContext -> TableCoordinate -> Rectangle -> IO ())- ,clearCustom :: Maybe (Ref a -> IO ())+ clearCustom :: Maybe (Ref a -> IO ()) ,setRowsCustom :: Maybe (Ref a -> Int -> IO ()) ,setColsCustom :: Maybe (Ref a -> Int -> IO ()) } fillCustomTableFunctionStruct :: forall a. (Parent a Table) => Ptr () ->+ Maybe (Ref a -> TableContext -> TableCoordinate -> Rectangle -> IO ()) -> CustomTableFuncs a -> IO ()-fillCustomTableFunctionStruct structPtr (CustomTableFuncs _drawCell' _clear' _setRows' _setCols') = do+fillCustomTableFunctionStruct structPtr _drawCell' (CustomTableFuncs _clear' _setRows' _setCols') = do toDrawCellPrim `orNullFunPtr` _drawCell' >>= {#set fl_Table_Virtual_Funcs->draw_cell#} structPtr toCallbackPrim `orNullFunPtr` _clear' >>= {#set fl_Table_Virtual_Funcs->clear#} structPtr toSetIntPrim `orNullFunPtr` _setRows' >>= {#set fl_Table_Virtual_Funcs->set_rows#} structPtr toSetIntPrim `orNullFunPtr` _setCols' >>= {#set fl_Table_Virtual_Funcs->set_cols#} structPtr defaultCustomTableFuncs :: forall a. (Parent a Table) => CustomTableFuncs a-defaultCustomTableFuncs = CustomTableFuncs Nothing Nothing Nothing Nothing+defaultCustomTableFuncs = CustomTableFuncs Nothing Nothing Nothing {# fun Fl_Table_default_virtual_funcs as virtualFuncs' {} -> `Ptr ()' id #} tableCustomFunctionStruct :: (Parent a Widget, Parent b Table) =>+ Maybe (Ref a -> IO ()) ->+ Maybe (Ref b -> TableContext -> TableCoordinate -> Rectangle -> IO ()) -> CustomWidgetFuncs a -> CustomTableFuncs b -> IO (Ptr ())-tableCustomFunctionStruct customWidgetFuncs' customTableFuncs' =+tableCustomFunctionStruct draw' drawCell' customWidgetFuncs' customTableFuncs' = do ptr <- virtualFuncs'- fillCustomWidgetFunctionStruct ptr customWidgetFuncs'- fillCustomTableFunctionStruct ptr customTableFuncs'+ fillCustomWidgetFunctionStruct ptr draw' customWidgetFuncs'+ fillCustomTableFunctionStruct ptr drawCell' customTableFuncs' return ptr {# fun Fl_Table_New as tableNew' { `Int',`Int', `Int', `Int', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_Table_New_WithLabel as tableNewWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #}-tableCustom :: Rectangle -> Maybe String -> CustomWidgetFuncs Table -> CustomTableFuncs Table -> IO (Ref Table)-tableCustom rectangle label' customWidgetFuncs' customTableFuncs' =+tableCustom :: Rectangle -- ^ Bounds of this table+ -> Maybe String -- ^ Optional label+ -> Maybe (Ref Table -> IO ()) -- ^ Optional custom table drawing function+ -> (Ref Table -> TableContext -> TableCoordinate -> Rectangle -> IO ()) -- ^ Custom table cell drawing function+ -> CustomWidgetFuncs Table -- ^ Widget overrides+ -> CustomTableFuncs Table -- ^ Table overrides+ -> IO (Ref Table)+tableCustom rectangle label' draw' drawCell' customWidgetFuncs' customTableFuncs' = do let (x_pos, y_pos, width, height) = fromRectangle rectangle- ptr <- tableCustomFunctionStruct customWidgetFuncs' customTableFuncs'+ ptr <- tableCustomFunctionStruct draw' (Just drawCell') customWidgetFuncs' customTableFuncs' case label' of (Just l') -> tableNewWithLabel' x_pos y_pos width height l' ptr >>= toRef Nothing -> tableNew' x_pos y_pos width height ptr >>= toRef
src/Graphics/UI/FLTK/LowLevel/TableRow.chs view
@@ -30,11 +30,11 @@ {# fun Fl_OverriddenTable_Row_New as tableRowNew' { `Int',`Int', `Int', `Int', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenTable_Row_New_WithLabel as tableRowNewWithLabel' { `Int',`Int',`Int',`Int', unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #}-tableRowNew :: Rectangle -> Maybe String -> CustomWidgetFuncs TableRow -> CustomTableFuncs TableRow -> IO (Ref TableRow)-tableRowNew rectangle label' customWidgetFuncs' customTableFuncs' =+tableRowNew :: Rectangle -> Maybe String -> Maybe (Ref TableRow -> IO ()) -> (Ref TableRow -> TableContext -> TableCoordinate -> Rectangle -> IO ()) -> CustomWidgetFuncs TableRow -> CustomTableFuncs TableRow -> IO (Ref TableRow)+tableRowNew rectangle label' draw' drawCell' customWidgetFuncs' customTableFuncs' = do let (x_pos, y_pos, width, height) = fromRectangle rectangle- ptr <- tableCustomFunctionStruct customWidgetFuncs' customTableFuncs'+ ptr <- tableCustomFunctionStruct draw' (Just drawCell') customWidgetFuncs' customTableFuncs' case label' of (Just l') -> tableRowNewWithLabel' x_pos y_pos width height l' ptr >>= toRef Nothing -> tableRowNew' x_pos y_pos width height ptr >>= toRef
src/Graphics/UI/FLTK/LowLevel/Valuator.chs view
@@ -4,6 +4,7 @@ ( -- * Constructor valuatorNew,+ valuatorCustom, ValuatorType(..), -- * Hierarchy --@@ -38,16 +39,26 @@ {# fun Fl_Valuator_New_WithLabel as valuatorNewWithLabel' { `Int',`Int',`Int',`Int', unsafeToCString `String'} -> `Ptr ()' id #} {# fun Fl_OverriddenValuator_New_WithLabel as overriddenValuatorNewWithLabel' { `Int',`Int',`Int',`Int', unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenValuator_New as overriddenValuatorNew' { `Int',`Int',`Int',`Int', id `Ptr ()'} -> `Ptr ()' id #}-valuatorNew :: Rectangle -> Maybe String -> Maybe (CustomWidgetFuncs Valuator) -> IO (Ref Valuator)-valuatorNew rectangle l' funcs' =+valuatorCustom :: Rectangle -> Maybe String -> Maybe (Ref Valuator -> IO ()) -> Maybe (CustomWidgetFuncs Valuator) -> IO (Ref Valuator)+valuatorCustom rectangle l' draw' funcs' = widgetMaker rectangle l'+ draw' funcs' valuatorNew' valuatorNewWithLabel' overriddenValuatorNew' overriddenValuatorNewWithLabel'++valuatorNew :: Rectangle -> Maybe String -> IO (Ref Valuator)+valuatorNew rectangle l' =+ let (x_pos, y_pos, width, height) = fromRectangle rectangle+ in case l' of+ Nothing -> valuatorNew' x_pos y_pos width height >>=+ toRef+ Just l -> valuatorNewWithLabel' x_pos y_pos width height l >>=+ toRef {# fun Fl_Valuator_Destroy as valuatorDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #} instance (impl ~ (IO ())) => Op (Destroy ()) Valuator orig impl where
src/Graphics/UI/FLTK/LowLevel/Widget.chs view
@@ -63,10 +63,8 @@ data CustomWidgetFuncs a = CustomWidgetFuncs {- -- | See <http://www.fltk.org/doc-1.3/classFl__Widget.html#a1acb38c6b3cb40452ad02ccfeedbac8a Fl_Widget::draw>- drawCustom :: Maybe (Ref a -> IO ()) -- | See <http://www.fltk.org/doc-1.3/classFl__Widget.html#a9cb17cc092697dfd05a3fab55856d218 Fl_Widget::handle>- ,handleCustom :: Maybe (Ref a -> Event -> IO Int)+ handleCustom :: Maybe (Ref a -> Event -> IO Int) -- | See <http://www.fltk.org/doc-1.3/classFl__Widget.html#aca98267e7a9b94f699ebd27d9f59e8bb Fl_Widget::resize> ,resizeCustom :: Maybe (Ref a -> Rectangle -> IO ()) -- | See <http://www.fltk.org/doc-1.3/classFl__Widget.html#ab572c6fbc922bf3268b72cf9e2939606 Fl_Widget::show>@@ -83,9 +81,10 @@ -- Only of interest to 'Widget' contributors fillCustomWidgetFunctionStruct :: forall a. (Parent a Widget) => Ptr () ->+ Maybe (Ref a -> IO ()) -> CustomWidgetFuncs a -> IO ()-fillCustomWidgetFunctionStruct structPtr (CustomWidgetFuncs _draw' _handle' _resize' _show' _hide') = do+fillCustomWidgetFunctionStruct structPtr _draw' (CustomWidgetFuncs _handle' _resize' _show' _hide') = do toCallbackPrim `orNullFunPtr` _draw' >>= {#set fl_Widget_Virtual_Funcs->draw#} structPtr toEventHandlerPrim `orNullFunPtr` _handle' >>= {#set fl_Widget_Virtual_Funcs->handle#} structPtr toRectangleFPrim `orNullFunPtr` _resize' >>= {#set fl_Widget_Virtual_Funcs->resize#} structPtr@@ -98,11 +97,12 @@ -- -- Only of interest to 'Widget' contributors. customWidgetFunctionStruct :: forall a. (Parent a Widget) =>+ Maybe (Ref a -> IO ()) -> CustomWidgetFuncs a -> IO (Ptr ())-customWidgetFunctionStruct customWidgetFuncs' = do+customWidgetFunctionStruct draw' customWidgetFuncs' = do p <- virtualFuncs'- fillCustomWidgetFunctionStruct p customWidgetFuncs'+ fillCustomWidgetFunctionStruct p draw' customWidgetFuncs' return p -- | An empty set of functions to pass to 'widgetCustom'.@@ -113,7 +113,6 @@ Nothing Nothing Nothing- Nothing -- | Lots of 'Widget' subclasses have the same constructor parameters. This function consolidates them. --@@ -121,22 +120,23 @@ widgetMaker :: forall a. (Parent a Widget) => Rectangle -- ^ Position and size -> Maybe String -- ^ Title+ -> Maybe (Ref a -> IO ()) -- ^ Custom drawing function -> Maybe (CustomWidgetFuncs a) -- ^ Custom functions -> (Int -> Int -> Int -> Int -> IO ( Ptr ())) -- ^ Foreign constructor to call if neither title nor custom functions are given -> (Int -> Int -> Int -> Int -> String -> IO ( Ptr () )) -- ^ Foreign constructor to call if only title is given -> (Int -> Int -> Int -> Int -> Ptr () -> IO ( Ptr () )) -- ^ Foreign constructor to call if only custom functions are given -> (Int -> Int -> Int -> Int -> String -> Ptr () -> IO ( Ptr () )) -- ^ Foreign constructor to call if both title and custom functions are given -> IO (Ref a) -- ^ Reference to the widget-widgetMaker rectangle _label' customFuncs' new' newWithLabel' newWithCustomFuncs' newWithCustomFuncsLabel' =+widgetMaker rectangle _label' draw' customFuncs' new' newWithLabel' newWithCustomFuncs' newWithCustomFuncsLabel' = let (x_pos, y_pos, width, height) = fromRectangle rectangle in case (_label', customFuncs') of (Nothing,Nothing) -> new' x_pos y_pos width height >>= toRef ((Just l), Nothing) -> newWithLabel' x_pos y_pos width height l >>= toRef ((Just l), (Just fs)) -> do- ptr <- customWidgetFunctionStruct fs+ ptr <- customWidgetFunctionStruct draw' fs newWithCustomFuncsLabel' x_pos y_pos width height l (castPtr ptr) >>= toRef (Nothing, (Just fs)) -> do- ptr <- customWidgetFunctionStruct fs+ ptr <- customWidgetFunctionStruct draw' fs newWithCustomFuncs' x_pos y_pos width height (castPtr ptr) >>= toRef {# fun Fl_Widget_New as widgetNew' { `Int',`Int',`Int',`Int' } -> `Ptr ()' id #}@@ -144,16 +144,17 @@ {# fun Fl_OverriddenWidget_New_WithLabel as overriddenWidgetNewWithLabel' { `Int',`Int',`Int',`Int', unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenWidget_New as overriddenWidgetNew' { `Int',`Int',`Int',`Int', id `Ptr ()'} -> `Ptr ()' id #} -- | Widget constructor.-widgetCustom :: Rectangle- -> Maybe String- -> (Ref Widget -> IO ())- -> CustomWidgetFuncs Widget+widgetCustom :: Rectangle -- ^ The bounds of this widget+ -> Maybe String -- ^ The widget label+ -> (Ref Widget -> IO ()) -- ^ Custom drawing function+ -> CustomWidgetFuncs Widget -- ^ Other custom functions -> IO (Ref Widget) widgetCustom rectangle l' draw' funcs' = widgetMaker rectangle l'- (Just funcs' { drawCustom = (Just draw') })+ (Just draw')+ (Just funcs') widgetNew' widgetNewWithLabel' overriddenWidgetNew'
src/Graphics/UI/FLTK/LowLevel/Window.chs view
@@ -89,6 +89,7 @@ Size -> Maybe Position -> Maybe String ->+ Maybe (Ref b -> IO ()) -> CustomWidgetFuncs b -> CustomWindowFuncs a -> (Int -> Int -> Ptr () -> IO (Ptr ())) ->@@ -99,6 +100,7 @@ windowMaker (Size (Width w) (Height h)) position title+ draw' customWidgetFuncs' customWindowFuncs' custom'@@ -107,7 +109,7 @@ customXYWithLabel' = do p <- virtualFuncs'- fillCustomWidgetFunctionStruct p customWidgetFuncs'+ fillCustomWidgetFunctionStruct p draw' customWidgetFuncs' fillCustomWindowFunctionStruct p customWindowFuncs' case (position, title) of (Nothing, Nothing) -> custom' w h p >>= toRef@@ -119,17 +121,19 @@ {# fun Fl_OverriddenWindow_NewXY as overriddenWindowNewXY' {`Int',`Int', `Int', `Int', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenWindow_NewXY_WithLabel as overriddenWindowNewXYWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #} {# fun Fl_OverriddenWindow_New_WithLabel as overriddenWindowNewWithLabel' { `Int',`Int', unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #}-windowCustom :: Size ->- Maybe Position ->- Maybe String ->- CustomWidgetFuncs Window ->- CustomWindowFuncs Window ->- IO (Ref Window)-windowCustom size position title customWidgetFuncs' customWindowFuncs' =+windowCustom :: Size -- ^ Size of this window+ -> Maybe Position -- ^ Optional position of this window+ -> Maybe String -- ^ Optional label+ -> Maybe (Ref Window -> IO ()) -- ^ Optional table drawing routine+ -> CustomWidgetFuncs Window -- ^ Custom widget overrides+ -> CustomWindowFuncs Window -- ^ Custom window overrides+ -> IO (Ref Window)+windowCustom size position title draw' customWidgetFuncs' customWindowFuncs' = windowMaker size position title+ draw' customWidgetFuncs' customWindowFuncs' overriddenWindowNew'@@ -143,6 +147,7 @@ size position title+ Nothing (defaultCustomWidgetFuncs :: CustomWidgetFuncs Window) (defaultCustomWindowFuncs :: CustomWindowFuncs Window) overriddenWindowNew'
src/TestPrograms/TestCall.hs view
@@ -30,9 +30,8 @@ (Size (Width 100) (Height 100)) Nothing (Just "Test")- (defaultCustomWidgetFuncs {- drawCustom = (Just drawOverride)- })+ (Just drawOverride)+ defaultCustomWidgetFuncs defaultCustomWindowFuncs button1 <- addButton 10 30 "button 1" button2 <- addButton 10 70 "button 2"