fltkhs 0.8.0.2 → 0.8.0.3

raw patch · 26 files changed

+151/−117 lines, 26 filessetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Setup.hs +32/−37
• c-src/Fl_Gl_WindowC.h +10/−0
• c-src/Fl_Text_BufferC.cpp +4/−4
• c-src/Fl_Types.h +1/−0
• c-src/Fl_WindowC.cpp +3/−2
• c-src/Fl_WindowC.h +2/−1
• c-src/Makefile.in +1/−1
• c-src/glC.h +1/−0
• c-src/xC.cpp +3/−0
• c-src/xC.h +1/−0
• fltk-master.zip too large to diff
• fltkhs.cabal +3/−3
• src/Fluid/Lookup.hs +1/−1
• src/Graphics/UI/FLTK/LowLevel/Ask.chs +29/−6
• src/Graphics/UI/FLTK/LowLevel/Base/GlWindow.chs +5/−5
• src/Graphics/UI/FLTK/LowLevel/Base/Window.chs +13/−3
• src/Graphics/UI/FLTK/LowLevel/DoubleWindow.chs +3/−0
• src/Graphics/UI/FLTK/LowLevel/FL.chs +11/−11
• src/Graphics/UI/FLTK/LowLevel/Fl_Enumerations.chs +1/−0
• src/Graphics/UI/FLTK/LowLevel/Fl_Types.chs +7/−4
• src/Graphics/UI/FLTK/LowLevel/GlWIndow.chs +0/−34
• src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs +0/−1
• src/Graphics/UI/FLTK/LowLevel/NativeFileChooser.chs +1/−1
• src/Graphics/UI/FLTK/LowLevel/Utils.hs +5/−1
• src/Graphics/UI/FLTK/LowLevel/X.chs +13/−1
• stack.yaml +1/−1

@@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-}-import Data.Maybe(fromJust, isJust, fromMaybe, maybeToList)+import Data.Maybe(isJust, fromMaybe, maybeToList) import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo+import Distribution.Types.LocalBuildInfo+import Distribution.Types.TargetInfo import Distribution.PackageDescription import Distribution.Simple import Distribution.System@@ -12,30 +14,16 @@ import Control.Monad import Data.List import Control.Applicative((<$>))-import Distribution.Simple.Program-  ( Program(..), ConfiguredProgram(..), programPath-   , requireProgram, requireProgramVersion-   , rawSystemProgramConf, rawSystemProgram-   , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram-   , happyProgram, alexProgram, ghcProgram, gccProgram, requireProgram, arProgram)-import Distribution.Simple.Program.Db import Distribution.Simple.Configure(findDistPrefOrDefault)-import Distribution.Simple.PreProcess import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage ) import qualified Distribution.Simple.Register as Register import Distribution.Simple.InstallDirs (fromPathTemplate) import System.IO.Unsafe (unsafePerformIO) import System.IO.Error-import qualified Distribution.Simple.Program.Ar    as Ar-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.BuildPaths import System.Directory(getCurrentDirectory, copyFile, createDirectoryIfMissing, listDirectory, withCurrentDirectory, doesDirectoryExist, makeAbsolute, doesFileExist)-import System.FilePath ( (</>), (<.>), takeExtension, combine, takeBaseName, takeDirectory)-import qualified Distribution.Simple.GHC  as GHC-import qualified Distribution.Simple.UHC  as UHC-import qualified Distribution.Simple.PackageIndex as PackageIndex+import System.FilePath ( (</>), (<.>), takeDirectory) import Distribution.PackageDescription as PD-import Distribution.InstalledPackageInfo (ldOptions, extraGHCiLibraries, showInstalledPackageInfo, libraryDynDirs, libraryDirs)+import Distribution.InstalledPackageInfo (ldOptions, extraGHCiLibraries, showInstalledPackageInfo, libraryDynDirs, libraryDirs,InstalledPackageInfo) import System.Environment (getEnv, setEnv)  ----------------------------------------@@ -44,6 +32,7 @@ -- "If you have a custom-setup stanza, you should be able to use the MIN_VERSION_Cabal macro in your setup script."  -- cabal >=2.0.0.2+_FlagName :: String -> FlagName #if defined(MIN_VERSION_Cabal) && MIN_VERSION_Cabal(2,0,0) _FlagName = mkFlagName #else@@ -51,6 +40,7 @@ #endif  -- cabal >=2.0.1.1+_registerPackage :: Verbosity -> LocalBuildInfo -> PackageDBStack -> InstalledPackageInfo -> IO () #if defined(MIN_VERSION_Cabal) && MIN_VERSION_Cabal(2,0,1) _registerPackage verbosity lbi packageDbs installedPkgInfo   = registerPackage verbosity (compiler lbi) (withPrograms lbi) packageDbs installedPkgInfo Register.defaultRegisterOptions@@ -402,27 +392,32 @@  register :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () register pkg@PackageDescription { library = Just lib } lbi regFlags = do-    let clbi = getComponentLocalBuildInfo lbi CLibName-    installedPkgInfoRaw' <- generateRegistrationInfo verbosity pkg lib lbi clbi inplace False distPref packageDb-    let installedPkgInfoRaw =-         case buildOS of-           Windows -> installedPkgInfoRaw' { Distribution.InstalledPackageInfo.ldOptions = fmap windowsFriendlyPaths (Distribution.InstalledPackageInfo.ldOptions installedPkgInfoRaw') }-           _ -> installedPkgInfoRaw'-    let installedPkgInfo = installedPkgInfoRaw {-                                libraryDynDirs = (libraryDynDirs installedPkgInfoRaw) ++ (libraryDirs installedPkgInfoRaw),-                                -- this is what this whole register code is all about-                                extraGHCiLibraries =-                                  case buildOS of-                                    Windows -> ["libfltkc-dyn"]-                                    _ -> ["fltkc-dyn"]-                                }+  -- Libraries can have more than one target now due to Backpack, but we don't+  -- use it so we only register the library with a single target.+  case componentNameTargets' pkg lbi (CLibName (libName lib)) of+    [targetInfo] -> do+      let clbi = targetCLBI targetInfo+      installedPkgInfoRaw' <- generateRegistrationInfo verbosity pkg lib lbi clbi inplace False distPref packageDb+      let installedPkgInfoRaw =+           case buildOS of+             Windows -> installedPkgInfoRaw' { Distribution.InstalledPackageInfo.ldOptions = fmap windowsFriendlyPaths (Distribution.InstalledPackageInfo.ldOptions installedPkgInfoRaw') }+             _ -> installedPkgInfoRaw'+      let installedPkgInfo = installedPkgInfoRaw {+                                  libraryDynDirs = (libraryDynDirs installedPkgInfoRaw) ++ (libraryDirs installedPkgInfoRaw),+                                  -- this is what this whole register code is all about+                                  extraGHCiLibraries =+                                    case buildOS of+                                      Windows -> ["libfltkc-dyn"]+                                      _ -> ["fltkc-dyn"]+                                  } -     -- Three different modes:-    case () of-     _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo-       | modeGenerateRegScript -> die "Generate Reg Script not supported"-       | otherwise             ->-          _registerPackage verbosity lbi packageDbs installedPkgInfo+       -- Three different modes:+      case () of+       _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo+         | modeGenerateRegScript -> dieNoVerbosity "Generate Reg Script not supported"+         | otherwise             ->+            _registerPackage verbosity lbi packageDbs installedPkgInfo+    _ -> pure ()   where     modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))     regFile             = fromMaybe (display (packageId pkg) <.> "conf")

@@ -12,6 +12,16 @@ #include "FL/platform_types.h" EXPORT { #endif++// A workaround because 'fltk' defines a 'GLContext' on+// macOS for Objective C and C++ but leaves out C+// which causes OpenGL code using these bindings to fail.+#ifndef INTERNAL_LINKAGE+# ifdef __APPLE__+typedef struct NSOpenGLContext* GLContext;+# endif+#endif+   /* Inherited from Fl_Widget */   FL_EXPORT_C_HEADER(fl_Gl_Window_Virtual_Funcs*,Fl_Gl_Window_default_virtual_funcs,());   FL_EXPORT_C_HEADER(int,Fl_Gl_Window_handle,(fl_Gl_Window self, int event));

@@ -1,13 +1,13 @@ #include "Fl_Text_BufferC.h" #ifdef __cplusplus-Fl_DerivedText_Buffer::Fl_DerivedText_Buffer(Destroy_Function_Pointers destroy) : Fl_Text_Buffer() {-  this->destroy = destroy;+Fl_DerivedText_Buffer::Fl_DerivedText_Buffer(Destroy_Function_Pointers dfps) : Fl_Text_Buffer() {+  this->destroy = dfps; }; Fl_DerivedText_Buffer::Fl_DerivedText_Buffer(int requestedSize, Destroy_Function_Pointers dfps) : Fl_Text_Buffer(requestedSize) {-  this->destroy = destroy;+  this->destroy = dfps; }; Fl_DerivedText_Buffer::Fl_DerivedText_Buffer(int requestedSize, int preferredGapSize, Destroy_Function_Pointers dfps) : Fl_Text_Buffer(requestedSize, preferredGapSize) {-  this->destroy = destroy;+  this->destroy = dfps; }; Fl_DerivedText_Buffer::~Fl_DerivedText_Buffer(){   destroy_data();

@@ -484,6 +484,7 @@   typedef void* fl_XPM_Image;   typedef void* fl_show_input;   typedef void (fl_Callback)(fl_Widget, void*);+  typedef void (fl_Open_Callback)(const char*);   typedef void (fl_Text_Buffer_Callback)(fl_Text_Buffer);   typedef void (*Unfinished_Style_Cb)(int, void *);   typedef void (fl_File_Chooser_Callback)(fl_File_Chooser,void*);

@@ -760,8 +760,9 @@   FL_EXPORT_C(const void*,Fl_Window_icon)(fl_Window win){     return (static_cast<Fl_DerivedWindow*>(win))->icon();   }-  FL_EXPORT_C(void,Fl_Window_set_icon)(fl_Window win,const void * ic){-    (static_cast<Fl_DerivedWindow*>(win))->icon(ic);+  FL_EXPORT_C(void,Fl_Window_set_icon)(fl_Window win,fl_RGB_Image i){+    Fl_RGB_Image* rgb = static_cast<Fl_RGB_Image*>(i);+    (static_cast<Fl_DerivedWindow*>(win))->icon(rgb);   }   FL_EXPORT_C(int,Fl_Window_shown)(fl_Window win){     return (static_cast<Fl_DerivedWindow*>(win))->shown();

@@ -2,6 +2,7 @@ #define __FL_WINDOW_C__ #ifdef __cplusplus #include "FL/Fl.H"+#include "FL/Fl_RGB_Image.H" #include "FL/Fl_Window.H" // always include the FL/*.H headers before local headers                           // Fl_Widget is included transitively and needed for                           // the callback mechanism included below to work.@@ -245,7 +246,7 @@   FL_EXPORT_C_HEADER(const char*,Fl_Window_xclass,(fl_Window win));   FL_EXPORT_C_HEADER(void,Fl_Window_set_xclass,(fl_Window win,const char* c));   FL_EXPORT_C_HEADER(const void*,Fl_Window_icon,(fl_Window win));-  FL_EXPORT_C_HEADER(void,Fl_Window_set_icon,(fl_Window win,const void * ic));+  FL_EXPORT_C_HEADER(void,Fl_Window_set_icon,(fl_Window win,fl_RGB_Image ic));   FL_EXPORT_C_HEADER(int,Fl_Window_shown,(fl_Window win));   FL_EXPORT_C_HEADER(void,Fl_Window_iconize,(fl_Window win));   FL_EXPORT_C_HEADER(int,Fl_Window_x_root,(fl_Window win));

@@ -126,7 +126,7 @@ STATIC_OBJECT_FILES = ../static_object_files ifeq ($(shell uname) , Darwin) 	SHARED_EXT=dylib-	SONAME_FLAGS=-dynamiclib -install_name+	SONAME_FLAGS=-dynamiclib -Wl,-install_name else 	SHARED_EXT=so 	SONAME_FLAGS= -shared -Wl,-soname

@@ -1,5 +1,6 @@ #ifndef __GL_C__ #define __GL_C__+ #ifdef __cplusplus // always include the FL/*.H headers before local headers // Fl_Widget is included transitively and needed for

@@ -17,6 +17,9 @@   FL_EXPORT_C(void,flc_delete_bitmask)(Fl_Bitmask bm){     fl_delete_bitmask(bm);   }+  FL_EXPORT_C(void,flc_open_callback)(fl_Open_Callback* cb){+    fl_open_callback(cb);+  } #if !defined(WIN32) && !defined(__APPLE__)   FL_EXPORT_C(void,flc_close_display)( ){     fl_close_display();

@@ -21,6 +21,7 @@  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));+ FL_EXPORT_C_HEADER(void,flc_open_callback,(fl_Open_Callback* cb)); #if !defined(WIN32) && !defined(__APPLE__)  typedef ulong Fl_Bitmask;  FL_EXPORT_C_HEADER(void,flc_close_display,());

file too large to diff

@@ -1,5 +1,5 @@ name : fltkhs-version : 0.8.0.2+version : 0.8.0.3 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@@ -48,10 +48,10 @@  custom-setup   setup-depends:-    Cabal >= 2.2.0.0 && < 3,+    Cabal >= 2.4.0.0 && < 4,     filepath,     directory >= 1.2.3.0,-    base >= 4.5 && < 4.13+    base >= 4.5 && < 4.14  ---------------------------------------- 

@@ -287,7 +287,7 @@   ,("Fl_Wizard",("Wizard", "wizardNew"))   ,("Fl_Pack",("Pack", "packNew"))   ,("Fl_Table",("Table", "tableNew"))-  ,("Fl_Scroll",("Scroll", "scrollNew"))+  ,("Fl_Scroll",("Scroll", "scrolledNew"))   ,("Fl_Menu_Bar",("MenuBar", "sysMenuBarNew"))   ,("Fl_Menu_Button",("MenuButton", "menuButtonNew"))   ,("Fl_Choice",("Choice", "choiceNew"))

@@ -5,6 +5,7 @@     BeepType(..),     flMessage,     flAlert,+    flChoice,     flInput,     flPassword   )@@ -15,6 +16,7 @@ import C2HS hiding (cFromEnum, cToBool,cToEnum)  import qualified Data.Text as T+import Data.Maybe (fromMaybe, maybe) import Graphics.UI.FLTK.LowLevel.Utils  #c@@ -28,6 +30,13 @@ }; #endc +escapePercent :: T.Text -> T.Text+escapePercent t =+  let helper [] = []+      helper ('%' : cs) = '%' : '%' : helper cs+      helper (c : cs) = c : helper cs+  in T.pack $ helper $ T.unpack t+ {#enum BeepType {} deriving (Eq, Show, Ord) #}  {# fun flc_beep as flBeep' {} -> `()' #}@@ -36,21 +45,35 @@ flBeep Nothing = flBeep' flBeep (Just bt) = flBeepType' (fromIntegral (fromEnum bt)) -{# fun flc_input as flInput' { `CString' } -> `CString' #}-flInput :: T.Text -> IO (Maybe T.Text)-flInput msg = do-  r <- copyTextToCString msg >>= flInput'+{# fun flc_input_with_deflt as flInput' { `CString',`CString' } -> `CString' #}+flInput :: T.Text -> Maybe T.Text -> IO (Maybe T.Text)+flInput msg defaultMsg = do+  msgC <- copyTextToCString $ escapePercent msg+  let def = fromMaybe T.empty defaultMsg+  defaultC <- copyTextToCString def+  r <- flInput' msgC defaultC   cStringToMaybeText r +{# fun flc_choice as flChoice' { `CString',`CString',`CString',`CString' } -> `CInt' #}+flChoice :: T.Text -> T.Text -> Maybe T.Text -> Maybe T.Text -> IO Int+flChoice msg b0 b1 b2 = do+  msgC <- copyTextToCString $ escapePercent msg+  b0C <- copyTextToCString b0+  let stringOrNull t = maybe (return nullPtr) copyTextToCString t+  b1C <- stringOrNull b1+  b2C <- stringOrNull b2+  r <- flChoice' msgC b0C b1C b2C+  return $ fromIntegral r+ {# fun flc_password as flPassword' { `CString' } -> `CString' #} flPassword :: T.Text -> IO (Maybe T.Text) flPassword msg = do-  r <- copyTextToCString msg >>= flPassword'+  r <- copyTextToCString (escapePercent msg) >>= flPassword'   cStringToMaybeText r  {# fun flc_message as flMessage' { `CString' } -> `()' #} flMessage :: T.Text -> IO ()-flMessage t = copyTextToCString t >>= flMessage'+flMessage t = copyTextToCString (escapePercent t) >>= flMessage'  {# fun flc_alert as flAlert' { `CString' } -> `()' #} flAlert :: T.Text -> IO ()

@@ -104,7 +104,7 @@ instance (impl ~ ( IO ())) => Op (ShowWidget ()) GlWindowBase orig impl where   runOp _ _ win = withRef win $ \winPtr -> show' winPtr {# fun Fl_DerivedGl_Window_handle as handle' { id `Ptr ()', cFromEnum `Event' } -> `Int' #}-instance (impl ~ (Event ->  IO(Either UnknownEvent ()))) => Op (Handle ()) GlWindowBase orig impl where+instance (impl ~ (Event ->  IO( Either UnknownEvent () ))) => Op (Handle ()) GlWindowBase orig impl where   runOp _ _ self event = withRef self $ \selfPtr -> handle' selfPtr event >>= return  . successOrUnknownEvent {# fun Fl_DerivedGl_Window_Destroy as windowDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #} instance (impl ~ (IO ())) => Op (Destroy ()) GlWindowBase orig impl where@@ -134,8 +134,8 @@ instance (impl ~ ( IO (Bool))) => Op (CanDo ()) GlWindowBase orig impl where   runOp _ _ win = withRef win $ \winPtr -> canDo' winPtr {# fun Fl_Gl_Window_mode as mode' { id `Ptr ()' } -> `Int' #}-instance (impl ~ ( IO (Mode))) => Op (GetMode ()) GlWindowBase orig impl where-  runOp _ _ win = withRef win $ \winPtr -> mode' winPtr >>= return . toEnum+instance (impl ~ ( IO (Modes))) => Op (GetMode ()) GlWindowBase orig impl where+  runOp _ _ win = withRef win $ \winPtr -> mode' winPtr >>= return . intToModes {# fun Fl_Gl_Window_set_mode as setMode' { id `Ptr ()',`Int' } -> `Int' #} instance (impl ~ (Modes ->  IO ())) => Op (SetMode ()) GlWindowBase orig impl where   runOp _ _ win a = withRef win $ \winPtr -> setMode' winPtr (modesToInt a) >> return ()@@ -205,11 +205,11 @@ -- -- getContextValid :: 'Ref' 'GlWindowBase' -> 'IO' ('Bool') ----- getMode :: 'Ref' 'GlWindowBase' -> 'IO' ('Mode')+-- getMode :: 'Ref' 'GlWindowBase' -> 'IO' ('Modes') -- -- getValid :: 'Ref' 'GlWindowBase' -> 'IO' ('Bool') ----- handle :: 'Ref' 'GlWindowBase' -> 'Event' -> 'IO(Either' 'UnknownEvent' ())+-- handle :: 'Ref' 'GlWindowBase' -> 'Event' -> 'IO'( 'Either' 'UnknownEvent' () ) -- -- hide :: 'Ref' 'GlWindowBase' -> 'IO' () --

@@ -41,6 +41,9 @@ import qualified Data.Text as T import Graphics.UI.FLTK.LowLevel.Hierarchy import Graphics.UI.FLTK.LowLevel.Base.Widget+import Graphics.UI.FLTK.LowLevel.RGBImage()+import Control.Exception(throwIO)+import System.IO.Error(userError)  #c  enum WindowType {@@ -319,8 +322,15 @@   runOp _ _ win = withRef win $ \winPtr -> icon' winPtr >>= toMaybeRef  {# fun Fl_Window_set_icon as setIcon' { id `Ptr ()', id `Ptr ()' } -> `()' supressWarningAboutRes #}-instance (Parent a Image, impl ~ (Maybe( Ref a ) ->  IO ())) => Op (SetIcon ()) WindowBase orig impl where-  runOp _ _ win bitmap = withRef win $ \winPtr -> withMaybeRef bitmap $ \bitmapPtr -> setIcon' winPtr bitmapPtr+instance (Parent a RGBImage, impl ~ (Maybe( Ref a ) ->  IO ())) => Op (SetIcon ()) WindowBase orig impl where+  runOp _ _ win rgbM = do+    case rgbM of+      Nothing -> withRef win $ \winPtr -> setIcon' winPtr (castPtr nullPtr)+      Just rgb -> do+        copyIM <- copy (safeCast rgb :: Ref RGBImage) (Nothing :: Maybe Size)+        case copyIM of+          Just copyI -> withRef win $ \winPtr -> withRef copyI $ \iPtr -> setIcon' winPtr iPtr+          Nothing -> throwIO (userError "Could not make a copy of icon image")  {# fun Fl_Window_shown as shown' { id `Ptr ()' } -> `Bool' toBool #} instance (impl ~ ( IO (Bool))) => Op (Shown ()) WindowBase orig impl where@@ -549,7 +559,7 @@ -- -- setDefaultCursorWithFgBg :: 'Ref' 'WindowBase' -> 'CursorType' -> ('Maybe' 'Color', 'Maybe' 'Color') -> 'IO' () ----- setIcon:: ('Parent' a 'Image') => 'Ref' 'WindowBase' -> 'Maybe'( 'Ref' a ) -> 'IO' ()+-- setIcon:: ('Parent' a 'RGBImage') => 'Ref' 'WindowBase' -> 'Maybe'( 'Ref' a ) -> 'IO' () -- -- setIconlabel :: 'Ref' 'WindowBase' -> 'T.Text' -> 'IO' () --

@@ -49,6 +49,9 @@ -- "Graphics.UI.FLTK.LowLevel.Base.Window" --  | --  v+-- "Graphics.UI.FLTK.LowLevel.Base.DoubleWindow"+--  |+--  v -- "Graphics.UI.FLTK.LowLevel.DoubleWindow" -- @ 

@@ -364,7 +364,7 @@        { `Int' } -> `()' #}  {# fun Fl_readqueue as readqueue' {  } -> `Ptr ()' #}-readqueue :: IO (Maybe (Ref Widget))+readqueue :: IO (Maybe (Ref WidgetBase)) readqueue = readqueue' >>= toMaybeRef {# fun Fl_add_timeout as addTimeout'        { `Double', id `FunPtr CallbackPrim' } -> `()' supressWarningAboutRes #}@@ -427,7 +427,7 @@ {# fun Fl_flush as flush        {  } -> `()' supressWarningAboutRes #} {# fun Fl_first_window as firstWindow' {  } -> `Ptr ()' #}-firstWindow :: IO (Maybe (Ref Window))+firstWindow :: IO (Maybe (Ref WindowBase)) firstWindow = firstWindow' >>= toMaybeRef  {# fun Fl_set_first_window as setFirstWindow'@@ -436,15 +436,15 @@ setFirstWindow wp =     withRef wp setFirstWindow' {# fun Fl_next_window as nextWindow' { id `Ptr ()' } -> `Ptr ()' #}-nextWindow :: Ref a -> IO (Maybe (Ref Window))+nextWindow :: Ref a -> IO (Maybe (Ref WindowBase)) nextWindow currWindow = withRef currWindow (\ptr -> nextWindow' ptr >>= toMaybeRef)  {# fun Fl_modal as modal' {  } -> `Ptr ()' #}-modal  :: IO (Maybe (Ref Widget))+modal  :: IO (Maybe (Ref WindowBase)) modal = modal' >>= toMaybeRef  {# fun Fl_grab as grab' {  } -> `Ptr ()' #}-grab  :: IO (Maybe (Ref Widget))+grab  :: IO (Maybe (Ref WindowBase)) grab = grab' >>= toMaybeRef  {# fun Fl_set_grab as setGrab'@@ -510,8 +510,8 @@   mb <- eventButton'   case mb of     mb' | mb' == (fromEnum Mouse_Left) -> return (Just Mouse_Left)-    mb' | mb' == (fromEnum Mouse_Middle) -> return (Just Mouse_Right)-    mb' | mb' == (fromEnum Mouse_Right) -> return (Just Mouse_Middle)+    mb' | mb' == (fromEnum Mouse_Middle) -> return (Just Mouse_Middle)+    mb' | mb' == (fromEnum Mouse_Right) -> return (Just Mouse_Right)     _ -> return Nothing  eventStates :: [EventState]@@ -615,21 +615,21 @@ setBelowmouse wp = withRef wp setBelowmouse' {# fun Fl_pushed as pushed'        {  } -> `Ptr ()' #}-pushed :: IO (Maybe (Ref Widget))+pushed :: IO (Maybe (Ref WidgetBase)) pushed = pushed' >>= toMaybeRef {# fun Fl_set_pushed as setPushed'        { id `Ptr ()' } -> `()' supressWarningAboutRes #} setPushed :: (Parent a WidgetBase) => Ref a -> IO () setPushed wp = withRef wp setPushed' {# fun Fl_focus as focus' {  } -> `Ptr ()' #}-focus :: IO (Maybe (Ref Widget))+focus :: IO (Maybe (Ref WidgetBase)) focus = focus' >>= toMaybeRef {# fun Fl_set_focus as setFocus'        { id `Ptr ()' } -> `()' supressWarningAboutRes #} setFocus :: (Parent a WidgetBase) => Ref a -> IO () setFocus wp = withRef wp setFocus' {# fun Fl_selection_owner as selectionOwner' {  } -> `Ptr ()' #}-selectionOwner :: IO (Maybe (Ref Widget))+selectionOwner :: IO (Maybe (Ref WidgetBase)) selectionOwner = selectionOwner' >>= toMaybeRef {# fun Fl_set_selection_owner as setSelection_Owner'        { id `Ptr ()' } -> `()' supressWarningAboutRes #}@@ -1115,6 +1115,6 @@                    else throw e)     Nothing -> return ()   where-    allToplevelWindows :: [Ref Window] -> Maybe (Ref Window) -> IO [Ref Window]+    allToplevelWindows :: [Ref WindowBase] -> Maybe (Ref WindowBase) -> IO [Ref WindowBase]     allToplevelWindows ws (Just w) = nextWindow w >>= allToplevelWindows (w:ws)     allToplevelWindows ws Nothing = return ws

@@ -314,6 +314,7 @@   Kb_Refresh = FL_Refresh,   Kb_Sleep = FL_Sleep,   Kb_Favorites = FL_Favorites,+  Kb_Unrecognized, }; enum MouseButton {   Mouse_Left = FL_LEFT_MOUSE,

@@ -7,6 +7,7 @@ module Graphics.UI.FLTK.LowLevel.Fl_Types where #include "Fl_Types.h" #include "Fl_Text_EditorC.h"+#include "Fl_Gl_WindowC.h" #include "FL/platform_types.h" import Foreign import Foreign.C hiding (CClock)@@ -275,9 +276,11 @@ type GlobalCallback              = IO () type CallbackWithUserDataPrim    = Ptr () -> Ptr () -> IO () type CallbackPrim                = Ptr () -> IO ()-type CustomColorAveragePrim    = Ptr () -> CUInt -> CFloat -> IO ()-type CustomImageDrawPrim       = Ptr () -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO ()-type CustomImageCopyPrim       = Ptr () -> CInt -> CInt -> IO (Ptr ())+type OpenCallback                = T.Text -> IO ()+type OpenCallbackPrim            = CString -> IO ()+type CustomColorAveragePrim      = Ptr () -> CUInt -> CFloat -> IO ()+type CustomImageDrawPrim         = Ptr () -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO ()+type CustomImageCopyPrim         = Ptr () -> CInt -> CInt -> IO (Ptr ()) type GlobalEventHandlerPrim      = CInt -> IO CInt type GlobalEventHandlerF         = Event -> IO Int type DrawCallback                = T.Text -> Position -> IO ()@@ -371,7 +374,7 @@ newtype FlBitmask = FlBitmask Fl_Bitmask newtype FlRegion = FlRegion Fl_Region newtype FlSocket = FlSocket Fl_Socket-#if GLSUPPORT+#ifdef GLSUPPORT type Fl_GlContext = {#type GLContext #} newtype FlGlContext = FlGlContext Fl_GlContext #endif

@@ -1,34 +0,0 @@-{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Graphics.UI.FLTK.LowLevel.GlWindow ()-where-#include "Fl_C.h"-#include "Fl_Gl_WindowC.h"-import Foreign-import Foreign.C-import Graphics.UI.FLTK.LowLevel.Fl_Types-import Graphics.UI.FLTK.LowLevel.Fl_Enumerations-import Graphics.UI.FLTK.LowLevel.Utils-import Graphics.UI.FLTK.LowLevel.Dispatch-import Graphics.UI.FLTK.LowLevel.Hierarchy--{# fun Fl_DerivedGl_Window_flush as flush' { id `Ptr ()' } -> `()' supressWarningAboutRes #}-instance (impl ~ ( IO ())) => Op (Flush ()) GlWindow orig impl where-  runOp _ _ win = withRef win $ \winPtr -> flush' winPtr-{# fun Fl_DerivedGl_Window_hide as hide' { id `Ptr ()' } -> `()' supressWarningAboutRes #}-instance (impl ~ ( IO ())) => Op (Hide ()) GlWindow orig impl where-  runOp _ _ win = withRef win $ \winPtr -> hide' winPtr-{# fun Fl_DerivedGl_Window_show as show' { id `Ptr ()' } -> `()' supressWarningAboutRes #}-instance (impl ~ ( IO ())) => Op (ShowWidget ()) GlWindow orig impl where-  runOp _ _ win = withRef win $ \winPtr -> show' winPtr-{# fun Fl_DerivedGl_Window_handle as handle' { id `Ptr ()', cFromEnum `Event' } -> `Int' #}-instance (impl ~ (Event ->  IO(Either UnknownEvent ()))) => Op (Handle ()) GlWindow orig impl where-  runOp _ _ self event = withRef self $ \selfPtr -> handle' selfPtr event >>= return  . successOrUnknownEvent-{# fun Fl_DerivedGl_Window_Destroy as windowDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #}-instance (impl ~ (IO ())) => Op (Destroy ()) GlWindow orig impl where-  runOp _ _ win = withRef win $ \winPtr -> windowDestroy' winPtr-{# fun Fl_DerivedGl_Window_resize as resize' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' supressWarningAboutRes #}-instance (impl ~ (Rectangle ->  IO ())) => Op (Resize ()) GlWindow orig impl where-  runOp _ _ win rectangle' =-    let (x_pos', y_pos', width', height') = fromRectangle rectangle' in-    withRef win $ \winPtr -> resize' winPtr x_pos' y_pos' width' height'

@@ -2601,7 +2601,6 @@ MAKE_METHOD(Activevisible,activevisible) MAKE_METHOD(Measure,measure) MAKE_METHOD(DrawWithT,drawWithT)-{-# WARNING draw "'draw' is bad." #-} MAKE_METHOD(Draw,draw) MAKE_METHOD(GetFlags,getFlags) MAKE_METHOD(SetFlags,setFlags)

@@ -53,7 +53,7 @@ data NativeFileChooserUserAction =   NativeFileChooserPicked |   NativeFileChooserCancelled |-  NativeFileChooserError+  NativeFileChooserError deriving (Show, Eq, Ord)  allNativeFileChooserOptions :: [NativeFileChooserOption] allNativeFileChooserOptions =

@@ -27,6 +27,8 @@ foreign import ccall "wrapper"         mkCallbackPtr :: CallbackPrim -> IO (FunPtr CallbackPrim) foreign import ccall "wrapper"+        mkOpenCallbackPtr :: OpenCallbackPrim -> IO (FunPtr OpenCallbackPrim)+foreign import ccall "wrapper"         mkCustomColorAveragePtr :: CustomColorAveragePrim -> IO (FunPtr CustomColorAveragePrim) foreign import ccall "wrapper"         mkGlobalEventHandlerPtr :: GlobalEventHandlerPrim -> IO (FunPtr GlobalEventHandlerPrim)@@ -311,7 +313,9 @@   in   case findSpecialKey of     Just sk -> SpecialKeyType sk-    Nothing -> NormalKeyType (toEnum $ fromIntegral cint)+    Nothing -> if cint <= 0x10FFFF+               then NormalKeyType (toEnum $ fromIntegral cint)+               else SpecialKeyType Kb_Unrecognized  cFromKeyType :: KeyType -> CInt cFromKeyType kt = case kt of

@@ -1,9 +1,10 @@ {-# LANGUAGE CPP, FlexibleContexts #-} -module Graphics.UI.FLTK.LowLevel.X (flcOpenDisplay, flcXid) where+module Graphics.UI.FLTK.LowLevel.X (flcOpenDisplay, flcXid, openCallback) where import Graphics.UI.FLTK.LowLevel.Fl_Types import Graphics.UI.FLTK.LowLevel.Hierarchy import Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.LowLevel.Utils import Foreign.Ptr #include "Fl_C.h" #include "xC.h"@@ -22,3 +23,14 @@          then return Nothing          else return (Just (WindowHandle res))     )++{# fun flc_open_callback as openCallback' { id `FunPtr OpenCallbackPrim' } -> `()' #}++openCallback :: Maybe OpenCallback -> IO (Maybe (FunPtr OpenCallbackPrim))+openCallback Nothing   = openCallback' nullFunPtr >> return Nothing+openCallback (Just cb) = do+  ptr <- mkOpenCallbackPtr $ \cstr -> do+    txt <- cStringToText cstr+    cb txt+  openCallback' ptr+  return (Just ptr)

@@ -1,4 +1,4 @@-resolver: lts-12.6+resolver: lts-15.0 packages: - '.' extra-deps: []