diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -311,10 +311,23 @@ rawSystemExit (fromFlag $ copyVerbosity flags) "cp" [fltkcdir "libfltkc.a" , libPref] case buildOS of - OSX -> rawSystemExit (fromFlag $ copyVerbosity flags) "cp" - ["c-lib" "libfltkc-dyn.dylib", libPref] - _ -> rawSystemExit (fromFlag $ copyVerbosity flags) "cp" - ["c-lib" "libfltkc-dyn.so", libPref] + OSX -> do + updateEnv "DYLD_LIBRARY_PATH" (takeDirectory libPref) + rawSystemExit + (fromFlag $ copyVerbosity flags) + "cp" + [ + "c-lib" "libfltkc-dyn.dylib" + , libPref + ] + _ -> do + updateEnv "LIBRARY_PATH" (takeDirectory libPref) + rawSystemExit + (fromFlag $ copyVerbosity flags) "cp" + [ + "c-lib" "libfltkc-dyn.so" + , libPref + ] if (bundledBuild (configFlags lbi)) then do executableDir <- (bundlePrefix (configFlags lbi)) "bin" 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 @@ -488,6 +488,7 @@ typedef void* fl_XBM_Image; typedef void* fl_XPM_Image; typedef void* fl_Region; + typedef void* fl_Window_Handle; typedef void (fl_Callback )(fl_Widget, void*); typedef void (fl_Text_Buffer_Callback)(fl_Text_Buffer); typedef void (*Unfinished_Style_Cb)(int, void *); diff --git a/c-src/xC.cpp b/c-src/xC.cpp --- a/c-src/xC.cpp +++ b/c-src/xC.cpp @@ -5,6 +5,9 @@ FL_EXPORT_C(void,flc_open_display)( ){ fl_open_display(); } + FL_EXPORT_C(fl_Window_Handle ,flc_xid)(fl_Window w){ + return (fl_Window_Handle) fl_xid(static_cast(w)); + } FL_EXPORT_C(Fl_Bitmask,flc_create_bitmask)(int w,int h,const uchar* data){ return fl_create_bitmask(w,h,data); } diff --git a/c-src/xC.h b/c-src/xC.h --- a/c-src/xC.h +++ b/c-src/xC.h @@ -17,6 +17,7 @@ # include #endif FL_EXPORT_C_HEADER(void,flc_open_display,()); + FL_EXPORT_C_HEADER(fl_Window_Handle ,flc_xid,(fl_Window w)); FL_EXPORT_C_HEADER(Fl_Bitmask,flc_create_bitmask,(int w, int h, const uchar *data)); FL_EXPORT_C_HEADER(Fl_Bitmask,flc_create_alphamask,(int w, int h, int d, int ld, const uchar *data)); FL_EXPORT_C_HEADER(void,flc_delete_bitmask,(Fl_Bitmask bm)); diff --git a/fltkhs.cabal b/fltkhs.cabal --- a/fltkhs.cabal +++ b/fltkhs.cabal @@ -1,5 +1,5 @@ name : fltkhs -version : 0.5.4.0 +version : 0.5.4.1 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 @@ -131,6 +131,7 @@ Graphics.UI.FLTK.LowLevel.XPMImage Graphics.UI.FLTK.LowLevel.PNGImage Graphics.UI.FLTK.LowLevel.PNMImage + Graphics.UI.FLTK.LowLevel.X build-depends: base == 4.*, bytestring, @@ -175,7 +176,7 @@ cpp-options: -DWIN64 if os(windows) ghc-Options: -optl-mwindows - ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + ghc-Options: -pgml g++ "-optl-Wl,--allow-multiple-definition" "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" if os(darwin) ghc-Options: "-optl-Wl,-lfltkc" if !os(darwin) && !os(windows) @@ -191,7 +192,7 @@ ghc-Options: -Wall -threaded if os(windows) ghc-Options: -optl-mwindows - ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + ghc-Options: -pgml g++ "-optl-Wl,--allow-multiple-definition" "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" if os(darwin) ghc-Options: "-optl-Wl,-lfltkc" if !os(darwin) && !os(windows) diff --git a/src/Graphics/UI/FLTK/LowLevel/Fl_Types.chs b/src/Graphics/UI/FLTK/LowLevel/Fl_Types.chs --- a/src/Graphics/UI/FLTK/LowLevel/Fl_Types.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Fl_Types.chs @@ -249,17 +249,18 @@ data StyleTableEntry = StyleTableEntry (Maybe Color) (Maybe Font) (Maybe FontSize) deriving Show {#enum PackType{} deriving (Show, Eq, Ord) #} -type FlShortcut = {#type Fl_Shortcut #} -type FlColor = {#type Fl_Color #} -type FlFont = {#type Fl_Font #} -type FlAlign = {#type Fl_Align #} -type LineDelta = Maybe Int -type Delta = Maybe Int -type FlIntPtr = {#type fl_intptr_t #} -type FlUIntPtr = {#type fl_uintptr_t#} -type ID = {#type ID#} -data Ref a = Ref !(ForeignPtr (Ptr ())) deriving (Eq, Show) -data FunRef = FunRef !(FunPtr ()) +type FlShortcut = {#type Fl_Shortcut #} +type FlColor = {#type Fl_Color #} +type FlFont = {#type Fl_Font #} +type FlAlign = {#type Fl_Align #} +type LineDelta = Maybe Int +type Delta = Maybe Int +type FlIntPtr = {#type fl_intptr_t #} +type FlUIntPtr = {#type fl_uintptr_t#} +type ID = {#type ID#} +newtype WindowHandle = WindowHandle (Ptr ()) +data Ref a = Ref !(ForeignPtr (Ptr ())) deriving (Eq, Show) +data FunRef = FunRef !(FunPtr ()) -- * The FLTK widget hierarchy data CBase parent type Base = CBase () diff --git a/src/Graphics/UI/FLTK/LowLevel/X.chs b/src/Graphics/UI/FLTK/LowLevel/X.chs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/LowLevel/X.chs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} + +module Graphics.UI.FLTK.LowLevel.X (flcOpenDisplay, flcXid) where +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.Hierarchy +import Graphics.UI.FLTK.LowLevel.Dispatch +import Foreign.Ptr +#include "Fl_C.h" +#include "xC.h" + +{# fun flc_open_display as flcOpenDisplay {} -> `()' #} + +{# fun flc_xid as flcXid' {`Ptr ()'} -> `Ptr ()' #} +flcXid :: (Parent a Window) => Ref a -> IO (Maybe WindowHandle) +flcXid win = + withRef + win + ( + \winPtr -> do + res <- flcXid' winPtr + if (res == nullPtr) + then return Nothing + else return (Just (WindowHandle res)) + )