diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,33 +5,81 @@ NOTE: As of version 0.4.0.0, due to the introduction of closed type families, only GHC >= 7.8.1 is supported. -Abbreviated installation instructions are for Linux and Mac are: +Quick Install +------------- +### Linux and *BSD +Install FLTK-1.3.3 from source: -- Download [FLTK 1.3.3] [2]. -- Install with: ``` - > ./configure --enable-shared - > make - > make install + > wget http://fltk.org/pub/fltk/1.3.3/fltk-1.3.3-source.tar.gz + > tar -zxvf fltk-1.3.3-source.tar.gz + > cd fltk-1.3.3 + > configure --enable-shared + > make + > sudo make install + > fltk-config --version + 1.3.3 ``` -- Install via the `fltkhs-hello-world` skeleton application: +Build the FLTKHS skeleton project: + ``` - > git clone https://github.com/deech/fltkhs-hello-world - > cd fltkhs-hello-world - > stack build + > git clone http://github.com/deech/fltkhs-hello-world + > cd fltkhs-hello-world + > stack install + # About 6-8 minutes passes ... + > stack exec fltkhs-hello-world ``` -- Test your installation by invoking: 'stack exec fltkhs-hello-world'. +### OSX Yosemite only -The rest of the documentation (including installation instructions for Windows and API usage) is located in the [FLTKHS module] [3]. This is the primary module that needs to be imported by every Fltkhs app and the entry point into the application. +Install FLTK-1.3.3 from Brew: +``` + > brew install autoconf + > brew install fltk + > fltk-config --version + 1.3.3 +``` +Build the FLTKHS skeleton project: + +``` + > git clone http://github.com/deech/fltkhs-hello-world + > cd fltkhs-hello-world + > stack install + # About 6-8 minutes passes ... + > stack exec fltkhs-hello-world +``` + +### OSX El Capitan only + +Install the development version of FLTK from Brew: + +``` + > brew install --devel fltk + > fltk-config --version + 1.3.4 +``` +Build the FLTKHS skeleton project: + +``` + > git clone http://github.com/deech/fltkhs-hello-world + > cd fltkhs-hello-world + > stack install + # About 6-8 minutes passes ... + > stack exec fltkhs-hello-world +``` + +### Windows + +Please see the [detailed Windows installation instructions](http://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html#g:7) + Screenshots ----------- [Drawing with FLTKHS](images/arc-windows.png) -[A table of widgets](images/widget-table.png) +[A table of widgets](images/widget-table-windows.png) [A complex tree](images/tree-complex-windows.png) Done completely using Fluid. Notice how tree nodes can be arbitrary widgets. diff --git a/c-src/Fl_CallbackC.cpp b/c-src/Fl_CallbackC.cpp --- a/c-src/Fl_CallbackC.cpp +++ b/c-src/Fl_CallbackC.cpp @@ -85,6 +85,24 @@ return menu_->insert(index,name,shortcut,NULL,p,flags); } } +int C_to_Fl_Callback::menu_insert(Fl_Sys_Menu_Bar* menu_, int index, char* name, int shortcut, int flags){ + if (this->callback) { + return menu_->insert(index,name,shortcut,intercept,this,flags); + } + else { + void* p = 0; + return menu_->insert(index,name,shortcut,NULL,p,flags); + } +} +int C_to_Fl_Callback::menu_insert(Fl_Sys_Menu_Bar* menu_, int index, char* name, char* shortcut, int flags){ + if (this->callback) { + return menu_->insert(index,name,shortcut,intercept,this,flags); + } + else { + void* p = 0; + return menu_->insert(index,name,shortcut,NULL,p,flags); + } +} int C_to_Fl_Callback::menu_add(Fl_Menu_Item* item, char* name, int shortcut, int flags){ if (this->callback) { return item->add(name, shortcut, intercept, this, flags); @@ -113,6 +131,24 @@ } } int C_to_Fl_Callback::menu_add(Fl_Menu_* menu_, char* name, int shortcut, int flags){ + if (this->callback) { + return menu_->add(name,shortcut,intercept,this,flags); + } + else { + void* p = 0; + return menu_->add(name,shortcut,NULL,p,flags); + } +} +int C_to_Fl_Callback::menu_add(Fl_Sys_Menu_Bar* menu_, char* name, char* shortcut, int flags){ + if (this->callback) { + return menu_->add(name,shortcut,intercept,this,flags); + } + else { + void* p = 0; + return menu_->add(name,shortcut,NULL,p,flags); + } +} +int C_to_Fl_Callback::menu_add(Fl_Sys_Menu_Bar* menu_, char* name, int shortcut, int flags){ if (this->callback) { return menu_->add(name,shortcut,intercept,this,flags); } diff --git a/c-src/Fl_CallbackC.h b/c-src/Fl_CallbackC.h --- a/c-src/Fl_CallbackC.h +++ b/c-src/Fl_CallbackC.h @@ -10,6 +10,7 @@ #include #include #include +#include #include #include #include @@ -62,10 +63,14 @@ int menu_insert(Fl_Menu_Item* item, int index, char* name, int shortcut, int flags = 0); int menu_insert(Fl_Menu_* menu_, int index, char* name, int shortcut, int flags = 0); int menu_insert(Fl_Menu_* menu_, int index, char* name, char* shortcut, int flags = 0); + int menu_insert(Fl_Sys_Menu_Bar* menu_, int index, char* name, int shortcut, int flags = 0); + int menu_insert(Fl_Sys_Menu_Bar* menu_, int index, char* name, char* shortcut, int flags = 0); int menu_add(Fl_Menu_Item* item, char* name, int shortcut, int flags = 0); int menu_add(Fl_Menu_Item* item, char* name, char* shortcut, int flags = 0); int menu_add(Fl_Menu_* menu,char* name, char* shortcut, int flags = 0); int menu_add(Fl_Menu_* menu,char* name, int shortcut, int flags = 0); + int menu_add(Fl_Sys_Menu_Bar* menu,char* name, char* shortcut, int flags = 0); + int menu_add(Fl_Sys_Menu_Bar* menu,char* name, int shortcut, int flags = 0); }; #endif #endif /* __FL_CALLBACK_C__ */ diff --git a/c-src/Fl_Menu_BarC.cpp b/c-src/Fl_Menu_BarC.cpp new file mode 100644 --- /dev/null +++ b/c-src/Fl_Menu_BarC.cpp @@ -0,0 +1,22 @@ +#include "Fl_Menu_BarC.h" +#include "UtilsC.h" +#ifdef __cplusplus +EXPORT { +#endif + FL_EXPORT_C(int,Fl_Menu_Bar_handle )(fl_Menu_Bar menu_bar, int event){ + return (static_cast(menu_bar))->handle(event); + } + FL_EXPORT_C(fl_Menu_Bar, Fl_Menu_Bar_New_WithLabel)(int x, int y, int w, int h, const char* label) { + Fl_Menu_Bar* menu_bar = new Fl_Menu_Bar(x,y,w,h,label); + return (static_cast(menu_bar)); + } + FL_EXPORT_C(fl_Menu_Bar, Fl_Menu_Bar_New)(int x, int y, int w, int h) { + Fl_Menu_Bar* menu_bar = new Fl_Menu_Bar(x,y,w,h,0); + return (fl_Menu_Bar)menu_bar; + } + FL_EXPORT_C(void , Fl_Menu_Bar_Destroy)(fl_Menu_Bar menu_bar){ + delete (static_cast(menu_bar)); + } +#ifdef __cplusplus +} +#endif diff --git a/c-src/Fl_Menu_BarC.h b/c-src/Fl_Menu_BarC.h new file mode 100644 --- /dev/null +++ b/c-src/Fl_Menu_BarC.h @@ -0,0 +1,19 @@ +#ifndef __FL_MENU_BAR_C__ +#define __FL_MENU_BAR_C__ +#ifdef __cplusplus +// always include the FL/*.H headers before local headers +// Fl_Widget is included transitively and needed for +// the callback mechanism included below to work. +#include "FL/Fl.H" +#include "FL/Fl_Menu_Bar.H" +#include "Fl_CallbackC.h" +EXPORT { +#endif + FL_EXPORT_C(int, Fl_Menu_Bar_handle)(fl_Group self, int event); + FL_EXPORT_C(fl_Menu_Bar, Fl_Menu_Bar_New_WithLabel)(int x, int y, int w, int h, const char* label); + FL_EXPORT_C(fl_Menu_Bar , Fl_Menu_Bar_New)(int x, int y, int w, int h); + FL_EXPORT_C(void , Fl_Menu_Bar_Destroy)(fl_Menu_Bar menu_bar); +#ifdef __cplusplus +} +#endif +#endif /* __FL_MENU_BAR_C__ */ diff --git a/c-src/Fl_Sys_Menu_BarC.cpp b/c-src/Fl_Sys_Menu_BarC.cpp --- a/c-src/Fl_Sys_Menu_BarC.cpp +++ b/c-src/Fl_Sys_Menu_BarC.cpp @@ -321,6 +321,10 @@ C_to_Fl_Callback* callback_interceptor = new C_to_Fl_Callback(cb); return callback_interceptor->menu_insert((static_cast(sys_menu_bar)),index,name,shortcut, flags); } + FL_EXPORT_C(int,Fl_Sys_Menu_Bar_insert_with_shortcutname_flags)(fl_Sys_Menu_Bar menu_,int index,char* name,char* shortcut,fl_Callback* cb,int flags){ + C_to_Fl_Callback* callback_interceptor = new C_to_Fl_Callback(cb); + return callback_interceptor->menu_insert((static_cast(menu_)),index, name,shortcut,flags); + } FL_EXPORT_C(int,Fl_Sys_Menu_Bar_insert_with_user_data_flags)(fl_Sys_Menu_Bar sys_menu_bar,int index,char* name,int shortcut,fl_Callback* cb,void* user_data,int flags){ C_to_Fl_Callback* callback_interceptor = new C_to_Fl_Callback(cb, user_data); return callback_interceptor->menu_insert((static_cast(sys_menu_bar)),index,name,shortcut,flags); @@ -332,6 +336,9 @@ FL_EXPORT_C(int,Fl_Sys_Menu_Bar_add_with_user_data)(fl_Sys_Menu_Bar sys_menu_bar,char* name,int shortcut,fl_Callback* cb,void* user_data){ C_to_Fl_Callback* callback_interceptor = new C_to_Fl_Callback(cb, user_data); return callback_interceptor->menu_add((static_cast(sys_menu_bar)),name,shortcut,0); + } + FL_EXPORT_C(int, Fl_Sys_Menu_Bar_add_with_name)(fl_Sys_Menu_Bar menu_, char* name){ + return (static_cast(menu_))->add(name); } FL_EXPORT_C(int,Fl_Sys_Menu_Bar_add_with_flags)(fl_Sys_Menu_Bar sys_menu_bar,char* name,int shortcut,fl_Callback* cb,int flags){ C_to_Fl_Callback* callback_interceptor = new C_to_Fl_Callback(cb); diff --git a/c-src/Fl_Sys_Menu_BarC.h b/c-src/Fl_Sys_Menu_BarC.h --- a/c-src/Fl_Sys_Menu_BarC.h +++ b/c-src/Fl_Sys_Menu_BarC.h @@ -7,7 +7,6 @@ #include "FL/Fl.H" #include "FL/Fl_Sys_Menu_Bar.H" #include "Fl_CallbackC.h" -#include "Fl_Menu_C.h" EXPORT { #endif /* Inherited from Fl_Widget */ diff --git a/c-src/Fl_Types.h b/c-src/Fl_Types.h --- a/c-src/Fl_Types.h +++ b/c-src/Fl_Types.h @@ -456,6 +456,7 @@ typedef void* fl_Single_Window; typedef void* fl_Slider; typedef void* fl_Spinner; + typedef void* fl_Menu_Bar; typedef void* fl_Sys_Menu_Bar; typedef void* fl_Table; typedef void* fl_Table_Row; diff --git a/c-src/Makefile.in b/c-src/Makefile.in --- a/c-src/Makefile.in +++ b/c-src/Makefile.in @@ -86,6 +86,7 @@ fl_show_colormapC.cpp \ Fl_Single_WindowC.cpp \ Fl_SliderC.cpp \ + Fl_Menu_BarC.cpp \ Fl_Sys_Menu_BarC.cpp \ Fl_TableC.cpp \ Fl_Table_RowC.cpp \ diff --git a/fltkhs.cabal b/fltkhs.cabal --- a/fltkhs.cabal +++ b/fltkhs.cabal @@ -1,5 +1,5 @@ name : fltkhs -version : 0.4.0.5 +version : 0.4.0.6 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. @@ -55,6 +55,7 @@ Graphics.UI.FLTK.LowLevel.Browser Graphics.UI.FLTK.LowLevel.SelectBrowser Graphics.UI.FLTK.LowLevel.SysMenuBar + Graphics.UI.FLTK.LowLevel.MenuBar Graphics.UI.FLTK.LowLevel.Choice Graphics.UI.FLTK.LowLevel.MenuButton Graphics.UI.FLTK.LowLevel.Image diff --git a/src/Graphics/UI/FLTK/LowLevel/Clock.chs b/src/Graphics/UI/FLTK/LowLevel/Clock.chs --- a/src/Graphics/UI/FLTK/LowLevel/Clock.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Clock.chs @@ -39,7 +39,7 @@ DigitalClock = FL_DIGITAL_CLOCK }; #endc -{# enum ClockType {} #} +{# enum ClockType {} deriving (Show) #} newtype Hour = Hour Int newtype Minute = Minute Int newtype Second = Second Int @@ -89,6 +89,14 @@ {#fun Fl_Clock_handle as menu_Handle' { id `Ptr ()', id `CInt' } -> `Int' #} instance (impl ~ (Event -> IO Int)) => Op (Handle ()) Clock orig impl where runOp _ _ menu_ event = withRef menu_ (\p -> menu_Handle' p (fromIntegral . fromEnum $ event)) + +{# fun Fl_Clock_set_type as setType' { id `Ptr ()',`Word8' } -> `()' #} +instance (impl ~ (ClockType -> IO ())) => Op (SetType ()) Clock orig impl where + runOp _ _ clock type'' = withRef clock $ \clockPtr -> setType' clockPtr (fromIntegral (fromEnum type'')) + +{# fun Fl_Clock_type as type' { id `Ptr ()' } -> `Word8' #} +instance (impl ~ ( IO (ClockType))) => Op (GetType_ ()) Clock orig impl where + runOp _ _ clock = withRef clock $ \clockPtr -> type' clockPtr >>= return . toEnum . fromIntegral -- $Clockfunctions -- 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 @@ -104,6 +104,7 @@ module Graphics.UI.FLTK.LowLevel.SingleWindow, module Graphics.UI.FLTK.LowLevel.Slider, module Graphics.UI.FLTK.LowLevel.Spinner, + module Graphics.UI.FLTK.LowLevel.MenuBar, module Graphics.UI.FLTK.LowLevel.SysMenuBar, module Graphics.UI.FLTK.LowLevel.Tabs, module Graphics.UI.FLTK.LowLevel.Table, @@ -174,6 +175,7 @@ import Graphics.UI.FLTK.LowLevel.NiceSlider import Graphics.UI.FLTK.LowLevel.MenuItem import Graphics.UI.FLTK.LowLevel.MenuPrim +import Graphics.UI.FLTK.LowLevel.MenuBar import Graphics.UI.FLTK.LowLevel.SysMenuBar import Graphics.UI.FLTK.LowLevel.Choice import Graphics.UI.FLTK.LowLevel.MenuButton 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 @@ -529,6 +529,8 @@ setTextcolor, DownBox, downBox, + -- * MenuBar + MenuBar, -- * SysMenuBar SysMenuBar, -- * Choice, @@ -2290,8 +2292,17 @@ MAKE_METHOD(SetTextcolor,setTextcolor) MAKE_METHOD(DownBox,downBox) +data CMenuBar parent +type MenuBar = CMenuBar MenuPrim +type MenuBarFuncs = + (Destroy + (Handle + ())) +type instance Functions MenuBar = MenuBarFuncs + + data CSysMenuBar parent -type SysMenuBar = CSysMenuBar MenuPrim +type SysMenuBar = CSysMenuBar MenuBar type SysMenuBarFuncs = (Destroy (SetMenu @@ -2305,7 +2316,10 @@ (GetMode (SetShortcut (Handle - ())))))))))))) + (Add + (AddName + (Insert + ()))))))))))))))) type instance Functions SysMenuBar = SysMenuBarFuncs @@ -3094,7 +3108,9 @@ (GetValue (GetValueSinceEpoch (SetValue - ())))) + (SetType + (GetType_ + ())))))) type instance Functions Clock = ClockFuncs diff --git a/src/Graphics/UI/FLTK/LowLevel/MenuBar.chs b/src/Graphics/UI/FLTK/LowLevel/MenuBar.chs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/LowLevel/MenuBar.chs @@ -0,0 +1,72 @@ +{-# LANGUAGE CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Graphics.UI.FLTK.LowLevel.MenuBar + ( + menuBarNew, + -- * Hierarchy + -- + -- $hierarchy + + -- * Functions + -- + -- $functions + ) +where +#include "Fl_ExportMacros.h" +#include "Fl_Types.h" +#include "Fl_Menu_BarC.h" +import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum) +import Foreign.C.Types +import Graphics.UI.FLTK.LowLevel.Widget +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.Utils +import Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.LowLevel.Hierarchy +import Graphics.UI.FLTK.LowLevel.MenuItem +import qualified Data.ByteString.Char8 as C + +{# fun Fl_Menu_Bar_New as widgetNew' { `Int',`Int',`Int',`Int' } -> `Ptr ()' id #} +{# fun Fl_Menu_Bar_New_WithLabel as widgetNewWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `String'} -> `Ptr ()' id #} +menuBarNew :: Rectangle -> Maybe String -> IO (Ref MenuBar) +menuBarNew 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_Bar_Destroy as widgetDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #} +instance (impl ~ (IO ())) => Op (Destroy ()) MenuBar orig impl where + runOp _ _ menuBar = swapRef menuBar $ + \menuBarPtr -> + widgetDestroy' menuBarPtr >> + return nullPtr +{#fun Fl_Menu_Bar_handle as menuBarHandle' { id `Ptr ()', id `CInt' } -> `Int' #} +instance (impl ~ (Event -> IO Int)) => Op (Handle ()) MenuBar orig impl where + runOp _ _ menuBar event = withRef menuBar (\p -> menuBarHandle' p (fromIntegral . fromEnum $ event)) + + +-- $functions +-- +-- @ +-- +-- destroy :: 'Ref' 'MenuBar' -> 'IO' () +-- +-- handle :: 'Ref' 'MenuBar' -> 'Event' -> 'IO' 'Int' +-- +-- @ + +-- $hierarchy +-- +-- @ +-- "Graphics.UI.FLTK.LowLevel.Widget" +-- | +-- v +-- "Graphics.UI.FLTK.LowLevel.MenuPrim" +-- | +-- v +-- "Graphics.UI.FLTK.LowLevel.MenuBar" +-- +-- @ diff --git a/src/Graphics/UI/FLTK/LowLevel/MenuItem.chs b/src/Graphics/UI/FLTK/LowLevel/MenuItem.chs --- a/src/Graphics/UI/FLTK/LowLevel/MenuItem.chs +++ b/src/Graphics/UI/FLTK/LowLevel/MenuItem.chs @@ -3,6 +3,7 @@ module Graphics.UI.FLTK.LowLevel.MenuItem ( menuItemNew, + addMenuItem, MenuItemIndex(..), MenuItemName(..), MenuItemPointer(..), @@ -235,40 +236,59 @@ instance (impl ~ (Ref Widget -> IO ())) => Op (DoCallback ()) MenuItem orig impl where runOp _ _ menu_item o = withRef menu_item $ \menu_itemPtr -> withRef o $ \oPtr -> doCallback' menu_itemPtr oPtr +addMenuItem :: + (Parent menuItem MenuItem) => + Either (Ref MenuPrim) (Ref MenuItem) -> + String -> + Maybe Shortcut -> + Maybe (Ref menuItem -> IO ()) -> + MenuItemFlags -> + (Ptr () -> String -> CInt -> FunPtr CallbackWithUserDataPrim -> Int -> IO Int) -> + (Ptr () -> String -> String -> FunPtr CallbackWithUserDataPrim -> Int -> IO Int) -> + IO (MenuItemIndex) +addMenuItem refMenuOrMenuItem name shortcut cb flags addWithFlags addWithShortcutnameFlags = + either + (\menu -> withRef menu (go "Menu_.add: Shortcut format string cannot be empty" )) + (\menuItem -> withRef menuItem (go "MenuItem.add: Shortcut format string cannot be empty")) + refMenuOrMenuItem + where + go :: String -> Ptr () -> IO MenuItemIndex + go errorMsg menu_Ptr = do + let combinedFlags = menuItemFlagsToInt flags + ptr <- maybe (return (castPtrToFunPtr nullPtr)) toCallbackPrim cb + idx' <- case shortcut of + Just s' -> case s' of + KeySequence (ShortcutKeySequence modifiers char) -> + addWithFlags + menu_Ptr + name + (keySequenceToCInt modifiers char) + (castFunPtr ptr) + combinedFlags + KeyFormat format' -> + if (not $ null format') then + addWithShortcutnameFlags + menu_Ptr + name + format' + (castFunPtr ptr) + combinedFlags + else error errorMsg + Nothing -> + addWithFlags + menu_Ptr + name + 0 + (castFunPtr ptr) + combinedFlags + return (MenuItemIndex idx') + {# fun Fl_Menu_Item_insert_with_flags as insertWithFlags' { id `Ptr ()',`Int', unsafeToCString `String',id `CInt',id `FunPtr CallbackWithUserDataPrim',`Int'} -> `Int' #} {# fun Fl_Menu_Item_add_with_flags as addWithFlags' { id `Ptr ()', unsafeToCString `String',id `CInt',id `FunPtr CallbackWithUserDataPrim',`Int'} -> `Int' #} {# fun Fl_Menu_Item_add_with_shortcutname_flags as addWithShortcutnameFlags' { id `Ptr ()', unsafeToCString `String', unsafeToCString `String',id `FunPtr CallbackWithUserDataPrim',`Int' } -> `Int' #} instance (Parent a MenuItem, impl ~ (String -> Maybe Shortcut -> Maybe (Ref a -> IO ()) -> MenuItemFlags -> IO (MenuItemIndex))) => Op (Add ()) MenuItem orig impl where runOp _ _ menu_item name shortcut cb flags = - withRef menu_item $ \menu_itemPtr -> do - let combinedFlags = menuItemFlagsToInt flags - ptr <- maybe (return nullFunPtr) toCallbackPrim cb - idx' <- case shortcut of - Just s' -> case s' of - KeySequence (ShortcutKeySequence modifiers char) -> - addWithFlags' - menu_itemPtr - name - (keySequenceToCInt modifiers char) - (castFunPtr ptr) - combinedFlags - KeyFormat format' -> - if (not $ null format') then - addWithShortcutnameFlags' - menu_itemPtr - name - format' - (castFunPtr ptr) - combinedFlags - else error "menuItemAdd: shortcut format string cannot be empty" - Nothing -> - addWithFlags' - menu_itemPtr - name - 0 - (castFunPtr ptr) - combinedFlags - return (MenuItemIndex idx') + addMenuItem (Right menu_item) name shortcut cb flags addWithFlags' addWithShortcutnameFlags' instance (Parent a MenuItem, impl ~ (Int -> String -> Maybe ShortcutKeySequence -> (Ref a -> IO ()) -> MenuItemFlags -> IO (MenuItemIndex))) => Op (Insert ()) MenuItem orig impl where runOp _ _ menu_item index' name ks cb flags = 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 @@ -3,7 +3,8 @@ module Graphics.UI.FLTK.LowLevel.MenuPrim ( menu_New, - menu_Custom + menu_Custom, + insertMenuItem -- * Hierarchy -- -- $hierarchy @@ -157,42 +158,56 @@ instance (Parent a MenuItem, impl ~ (Ref a-> IO ())) => Op (Copy ()) MenuPrim orig impl where runOp _ _ menu_ m = withRef menu_ $ \menu_Ptr -> withRef m $ \mPtr -> copy' menu_Ptr mPtr +insertMenuItem :: + (Parent a MenuPrim) => + Ref MenuPrim -> + Int -> + String -> + Maybe Shortcut -> + (Ref a -> IO ()) -> + MenuItemFlags -> + (Ptr () -> Int -> String -> CInt -> FunPtr CallbackWithUserDataPrim -> Int -> IO Int) -> + (Ptr () -> Int -> String -> String -> FunPtr CallbackWithUserDataPrim -> Int -> IO Int) -> + IO (MenuItemIndex) +insertMenuItem menu_ index' name shortcut cb flags insertWithFlags'' insertWithShortcutnameFlags'' = + withRef menu_ $ \menu_Ptr -> do + let combinedFlags = menuItemFlagsToInt flags + ptr <- toCallbackPrim cb + idx' <- case shortcut of + Just s' -> case s' of + KeySequence (ShortcutKeySequence modifiers char) -> + insertWithFlags'' + menu_Ptr + index' + name + (keySequenceToCInt modifiers char) + (castFunPtr ptr) + combinedFlags + KeyFormat format' -> + if (not $ null format') then + insertWithShortcutnameFlags'' + menu_Ptr + index' + name + format' + (castFunPtr ptr) + combinedFlags + else error "Fl_Menu_.menu_insert: shortcut format string cannot be empty" + Nothing -> + insertWithFlags'' + menu_Ptr + index' + name + 0 + (castFunPtr ptr) + combinedFlags + return (MenuItemIndex idx') + {# fun Fl_Menu__insert_with_flags as insertWithFlags' { id `Ptr ()',`Int',unsafeToCString `String',id `CInt',id `FunPtr CallbackWithUserDataPrim',`Int'} -> `Int' #} {# fun Fl_Menu__insert_with_shortcutname_flags as insertWithShortcutnameFlags' { id `Ptr ()',`Int',unsafeToCString `String', unsafeToCString `String',id `FunPtr CallbackWithUserDataPrim',`Int' } -> `Int' #} instance (Parent a MenuPrim, impl ~ ( Int -> String -> Maybe Shortcut -> (Ref a -> IO ()) -> MenuItemFlags -> IO (MenuItemIndex))) => Op (Insert ()) MenuPrim orig impl where - runOp _ _ menu_ index' name shortcut cb flags = - withRef menu_ $ \menu_Ptr -> do - let combinedFlags = menuItemFlagsToInt flags - ptr <- toCallbackPrim cb - idx' <- case shortcut of - Just s' -> case s' of - KeySequence (ShortcutKeySequence modifiers char) -> - insertWithFlags' - menu_Ptr - index' - name - (keySequenceToCInt modifiers char) - (castFunPtr ptr) - combinedFlags - KeyFormat format' -> - if (not $ null format') then - insertWithShortcutnameFlags' - menu_Ptr - index' - name - format' - (castFunPtr ptr) - combinedFlags - else error "Fl_Menu_.menu_insert: shortcut format string cannot be empty" - Nothing -> - insertWithFlags' - menu_Ptr - index' - name - 0 - (castFunPtr ptr) - combinedFlags - return (MenuItemIndex idx') + runOp _ _ menu_ index' name shortcut cb flags = insertMenuItem menu_ index' name shortcut cb flags insertWithFlags' insertWithShortcutnameFlags' + {# fun Fl_Menu__add_with_name as add' { id `Ptr ()',unsafeToCString `String'} -> `()' #} instance (impl ~ (String -> IO ())) => Op (AddName ()) MenuPrim orig impl where runOp _ _ menu_ name' = withRef menu_ $ \menu_Ptr -> add' menu_Ptr name' @@ -200,35 +215,8 @@ {# fun Fl_Menu__add_with_shortcutname_flags as addWithShortcutnameFlags' { id `Ptr ()', unsafeToCString `String', unsafeToCString `String',id `FunPtr CallbackWithUserDataPrim',`Int' } -> `Int' #} instance (Parent a MenuItem, impl ~ ( String -> Maybe Shortcut -> Maybe (Ref a-> IO ()) -> MenuItemFlags -> IO (MenuItemIndex))) => Op (Add ()) MenuPrim orig (impl) where runOp _ _ menu_ name shortcut cb flags = - withRef menu_ $ \menu_Ptr -> do - let combinedFlags = menuItemFlagsToInt flags - ptr <- maybe (return (castPtrToFunPtr nullPtr)) toCallbackPrim cb - idx' <- case shortcut of - Just s' -> case s' of - KeySequence (ShortcutKeySequence modifiers char) -> - addWithFlags' - menu_Ptr - name - (keySequenceToCInt modifiers char) - (castFunPtr ptr) - combinedFlags - KeyFormat format' -> - if (not $ null format') then - addWithShortcutnameFlags' - menu_Ptr - name - format' - (castFunPtr ptr) - combinedFlags - else error "Fl_Menu_.menu_add: Shortcut format string cannot be empty" - Nothing -> - addWithFlags' - menu_Ptr - name - 0 - (castFunPtr ptr) - combinedFlags - return (MenuItemIndex idx') + addMenuItem (Left menu_) name shortcut cb flags addWithFlags' addWithShortcutnameFlags' + {# fun Fl_Menu__size as size' { id `Ptr ()' } -> `Int' #} instance (impl ~ ( IO (Int))) => Op (GetSize ()) MenuPrim orig impl where runOp _ _ menu_ = withRef menu_ $ \menu_Ptr -> size' menu_Ptr diff --git a/src/Graphics/UI/FLTK/LowLevel/SysMenuBar.chs b/src/Graphics/UI/FLTK/LowLevel/SysMenuBar.chs --- a/src/Graphics/UI/FLTK/LowLevel/SysMenuBar.chs +++ b/src/Graphics/UI/FLTK/LowLevel/SysMenuBar.chs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, EmptyDataDecls, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} +{-# LANGUAGE CPP, EmptyDataDecls, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.UI.FLTK.LowLevel.SysMenuBar ( @@ -23,6 +23,8 @@ import Graphics.UI.FLTK.LowLevel.Utils import Graphics.UI.FLTK.LowLevel.Dispatch import Graphics.UI.FLTK.LowLevel.Hierarchy +import Graphics.UI.FLTK.LowLevel.MenuItem +import Graphics.UI.FLTK.LowLevel.MenuPrim {# fun Fl_Sys_Menu_Bar_New as sysMenuBarNew' { `Int',`Int',`Int',`Int' } -> `Ptr ()' id #} {# fun Fl_Sys_Menu_Bar_New_WithLabel as sysMenuBarNewWithLabel' { `Int',`Int',`Int',`Int', unsafeToCString `String'} -> `Ptr ()' id #} @@ -75,9 +77,28 @@ withRefs items $ \menu_itemsPtr -> menuWithM' menu_Ptr menu_itemsPtr (length items) +{# fun Fl_Sys_Menu_Bar_add_with_name as add' { id `Ptr ()',unsafeToCString `String'} -> `()' #} +instance (impl ~ (String -> IO ())) => Op (AddName ()) SysMenuBar orig impl where + runOp _ _ menu_ name' = withRef menu_ $ \menu_Ptr -> add' menu_Ptr name' + +{# fun Fl_Sys_Menu_Bar_add_with_flags as addWithFlags' { id `Ptr ()',unsafeToCString `String',id `CInt',id `FunPtr CallbackWithUserDataPrim',`Int' } -> `Int' #} +{# fun Fl_Sys_Menu_Bar_add_with_shortcutname_flags as addWithShortcutnameFlags' { id `Ptr ()', unsafeToCString `String', unsafeToCString `String',id `FunPtr CallbackWithUserDataPrim',`Int' } -> `Int' #} +instance (Parent a MenuItem, impl ~ ( String -> Maybe Shortcut -> Maybe (Ref a-> IO ()) -> MenuItemFlags -> IO (MenuItemIndex))) => Op (Add ()) SysMenuBar orig (impl) where + runOp _ _ menu_ name shortcut cb flags = + addMenuItem (Left (safeCast menu_)) name shortcut cb flags addWithFlags' addWithShortcutnameFlags' + +{# fun Fl_Sys_Menu_Bar_insert_with_flags as insertWithFlags' { id `Ptr ()',`Int',unsafeToCString `String',id `CInt',id `FunPtr CallbackWithUserDataPrim',`Int'} -> `Int' #} +{# fun Fl_Sys_Menu_Bar_insert_with_shortcutname_flags as insertWithShortcutnameFlags' { id `Ptr ()',`Int',unsafeToCString `String', unsafeToCString `String',id `FunPtr CallbackWithUserDataPrim',`Int' } -> `Int' #} +instance (Parent a MenuPrim, impl ~ ( Int -> String -> Maybe Shortcut -> (Ref a -> IO ()) -> MenuItemFlags -> IO (MenuItemIndex))) => Op (Insert ()) SysMenuBar orig impl where + runOp _ _ menu_ index' name shortcut cb flags = insertMenuItem (safeCast menu_) index' name shortcut cb flags insertWithFlags' insertWithShortcutnameFlags' + -- $functions -- @ -- +-- add:: ('Parent' a 'MenuItem') => 'Ref' 'SysMenuBar' -> 'String' -> 'Maybe' 'Shortcut' -> 'Maybe' ('Ref' a-> 'IO' ()) -> 'MenuItemFlags' -> 'IO' ('MenuItemIndex') +-- +-- addName :: 'Ref' 'SysMenuBar' -> 'String' -> 'IO' () +-- -- clear :: 'Ref' 'SysMenuBar' -> 'IO' () -- -- clearSubmenu :: 'Ref' 'SysMenuBar' -> 'Int' -> 'IO' ('Int') @@ -90,6 +111,8 @@ -- -- handle :: 'Ref' 'SysMenuBar' -> 'Event' -> 'IO' 'Int' -- +-- insert:: ('Parent' a 'MenuPrim') => 'Ref' 'SysMenuBar' -> 'Int' -> 'String' -> 'Maybe' 'Shortcut' -> ('Ref' a -> 'IO' ()) -> 'MenuItemFlags' -> 'IO' ('MenuItemIndex') +-- -- remove :: 'Ref' 'SysMenuBar' -> 'Int' -> 'IO' () -- -- replace :: 'Ref' 'SysMenuBar' -> 'Int' -> 'String' -> 'IO' () @@ -99,7 +122,8 @@ -- setMode :: 'Ref' 'SysMenuBar' -> 'Int' -> 'Int' -> 'IO' () -- -- setShortcut :: 'Ref' 'SysMenuBar' -> 'Int' -> 'ShortcutKeySequence' -> 'IO' () - +-- +-- @ -- $hierarchy -- @ @@ -109,5 +133,9 @@ -- "Graphics.UI.FLTK.LowLevel.MenuPrim" -- | -- v +-- "Graphics.UI.FLTK.LowLevel.MenuBar" +-- | +-- v -- "Graphics.UI.FLTK.LowLevel.SysMenuBar" +-- -- @