fltkhs 0.3.0.1 → 0.4.0.0

raw patch · 50 files changed

+1339/−274 lines, 50 filesdep ~directorysetup-changed

Dependency ranges changed: directory

Files

CMakeLists.txt +30/−3
README.md +2/−0
Setup.hs +56/−4
c-src/CMakeLists.txt +16/−6
c-src/Fl_BMP_ImageC.cpp +11/−0
c-src/Fl_BMP_ImageC.h +13/−0
c-src/Fl_File_BrowserC.h +7/−0
c-src/Fl_GIF_ImageC.cpp +11/−0
c-src/Fl_GIF_ImageC.h +13/−0
c-src/Fl_JPEG_ImageC.cpp +15/−0
c-src/Fl_JPEG_ImageC.h +14/−0
c-src/Fl_PNG_ImageC.cpp +15/−0
c-src/Fl_PNG_ImageC.h +14/−0
c-src/Fl_RGB_ImageC.cpp +3/−0
c-src/Fl_RGB_ImageC.h +1/−0
c-src/Fl_TileC.cpp +3/−0
c-src/Fl_XBM_ImageC.cpp +11/−0
c-src/Fl_XBM_ImageC.h +13/−0
c-src/Fl_XPM_ImageC.cpp +11/−0
c-src/Fl_XPM_ImageC.h +13/−0
c-src/Makefile.in +6/−0
c-src/filenameC.cpp +12/−0
c-src/filenameC.h +4/−0
configure.ac +1/−1
fltkhs.buildinfo.in +1/−1
fltkhs.cabal +94/−43
src/Fluid/Generate.hs +49/−38
src/Fluid/Lookup.hs +20/−3
src/Fluid/Parser.hs +18/−1
src/Fluid/Types.hs +2/−0
src/Fluid/Utils.hs +24/−0
src/Graphics/UI/FLTK/LowLevel/BMPImage.chs +36/−0
src/Graphics/UI/FLTK/LowLevel/Dispatch.hs +25/−57
src/Graphics/UI/FLTK/LowLevel/Draw.chs +2/−3
src/Graphics/UI/FLTK/LowLevel/FLTKHS.hs +18/−15
src/Graphics/UI/FLTK/LowLevel/FileBrowser.chs +112/−0
src/Graphics/UI/FLTK/LowLevel/GIFImage.chs +36/−0
src/Graphics/UI/FLTK/LowLevel/GlWindow.chs +0/−1
src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs +242/−81
src/Graphics/UI/FLTK/LowLevel/Image.chs +8/−6
src/Graphics/UI/FLTK/LowLevel/JPEGImage.chs +41/−0
src/Graphics/UI/FLTK/LowLevel/OverlayWindow.chs +0/−1
src/Graphics/UI/FLTK/LowLevel/PNGImage.chs +41/−0
src/Graphics/UI/FLTK/LowLevel/PNMImage.chs +36/−0
src/Graphics/UI/FLTK/LowLevel/RGBImage.chs +153/−0
src/Graphics/UI/FLTK/LowLevel/SysMenuBar.chs +1/−6
src/Graphics/UI/FLTK/LowLevel/Utils.hs +9/−0
src/Graphics/UI/FLTK/LowLevel/Widget.chs +4/−4
src/Graphics/UI/FLTK/LowLevel/XBMImage.chs +36/−0
src/Graphics/UI/FLTK/LowLevel/XPMImage.chs +36/−0

CMakeLists.txt view

@@ -1,6 +1,10 @@ CMAKE_MINIMUM_REQUIRED(VERSION 2.6)  PROJECT(fltkc)++# CMake doesn't like backslashes in path+STRING(REGEX REPLACE "\\\\" "/" FLTK_HOME ${FLTK_HOME}) + if(EXISTS "${FLTK_HOME}/lib/libfltk_z.a")   SET(FLTK_Z "${FLTK_HOME}/lib/libfltk_z.a") else()@@ -22,9 +26,32 @@   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_PNG} ${FLTK_JPEG} ${FLTK_Z} ${FLTK_HOME}/lib/libfltk_forms.a")-SET(FLTKCONFIGCOMMAND "${FLTKCONFIGCOMMAND} -mwindows -lglu32 -lopengl32 -lole32 -luuid -lcomctl32")-MESSAGE("${FLTKCONFIGCOMMAND}")++SET(FLTKLINKFLAGS "-Wl,-Bstatic")+SET(FLTKLINKFLAGS "${FLTKLINKFLAGS} -lfltk.a -lfltk_gl -lfltk_images.a ${FLTK_PNG} ${FLTK_JPEG} ${FLTK_Z} -lfltk_forms")+SET(FLTKLINKFLAGS "${FLTKLINKFLAGS} -Wl,-Bdynamic")++# target_link_libraries doesn't accept libraries as absolute path and+# find_library usually returns path to import library instead static one+# so replace any string in form of 'c:/dev/lib/libfoo.dll.a' with '-lfoo'+STRING(REGEX REPLACE "[^ ]*/lib" "-l" FLTKLINKFLAGS ${FLTKLINKFLAGS})+STRING(REGEX REPLACE "\\.dll\\.a|\\.a" "" FLTKLINKFLAGS ${FLTKLINKFLAGS})++SET(FLTKLINKFLAGS "${FLTKLINKFLAGS} -lglu32 -lopengl32 -lole32 -luuid -lcomctl32 -lComdlg32 -static-libstdc++ -static-libgcc")++# Newer versions of MinGW come with libwinpthread which gets linked dynamicaly by default+find_library (HAVE_PTHREAD pthread)+IF(HAVE_PTHREAD)+	SET(FLTKLINKFLAGS "${FLTKLINKFLAGS} -Wl,-Bstatic,-lstdc++,-lpthread,-Bdynamic")+else()+	SET(FLTKLINKFLAGS "${FLTKLINKFLAGS} -Wl,-Bstatic,-lstdc++,-Bdynamic")+endif()+++MESSAGE(STATUS "FLTKLINKFLAGS: ${FLTKLINKFLAGS}")++SET(FLTKCONFIGCOMMAND "-Wl,-Bstatic,-whole-archive,-lfltkc,-no-whole-archive,-Bdynamic ${FLTKLINKFLAGS}")+ CONFIGURE_FILE(${CMAKE_CURRENT_SOURCE_DIR}/fltkhs.buildinfo.in                ${CMAKE_CURRENT_SOURCE_DIR}/fltkhs.buildinfo) FIND_PACKAGE(OpenGL REQUIRED)

README.md view

@@ -3,6 +3,8 @@  Fltkhs aims to be a complete Haskell binding to the [FLTK GUI library] [1]. +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:  - Download [FLTK 1.3.3] [2].

Setup.hs view

@@ -1,4 +1,4 @@-import Data.Maybe(fromJust)+import Data.Maybe(fromJust, isJust, fromMaybe, maybeToList) import Data.List(partition, isPrefixOf) import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo@@ -8,6 +8,7 @@ import Distribution.Simple.Setup import Distribution.Simple.Utils import Distribution.Verbosity+import Distribution.Text ( display ) import Control.Monad import Data.List import Distribution.Simple.Program@@ -18,6 +19,7 @@    , happyProgram, alexProgram, ghcProgram, gccProgram, requireProgram, arProgram) import Distribution.Simple.Program.Db import Distribution.Simple.PreProcess+import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage ) import System.IO.Unsafe (unsafePerformIO) import qualified Distribution.Simple.Program.Ar    as Ar import qualified Distribution.ModuleName as ModuleName@@ -30,7 +32,7 @@ import qualified Distribution.Simple.UHC  as UHC import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.PackageDescription as PD-import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.InstalledPackageInfo (extraGHCiLibraries, showInstalledPackageInfo) import System.Environment (getEnv)  main :: IO ()@@ -40,7 +42,8 @@               _ -> myPreConf,   buildHook = myBuildHook,   cleanHook = myCleanHook,-  copyHook = copyCBindings+  copyHook = copyCBindings,+  regHook = registerHook   }  myPreConf :: Args -> ConfigFlags -> IO HookedBuildInfo@@ -61,7 +64,7 @@      then runCMake      else do        libs <- getDirectoryContents fltkcdir-       if (null $ filter ((==) "libfltkc.a") libs)+       if (null $ filter ((==) "libfltkc.dll") libs)         then runCMake         else return ()        return ()@@ -105,7 +108,56 @@     case buildOS of      Linux -> rawSystemExit (fromFlag $ copyVerbosity flags) "cp"               ["c-lib/libfltkcdyn.so", libPref]+     Windows -> do+        rawSystemExit (fromFlag $ copyVerbosity flags) "cp"+              ["c-lib/libfltkc.dll.a", libPref]+        rawSystemExit (fromFlag $ copyVerbosity flags) "cp"+              ["c-lib/libfltkc.dll", libPref]  myCleanHook pd x uh cf = do   rawSystemExit normal "make" ["clean"]   cleanHook defaultUserHooks pd x uh cf+++-- Based on code in "Gtk2HsSetup.hs" from "gtk" package+registerHook pkg_descr localbuildinfo _ flags =+    if hasLibs pkg_descr+    then register pkg_descr localbuildinfo flags+    else setupMessage verbosity+           "Package contains no library to register:" (packageId pkg_descr)+  where verbosity = fromFlag (regVerbosity flags)++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 installedPkgInfo = installedPkgInfoRaw {+                                -- this is what this whole register code is all about+                                extraGHCiLibraries = ["fltkc"] }++     -- Three different modes:+    case () of+     _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo+       | modeGenerateRegScript -> die "Generate Reg Script not supported"+       | otherwise             -> registerPackage verbosity+                                    installedPkgInfo pkg lbi inplace packageDbs+  where+    modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))+    regFile             = fromMaybe (display (packageId pkg) <.> "conf")+                                    (fromFlag (regGenPkgConf regFlags))+    modeGenerateRegScript = fromFlag (regGenScript regFlags)+    inplace   = fromFlag (regInPlace regFlags)+    packageDbs = nub $ withPackageDB lbi+                    ++ maybeToList (flagToMaybe  (regPackageDB regFlags))+    packageDb = registrationPackageDB packageDbs+    distPref  = fromFlag (regDistPref regFlags)+    verbosity = fromFlag (regVerbosity regFlags)++    writeRegistrationFile installedPkgInfo = do+      notice verbosity ("Creating package registration file: " ++ regFile)+      writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo)

c-src/CMakeLists.txt view

@@ -99,16 +99,26 @@ 	Fl_WizardC.cpp   ) -ADD_DEFINITIONS("${CXX_FLAGS} -mwindows -DWIN32 -DUSE_OPENGL32 -D_LARGEFILE_SOURCE -D_LARGEFILE64_SOURCE -D_FILE_OFFSET_BITS=64 -c -Wall -DINTERNAL_LINKAGE -g -Icpp -I\"${FLTK_HOME}\"")+ADD_DEFINITIONS("${CXX_FLAGS} -DWIN32 -DUSE_OPENGL32 -D_LARGEFILE_SOURCE -D_LARGEFILE64_SOURCE -D_FILE_OFFSET_BITS=64 -c -Wall -DINTERNAL_LINKAGE -g -Icpp -I\"${FLTK_HOME}/include\"")  MESSAGE(STATUS ${CXX_FLAGS})-ADD_LIBRARY(fltkc ${SourceFiles}) -set_target_properties(fltkc PROPERTIES ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/../c-lib)+# first build object library so that we can reuse same objects for both static and shared library+ADD_LIBRARY(fltkc_obj OBJECT ${SourceFiles}) -add_custom_command(TARGET fltkc PRE_LINK-                   COMMAND ${CMAKE_COMMAND} -P ${CMAKE_CURRENT_SOURCE_DIR}/CMakeCopyObjectFiles.txt-                   )+ADD_LIBRARY(fltkc SHARED $<TARGET_OBJECTS:fltkc_obj>)++target_link_libraries(fltkc ${FLTKLINKFLAGS} -L${FLTK_HOME}/lib)++set_target_properties(fltkc PROPERTIES ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/../c-lib+                                       RUNTIME_OUTPUT_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/../c-lib)+++ADD_LIBRARY(fltkc_static STATIC $<TARGET_OBJECTS:fltkc_obj>)+set_target_properties(fltkc_static PROPERTIES ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/../c-lib+                                              OUTPUT_NAME fltkc)++ set_directory_properties(PROPERTIES                          ADDITIONAL_MAKE_CLEAN_FILES "${CMAKE_CURRENT_SOURCE_DIR}/../c-lib;                                                       ${CMAKE_CURRENT_SOURCE_DIR}/../static_object_files;

+ c-src/Fl_BMP_ImageC.cpp view

@@ -0,0 +1,11 @@+#include "Fl_BMP_ImageC.h"+#ifdef __cplusplus+EXPORT {+#endif+  FL_EXPORT_C(fl_BMP_Image,Fl_BMP_Image_New)(const char* filename){+    Fl_BMP_Image* image = new Fl_BMP_Image(filename);+    return (static_cast<fl_BMP_Image>(image));+  }+#ifdef __cplusplus+}+#endif

+ c-src/Fl_BMP_ImageC.h view

@@ -0,0 +1,13 @@+#ifndef __FL_BMP_IMAGE_C__+#define __FL_BMP_IMAGE_C__+#ifdef __cplusplus+#include "FL/Fl.H"+#include "FL/Fl_BMP_Image.H"+#include "Fl_CallbackC.h"+EXPORT {+#endif+  FL_EXPORT_C(fl_BMP_Image, Fl_BMP_Image_New)(const char* filename);+#ifdef __cplusplus+}+#endif+#endif

c-src/Fl_File_BrowserC.h view

@@ -10,6 +10,13 @@ #endif #include "filenameC.h" +#ifndef INTERNAL_LINKAGE+  typedef enum FILE_BROWSER_TYPE {+    FILES,+    DIRECTORIES+  } FILE_BROWSER_TYPE;+#endif+   /* Inherited from Fl_Widget */   FL_EXPORT_C(int ,         Fl_File_Browser_handle_super)(fl_File_Browser file_browser,int event);   FL_EXPORT_C(int ,         Fl_File_Browser_handle )(fl_File_Browser file_browser,int event);

+ c-src/Fl_GIF_ImageC.cpp view

@@ -0,0 +1,11 @@+#include "Fl_GIF_ImageC.h"+#ifdef __cplusplus+EXPORT {+#endif+  FL_EXPORT_C(fl_GIF_Image,Fl_GIF_Image_New)(const char* filename){+    Fl_GIF_Image* image = new Fl_GIF_Image(filename);+    return (static_cast<fl_GIF_Image>(image));+  }+#ifdef __cplusplus+}+#endif

+ c-src/Fl_GIF_ImageC.h view

@@ -0,0 +1,13 @@+#ifndef __FL_GIF_IMAGE_C__+#define __FL_GIF_IMAGE_C__+#ifdef __cplusplus+#include "FL/Fl.H"+#include "FL/Fl_GIF_Image.H"+#include "Fl_CallbackC.h"+EXPORT {+#endif+  FL_EXPORT_C(fl_GIF_Image, Fl_GIF_Image_New)(const char* filename);+#ifdef __cplusplus+}+#endif+#endif

+ c-src/Fl_JPEG_ImageC.cpp view

@@ -0,0 +1,15 @@+#include "Fl_JPEG_ImageC.h"+#ifdef __cplusplus+EXPORT {+#endif+  FL_EXPORT_C(fl_JPEG_Image,Fl_JPEG_Image_New_WithData)(const char* name, const unsigned char* data){+    Fl_JPEG_Image* image = new Fl_JPEG_Image(name, data);+    return (static_cast<fl_JPEG_Image>(image));+  }+  FL_EXPORT_C(fl_JPEG_Image,Fl_JPEG_Image_New)(const char* filename){+    Fl_JPEG_Image* image = new Fl_JPEG_Image(filename);+    return (static_cast<fl_JPEG_Image>(image));+  }+#ifdef __cplusplus+}+#endif

+ c-src/Fl_JPEG_ImageC.h view

@@ -0,0 +1,14 @@+#ifndef __FL_JPEG_IMAGE_C__+#define __FL_JPEG_IMAGE_C__+#ifdef __cplusplus+#include "FL/Fl.H"+#include "FL/Fl_JPEG_Image.H"+#include "Fl_CallbackC.h"+EXPORT {+#endif+  FL_EXPORT_C(fl_JPEG_Image, Fl_JPEG_Image_New_WithData)(const char* name, const unsigned char* data);+  FL_EXPORT_C(fl_JPEG_Image, Fl_JPEG_Image_New)(const char* filename);+#ifdef __cplusplus+}+#endif+#endif

+ c-src/Fl_PNG_ImageC.cpp view

@@ -0,0 +1,15 @@+#include "Fl_PNG_ImageC.h"+#ifdef __cplusplus+EXPORT {+#endif+  FL_EXPORT_C(fl_PNG_Image,Fl_PNG_Image_New_WithData)(const char* name, const unsigned char* data, int datasize){+    Fl_PNG_Image* image = new Fl_PNG_Image(name, data, datasize);+    return (static_cast<fl_PNG_Image>(image));+  }+  FL_EXPORT_C(fl_PNG_Image,Fl_PNG_Image_New)(const char* filename){+    Fl_PNG_Image* image = new Fl_PNG_Image(filename);+    return (static_cast<fl_PNG_Image>(image));+  }+#ifdef __cplusplus+}+#endif

+ c-src/Fl_PNG_ImageC.h view

@@ -0,0 +1,14 @@+#ifndef __FL_PNG_IMAGE_C__+#define __FL_PNG_IMAGE_C__+#ifdef __cplusplus+#include "FL/Fl.H"+#include "FL/Fl_PNG_Image.H"+#include "Fl_CallbackC.h"+EXPORT {+#endif+  FL_EXPORT_C(fl_PNG_Image, Fl_PNG_Image_New_WithData)(const char* name, const unsigned char* data, int datasize);+  FL_EXPORT_C(fl_PNG_Image, Fl_PNG_Image_New)(const char* filename);+#ifdef __cplusplus+}+#endif+#endif

c-src/Fl_RGB_ImageC.cpp view

@@ -66,6 +66,9 @@   FL_EXPORT_C(void,Fl_RGB_Image_draw_with_cy)(fl_RGB_Image rgb_image,int X,int Y,int W,int H,int cy){     (static_cast<Fl_RGB_Image*>(rgb_image))->draw(X,Y,W,H,cy);   }+  FL_EXPORT_C(void,Fl_RGB_Image_draw_with)(fl_RGB_Image rgb_image,int X,int Y,int W,int H){+    (static_cast<Fl_RGB_Image*>(rgb_image))->draw(X,Y,W,H);+  }   FL_EXPORT_C(void,Fl_RGB_Image_draw)(fl_RGB_Image rgb_image,int X,int Y){     (static_cast<Fl_RGB_Image*>(rgb_image))->draw(X,Y);   }

c-src/Fl_RGB_ImageC.h view

@@ -29,6 +29,7 @@   FL_EXPORT_C(void, Fl_RGB_Image_draw_with_cx_cy)(fl_RGB_Image rgb_image,int X, int Y, int W, int H, int cx, int cy);   FL_EXPORT_C(void, Fl_RGB_Image_draw_with_cx)(fl_RGB_Image rgb_image,int X, int Y, int W, int H, int cx);   FL_EXPORT_C(void, Fl_RGB_Image_draw_with_cy)(fl_RGB_Image rgb_image,int X, int Y, int W, int H, int cy);+  FL_EXPORT_C(void, Fl_RGB_Image_draw_with)(fl_RGB_Image rgb_image,int X, int Y, int W, int H);   FL_EXPORT_C(void, Fl_RGB_Image_draw)(fl_RGB_Image rgb_image,int X, int Y);   FL_EXPORT_C(void, Fl_RGB_Image_uncache)(fl_RGB_Image rgb_image);   FL_EXPORT_C(void, Fl_RGB_Image_set_max_size)(size_t size);

c-src/Fl_TileC.cpp view

@@ -303,6 +303,9 @@   FL_EXPORT_C(void,Fl_Tile_add_resizable)(fl_Tile tile,fl_Widget o){     return (static_cast<Fl_Tile*>(tile))->add_resizable(*(static_cast<Fl_Widget*>(o)));   }+  FL_EXPORT_C(void,Fl_Tile_resize)(fl_Tile tile, int x, int y, int w, int h){+    return (static_cast<Fl_Tile*>(tile))->resize(x, y, w, h);+  }   FL_EXPORT_C(void,Fl_Tile_init_sizes)(fl_Tile tile){     (static_cast<Fl_Tile*>(tile))->init_sizes();   }

+ c-src/Fl_XBM_ImageC.cpp view

@@ -0,0 +1,11 @@+#include "Fl_XBM_ImageC.h"+#ifdef __cplusplus+EXPORT {+#endif+  FL_EXPORT_C(fl_XBM_Image,Fl_XBM_Image_New)(const char* filename){+    Fl_XBM_Image* image = new Fl_XBM_Image(filename);+    return (static_cast<fl_XBM_Image>(image));+  }+#ifdef __cplusplus+}+#endif

+ c-src/Fl_XBM_ImageC.h view

@@ -0,0 +1,13 @@+#ifndef __FL_XBM_IMAGE_C__+#define __FL_XBM_IMAGE_C__+#ifdef __cplusplus+#include "FL/Fl.H"+#include "FL/Fl_XBM_Image.H"+#include "Fl_CallbackC.h"+EXPORT {+#endif+  FL_EXPORT_C(fl_XBM_Image, Fl_XBM_Image_New)(const char* filename);+#ifdef __cplusplus+}+#endif+#endif

+ c-src/Fl_XPM_ImageC.cpp view

@@ -0,0 +1,11 @@+#include "Fl_XPM_ImageC.h"+#ifdef __cplusplus+EXPORT {+#endif+  FL_EXPORT_C(fl_XPM_Image,Fl_XPM_Image_New)(const char* filename){+    Fl_XPM_Image* image = new Fl_XPM_Image(filename);+    return (static_cast<fl_XPM_Image>(image));+  }+#ifdef __cplusplus+}+#endif

+ c-src/Fl_XPM_ImageC.h view

@@ -0,0 +1,13 @@+#ifndef __FL_XPM_IMAGE_C__+#define __FL_XPM_IMAGE_C__+#ifdef __cplusplus+#include "FL/Fl.H"+#include "FL/Fl_XPM_Image.H"+#include "Fl_CallbackC.h"+EXPORT {+#endif+  FL_EXPORT_C(fl_XPM_Image, Fl_XPM_Image_New)(const char* filename);+#ifdef __cplusplus+}+#endif+#endif

c-src/Makefile.in view

@@ -49,6 +49,7 @@ 	Fl_Hold_BrowserC.cpp \ 	Fl_Image_SurfaceC.cpp \ 	Fl_ImageC.cpp \+	Fl_JPEG_ImageC.cpp \ 	Fl_Input_C.cpp \ 	Fl_InputC.cpp \ 	Fl_Int_InputC.cpp \@@ -64,6 +65,11 @@ 	Fl_Paged_DeviceC.cpp \ 	Fl_PixmapC.cpp \ 	Fl_PNM_ImageC.cpp \+	Fl_PNG_ImageC.cpp \+	Fl_XBM_ImageC.cpp \+	Fl_XPM_ImageC.cpp \+	Fl_GIF_ImageC.cpp \+	Fl_BMP_ImageC.cpp \ 	Fl_PreferencesC.cpp \ 	Fl_PrinterC.cpp \ 	Fl_ProgressC.cpp \

c-src/filenameC.cpp view

@@ -53,6 +53,18 @@   FL_EXPORT_C(int,flc_filename_relative_with_cwd)(char* to,int tolen,const char* from,const char* cwd){     return fl_filename_relative(to,tolen,from,cwd);   }+  FL_EXPORT_C(Fl_File_Sort_F* ,fl_numericsort_reference ()){+    return &fl_numericsort;+  }+  FL_EXPORT_C(Fl_File_Sort_F* ,fl_alphasort_reference ()){+    return &fl_alphasort;+  }+  FL_EXPORT_C(Fl_File_Sort_F* ,fl_casealphasort_reference ()){+    return &fl_casealphasort;+  }+  FL_EXPORT_C(Fl_File_Sort_F* ,fl_casenumericsort_reference ()){+    return &fl_casenumericsort;+  } #ifdef __cplusplus } #endif

c-src/filenameC.h view

@@ -29,6 +29,10 @@   FL_EXPORT_C(int		,flc_filename_match)(const char* name, const char* pattern);   FL_EXPORT_C(int		,flc_filename_isdir)(const char* name);   FL_EXPORT_C(int		,flc_filename_relative_with_cwd)(char* to, int tolen, const char* from, const char* cwd);+  FL_EXPORT_C(Fl_File_Sort_F* ,fl_numericsort_reference ());+  FL_EXPORT_C(Fl_File_Sort_F* ,fl_alphasort_reference ());+  FL_EXPORT_C(Fl_File_Sort_F* ,fl_casealphasort_reference ());+  FL_EXPORT_C(Fl_File_Sort_F* ,fl_casenumericsort_reference ()); #ifdef __cplusplus } #endif

configure.ac view

@@ -29,7 +29,7 @@              FormsFlag='--use-forms',              FormsFlag='') -AC_SUBST(FLTKCONFIGCOMMAND,`fltk-config --ldstaticflags $GlFlag $ImagesFlag $CairoFlag $FormsFlag`)+AC_SUBST(FLTKCONFIGCOMMAND,"$(fltk-config --ldstaticflags $GlFlag $ImagesFlag $CairoFlag $FormsFlag) -lstdc++") AC_SUBST(FLTK_HOME,`fltk-config --includedir`) # Checks for typedefs, structures, and compiler characteristics. AC_TYPE_SIZE_T

fltkhs.buildinfo.in view

@@ -1,2 +1,2 @@-ld-options: @FLTKCONFIGCOMMAND@ -lstdc+++ld-options: @FLTKCONFIGCOMMAND@ include-dirs: @FLTK_HOME@

fltkhs.cabal view

@@ -1,10 +1,11 @@ name : fltkhs-version : 0.3.0.1+version : 0.4.0.0 synopsis : FLTK bindings description:     Low level bindings for the FLTK GUI toolkit. license : MIT license-file : LICENSE+tested-with: GHC >=7.8.1 author : Aditya Siram maintainer: aditya.siram@gmail.com homepage: http://github.com/deech/fltkhs@@ -99,6 +100,15 @@                    Graphics.UI.FLTK.LowLevel.Tabs                    Graphics.UI.FLTK.LowLevel.Spinner                    Graphics.UI.FLTK.LowLevel.ColorChooser+                   Graphics.UI.FLTK.LowLevel.FileBrowser+                   Graphics.UI.FLTK.LowLevel.JPEGImage+                   Graphics.UI.FLTK.LowLevel.RGBImage+                   Graphics.UI.FLTK.LowLevel.BMPImage+                   Graphics.UI.FLTK.LowLevel.GIFImage+                   Graphics.UI.FLTK.LowLevel.XBMImage+                   Graphics.UI.FLTK.LowLevel.XPMImage+                   Graphics.UI.FLTK.LowLevel.PNGImage+                   Graphics.UI.FLTK.LowLevel.PNMImage   build-depends:                 base == 4.*,                 bytestring@@ -108,7 +118,7 @@   include-dirs: ./c-src, ./   default-extensions: GADTs   default-language: Haskell2010-  ghc-options: -Wall -fcontext-stack=300+  ghc-options: -Wall   if impl(ghc >= 7.10.2)      cpp-options: -DCALLSTACK_AVAILABLE   if impl(ghc >= 7.10)@@ -122,10 +132,13 @@     filepath,     fltkhs,     parsec >= 3.1.6,+    directory >= 1.2.2.0,     mtl   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300-  if !os(darwin)+  ghc-Options: -Wall -threaded+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Flag FastCompile@@ -138,13 +151,15 @@   Hs-Source-Dirs: src/Examples   Build-Depends:     base == 4.*,-    directory,+    directory >= 1.2.2.0,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-tile@@ -155,10 +170,12 @@     directory,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-nativefilechooser-simple-app@@ -169,10 +186,12 @@     directory,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-table-as-container@@ -182,10 +201,12 @@     base == 4.*,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-texteditor-simple@@ -195,10 +216,12 @@     base == 4.*,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-textdisplay-with-colors@@ -208,10 +231,12 @@     base == 4.*,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-doublebuffer@@ -221,10 +246,12 @@     base == 4.*,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-make-tree@@ -234,10 +261,12 @@     base == 4.*,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-tree-simple@@ -247,10 +276,12 @@     base == 4.*,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-table-spreadsheet-with-keyboard-nav@@ -260,10 +291,12 @@     base == 4.*,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-test_call@@ -273,10 +306,12 @@     base == 4.*,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-buttons@@ -286,10 +321,12 @@     base == 4.*,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-table-simple@@ -299,10 +336,12 @@     base == 4.*,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-table-sort@@ -313,10 +352,12 @@     fltkhs,     process   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-arc@@ -326,10 +367,12 @@     base == 4.*,     fltkhs   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-bitmap@@ -339,10 +382,12 @@      base == 4.*,      fltkhs,bytestring   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-boxtype@@ -352,10 +397,12 @@      base == 4.*,      fltkhs,bytestring   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-browser@@ -366,10 +413,12 @@      fltkhs,      bytestring   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"  Executable fltkhs-clock@@ -380,8 +429,10 @@      fltkhs,      bytestring   default-language: Haskell2010-  ghc-Options: -Wall -threaded -fcontext-stack=300+  ghc-Options: -Wall -threaded   if impl(ghc >= 7.10) && flag(FastCompile)      ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0-  if !os(darwin)+  if os(windows)+   ghc-Options: -optl-mwindows+  if !os(darwin) && !os(windows)     ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"

src/Fluid/Generate.hs view

@@ -1,7 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} module Generate-       (collapseString,-        typeToHs,+       (typeToHs,         typicalConstructorG,         constructorG,         attributeG,@@ -9,44 +8,24 @@        )        where -import           Control.Monad.State-import           Control.Monad.Writer-import           Control.Monad.Identity-import           Data.Char-import           Data.List-import           Foreign.C.Types-import           Graphics.UI.FLTK.LowLevel.Utils-import           Lookup-import           Numeric-import           Types-import           Parser+import Control.Monad.State+import Control.Monad.Writer+import Control.Monad.Identity+import Data.Char+import Data.List+import Foreign.C.Types+import Graphics.UI.FLTK.LowLevel.Utils+import Lookup+import Types+import Parser+import Utils+import System.FilePath+ apply   :: [Char] -> [Char] -> Maybe [Char] -> [Char] apply f n args =   f ++ " " ++ n ++ (maybe "" (\args' -> " " ++ args') args) --collapseParts :: [BracedStringParts] -> String-collapseParts parts = go parts []-  where go ((BareString s):_parts) accum =-          go _parts (accum ++ s)-        go ((QuotedCharCode c):_parts) accum =-          go _parts (accum ++ "\\" ++ [c])-        go ((QuotedHex h):_parts) accum =-          go _parts (accum ++ "0x" ++ (showHex h ""))-        go ((QuotedOctal o):_parts) accum =-          go _parts (accum ++ "0o" ++ (showOct o ""))-        go ((QuotedChar c):_parts) accum =-          go _parts (accum ++ c)-        go ((NestedBrace ps):_parts) accum =-          go _parts ("{" ++ (go ps accum) ++ "}")-        go [] accum = accum--collapseString :: UnbrokenOrBraced -> String-collapseString (UnbrokenString s) = s-collapseString (BracedString []) = ""-collapseString (BracedString parts) = collapseParts parts- typeToHs :: String -> String -> Maybe String typeToHs flClassName flWidgetType   | flClassName == "Fl_Box" =@@ -113,7 +92,14 @@     Types.Label l ->       apply "setLabel" name (Just $ show $ collapseString l)     Types.Value v ->-      apply "setValue" name (Just $ collapseString v)+      if (not (flClassName `elem` ["MenuItem"]))+      then if (flClassName `elem` ["Fl_Return_Button", "Fl_Light_Button", "Fl_Check_Button", "Fl_Repeat_Button", "Fl_Round_Button", "Fl_Button"])+           then apply "setValue" name (Just (show (cToBool ((read (collapseString v)) :: Int))))+           else+             if (flClassName `elem` ["Fl_Output", "Fl_Int_Input", "Fl_Input"])+             then apply "setValue" name (Just (show (collapseString v)))+             else apply "setValue" name (Just (collapseString v))+      else ""     Types.WidgetType w ->       maybe ""             (\t ->@@ -130,7 +116,9 @@     Types.Labelsize s ->       apply "setLabelsize" name (Just ("(FontSize " ++ (show s) ++ ")"))     Types.Resizable ->-      apply "setResizable" name (Just ("((Just (safeCast " ++ name  ++ ")) :: Maybe (Ref Widget))"))+      (apply "groupCurrent" "" Nothing) +++      " >>= " +++      " maybe (error \"setResizable: Could not determine containing group for " ++ name ++ "\") (\\g -> setResizable g " ++ ("((Just (safeCast " ++ name  ++ ")) :: Maybe (Ref Widget))") ++ ")"     Types.Visible ->       apply "setVisible" name Nothing     Types.Align a ->@@ -162,7 +150,9 @@     Types.When w ->       apply "setWhen" name (Just $ "[" ++ (snd (whenType !! w)) ++ "]")     Types.Hotspot ->-      apply "setHotspot" name Nothing+      (apply "getWindow" name Nothing) +++      " >>= " +++      " maybe (error \"hotSpot: Could not determine containing window for " ++ name ++ "\") (\\w -> hotSpot w (ByWidget " ++ name  ++ " ) Nothing)"     Types.Modal ->       apply "setModal" name Nothing     Types.TextFont f ->@@ -200,7 +190,24 @@       collapseParts code     Types.Code3 code ->       collapseParts code+    Types.Image path ->+      setImageOrDeimage path "setImage"+    Types.Deimage path ->+      setImageOrDeimage path "setDeimage"+    Types.Hide ->+      apply "hide" name Nothing     unknown -> " -- unknown attribute: " ++ (show unknown)+  where+    setImageOrDeimage path imageOrDeimage =+      let imageConstructor = lookup (takeExtension (collapseString path)) imageExtensions+      in+      case imageConstructor of+        (Just imageConstructor') ->+          (apply imageConstructor' "" (Just $ show $ collapseString path)) +++          " >>= " +++          "either (\\_ -> error \"Could not open image: " ++ (collapseString path) ++ "\") " +++          "(" ++ (apply imageOrDeimage name Nothing) ++ " . Just )"+        Nothing -> "error \"Image format not supported: " ++ (collapseString path) ++ "\""  haskellIdToName :: TakenNames -> String -> HaskellIdentifier -> String haskellIdToName _ _ (ValidHaskell hid) = hid@@ -365,6 +372,10 @@                                   (map (attributeG newFlClassName newName) restAttrs) ++                                   ["setMenu " ++ newName ++ " ([] :: [Ref MenuItem])"] ++                                   innerTreeOutput+                           "MenuItem" ->+                             (constructorG newFlClassName hsConstructor (Just newName) posSize) +++                             (map (attributeG newFlClassName newName) restAttrs) +++                             innerTreeOutput                            _ ->                              (constructorG newFlClassName hsConstructor (Just newName) posSize) ++                              (map (attributeG newFlClassName newName) restAttrs) ++

src/Fluid/Lookup.hs view

@@ -20,7 +20,8 @@   windowType,   fontType,   spinnerType,-  flClasses+  flClasses,+  imageExtensions  ) where @@ -45,6 +46,7 @@ fontType :: [(String, String)] spinnerType :: [(String, String)] flClasses :: [(String, (String, String))]+imageExtensions :: [(String, String)]  boxType = [   ("NO_BOX"                 ,"NoBox"),@@ -281,8 +283,23 @@   ,("Fl_Pack",("Pack", "packNew"))   ,("Fl_Table",("Table", "tableNew"))   ,("Fl_Scroll",("Scroll", "scrollNew"))-  ,("Fl_Menu_Bar",("MenuBar", "menuBarNew"))+  ,("Fl_Menu_Bar",("MenuBar", "sysMenuBarNew"))   ,("Menu_Button",("MenuButton", "menuButtonNew"))   ,("Fl_Choice",("Choice", "choiceNew"))   ,("Fl_Browser",("Browser", "browserNew" ))-  ,("Fl_Tabs",("Tabs", "tabsNew"))]+  ,("Fl_Tabs",("Tabs", "tabsNew"))+  ,("Fl_Progress", ("Progress", "progressNew"))+  ]++imageExtensions =+  [(".bm", "bmpImageNew")+   ,(".bmp", "bmpImageNew")+   ,(".gif", "gifImageNew")+   ,(".jpg", "jpegImageNew")+   ,(".pbm", "pnmImageNew")+   ,(".pgm", "pnmImageNew")+   ,(".png", "pngImageNew")+   ,(".ppm", "pnmImageNew")+   ,(".xbm", "xbmImageNew")+   ,(".xpm", "xpmImageNew")+  ]

src/Fluid/Parser.hs view

@@ -6,8 +6,11 @@ import Text.Parsec.Token import Debug.Trace import Control.Monad.Identity+import System.Directory import Types+import Utils import Data.List+import System.IO.Unsafe  println :: (Monad m)         => String -> m ()@@ -175,6 +178,17 @@   (try $ bracedContentsP >>= return . BracedString) <|>   (unbrokenString >>= return . UnbrokenString) +pathLiteral+  :: ParsecT String () Identity UnbrokenOrBraced+pathLiteral =+  (try $ do+      bc <- bracedContentsP+      -- take the canonical path relative this the Fluid file since the generated Haskell+      -- file gets put under the `dist` directory and this path will no longer be valid+      return (BracedString [(BareString (unsafePerformIO (canonicalizePath (collapseParts bc))))]))+  <|>+  (unbrokenString >>= return . UnbrokenString)+ langDef :: GenTokenParser String a Control.Monad.Identity.Identity langDef = makeTokenParser haskellDef @@ -287,7 +301,9 @@        ,(string "global" >> return Global)        ,(string "deactivate" >> return Deactivate)        ,(string "public" >> return Public)-       ,(string "divider" >> return Divider)]) +++       ,(string "divider" >> return Divider)+       ,(attrP "image" Image pathLiteral)+       ,(attrP "deimage" Deimage pathLiteral)]) ++   [(attrP "size_range" SizeRange numFourTuple)]  innardsP :: ParsecT String () Identity Attribute@@ -355,6 +371,7 @@      , (string "Fl_Check_Browser")      , (string "Fl_File_Browser")      , (string "Fl_Tree")+     , (string "Fl_Progress")      ])  testIdentifier :: String

src/Fluid/Types.hs view

@@ -79,6 +79,8 @@   | DerivedFromClass String   | Filename UnbrokenOrBraced   | Divider+  | Image UnbrokenOrBraced+  | Deimage UnbrokenOrBraced   deriving (Show) type Type = String data WidgetTree = Group Type HaskellIdentifier [Attribute] [WidgetTree]

+ src/Fluid/Utils.hs view

@@ -0,0 +1,24 @@+module Utils (collapseParts, collapseString) where+import Types+import Numeric++collapseParts :: [BracedStringParts] -> String+collapseParts parts = go parts []+  where go ((BareString s):_parts) accum =+          go _parts (accum ++ s)+        go ((QuotedCharCode c):_parts) accum =+          go _parts (accum ++ "\\" ++ [c])+        go ((QuotedHex h):_parts) accum =+          go _parts (accum ++ "0x" ++ (showHex h ""))+        go ((QuotedOctal o):_parts) accum =+          go _parts (accum ++ "0o" ++ (showOct o ""))+        go ((QuotedChar c):_parts) accum =+          go _parts (accum ++ c)+        go ((NestedBrace ps):_parts) accum =+          go _parts ("{" ++ (go ps accum) ++ "}")+        go [] accum = accum++collapseString :: UnbrokenOrBraced -> String+collapseString (UnbrokenString s) = s+collapseString (BracedString []) = ""+collapseString (BracedString parts) = collapseParts parts

+ src/Graphics/UI/FLTK/LowLevel/BMPImage.chs view

@@ -0,0 +1,36 @@+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Graphics.UI.FLTK.LowLevel.BMPImage+    (+     bmpImageNew+     -- * Hierarchy+     --+     -- $hierarchy++    )+where+#include "Fl_ExportMacros.h"+#include "Fl_Types.h"+#include "Fl_BMP_ImageC.h"+import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Utils+import Graphics.UI.FLTK.LowLevel.Hierarchy+import Graphics.UI.FLTK.LowLevel.RGBImage++{# fun Fl_BMP_Image_New as bmpImageNew' { unsafeToCString `String' } -> `Ptr ()' id #}+bmpImageNew :: String -> IO (Either UnknownError (Ref BMPImage))+bmpImageNew filename' = do+  ptr <- bmpImageNew' filename'+  ref' <- (toRef ptr :: IO (Ref BMPImage))+  checkImage ref'++-- $hierarchy+--+-- "Graphics.UI.FLTK.LowLevel.Image"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.RGBImage"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.BMPImage"

src/Graphics/UI/FLTK/LowLevel/Dispatch.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, ScopedTypeVariables, EmptyDataDecls, CPP #-}+{-# LANGUAGE KindSignatures, TypeFamilies, DataKinds, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, ScopedTypeVariables, EmptyDataDecls, CPP #-} #ifndef OVERLAPPING_INSTANCES_DEPRECATED {-# LANGUAGE OverlappingInstances #-} #endif@@ -33,50 +33,20 @@ -- if not. data Same data Different-class TypeEqual x y b | x y -> b-instance-#ifdef OVERLAPPING_INSTANCES_DEPRECATED-  {-# OVERLAPPING #-}-#endif-  TypeEqual a a Same-instance-#ifdef OVERLAPPING_INSTANCES_DEPRECATED-  {-# OVERLAPPABLE #-}-#endif-  Different ~ b => TypeEqual x y b --- Move down a nested type hierarchy--- eg. Tail (w (x (y (z ())))) (x (y (z ())))-class Tail aas as | aas -> as-instance Tail (a as) as-instance (r ~ ()) => Tail () r---- Test whether a given nested type contains--- a type--- eg. Contains (w (x (y (z ())))) (y ()) Same---     Contains (w (x (y (z ())))) (a ()) Different-class Contains' a b match r | a b match -> r-instance (Tail aas as, Contains as b r) => Contains' aas b Different r-instance (r ~ Same) => Contains' a b Same r--class Contains as a r | as a -> r-instance (TypeEqual (a ()) b match, Contains' (a as) b match r) => Contains (a as) b r-instance Contains () b Different---- | Move down the "object" hierarchy--- | eg. Downcast Rectangle Shape-class Downcast aas as | aas -> as-instance Downcast (a as) as-instance (as ~ Base) => Downcast Base as- -- | See 'FindOp' for more details. data Match a -- | See 'FindOp' for more details. data NoFunction a -class FindOp' a b c r | a b c -> r-instance (Downcast aas as, FindOp as f r) => FindOp' aas f Different r-instance (r ~ (Match a)) => FindOp' a b Same r+-- Test whether a given nested type contains+-- a type+-- eg. Same ~ Contains (w (x (y (z ())))) (y ())+--     Different ~ Contains (w (x (y (z ())))) (a ())+type family Contains as a where+  Contains (a as) (a ()) = Same+  Contains () x = Different+  Contains (a as) b = Contains as b  -- | @FindOp@ searches a class hierarchy for a member function (an  Op-eration) -- and returns the first class in the hierarchy that support it.@@ -85,37 +55,35 @@ -- closest ancestor to @a@ (possibly @a@) that has that function. -- -- If found @r@ is @Match c@, if not found @r@ is @NoFunction b@.-class FindOp a b c | a b -> c-instance (Functions (a as) fs, Contains fs f match, FindOp' (a as) f match r) => FindOp (a as) f r-instance FindOp Base f (NoFunction f)+type family FindOpHelper hierarchy  (needle :: *) (found :: *) :: * where+  FindOpHelper hierarchy needle Same = Match hierarchy+  FindOpHelper (child ancestors) needle Different = FindOp ancestors needle +type family FindOp hierarchy (needle :: *) :: * where+  FindOp () n = NoFunction n+  FindOp hierarchy needle = FindOpHelper hierarchy needle (Contains (Functions hierarchy) needle)+ -- | Find the first "object" of the given type -- | in the hierarchy. data InHierarchy data NotInHierarchy a b -class FindInHierarchy' orig a b c r | orig a b c -> r-instance (Downcast aas as, FindInHierarchy orig as o r) => FindInHierarchy' orig aas o Different r-instance (r ~ InHierarchy) => FindInHierarchy' orig a b Same r--class FindInHierarchy orig a b c | orig a b -> c-instance (TypeEqual as oos match, FindInHierarchy' orig as oos match r) => FindInHierarchy orig as oos r-instance (r ~ NotInHierarchy orig o) => FindInHierarchy orig Base o r-instance FindInHierarchy orig Base Base InHierarchy--+type family FindInHierarchy (needle :: * ) (curr :: *) (haystack :: *) :: * where+  FindInHierarchy needle () (a as) = NotInHierarchy needle (a as)+  FindInHierarchy needle (a as) (a as) = InHierarchy+  FindInHierarchy needle (a as) (b bs) = FindInHierarchy needle as (b bs)  -- | A class with a single instance that is found only if @b@ is an ancestor of @a@. -- -- Used by some 'Op' implementations to enforce that certain parameters have to be -- at least a @b@.+ class Parent a b-instance (FindInHierarchy a a b InHierarchy) => Parent a b+instance (InHierarchy ~ FindInHierarchy a a b) => Parent a b + -- | Associate a "class" with it's member functions-class Functions a b | a -> b--- | The Base of the hierarchy has no functions-instance Functions Base ()+type family Functions (x :: *) :: *  -- | Implementations of methods on various types --  of objects.@@ -147,7 +115,7 @@ -- what arguments it needs. dispatch :: forall op obj origObj impl.             (-              FindOp origObj op (Match obj),+              Match obj ~ FindOp origObj op,               Op op obj origObj impl             ) =>             op -> Ref origObj -> impl

src/Graphics/UI/FLTK/LowLevel/Draw.chs view

@@ -127,7 +127,6 @@ import Graphics.UI.FLTK.LowLevel.Dispatch import Graphics.UI.FLTK.LowLevel.Hierarchy import Data.ByteString-import Data.ByteString.Unsafe  #c enum LineStyle {@@ -542,7 +541,7 @@ flcDrawImageBuf :: ByteString -> Rectangle -> Delta -> LineDelta -> IO () flcDrawImageBuf buf rectangle d l =   let (x_pos', y_pos', width', height') = fromRectangle rectangle-  in unsafeUseAsCString+  in useAsCString        buf        (\cs ->          case (d,l) of@@ -555,7 +554,7 @@ flcDrawImageMonoBuf :: ByteString -> Rectangle -> Delta -> LineDelta ->  IO () flcDrawImageMonoBuf buf rectangle d l =   let (x_pos', y_pos', width', height') = fromRectangle rectangle-  in unsafeUseAsCString+  in useAsCString        buf        (\cs ->          case (d,l) of

src/Graphics/UI/FLTK/LowLevel/FLTKHS.hs view

@@ -116,6 +116,15 @@          module Graphics.UI.FLTK.LowLevel.Scrolled,          module Graphics.UI.FLTK.LowLevel.Ask,          module Graphics.UI.FLTK.LowLevel.ColorChooser,+         module Graphics.UI.FLTK.LowLevel.FileBrowser,+         module Graphics.UI.FLTK.LowLevel.JPEGImage,+         module Graphics.UI.FLTK.LowLevel.RGBImage,+         module Graphics.UI.FLTK.LowLevel.BMPImage,+         module Graphics.UI.FLTK.LowLevel.GIFImage,+         module Graphics.UI.FLTK.LowLevel.XBMImage,+         module Graphics.UI.FLTK.LowLevel.XPMImage,+         module Graphics.UI.FLTK.LowLevel.PNGImage,+         module Graphics.UI.FLTK.LowLevel.PNMImage,          -- * Machinery for static dispatch          module Graphics.UI.FLTK.LowLevel.Dispatch,          -- * Association of widgets and functions@@ -198,6 +207,15 @@ import Graphics.UI.FLTK.LowLevel.Scrolled import Graphics.UI.FLTK.LowLevel.Ask import Graphics.UI.FLTK.LowLevel.ColorChooser+import Graphics.UI.FLTK.LowLevel.FileBrowser+import Graphics.UI.FLTK.LowLevel.JPEGImage+import Graphics.UI.FLTK.LowLevel.RGBImage+import Graphics.UI.FLTK.LowLevel.BMPImage+import Graphics.UI.FLTK.LowLevel.GIFImage+import Graphics.UI.FLTK.LowLevel.XBMImage+import Graphics.UI.FLTK.LowLevel.XPMImage+import Graphics.UI.FLTK.LowLevel.PNGImage+import Graphics.UI.FLTK.LowLevel.PNMImage  -- $Module Documentation -- This module re-exports all the available widgets and their core types. The types and list@@ -683,18 +701,3 @@ --           - LowLevel -- Haskell bindings --   - scripts          -- various helper scripts (probably not interesting to anyone but the original author) -- @------ = Common Type Errors------ * No instance for ('FindOp' () (Blah ()) ('Match' r0)) ...------ Given code that look something like:------ @--- do---   ...---   blah widget---   ...--- @------ that means this the widget `widget` does not support the function `blah`.

+ src/Graphics/UI/FLTK/LowLevel/FileBrowser.chs view

@@ -0,0 +1,112 @@+{-# LANGUAGE CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Graphics.UI.FLTK.LowLevel.FileBrowser+    (+     -- * Constructor+     fileBrowserNew,+     FileBrowserType(..),+     FileSortF,+     numericSort,+     alphaSort,+     caseAlphaSort,+     caseNumericSort+     -- * Hierarchy+     --+     -- $hierarchy++     -- * Functions+     --+     -- $FileBrowserfunctions+     --+    )+where+#include "Fl_ExportMacros.h"+#include "Fl_Types.h"+#include "Fl_File_BrowserC.h"+#include "Fl_WidgetC.h"+#include "FL/filename.H"+import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)+import Foreign.C.Types+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Utils+import Graphics.UI.FLTK.LowLevel.Hierarchy+import Graphics.UI.FLTK.LowLevel.Dispatch+{# pointer *Fl_File_Sort_F as FileSortF #}+{# fun Fl_File_Browser_New as fileBrowserNew' { `Int',`Int',`Int',`Int' } -> `Ptr ()' id #}+{# fun Fl_File_Browser_New_WithLabel as fileBrowserNewWithLabel' { `Int',`Int',`Int',`Int', unsafeToCString `String'} -> `Ptr ()' id #}+fileBrowserNew :: Rectangle -> Maybe String -> IO (Ref FileBrowser)+fileBrowserNew rectangle l'=+    let (x_pos, y_pos, width, height) = fromRectangle rectangle+    in case l' of+        Nothing -> fileBrowserNew' x_pos y_pos width height >>=+                             toRef+        Just l -> fileBrowserNewWithLabel' x_pos y_pos width height l >>=+                               toRef++{# fun Fl_File_Browser_set_iconsize as setIconsize' { id `Ptr ()', id `CUChar' } -> `()' #}+instance (impl ~ (CUChar ->  IO ())) => Op (SetIconsize ()) FileBrowser orig impl where+  runOp _ _ fileBrowser text = withRef fileBrowser $ \fileBrowserPtr -> setIconsize' fileBrowserPtr text+{# fun Fl_File_Browser_iconsize as iconsize' { id `Ptr ()' } -> `CUChar' id #}+instance (impl ~ ( IO (CUChar))) => Op (GetIconsize ()) FileBrowser orig impl where+  runOp _ _ fileBrowser = withRef fileBrowser $ \fileBrowserPtr -> iconsize' fileBrowserPtr+{# fun Fl_File_Browser_set_filter as setFilter' { id `Ptr ()', `String' } -> `()' #}+instance (impl ~ (String ->  IO ())) => Op (SetFilter ()) FileBrowser orig impl where+  runOp _ _ fileBrowser text = withRef fileBrowser $ \fileBrowserPtr -> setFilter' fileBrowserPtr text+{# fun Fl_File_Browser_filter as filter' { id `Ptr ()' } -> `String' unsafeFromCString #}+instance (impl ~ ( IO (String))) => Op (GetFilter ()) FileBrowser orig impl where+  runOp _ _ fileBrowser = withRef fileBrowser $ \fileBrowserPtr -> filter' fileBrowserPtr+{# fun Fl_File_Browser_set_textsize as setTextsize' { id `Ptr ()', id `CInt' } -> `()' #}+instance (impl ~ (FontSize ->  IO ())) => Op (SetTextsize ()) FileBrowser orig impl where+  runOp _ _ fileBrowser (FontSize text) = withRef fileBrowser $ \fileBrowserPtr -> setTextsize' fileBrowserPtr text+{# fun Fl_File_Browser_textsize as textsize' { id `Ptr ()' } -> `CInt' id #}+instance (impl ~ ( IO (FontSize))) => Op (GetTextsize ()) FileBrowser orig impl where+  runOp _ _ fileBrowser = withRef fileBrowser $ \fileBrowserPtr -> textsize' fileBrowserPtr >>= return . FontSize+{# fun Fl_File_Browser_set_filetype as setFileType' { id `Ptr ()',`Word8' } -> `()' supressWarningAboutRes #}+instance (impl ~ (FileBrowserType ->  IO ())) => Op (SetFiletype ()) FileBrowser orig impl where+  runOp _ _ widget t = withRef widget $ \widgetPtr -> setFileType' widgetPtr (fromInteger $ toInteger $ fromEnum t)+{# fun Fl_File_Browser_filetype as filetype' { id `Ptr ()' } -> `Word8' #}+instance (impl ~ IO (FileBrowserType)) => Op (GetFiletype ()) FileBrowser orig impl where+  runOp _ _ widget = withRef widget $ \widgetPtr -> filetype' widgetPtr >>= return . toEnum . fromInteger . toInteger+{# fun Fl_File_Browser_load as load' { id `Ptr ()', `String', id `FileSortF' } -> `CInt' id #}+instance (impl ~ (String -> FileSortF -> IO (Either UnknownError ()))) => Op (Load ()) FileBrowser orig impl where+  runOp _ _ widget dir sortF = withRef widget $ \widgetPtr -> do+                               status <- load' widgetPtr dir sortF+                               return (if (status == 0) then (Left UnknownError) else (Right ()))++{# fun fl_numericsort_reference     as numericSort     {} -> `FileSortF' #}+{# fun fl_alphasort_reference       as alphaSort       {} -> `FileSortF' #}+{# fun fl_casealphasort_reference   as caseAlphaSort   {} -> `FileSortF' #}+{# fun fl_casenumericsort_reference as caseNumericSort {} -> `FileSortF' #}++-- $hierarchy+--+-- "Graphics.UI.FLTK.LowLevel.Widget"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.Group"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.Browser"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.FileBrowser"++-- $FileBrowserFunctions+--+-- getFiletype :: 'Ref' 'FileBrowser' -> 'IO' ('FileBrowserType')+--+-- getFilter :: 'Ref' 'FileBrowser' -> 'IO' ('String')+--+-- getIconsize :: 'Ref' 'FileBrowser' -> 'IO' ('CUChar')+--+-- getTextsize :: 'Ref' 'FileBrowser' -> 'IO' ('FontSize')+--+-- load :: 'Ref' 'FileBrowser' -> 'String' -> 'FileSortF' -> 'IO' ('Either' 'UnknownError' ())+--+-- setFiletype :: 'Ref' 'FileBrowser' -> 'FileBrowserType' -> 'IO' ()+--+-- setFilter :: 'Ref' 'FileBrowser' -> 'String' -> 'IO' ()+--+-- setIconsize :: 'Ref' 'FileBrowser' -> 'CUChar' -> 'IO' ()+--+-- setTextsize :: 'Ref' 'FileBrowser' -> 'FontSize' -> 'IO' ()

+ src/Graphics/UI/FLTK/LowLevel/GIFImage.chs view

@@ -0,0 +1,36 @@+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Graphics.UI.FLTK.LowLevel.GIFImage+    (+     gifImageNew+     -- * Hierarchy+     --+     -- $hierarchy++    )+where+#include "Fl_ExportMacros.h"+#include "Fl_Types.h"+#include "Fl_GIF_ImageC.h"+import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Utils+import Graphics.UI.FLTK.LowLevel.Hierarchy+import Graphics.UI.FLTK.LowLevel.RGBImage++{# fun Fl_GIF_Image_New as gifImageNew' { unsafeToCString `String' } -> `Ptr ()' id #}+gifImageNew :: String -> IO (Either UnknownError (Ref GIFImage))+gifImageNew filename' = do+  ptr <- gifImageNew' filename'+  ref' <- (toRef ptr :: IO (Ref GIFImage))+  checkImage ref'++-- $hierarchy+--+-- "Graphics.UI.FLTK.LowLevel.Image"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.RGBImage"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.GIFImage"

src/Graphics/UI/FLTK/LowLevel/GlWindow.chs view

@@ -17,7 +17,6 @@ #include "Fl_Double_WindowC.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

src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, GADTs, FlexibleContexts, ScopedTypeVariables, EmptyDataDecls, CPP #-}+{-# LANGUAGE TypeSynonymInstances, TypeFamilies, GADTs, FlexibleContexts, EmptyDataDecls, CPP #-}  #ifdef CALLSTACK_AVAILABLE {-# LANGUAGE ImplicitParams #-}@@ -7,12 +7,12 @@ #ifdef CALLSTACK_AVAILABLE #define MAKE_METHOD(Datatype, Method) \ data Datatype a; \-Method :: (?loc :: CallStack, FindOp a (Datatype ()) (Match r), Op (Datatype ()) r a impl) => Ref a -> impl; \+Method :: (?loc :: CallStack, Match r ~ FindOp a (Datatype ()), Op (Datatype ()) r a impl) => Ref a -> impl; \ Method aRef = (unsafePerformIO $ withRef aRef (\_ -> return ())) `seq` dispatch (undefined :: Datatype()) aRef #else #define MAKE_METHOD(Datatype, Method) \ data Datatype a; \-Method :: (FindOp a (Datatype ()) (Match r), Op (Datatype ()) r a impl) => Ref a -> impl; \+Method :: (Match r ~ FindOp a (Datatype ()), Op (Datatype ()) r a impl) => Ref a -> impl; \ Method aRef = dispatch (undefined :: Datatype ()) aRef #endif @@ -1513,7 +1513,33 @@          SetHsv,          setHsv,          SetRgb,-         setRgb+         setRgb,+         -- FileBrowser+         FileBrowser,+         SetIconsize,+         setIconsize,+         GetIconsize,+         getIconsize,+         SetFiletype,+         setFiletype,+         GetFiletype,+         getFiletype,+         -- RGBImage+         RGBImage,+         -- JPEGImage+         JPEGImage,+         -- BMPImage+         BMPImage,+         -- GIFImage+         GIFImage,+         -- XBMImage+         XBMImage,+         -- XPMImage+         XPMImage,+         -- PNGImage+         PNGImage,+         -- PNMImage+         PNMImage   ) where import Prelude hiding (round)@@ -1526,11 +1552,11 @@  data CRegion parent type Region = CRegion Base-instance Functions Region ()+type instance Functions Region = ()  data CGlContext parent type GlContext = CGlContext Base-instance Functions GlContext ()+type instance Functions GlContext = ()  data CWidget parent type Widget = CWidget Base@@ -1624,7 +1650,7 @@   (DrawBackdrop   (DrawFocus   ()))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))-instance Functions Widget WidgetFuncs+type instance Functions Widget = WidgetFuncs  MAKE_METHOD(Destroy, destroy) MAKE_METHOD(Handle, handle)@@ -1745,7 +1771,7 @@   (GetArray   (GetChild   ()))))))))))))))))))))))))))-instance Functions Group GroupFuncs+type instance Functions Group = GroupFuncs  MAKE_METHOD(DrawChild,drawChild) MAKE_METHOD(DrawChildren,drawChildren)@@ -1826,7 +1852,7 @@   (GetDecoratedH   (WaitForExpose   ())))))))))))))))))))))))))))))))))))))))))))))))))-instance Functions Window WindowFuncs+type instance Functions Window = WindowFuncs  MAKE_METHOD(DrawSuper,drawSuper) MAKE_METHOD(HandleSuper,handleSuper)@@ -1886,7 +1912,7 @@   (Handle   (Resize   ())))))))))))-instance Functions SingleWindow SingleWindowFuncs+type instance Functions SingleWindow = SingleWindowFuncs   data CDoubleWindow parent@@ -1904,9 +1930,10 @@   (Handle   (Resize   ())))))))))))-instance Functions DoubleWindow DoubleWindowFuncs +type instance Functions DoubleWindow = DoubleWindowFuncs + data COverlayWindow parent type OverlayWindow = COverlayWindow DoubleWindow type OverlayWindowFuncs =@@ -1918,9 +1945,10 @@   (CanDoOverlay   (RedrawOverlay   ())))))))-instance Functions OverlayWindow OverlayWindowFuncs +type instance Functions OverlayWindow = OverlayWindowFuncs + MAKE_METHOD(CanDoOverlay,canDoOverlay) MAKE_METHOD(RedrawOverlay,redrawOverlay) MAKE_METHOD(Flush,flush)@@ -1955,8 +1983,9 @@   (SetType   (GetType_   ()))))))))))))))))))))))))))-instance Functions Button ButtonFuncs +type instance Functions Button = ButtonFuncs+ MAKE_METHOD(GetValue,getValue) MAKE_METHOD(SetValue,setValue) MAKE_METHOD(Set,set)@@ -1972,31 +2001,36 @@ type LightButtonFuncs =   (Destroy ()) type LightButton = CLightButton Button-instance Functions LightButton LightButtonFuncs +type instance Functions LightButton = LightButtonFuncs+ data CRadioLightButton parent type RadioLightButton = CRadioLightButton LightButton-instance Functions RadioLightButton () +type instance Functions RadioLightButton = ()+ data CCheckButton parent type CheckButtonFuncs =   (Destroy ()) type CheckButton = CCheckButton Button-instance Functions CheckButton CheckButtonFuncs +type instance Functions CheckButton = CheckButtonFuncs+ data CReturnButton parent type ReturnButton = CReturnButton Button type ReturnButtonFuncs =   (Destroy   (Handle ()))-instance Functions ReturnButton ReturnButtonFuncs +type instance Functions ReturnButton = ReturnButtonFuncs+ data CRoundButton parent type RoundButton = CRoundButton Button type RoundButtonFuncs =   (Destroy ())-instance Functions RoundButton RoundButtonFuncs +type instance Functions RoundButton = RoundButtonFuncs+ data CRepeatButton parent type RepeatButton = CRepeatButton Button type RepeatButtonFuncs =@@ -2004,15 +2038,17 @@   (Handle   (Deactivate   ())))-instance Functions RepeatButton RepeatButtonFuncs +type instance Functions RepeatButton = RepeatButtonFuncs + data CToggleButton parent type ToggleButton = CToggleButton Button type ToggleButtonFuncs =   (Destroy ())-instance Functions ToggleButton ToggleButtonFuncs +type instance Functions ToggleButton = ToggleButtonFuncs+ data CValuator parent type Valuator = CValuator Widget type ValuatorFuncs =@@ -2038,8 +2074,9 @@   (SetType   (GetType_   ())))))))))))))))))))))-instance Functions Valuator ValuatorFuncs +type instance Functions Valuator = ValuatorFuncs+ MAKE_METHOD(Bounds,bounds) MAKE_METHOD(GetMinimum,getMinimum) MAKE_METHOD(SetMinimum,setMinimum)@@ -2067,8 +2104,9 @@   (SetSlider   (SetType   (GetType_ ()))))))))))-instance Functions Slider SliderFuncs +type instance Functions Slider = SliderFuncs+ MAKE_METHOD(Scrollvalue,scrollvalue) MAKE_METHOD(SetSliderSize,setSliderSize) MAKE_METHOD(GetSliderSize,getSliderSize)@@ -2077,24 +2115,29 @@  data CFillSlider parent type FillSlider = CFillSlider Slider-instance Functions FillSlider () +type instance Functions FillSlider = ()+ data CHorSlider parent type HorSlider = CHorSlider Slider-instance Functions HorSlider () +type instance Functions HorSlider = ()+ data CHorFillSlider parent type HorFillSlider = CHorFillSlider Slider-instance Functions HorFillSlider () +type instance Functions HorFillSlider = ()+ data CNiceSlider parent type NiceSlider = CNiceSlider Slider-instance Functions NiceSlider () +type instance Functions NiceSlider = ()+ data CHorNiceSlider parent type HorNiceSlider = CHorNiceSlider Slider-instance Functions HorNiceSlider () +type instance Functions HorNiceSlider = ()+ data CMenuItem parent type MenuItem = CMenuItem Base type MenuItemFuncs =@@ -2145,8 +2188,9 @@   (Insert   (GetSize   ()))))))))))))))))))))))))))))))))))))))))))))))-instance Functions MenuItem MenuItemFuncs +type instance Functions MenuItem = MenuItemFuncs+ MAKE_METHOD(NextWithStep,nextWithStep) MAKE_METHOD(Next,next) MAKE_METHOD(GetFirst,getFirst)@@ -2217,8 +2261,9 @@   (GetDownColor   (SetDownColor   ())))))))))))))))))))))))))))))))))))))))))))))-instance Functions MenuPrim MenuPrimFuncs +type instance Functions MenuPrim = MenuPrimFuncs+ MAKE_METHOD(ItemPathname,itemPathname) MAKE_METHOD(ItemPathnameRecent,itemPathnameRecent) MAKE_METHOD(Picked,picked)@@ -2249,7 +2294,6 @@ type SysMenuBar = CSysMenuBar MenuPrim type SysMenuBarFuncs =   (Destroy-  (GetMenu   (SetMenu   (Insert   (Remove@@ -2261,9 +2305,10 @@   (GetMode   (SetShortcut   (Handle-  ())))))))))))))-instance Functions SysMenuBar SysMenuBarFuncs+  ())))))))))))) +type instance Functions SysMenuBar = SysMenuBarFuncs+ data CChoice parent type Choice = CChoice MenuPrim type ChoiceFuncs =@@ -2272,9 +2317,10 @@   (GetValue   (SetValue   ()))))-instance Functions Choice ChoiceFuncs +type instance Functions Choice = ChoiceFuncs + data CMenuButton parent type MenuButton = CMenuButton MenuPrim type MenuButtonFuncs =@@ -2282,8 +2328,9 @@   (Handle   (Popup   ())))-instance Functions MenuButton MenuButtonFuncs +type instance Functions MenuButton = MenuButtonFuncs+ data CImage parent type Image = CImage Base type ImageFuncs =@@ -2301,8 +2348,9 @@   (Draw   (Uncache   ())))))))))))))-instance Functions Image ImageFuncs +type instance Functions Image = ImageFuncs+ MAKE_METHOD(GetD,getD) MAKE_METHOD(GetLd,getLd) MAKE_METHOD(GetCount,getCount)@@ -2329,8 +2377,9 @@  (Draw  (Uncache  ())))))))))))))-instance Functions Bitmap BitmapFuncs +type instance Functions Bitmap = BitmapFuncs+ data CPixmap parent type Pixmap = CPixmap Image type PixmapFuncs =@@ -2348,8 +2397,9 @@   (Draw   (Uncache   ())))))))))))))-instance Functions Pixmap PixmapFuncs +type instance Functions Pixmap = PixmapFuncs+ data CCopySurface parent type CopySurface = CCopySurface Base type CopySurfaceFuncs =@@ -2358,8 +2408,9 @@   (SetCurrent   (Draw   ()))))-instance Functions CopySurface CopySurfaceFuncs +type instance Functions CopySurface = CopySurfaceFuncs+ MAKE_METHOD(ClassName,className) MAKE_METHOD(SetCurrent,setCurrent) @@ -2371,9 +2422,10 @@   (SetCurrent   (Draw   ()))))-instance Functions ImageSurface ImageSurfaceFuncs +type instance Functions ImageSurface = ImageSurfaceFuncs + data CAdjuster parent type Adjuster = CAdjuster Valuator type AdjusterFuncs =@@ -2381,9 +2433,10 @@   (SetSoft   (GetSoft   ())))-instance Functions Adjuster AdjusterFuncs +type instance Functions Adjuster = AdjusterFuncs + MAKE_METHOD(SetSoft,setSoft) MAKE_METHOD(GetSoft,getSoft) @@ -2399,8 +2452,9 @@  (SetType  (GetType_  ()))))))))-instance Functions Dial DialFuncs +type instance Functions Dial = DialFuncs+ MAKE_METHOD(GetAngle1,getAngle1) MAKE_METHOD(SetAngle1,setAngle1) MAKE_METHOD(GetAngle2,getAngle2)@@ -2409,20 +2463,23 @@  data CFillDial parent type FillDial = CFillDial Dial-instance Functions FillDial () +type instance Functions FillDial = ()+ data CLineDial parent type LineDial = CLineDial Dial-instance Functions LineDial () +type instance Functions LineDial = ()+ data CRoller parent type Roller = CRoller Valuator type RollerFuncs =   (Destroy   (Handle   ()))-instance Functions Roller RollerFuncs +type instance Functions Roller = RollerFuncs+ data CCounter parent type Counter = CCounter Valuator type CounterFuncs =@@ -2438,14 +2495,16 @@   (SetType   (GetType_   ())))))))))))-instance Functions Counter CounterFuncs +type instance Functions Counter = CounterFuncs+ MAKE_METHOD(SetLstep,setLstep)  data CSimpleCounter parent type SimpleCounter = CSimpleCounter Counter-instance Functions SimpleCounter () +type instance Functions SimpleCounter = ()+ data CScrollbar parent type Scrollbar = CScrollbar Slider type ScrollbarFuncs =@@ -2456,8 +2515,9 @@  (GetLinesize  (SetType  (GetType_ ())))))))-instance Functions Scrollbar ScrollbarFuncs +type instance Functions Scrollbar = ScrollbarFuncs+ MAKE_METHOD(SetLinesize,setLinesize) MAKE_METHOD(GetLinesize,getLinesize) MAKE_METHOD(SetScrollValue,setScrollValue)@@ -2474,12 +2534,14 @@   (GetTextcolor   (SetTextcolor   ()))))))))-instance Functions ValueSlider ValueSliderFuncs +type instance Functions ValueSlider = ValueSliderFuncs+ data CHorValueSlider parent type HorValueSlider = CHorValueSlider ValueSlider-instance Functions HorValueSlider () +type instance Functions HorValueSlider = ()+ data CInput parent type Input = CInput Widget type InputFuncs =@@ -2526,8 +2588,9 @@   (GetTabNav   (SetTabNav   ()))))))))))))))))))))))))))))))))))))))))))-instance Functions Input InputFuncs +type instance Functions Input = InputFuncs+ MAKE_METHOD(StaticValue,staticValue) MAKE_METHOD(Index,index) MAKE_METHOD(GetMaximumSize,getMaximumSize)@@ -2557,8 +2620,9 @@ type Output = COutput Input type OutputFuncs =   (SetType ())-instance Functions Output OutputFuncs +type instance Functions Output = OutputFuncs+ data CValueInput parent type ValueInput = CValueInput Valuator type ValueInputFuncs =@@ -2575,8 +2639,9 @@   (SetTextcolor   (GetTextcolor   ()))))))))))))-instance Functions ValueInput ValueInputFuncs +type instance Functions ValueInput = ValueInputFuncs+ data CValueOutput parent type ValueOutput = CValueOutput Valuator type ValueOutputFuncs =@@ -2591,8 +2656,9 @@   (SetTextcolor   (GetTextcolor   ()))))))))))-instance Functions ValueOutput ValueOutputFuncs +type instance Functions ValueOutput = ValueOutputFuncs+ data CTimer parent type Timer = CTimer Widget type TimerFuncs =@@ -2605,8 +2671,9 @@   (GetSuspended   (SetSuspended   ()))))))))-instance Functions Timer TimerFuncs +type instance Functions Timer = TimerFuncs+ MAKE_METHOD(GetDirection,getDirection) MAKE_METHOD(SetDirection,setDirection) MAKE_METHOD(GetSuspended,getSuspended)@@ -2614,12 +2681,14 @@  data CHiddenTimer parent type HiddenTimer = CHiddenTimer Widget-instance Functions HiddenTimer () +type instance Functions HiddenTimer = ()+ data CValueTimer parent type ValueTimer = CValueTimer Widget-instance Functions ValueTimer () +type instance Functions ValueTimer = ()+ data CProgress parent type Progress = CProgress Widget type ProgressFuncs =@@ -2631,8 +2700,9 @@   (SetValue   (GetValue   ())))))))-instance Functions Progress ProgressFuncs +type instance Functions Progress = ProgressFuncs+ data CPositioner parent type Positioner = CPositioner Widget type PositionerFuncs =@@ -2655,8 +2725,9 @@   (SetXstep   (SetYstep   ()))))))))))))))))))-instance Functions Positioner PositionerFuncs +type instance Functions Positioner = PositionerFuncs+ MAKE_METHOD(SetXvalue,setXvalue) MAKE_METHOD(GetXvalue,getXvalue) MAKE_METHOD(SetYvalue,setYvalue)@@ -2683,8 +2754,9 @@   (SetValue   (GetValue   ())))))-instance Functions Wizard WizardFuncs +type instance Functions Wizard = WizardFuncs+ MAKE_METHOD(Prev,prev)  data CTable parent@@ -2764,8 +2836,9 @@   (Hide   (HideSuper   ())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))-instance Functions Table TableFuncs +type instance Functions Table = TableFuncs+ MAKE_METHOD(SetTableBox,setTableBox) MAKE_METHOD(GetTableBox,getTableBox) MAKE_METHOD(SetRows,setRows)@@ -2837,8 +2910,9 @@   (GetRowSelected   (SelectAllRows   ())))))))))))))))-instance Functions TableRow TableRowFuncs +type instance Functions TableRow = TableRowFuncs+ MAKE_METHOD(GetRowSelected,getRowSelected) MAKE_METHOD(SelectAllRows,selectAllRows) @@ -2876,8 +2950,9 @@   (HideOverlay   (MakeOverlayCurrent   ()))))))))))))))))))))))))))))))-instance Functions GlWindow GlWindowFuncs +type instance Functions GlWindow = GlWindowFuncs+ MAKE_METHOD(GetValid,getValid) MAKE_METHOD(SetValid,setValid) MAKE_METHOD(Invalidate,invalidate)@@ -2895,8 +2970,9 @@  data CBox parent type Box = CBox Widget-instance Functions Box () +type instance Functions Box = ()+ data CBrowser parent type Browser = CBrowser Group type BrowserFuncs =@@ -2961,8 +3037,9 @@   (SetType   (GetType_   ()))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))-instance Functions Browser BrowserFuncs +type instance Functions Browser = BrowserFuncs+ MAKE_METHOD(Move,move) MAKE_METHOD(Load,load) MAKE_METHOD(Swap,swap)@@ -3002,12 +3079,14 @@  data CSelectBrowser parent type SelectBrowser = CSelectBrowser Browser-instance Functions SelectBrowser () +type instance Functions SelectBrowser = ()+ data CIntInput parent type IntInput = CIntInput Input-instance Functions IntInput () +type instance Functions IntInput = ()+ data CClock parent type Clock = CClock Widget type ClockFuncs =@@ -3017,7 +3096,8 @@   (SetValue   ())))) -instance Functions Clock ClockFuncs++type instance Functions Clock = ClockFuncs MAKE_METHOD(GetValueSinceEpoch,getValueSinceEpoch)  data CTreePrefs parent@@ -3073,8 +3153,9 @@   (GetSelectmode   (SetSelectmode   ())))))))))))))))))))))))))))))))))))))))))))))))))-instance Functions TreePrefs TreePrefsFuncs +type instance Functions TreePrefs = TreePrefsFuncs+ MAKE_METHOD(GetItemLabelfont,getItemLabelfont) MAKE_METHOD(GetItemLabelsize,getItemLabelsize) MAKE_METHOD(SetItemLabelsize,setItemLabelsize)@@ -3203,8 +3284,9 @@   (LabelH   ())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) -instance Functions TreeItem TreeItemFuncs +type instance Functions TreeItem = TreeItemFuncs+ MAKE_METHOD(ShowSelf,showSelf) MAKE_METHOD(SetWidget,setWidget) MAKE_METHOD(GetWidget,getWidget)@@ -3365,8 +3447,9 @@   (GetCallbackReason   ())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) -instance Functions Tree TreeFuncs +type instance Functions Tree = TreeFuncs+ MAKE_METHOD(RootLabel,rootLabel) MAKE_METHOD(Root,root) MAKE_METHOD(ItemClicked,itemClicked)@@ -3420,7 +3503,8 @@   (Includes   (GetPosition   ()))))))))-instance Functions TextSelection TextSelectionFuncs++type instance Functions TextSelection = TextSelectionFuncs MAKE_METHOD(Update,update) MAKE_METHOD(Start,start) MAKE_METHOD(SetSelected,setSelected)@@ -3505,8 +3589,9 @@   (NextCharClipped   (Utf8Align   ())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))-instance Functions TextBuffer TextBufferFuncs +type instance Functions TextBuffer = TextBufferFuncs+ MAKE_METHOD(InputFileWasTranscoded,inputFileWasTranscoded) MAKE_METHOD(FileEncodingWarningMessage,fileEncodingWarningMessage) MAKE_METHOD(GetLength,getLength)@@ -3637,8 +3722,9 @@   (SetLinenumberFormat   (GetLinenumberFormat   ()))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))-instance Functions TextDisplay TextDisplayFuncs +type instance Functions TextDisplay = TextDisplayFuncs+ MAKE_METHOD(SetBuffer,setBuffer) MAKE_METHOD(GetBuffer,getBuffer) MAKE_METHOD(RedisplayRange,redisplayRange)@@ -3687,8 +3773,9 @@   (GetDefaultKeyBindings   (ReplaceKeyBindings   ())))))-instance Functions TextEditor TextEditorFuncs +type instance Functions TextEditor = TextEditorFuncs+ MAKE_METHOD(SetInsertMode,setInsertMode) MAKE_METHOD(GetInsertMode,getInsertMode) MAKE_METHOD(GetDefaultKeyBindings,getDefaultKeyBindings)@@ -3719,8 +3806,9 @@   (GetErrmsg   (ShowWidget   ())))))))))))))))))))))-instance Functions NativeFileChooser NativeFileChooserFuncs +type instance Functions NativeFileChooser = NativeFileChooserFuncs+ MAKE_METHOD(SetOptions,setOptions) MAKE_METHOD(GetOptions,getOptions) MAKE_METHOD(GetFilename,getFilename)@@ -3745,8 +3833,9 @@   (Handle   (Resize   ())))-instance Functions Tile TileFuncs +type instance Functions Tile = TileFuncs+ data CPack parent type Pack = CPack Group type PackFuncs =@@ -3756,8 +3845,9 @@   (GetSpacing   (IsHorizontal   ())))))-instance Functions Pack PackFuncs +type instance Functions Pack = PackFuncs+ MAKE_METHOD(SetSpacing,setSpacing) MAKE_METHOD(GetSpacing,getSpacing) MAKE_METHOD(IsHorizontal,isHorizontal)@@ -3775,8 +3865,9 @@   (SetType   (Resize   (Handle ()))))))))))-instance Functions Scrolled ScrolledFuncs +type instance Functions Scrolled = ScrolledFuncs+ MAKE_METHOD(ScrollTo,scrollTo) MAKE_METHOD(Xposition,xposition) MAKE_METHOD(Yposition,yposition)@@ -3792,8 +3883,9 @@   (Which   (ClientArea ()))))))) -instance Functions Tabs TabsFuncs +type instance Functions Tabs = TabsFuncs+ MAKE_METHOD(GetPush,getPush) MAKE_METHOD(SetPush,setPush) MAKE_METHOD(Which,which)@@ -3825,7 +3917,8 @@   (Resize   ()))))))))))))))))))))) -instance Functions Spinner SpinnerFuncs++type instance Functions Spinner = SpinnerFuncs MAKE_METHOD(GetFormat,getFormat)  data CColorChooser parent@@ -3842,8 +3935,9 @@   (SetHsv   (SetRgb   ()))))))))))-instance Functions ColorChooser ColorChooserFuncs +type instance Functions ColorChooser = ColorChooserFuncs+ MAKE_METHOD(GetHue, getHue) MAKE_METHOD(GetSaturation, getSaturation) MAKE_METHOD(GetR, getR)@@ -3851,3 +3945,70 @@ MAKE_METHOD(GetB, getB) MAKE_METHOD(SetHsv, setHsv) MAKE_METHOD(SetRgb, setRgb)++data CFileBrowser parent+type FileBrowser = CFileBrowser Browser+type FileBrowserFuncs =+  (SetIconsize+  (GetIconsize+  (SetFilter+  (GetFilter+  (SetTextsize+  (GetTextsize+  (GetFiletype+  (SetFiletype+  ()))))))))+type instance Functions FileBrowser = FileBrowserFuncs++MAKE_METHOD(SetIconsize, setIconsize)+MAKE_METHOD(GetIconsize, getIconsize)+MAKE_METHOD(SetFiletype, setFiletype)+MAKE_METHOD(GetFiletype, getFiletype)++data CRGBImage parent+type RGBImage = CRGBImage Image+type RGBImageFuncs =+  (Destroy+  (GetW+  (GetH+  (GetD+  (GetLd+  (GetCount+  (Copy+  (ColorAverage+  (Inactive+  (Desaturate+  (DrawResize+  (Draw+  (Uncache+  ())))))))))))))++type instance Functions RGBImage = RGBImageFuncs++data CJPEGImage parent+type JPEGImage = CJPEGImage RGBImage+type instance Functions JPEGImage = ()++data CBMPImage parent+type BMPImage = CBMPImage RGBImage+type instance Functions BMPImage = ()++data CGIFImage parent+type GIFImage = CGIFImage RGBImage+type instance Functions GIFImage = ()++data CXBMImage parent+type XBMImage = CXBMImage RGBImage+type instance Functions XBMImage = ()++data CXPMImage parent+type XPMImage = CXPMImage RGBImage+type instance Functions XPMImage = ()++data CPNGImage parent+type PNGImage = CPNGImage RGBImage+type instance Functions PNGImage = ()++data CPNMImage parent+type PNMImage = CPNMImage RGBImage+type instance Functions PNMImage = ()

src/Graphics/UI/FLTK/LowLevel/Image.chs view

@@ -107,6 +107,7 @@             toRef obj     Nothing -> flImageNew' width' height' depth' >>= toRef + {# fun Fl_Image_Destroy as flImageDestroy' { id `Ptr ()' } -> `()' id #} instance (impl ~ (IO ())) => Op (Destroy ()) Image orig impl where   runOp _ _ image = withRef image $ \imagePtr -> flImageDestroy' imagePtr@@ -130,7 +131,8 @@ {# fun Fl_Image_copy as copy' { id `Ptr ()' } -> `Ptr ()' id #} instance (impl ~ ( Maybe Size -> IO (Maybe (Ref Image)))) => Op (Copy ()) Image orig impl where   runOp _ _ image size' = case size' of-    Just (Size (Width w) (Height h)) -> withRef image $ \imagePtr -> copyWithWH' imagePtr w h >>= toMaybeRef+    Just (Size (Width imageWidth) (Height imageHeight)) ->+        withRef image $ \imagePtr -> copyWithWH' imagePtr imageWidth imageHeight >>= toMaybeRef     Nothing -> withRef image $ \imagePtr -> copy' imagePtr >>= toMaybeRef  {# fun Fl_Image_color_average as colorAverage' { id `Ptr ()',cFromColor `Color',`Float' } -> `()' #}@@ -151,16 +153,16 @@ {# fun Fl_Image_draw_with as drawWith' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' #}  instance (impl ~ (Position -> Size -> Maybe X -> Maybe Y -> IO ())) => Op (DrawResize ()) Image orig impl where-  runOp _ _ image (Position (X x) (Y y)) (Size (Width w) (Height h)) xOffset yOffset =+  runOp _ _ image (Position (X imageX) (Y imageY)) (Size (Width imageWidth) (Height imageHeight)) xOffset yOffset =     case (xOffset, yOffset) of       (Just (X xOff), Just (Y yOff)) ->-        withRef image $ \imagePtr -> drawWithCxCy' imagePtr x y w h (fromIntegral xOff) (fromIntegral yOff)+        withRef image $ \imagePtr -> drawWithCxCy' imagePtr imageX imageY imageWidth imageHeight (fromIntegral xOff) (fromIntegral yOff)       (Just (X xOff), Nothing) ->-        withRef image $ \imagePtr -> drawWithCx' imagePtr x y w h (fromIntegral xOff)+        withRef image $ \imagePtr -> drawWithCx' imagePtr imageX imageY imageWidth imageHeight (fromIntegral xOff)       (Nothing, Just (Y yOff)) ->-        withRef image $ \imagePtr -> drawWithCy' imagePtr x y w h (fromIntegral yOff)+        withRef image $ \imagePtr -> drawWithCy' imagePtr imageX imageY imageWidth imageHeight (fromIntegral yOff)       (Nothing, Nothing) ->-        withRef image $ \imagePtr -> drawWith' imagePtr x y w h+        withRef image $ \imagePtr -> drawWith' imagePtr imageX imageY imageWidth imageHeight  {# fun Fl_Image_draw as draw' { id `Ptr ()',`Int',`Int' } -> `()' #} instance (impl ~ (Position ->  IO ())) => Op (Draw ()) Image orig impl where

+ src/Graphics/UI/FLTK/LowLevel/JPEGImage.chs view

@@ -0,0 +1,41 @@+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Graphics.UI.FLTK.LowLevel.JPEGImage+    (+     jpegImageNew,+     jpegImageNewWithData+     -- * Hierarchy+     --+     -- $hierarchy++    )+where+#include "Fl_ExportMacros.h"+#include "Fl_Types.h"+#include "Fl_JPEG_ImageC.h"+import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Utils+import Graphics.UI.FLTK.LowLevel.Hierarchy+import Graphics.UI.FLTK.LowLevel.RGBImage+import qualified Data.ByteString as B++{# fun Fl_JPEG_Image_New as jpegImageNew' { unsafeToCString `String' } -> `Ptr ()' id #}+{# fun Fl_JPEG_Image_New_WithData as jpegImageNewWithData' { unsafeToCString `String', id `Ptr CUChar' } -> `Ptr ()' id #}+jpegImageNew :: String -> IO (Either UnknownError (Ref JPEGImage))+jpegImageNew filename' = jpegImageNew' filename' >>= toRef >>= checkImage++jpegImageNewWithData :: String -> B.ByteString -> IO (Either UnknownError (Ref JPEGImage))+jpegImageNewWithData l' data' = do+  jpeg' <- copyByteStringToCString data'+  jpegImageNewWithData' l' (castPtr jpeg') >>= toRef >>= checkImage++-- $hierarchy+--+-- "Graphics.UI.FLTK.LowLevel.Image"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.RGBImage"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.JPEGImage"

src/Graphics/UI/FLTK/LowLevel/OverlayWindow.chs view

@@ -15,7 +15,6 @@ #include "Fl_C.h" #include "Fl_Overlay_WindowC.h" import Foreign-import Foreign.C import Graphics.UI.FLTK.LowLevel.Fl_Types import Graphics.UI.FLTK.LowLevel.Utils import Graphics.UI.FLTK.LowLevel.Hierarchy

+ src/Graphics/UI/FLTK/LowLevel/PNGImage.chs view

@@ -0,0 +1,41 @@+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Graphics.UI.FLTK.LowLevel.PNGImage+    (+     pngImageNew,+     pngImageNewWithData+     -- * Hierarchy+     --+     -- $hierarchy++    )+where+#include "Fl_ExportMacros.h"+#include "Fl_Types.h"+#include "Fl_PNG_ImageC.h"+import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Utils+import Graphics.UI.FLTK.LowLevel.Hierarchy+import Graphics.UI.FLTK.LowLevel.RGBImage+import qualified Data.ByteString as B++{# fun Fl_PNG_Image_New as pngImageNew' { unsafeToCString `String' } -> `Ptr ()' id #}+{# fun Fl_PNG_Image_New_WithData as pngImageNewWithData' { unsafeToCString `String', id `Ptr CUChar', `Int' } -> `Ptr ()' id #}+pngImageNew :: String -> IO (Either UnknownError (Ref PNGImage))+pngImageNew filename' = pngImageNew' filename' >>= toRef >>= checkImage++pngImageNewWithData :: String -> B.ByteString -> IO (Either UnknownError (Ref PNGImage))+pngImageNewWithData l' data' = do+  png' <- copyByteStringToCString data'+  pngImageNewWithData' l' (castPtr png') (B.length data') >>= toRef >>= checkImage++-- $hierarchy+--+-- "Graphics.UI.FLTK.LowLevel.Image"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.RGBImage"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.PNGImage"

+ src/Graphics/UI/FLTK/LowLevel/PNMImage.chs view

@@ -0,0 +1,36 @@+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Graphics.UI.FLTK.LowLevel.PNMImage+    (+     pnmImageNew+     -- * Hierarchy+     --+     -- $hierarchy++    )+where+#include "Fl_ExportMacros.h"+#include "Fl_Types.h"+#include "Fl_PNM_ImageC.h"+import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Utils+import Graphics.UI.FLTK.LowLevel.Hierarchy+import Graphics.UI.FLTK.LowLevel.RGBImage++{# fun Fl_PNM_Image_New as pnmImageNew' { unsafeToCString `String' } -> `Ptr ()' id #}+pnmImageNew :: String -> IO (Either UnknownError (Ref PNMImage))+pnmImageNew filename' = do+  ptr <- pnmImageNew' filename'+  ref' <- (toRef ptr :: IO (Ref PNMImage))+  checkImage ref'++-- $hierarchy+--+-- "Graphics.UI.FLTK.LowLevel.Image"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.RGBImage"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.PNMImage"

src/Graphics/UI/FLTK/LowLevel/RGBImage.chs view

@@ -0,0 +1,153 @@+{-# LANGUAGE CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Graphics.UI.FLTK.LowLevel.RGBImage+       (+       rgbImageNew,+       checkImage,+       -- * Hierarchy+       --+       -- $hierarchy++       -- * Functions+       --+       -- $functions+       )+where+#include "Fl_ExportMacros.h"+#include "Fl_Types.h"+#include "Fl_RGB_ImageC.h"+import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)+import Foreign.C.Types+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.Hierarchy+import Graphics.UI.FLTK.LowLevel.Dispatch+import Data.ByteString as B++{# fun Fl_RGB_Image_New as rgbImageNew' { id `Ptr CUChar',`Int',`Int' } -> `Ptr ()' id #}+{# fun Fl_RGB_Image_New_With_D as rgbImageNew_WithD' {id `Ptr CUChar',`Int',`Int', `Int'} -> `Ptr ()' id #};+{# fun Fl_RGB_Image_New_With_LD as rgbImageNew_WithLD' {id `Ptr CUChar',`Int',`Int', `Int'} -> `Ptr ()' id #};+{# fun Fl_RGB_Image_New_With_D_LD as rgbImageNew_WithD_LD' {id `Ptr CUChar',`Int',`Int', `Int', `Int'} -> `Ptr ()' id #};+rgbImageNew :: B.ByteString -> Size -> Maybe Depth  -> Maybe LineSize -> IO (Ref RGBImage)+rgbImageNew bits' (Size (Width width') (Height height')) depth' linesize' = do+  asCString <- copyByteStringToCString bits'+  case (depth', linesize') of+    (Just (Depth imageDepth) , Nothing) -> rgbImageNew_WithD' (castPtr asCString) width' height' imageDepth >>= toRef+    (Nothing, Just (LineSize l')) -> rgbImageNew_WithLD' (castPtr asCString) width' height' l' >>= toRef+    (Just (Depth imageDepth), Just (LineSize l')) -> rgbImageNew_WithD_LD' (castPtr asCString) width' height' imageDepth l' >>= toRef+    (Nothing, Nothing) -> rgbImageNew' (castPtr asCString) width' height' >>= toRef++checkImage :: (+                Parent orig RGBImage,+                Match x ~ FindOp orig (GetW ()),+                Op (GetW ()) x orig (IO Int),+                Match y ~ FindOp orig (Destroy ()),+                Op (Destroy ()) y orig (IO ())+               )+               => Ref orig -> IO (Either UnknownError (Ref orig))+checkImage ref' = do+  imageWidth <- getW ref'+  if (imageWidth == (0 :: Int))+   then do+     () <- destroy ref'+     return (Left UnknownError)+   else (return (Right ref'))++{# fun Fl_RGB_Image_Destroy as flImageDestroy' { id `Ptr ()' } -> `()' id #}+instance (impl ~ (IO ())) => Op (Destroy ()) RGBImage orig impl where+  runOp _ _ image = withRef image $ \imagePtr -> flImageDestroy' imagePtr+{# fun Fl_RGB_Image_w as w' { id `Ptr ()' } -> `Int' #}+instance (impl ~ ( IO (Int))) => Op (GetW ()) RGBImage orig impl where+  runOp _ _ image = withRef image $ \imagePtr -> w' imagePtr+{# fun Fl_RGB_Image_h as h' { id `Ptr ()' } -> `Int' #}+instance (impl ~ ( IO (Int))) => Op (GetH ()) RGBImage orig impl where+  runOp _ _ image = withRef image $ \imagePtr -> h' imagePtr+{# fun Fl_RGB_Image_d as d' { id `Ptr ()' } -> `Int' #}+instance (impl ~ ( IO (Int))) => Op (GetD ()) RGBImage orig impl where+  runOp _ _ image = withRef image $ \imagePtr -> d' imagePtr+{# fun Fl_RGB_Image_ld as ld' { id `Ptr ()' } -> `Int' #}+instance (impl ~ ( IO (Int))) => Op (GetLd ()) RGBImage orig impl where+  runOp _ _ image = withRef image $ \imagePtr -> ld' imagePtr+{# fun Fl_RGB_Image_count as count' { id `Ptr ()' } -> `Int' #}+instance (impl ~ ( IO (Int))) => Op (GetCount ()) RGBImage orig impl where+  runOp _ _ image = withRef image $ \imagePtr -> count' imagePtr++{# fun Fl_RGB_Image_copy_with_w_h as copyWithWH' { id `Ptr ()',`Int',`Int' } -> `Ptr ()' id #}+{# fun Fl_RGB_Image_copy as copy' { id `Ptr ()' } -> `Ptr ()' id #}+instance (Parent a RGBImage, impl ~ ( Maybe Size -> IO (Maybe (Ref a)))) => Op (Copy ()) RGBImage orig impl where+  runOp _ _ image size' = case size' of+    Just (Size (Width imageWidth) (Height imageHeight)) ->+        withRef image $ \imagePtr -> copyWithWH' imagePtr imageWidth imageHeight >>= toMaybeRef+    Nothing -> withRef image $ \imagePtr -> copy' imagePtr >>= toMaybeRef++{# fun Fl_RGB_Image_color_average as colorAverage' { id `Ptr ()',cFromColor `Color',`Float' } -> `()' #}+instance (impl ~ (Color -> Float ->  IO ())) => Op (ColorAverage ()) RGBImage orig impl where+  runOp _ _ image c i = withRef image $ \imagePtr -> colorAverage' imagePtr c i++{# fun Fl_RGB_Image_inactive as inactive' { id `Ptr ()' } -> `()' #}+instance (impl ~ ( IO ())) => Op (Inactive ()) RGBImage orig impl where+  runOp _ _ image = withRef image $ \imagePtr -> inactive' imagePtr++{# fun Fl_RGB_Image_desaturate as desaturate' { id `Ptr ()' } -> `()' #}+instance (impl ~ ( IO ())) => Op (Desaturate ()) RGBImage orig impl where+  runOp _ _ image = withRef image $ \imagePtr -> desaturate' imagePtr++{# fun Fl_RGB_Image_draw_with_cx_cy as drawWithCxCy' { id `Ptr ()',`Int',`Int',`Int',`Int',`Int',`Int' } -> `()' #}+{# fun Fl_RGB_Image_draw_with_cx as drawWithCx' { id `Ptr ()',`Int',`Int',`Int',`Int',`Int' } -> `()' #}+{# fun Fl_RGB_Image_draw_with_cy as drawWithCy' { id `Ptr ()',`Int',`Int',`Int',`Int',`Int' } -> `()' #}+{# fun Fl_RGB_Image_draw_with as drawWith' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' #}+instance (impl ~ (Position -> Size -> Maybe X -> Maybe Y -> IO ())) => Op (DrawResize ()) RGBImage orig impl where+  runOp _ _ image (Position (X imageX) (Y imageY)) (Size (Width imageWidth) (Height imageHeight)) xOffset yOffset =+    case (xOffset, yOffset) of+      (Just (X xOff), Just (Y yOff)) ->+        withRef image $ \imagePtr -> drawWithCxCy' imagePtr imageX imageY imageWidth imageHeight (fromIntegral xOff) (fromIntegral yOff)+      (Just (X xOff), Nothing) ->+        withRef image $ \imagePtr -> drawWithCx' imagePtr imageX imageY imageWidth imageHeight (fromIntegral xOff)+      (Nothing, Just (Y yOff)) ->+        withRef image $ \imagePtr -> drawWithCy' imagePtr imageX imageY imageWidth imageHeight (fromIntegral yOff)+      (Nothing, Nothing) ->+        withRef image $ \imagePtr -> drawWith' imagePtr imageX imageY imageWidth imageHeight++{# fun Fl_RGB_Image_draw as draw' { id `Ptr ()',`Int',`Int' } -> `()' #}+instance (impl ~ (Position ->  IO ())) => Op (Draw ()) RGBImage orig impl where+  runOp _ _ image (Position (X x_pos') (Y y_pos')) = withRef image $ \imagePtr -> draw' imagePtr x_pos' y_pos'+{# fun Fl_RGB_Image_uncache as uncache' { id `Ptr ()' } -> `()' #}+instance (impl ~ ( IO ())) => Op (Uncache ()) RGBImage orig impl where+  runOp _ _ image = withRef image $ \imagePtr -> uncache' imagePtr++-- $hierarchy+--+-- "Graphics.UI.FLTK.LowLevel.Image"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.RGBImage"+--++-- $functions+--+-- colorAverage :: 'Ref' 'RGBImage' -> 'Color' -> 'Float' -> 'IO' ()+--+-- copy:: ('Parent' a 'RGBImage') => 'Ref' 'RGBImage' -> 'Maybe' 'Size' -> 'IO' ('Maybe' ('Ref' a))+--+-- desaturate :: 'Ref' 'RGBImage' -> 'IO' ()+--+-- destroy :: 'Ref' 'RGBImage' -> 'IO' ()+--+-- draw :: 'Ref' 'RGBImage' -> 'Position' -> 'IO' ()+--+-- drawResize :: 'Ref' 'RGBImage' -> 'Position' -> 'Size' -> 'Maybe' 'X' -> 'Maybe' 'Y' -> 'IO' ()+--+-- getCount :: 'Ref' 'RGBImage' -> 'IO' ('Int')+--+-- getD :: 'Ref' 'RGBImage' -> 'IO' ('Int')+--+-- getH :: 'Ref' 'RGBImage' -> 'IO' ('Int')+--+-- getLd :: 'Ref' 'RGBImage' -> 'IO' ('Int')+--+-- getW :: 'Ref' 'RGBImage' -> 'IO' ('Int')+--+-- inactive :: 'Ref' 'RGBImage' -> 'IO' ()+--+-- uncache :: 'Ref' 'RGBImage' -> 'IO' ()

src/Graphics/UI/FLTK/LowLevel/SysMenuBar.chs view

@@ -68,9 +68,6 @@ {# fun Fl_Sys_Menu_Bar_global as global' { id `Ptr ()' } -> `()' #} instance (impl ~ ( IO ())) => Op (Global ()) SysMenuBar orig impl where   runOp _ _ menu_ = withRef menu_ $ \menu_Ptr -> global' menu_Ptr-{# fun Fl_Sys_Menu_Bar_menu as menu' { id `Ptr ()' } -> `Ptr ()' id #}-instance (impl ~ ( IO (Maybe (Ref MenuItem)))) => Op (GetMenu ()) SysMenuBar orig impl where-  runOp _ _ menu_ = withRef menu_ $ \menu_Ptr -> menu' menu_Ptr >>= toMaybeRef {# fun Fl_Sys_Menu_Bar_menu_with_m as menuWithM' { id `Ptr ()',id `Ptr ( Ptr () )',`Int' } -> `()' #} instance (impl ~ ([Ref MenuItem] -> IO ())) => Op (SetMenu ()) SysMenuBar orig impl where   runOp _ _ menu_ items =@@ -87,8 +84,6 @@ -- -- destroy :: 'Ref' 'SysMenuBar' -> 'IO' () ----- getMenu :: 'Ref' 'SysMenuBar' -> 'IO' ('Maybe' ('Ref' 'MenuItem'))--- -- getMode :: 'Ref' 'SysMenuBar' -> 'Int' -> 'IO' ('Int') -- -- global :: 'Ref' 'SysMenuBar' -> 'IO' ()@@ -104,7 +99,7 @@ -- setMode :: 'Ref' 'SysMenuBar' -> 'Int' -> 'Int' -> 'IO' () -- -- setShortcut :: 'Ref' 'SysMenuBar' -> 'Int' -> 'ShortcutKeySequence' -> 'IO' ()--- @+  -- $hierarchy -- @

src/Graphics/UI/FLTK/LowLevel/Utils.hs view

@@ -309,3 +309,12 @@  withStrings :: [String] -> (Ptr (Ptr CChar) -> IO a) -> IO a withStrings ss f = withByteStrings (map C.pack ss) f++copyByteStringToCString :: B.ByteString -> IO CString+copyByteStringToCString bs =+  B.useAsCStringLen bs+    (\(cstring, len) -> do+        dest <- mallocArray len+        copyArray dest cstring len+        return dest+    )

@@ -210,10 +210,10 @@ instance (impl ~ IO (Int)) => Op (GetH ()) Widget orig impl where   runOp _ _ widget = withRef widget $ \widgetPtr -> h' widgetPtr instance (-         FindOp orig (GetX ()) (Match obj),-         FindOp orig (GetY ()) (Match obj),-         FindOp orig (GetW ()) (Match obj),-         FindOp orig (GetH ()) (Match obj),+         Match obj ~ FindOp orig (GetX ()),+         Match obj ~ FindOp orig (GetY ()),+         Match obj ~ FindOp orig (GetW ()),+         Match obj ~ FindOp orig (GetH ()),          Op (GetX ()) obj orig (IO Int),          Op (GetY ()) obj orig (IO Int),          Op (GetW ()) obj orig (IO Int),

+ src/Graphics/UI/FLTK/LowLevel/XBMImage.chs view

@@ -0,0 +1,36 @@+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Graphics.UI.FLTK.LowLevel.XBMImage+    (+     xbmImageNew+     -- * Hierarchy+     --+     -- $hierarchy++    )+where+#include "Fl_ExportMacros.h"+#include "Fl_Types.h"+#include "Fl_XBM_ImageC.h"+import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Utils+import Graphics.UI.FLTK.LowLevel.Hierarchy+import Graphics.UI.FLTK.LowLevel.RGBImage++{# fun Fl_XBM_Image_New as xbmImageNew' { unsafeToCString `String' } -> `Ptr ()' id #}+xbmImageNew :: String -> IO (Either UnknownError (Ref XBMImage))+xbmImageNew filename' = do+  ptr <- xbmImageNew' filename'+  ref' <- (toRef ptr :: IO (Ref XBMImage))+  checkImage ref'++-- $hierarchy+--+-- "Graphics.UI.FLTK.LowLevel.Image"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.RGBImage"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.XBMImage"

+ src/Graphics/UI/FLTK/LowLevel/XPMImage.chs view

@@ -0,0 +1,36 @@+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Graphics.UI.FLTK.LowLevel.XPMImage+    (+     xpmImageNew+     -- * Hierarchy+     --+     -- $hierarchy++    )+where+#include "Fl_ExportMacros.h"+#include "Fl_Types.h"+#include "Fl_XPM_ImageC.h"+import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Utils+import Graphics.UI.FLTK.LowLevel.Hierarchy+import Graphics.UI.FLTK.LowLevel.RGBImage++{# fun Fl_XPM_Image_New as xpmImageNew' { unsafeToCString `String' } -> `Ptr ()' id #}+xpmImageNew :: String -> IO (Either UnknownError (Ref XPMImage))+xpmImageNew filename' = do+  ptr <- xpmImageNew' filename'+  ref' <- (toRef ptr :: IO (Ref XPMImage))+  checkImage ref'++-- $hierarchy+--+-- "Graphics.UI.FLTK.LowLevel.Image"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.RGBImage"+--  |+--  v+-- "Graphics.UI.FLTK.LowLevel.XPMImage"