diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -16,9 +16,9 @@ AC_CHECK_LIB([dl], [main]) AC_SUBST(FLTKCONFIGCOMMAND,"$(fltk-config --ldstaticflags --use-images --use-forms) -lstdc++") -AC_DEFINE([FLTK_MAJOR_VERSION], [], [Fltk Major Version]), -AC_DEFINE([FLTK_MINOR_VERSION], [], [Fltk Minor Version]), -AC_DEFINE([FLTK_PATCH_VERSION], [], [Fltk Patch Version]), +AC_DEFINE([FLTK_MAJOR_VERSION], [], [Fltk Major Version]) +AC_DEFINE([FLTK_MINOR_VERSION], [], [Fltk Minor Version]) +AC_DEFINE([FLTK_PATCH_VERSION], [], [Fltk Patch Version]) AC_SUBST([GLSUPPORT],"") dnl Example of default-disabled feature @@ -47,9 +47,9 @@ fltk_patch_version=4 ) -AC_DEFINE_UNQUOTED([FLTK_MAJOR_VERSION], $fltk_major_version, [Fltk Major Version]), -AC_DEFINE_UNQUOTED([FLTK_MINOR_VERSION], $fltk_minor_version, [Fltk Minor Version]), -AC_DEFINE_UNQUOTED([FLTK_PATCH_VERSION], $fltk_patch_version, [Fltk Patch Version]), +AC_DEFINE_UNQUOTED([FLTK_MAJOR_VERSION], $fltk_major_version, [Fltk Major Version]) +AC_DEFINE_UNQUOTED([FLTK_MINOR_VERSION], $fltk_minor_version, [Fltk Minor Version]) +AC_DEFINE_UNQUOTED([FLTK_PATCH_VERSION], $fltk_patch_version, [Fltk Patch Version]) AC_SUBST(FLTK_HOME,`fltk-config --includedir`) # Checks for typedefs, structures, and compiler characteristics. diff --git a/fltkhs.cabal b/fltkhs.cabal --- a/fltkhs.cabal +++ b/fltkhs.cabal @@ -1,5 +1,5 @@ name : fltkhs -version : 0.5.4.4 +version : 0.5.4.5 synopsis : FLTK bindings description: Low level bindings for the FLTK GUI toolkit. For installation and quick start instruction please scroll all the way down to the README. license : MIT diff --git a/src/Graphics/UI/FLTK/LowLevel/Group.chs b/src/Graphics/UI/FLTK/LowLevel/Group.chs --- a/src/Graphics/UI/FLTK/LowLevel/Group.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Group.chs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP,EmptyDataDecls, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE CPP, RankNTypes, UndecidableInstances, GADTs, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.UI.FLTK.LowLevel.Group ( @@ -27,6 +27,7 @@ import Graphics.UI.FLTK.LowLevel.Utils import Graphics.UI.FLTK.LowLevel.Hierarchy import Graphics.UI.FLTK.LowLevel.Widget +import Control.Exception (finally) {# fun Fl_Group_set_current as groupSetCurrent' { id `Ptr ()' } -> `()' #} {# fun Fl_Group_current as groupCurrent' {} -> `Ptr ()' id #} @@ -81,6 +82,19 @@ instance (impl ~ (IO ())) => Op (End ()) Group orig impl where runOp _ _ group = withRef group $ \groupPtr -> end' groupPtr +instance ( + Match obj ~ FindOp orig orig (Begin ()), + Match obj ~ FindOp orig orig (End ()), + Op (Begin ()) obj orig (IO ()), + Op (End ()) obj orig (IO ()), + impl ~ (IO a -> IO a) + ) + => + Op (Within ()) Group orig impl where + runOp _ _ group action = do + () <- begin (castTo group :: Ref orig) + finally action ((end (castTo group :: Ref orig)) :: IO ()) + {# fun Fl_Group_find as find' { id `Ptr ()',id `Ptr ()' } -> `Int' #} instance (Parent a Widget, impl ~ (Ref a -> IO (Int))) => Op (Find ()) Group orig impl where runOp _ _ group w = withRef group $ \groupPtr -> withRef w $ \wPtr -> find' groupPtr wPtr @@ -212,6 +226,8 @@ -- setResizable:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Maybe' ( 'Ref' a ) -> 'IO' () -- -- updateChild:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' () +-- +-- within:: 'Ref' 'Group' -> 'IO' a -> 'IO' a -- @ -- $hierarchy diff --git a/src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs b/src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs --- a/src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs +++ b/src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs @@ -219,6 +219,8 @@ begin, End, end, + Within, + within, Find, find, Add, @@ -1771,6 +1773,7 @@ (UpdateChild (Begin (End + (Within (Find (Add (Insert @@ -1790,7 +1793,7 @@ (InsertWithBefore (GetArray (GetChild - ())))))))))))))))))))))))))) + ()))))))))))))))))))))))))))) type instance Functions Group = GroupFuncs MAKE_METHOD(DrawChild,drawChild) @@ -1799,6 +1802,7 @@ MAKE_METHOD(UpdateChild,updateChild) MAKE_METHOD(Begin,begin) MAKE_METHOD(End,end) +MAKE_METHOD(Within, within) MAKE_METHOD(Find,find) MAKE_METHOD(Add,add) MAKE_METHOD(Insert,insert) diff --git a/src/TestPrograms/Buttons.hs b/src/TestPrograms/Buttons.hs --- a/src/TestPrograms/Buttons.hs +++ b/src/TestPrograms/Buttons.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Ported from [buttons.cxx], -which is also included in @fltkhs@ at @c-examples\/buttons.c@. +which is also included in @fltkhs@ at @c-examples\/buttons.c@. @ cabal configure -fdemos @@ -20,29 +20,30 @@ (Size (Width 320) (Height 170)) Nothing Nothing - b <- buttonNew - (Rectangle (Position (X 10) (Y 10)) (Size (Width 130) (Height 30))) - (Just "Fl_Button") - setTooltip b "This is a tooltip." - _ <- repeatButtonNew - (Rectangle (Position (X 10) (Y 50)) (Size (Width 130) (Height 30))) - (Just "Fl_Repeat_Button") - _ <- lightButtonNew - (Rectangle (Position (X 10) (Y 90)) (Size (Width 130) (Height 30))) - (Just "Fl_Light_Button") - _ <- toggleButtonNew - (Rectangle (Position (X 10) (Y 130)) (Size (Width 130) (Height 30))) - (Just "Fl_Toggle_Button") - _ <- returnButtonNew - (Rectangle (Position (X 150) (Y 10)) (Size (Width 160) (Height 30))) - (Just "Fl_Return_Button") - _ <- roundButtonNew - (Rectangle (Position (X 150) (Y 50)) (Size (Width 160) (Height 30))) - (Just "Fl_Round_Button") - _ <- checkButtonNew - (Rectangle (Position (X 150) (Y 90)) (Size (Width 160) (Height 30))) - (Just "Fl_Check_Button") - end window + within window $ do + b <- buttonNew + (Rectangle (Position (X 10) (Y 10)) (Size (Width 130) (Height 30))) + (Just "Fl_Button") + setTooltip b "This is a tooltip." + _ <- repeatButtonNew + (Rectangle (Position (X 10) (Y 50)) (Size (Width 130) (Height 30))) + (Just "Fl_Repeat_Button") + _ <- lightButtonNew + (Rectangle (Position (X 10) (Y 90)) (Size (Width 130) (Height 30))) + (Just "Fl_Light_Button") + _ <- toggleButtonNew + (Rectangle (Position (X 10) (Y 130)) (Size (Width 130) (Height 30))) + (Just "Fl_Toggle_Button") + _ <- returnButtonNew + (Rectangle (Position (X 150) (Y 10)) (Size (Width 160) (Height 30))) + (Just "Fl_Return_Button") + _ <- roundButtonNew + (Rectangle (Position (X 150) (Y 50)) (Size (Width 160) (Height 30))) + (Just "Fl_Round_Button") + _ <- checkButtonNew + (Rectangle (Position (X 150) (Y 90)) (Size (Width 160) (Height 30))) + (Just "Fl_Check_Button") + return () showWidget window _ <- FL.run return ()