diff --git a/CMakeLists.txt b/CMakeLists.txt --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -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) diff --git a/fltkhs.cabal b/fltkhs.cabal --- a/fltkhs.cabal +++ b/fltkhs.cabal @@ -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" diff --git a/src/Examples/boxtype.hs b/src/Examples/boxtype.hs --- a/src/Examples/boxtype.hs +++ b/src/Examples/boxtype.hs @@ -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 () diff --git a/src/Examples/doublebuffer.hs b/src/Examples/doublebuffer.hs --- a/src/Examples/doublebuffer.hs +++ b/src/Examples/doublebuffer.hs @@ -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 diff --git a/src/Examples/nativefilechooser-simple-app.hs b/src/Examples/nativefilechooser-simple-app.hs --- a/src/Examples/nativefilechooser-simple-app.hs +++ b/src/Examples/nativefilechooser-simple-app.hs @@ -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]) diff --git a/src/Examples/table-as-container.hs b/src/Examples/table-as-container.hs --- a/src/Examples/table-as-container.hs +++ b/src/Examples/table-as-container.hs @@ -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 diff --git a/src/Examples/table-simple.hs b/src/Examples/table-simple.hs --- a/src/Examples/table-simple.hs +++ b/src/Examples/table-simple.hs @@ -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 diff --git a/src/Examples/table-sort.hs b/src/Examples/table-sort.hs --- a/src/Examples/table-sort.hs +++ b/src/Examples/table-sort.hs @@ -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 diff --git a/src/Examples/table-spreadsheet-with-keyboard-nav.hs b/src/Examples/table-spreadsheet-with-keyboard-nav.hs --- a/src/Examples/table-spreadsheet-with-keyboard-nav.hs +++ b/src/Examples/table-spreadsheet-with-keyboard-nav.hs @@ -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 diff --git a/src/Examples/tile.hs b/src/Examples/tile.hs --- a/src/Examples/tile.hs +++ b/src/Examples/tile.hs @@ -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 diff --git a/src/Fluid/Generate.hs b/src/Fluid/Generate.hs --- a/src/Fluid/Generate.hs +++ b/src/Fluid/Generate.hs @@ -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) ++ diff --git a/src/Graphics/UI/FLTK/LowLevel/Box.chs b/src/Graphics/UI/FLTK/LowLevel/Box.chs --- a/src/Graphics/UI/FLTK/LowLevel/Box.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Box.chs @@ -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 diff --git a/src/Graphics/UI/FLTK/LowLevel/Browser.chs b/src/Graphics/UI/FLTK/LowLevel/Browser.chs --- a/src/Graphics/UI/FLTK/LowLevel/Browser.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Browser.chs @@ -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 diff --git a/src/Graphics/UI/FLTK/LowLevel/Button.chs b/src/Graphics/UI/FLTK/LowLevel/Button.chs --- a/src/Graphics/UI/FLTK/LowLevel/Button.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Button.chs @@ -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' diff --git a/src/Graphics/UI/FLTK/LowLevel/DoubleWindow.chs b/src/Graphics/UI/FLTK/LowLevel/DoubleWindow.chs --- a/src/Graphics/UI/FLTK/LowLevel/DoubleWindow.chs +++ b/src/Graphics/UI/FLTK/LowLevel/DoubleWindow.chs @@ -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' diff --git a/src/Graphics/UI/FLTK/LowLevel/FLTKHS.hs b/src/Graphics/UI/FLTK/LowLevel/FLTKHS.hs --- a/src/Graphics/UI/FLTK/LowLevel/FLTKHS.hs +++ b/src/Graphics/UI/FLTK/LowLevel/FLTKHS.hs @@ -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 . +-- 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 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 and the 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 diff --git a/src/Graphics/UI/FLTK/LowLevel/GlWindow.chs b/src/Graphics/UI/FLTK/LowLevel/GlWindow.chs --- a/src/Graphics/UI/FLTK/LowLevel/GlWindow.chs +++ b/src/Graphics/UI/FLTK/LowLevel/GlWindow.chs @@ -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' diff --git a/src/Graphics/UI/FLTK/LowLevel/MenuPrim.chs b/src/Graphics/UI/FLTK/LowLevel/MenuPrim.chs --- a/src/Graphics/UI/FLTK/LowLevel/MenuPrim.chs +++ b/src/Graphics/UI/FLTK/LowLevel/MenuPrim.chs @@ -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 diff --git a/src/Graphics/UI/FLTK/LowLevel/SingleWindow.chs b/src/Graphics/UI/FLTK/LowLevel/SingleWindow.chs --- a/src/Graphics/UI/FLTK/LowLevel/SingleWindow.chs +++ b/src/Graphics/UI/FLTK/LowLevel/SingleWindow.chs @@ -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' diff --git a/src/Graphics/UI/FLTK/LowLevel/Table.chs b/src/Graphics/UI/FLTK/LowLevel/Table.chs --- a/src/Graphics/UI/FLTK/LowLevel/Table.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Table.chs @@ -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 diff --git a/src/Graphics/UI/FLTK/LowLevel/TableRow.chs b/src/Graphics/UI/FLTK/LowLevel/TableRow.chs --- a/src/Graphics/UI/FLTK/LowLevel/TableRow.chs +++ b/src/Graphics/UI/FLTK/LowLevel/TableRow.chs @@ -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 diff --git a/src/Graphics/UI/FLTK/LowLevel/Valuator.chs b/src/Graphics/UI/FLTK/LowLevel/Valuator.chs --- a/src/Graphics/UI/FLTK/LowLevel/Valuator.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Valuator.chs @@ -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 diff --git a/src/Graphics/UI/FLTK/LowLevel/Widget.chs b/src/Graphics/UI/FLTK/LowLevel/Widget.chs --- a/src/Graphics/UI/FLTK/LowLevel/Widget.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Widget.chs @@ -63,10 +63,8 @@ data CustomWidgetFuncs a = CustomWidgetFuncs { - -- | See - drawCustom :: Maybe (Ref a -> IO ()) -- | See - ,handleCustom :: Maybe (Ref a -> Event -> IO Int) + handleCustom :: Maybe (Ref a -> Event -> IO Int) -- | See ,resizeCustom :: Maybe (Ref a -> Rectangle -> IO ()) -- | See @@ -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' diff --git a/src/Graphics/UI/FLTK/LowLevel/Window.chs b/src/Graphics/UI/FLTK/LowLevel/Window.chs --- a/src/Graphics/UI/FLTK/LowLevel/Window.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Window.chs @@ -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' diff --git a/src/TestPrograms/TestCall.hs b/src/TestPrograms/TestCall.hs --- a/src/TestPrograms/TestCall.hs +++ b/src/TestPrograms/TestCall.hs @@ -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"