diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,7 +14,7 @@ > wget http://fltk.org/pub/fltk/1.3.3/fltk-1.3.3-source.tar.gz > tar -zxvf fltk-1.3.3-source.tar.gz > cd fltk-1.3.3 - > configure --enable-shared + > configure --enable-shared --enable-gl > make > sudo make install > fltk-config --version diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} import Data.Maybe(fromJust, isJust, fromMaybe, maybeToList) import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo @@ -157,8 +158,12 @@ case () of _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo | modeGenerateRegScript -> die "Generate Reg Script not supported" - | otherwise -> registerPackage verbosity - installedPkgInfo pkg lbi inplace packageDbs + | otherwise -> +#if __GLASGOW_HASKELL__ >= 800 + registerPackage verbosity (compiler lbi) (withPrograms lbi) False {- multiinstance -} packageDbs installedPkgInfo +#else + registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs +#endif where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) regFile = fromMaybe (display (packageId pkg) <.> "conf") diff --git a/c-src/Fl_C.h b/c-src/Fl_C.h --- a/c-src/Fl_C.h +++ b/c-src/Fl_C.h @@ -40,6 +40,18 @@ OPTION_SHOW_TOOLTIPS, OPTION_LAST } Fl_Option; +#ifndef INTERNAL_LINKAGE +#if defined(WIN32) && !defined(__CYGWIN__) +# if defined(_WIN64) +# define FL_SOCKET unsigned __int64 +# else +# define FL_SOCKET int +# endif +#else +# define FL_SOCKET int +#endif +#endif + typedef void (fl_Label_Draw_F)(const fl_Label label, int x, int y, int w, int h, Fl_Align align); typedef void (fl_Label_Measure_F)(const fl_Label label, int *width, int *height); typedef void (fl_Box_Draw_F)(int x, int y, int w, int h, Fl_Color color); diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -7,15 +7,13 @@ AC_PROG_CC # Checks for libraries. -AC_CHECK_PROG(FLTKCONFIG,fltk-config,fltk-config,AC_MSG_ERROR(Cannot find the fltk-config executable. Is FLTK installed?)) +AC_CHECK_PROG(FLTKCONFIG,fltk-config,[fltk-config],[no]) +test "$FLTKCONFIG" == "no" && AC_MSG_ERROR([Cannot find the fltk-config executable. Is FLTK installed?]) + # Checks for header files. AC_CHECK_HEADERS([stddef.h stdint.h stdlib.h string.h unistd.h]) AC_CHECK_LIB([dl], [main]) AC_CHECK_LIB([fltk], [fl_alphasort]) -AC_CHECK_LIB([fltk_gl], - [main], - GlFlag='--use-gl --use-glut', - GlFlag='') AC_CHECK_LIB([fltk_images], [main], ImagesFlag='--use-images', @@ -29,7 +27,7 @@ FormsFlag='--use-forms', FormsFlag='') -AC_SUBST(FLTKCONFIGCOMMAND,"$(fltk-config --ldstaticflags $GlFlag $ImagesFlag $CairoFlag $FormsFlag) -lstdc++") +AC_SUBST(FLTKCONFIGCOMMAND,"$(fltk-config --ldstaticflags --use-gl --use-glut $ImagesFlag $CairoFlag $FormsFlag) -lstdc++") AC_SUBST(FLTK_HOME,`fltk-config --includedir`) # Checks for typedefs, structures, and compiler characteristics. AC_TYPE_SIZE_T diff --git a/fltkhs.cabal b/fltkhs.cabal --- a/fltkhs.cabal +++ b/fltkhs.cabal @@ -1,5 +1,5 @@ name : fltkhs -version : 0.4.0.7 +version : 0.4.0.8 synopsis : FLTK bindings description: Low level bindings for the FLTK GUI toolkit. For installation and quick start instruction please scroll all the way down to the README. @@ -120,8 +120,11 @@ default-extensions: GADTs default-language: Haskell2010 ghc-options: -Wall - if impl(ghc >= 7.10.2) - cpp-options: -DCALLSTACK_AVAILABLE + if impl(ghc >= 8.0.1) + cpp-options: -DHASCALLSTACK_AVAILABLE + else + if impl(ghc >= 7.10.2) + cpp-options: -DCALLSTACK_AVAILABLE if impl(ghc >= 7.10) cpp-options: -DOVERLAPPING_INSTANCES_DEPRECATED diff --git a/src/Fluid/Generate.hs b/src/Fluid/Generate.hs --- a/src/Fluid/Generate.hs +++ b/src/Fluid/Generate.hs @@ -234,52 +234,53 @@ (_ : _ : _) -> (Nothing, rest) _ -> (Just (head found), rest) -menuItemCode :: String -> String -> [Attribute] -> ([String], [Attribute]) -menuItemCode mn menuItemName restAttrs = +menuLabel :: String -> [Attribute] -> (String, [Attribute]) +menuLabel menuItemName restAttrs = + let (label, attrsWithoutLabel) = findDrop restAttrs (\a -> case a of Label _ -> True; _ -> False) + in + (maybe menuItemName (\(Label l) -> (collapseString l)) label , attrsWithoutLabel) + +menuItemCode :: String -> String -> String -> [String] -> [Attribute] -> ([String], [Attribute]) +menuItemCode mn menuItemName label menuPath restAttrs = let callbackCode callback = [ "let { callback :: Maybe (Ref MenuItem -> IO ()); callback = " ++ callback ++ "}" ] - labelCode label = [ - "let { label = \"" ++ label ++ "\"}" - ] - (((), attrs), haskellCode)= (runIdentity - (runWriterT - (runStateT - (do - let attrCode :: (Attribute -> Bool) -> - (Attribute -> [String]) -> - [String] -> - StateT [Attribute] (WriterT [String] Identity) () - attrCode findAttr toCode fallback = - do - currentAttrs <- get - let (attr, restAttrs') = findDrop currentAttrs findAttr - modify (\_ -> restAttrs') - tell (maybe fallback toCode attr) - attrCode (\a -> case a of Callback _ -> True; _ -> False) - (\(Callback c) -> callbackCode (collapseString c)) - (callbackCode "(Nothing :: Maybe (Ref MenuItem -> IO ())) ") - attrCode (\a -> case a of Label _ -> True ; _ -> False) - (\(Label l) -> labelCode (collapseString l)) - ["let {label = " ++ menuItemName ++ "}"] - tell [ - "(MenuItemIndex idx) <- add " ++ - mn ++ " label " ++ - "(Nothing :: Maybe Shortcut) " ++ - "callback " ++ - "(MenuItemFlags [])", - mn ++ "_menuItems <- getMenu " ++ mn, - "let {" ++ menuItemName ++ " = fromJust (" ++ mn ++ "_menuItems !! idx)}" - ] - attrCode (\a -> case a of Shortcut _ -> True; _ -> False) - (\(Shortcut s) -> - maybe - [] - (\ks -> ["setShortcut " ++ mn ++ " idx (" ++ (show ks) ++ ")"]) - (cIntToKeySequence ((read s) :: CInt))) - [] - ) restAttrs))) - in (haskellCode, attrs) + (((), attrs), haskellCode) + = (runIdentity + (runWriterT + (runStateT + (do + let attrCode :: (Attribute -> Bool) -> + (Attribute -> [String]) -> + [String] -> + StateT [Attribute] (WriterT [String] Identity) () + attrCode findAttr toCode fallback = do + currentAttrs <- get + let (attr, restAttrs') = findDrop currentAttrs findAttr + modify (\_ -> restAttrs') + tell (maybe fallback toCode attr) + attrCode (\a -> case a of Callback _ -> True; _ -> False) + (\(Callback c) -> callbackCode (collapseString c)) + (callbackCode "(Nothing :: Maybe (Ref MenuItem -> IO ())) ") + tell ["let { label = \"" ++ (concat (intersperse "/" ((reverse menuPath) ++ [label]))) ++ "\"}" ] + tell ["(MenuItemIndex idx) <- add " ++ + mn ++ " label " ++ + "(Nothing :: Maybe Shortcut) " ++ + "callback " ++ + "(MenuItemFlags [])", + mn ++ "_menuItems <- getMenu " ++ mn, + "let {" ++ menuItemName ++ " = fromJust (" ++ mn ++ "_menuItems !! idx)}" + ] + attrCode (\a -> case a of Shortcut _ -> True; _ -> False) + (\(Shortcut s) -> + maybe + [] + (\ks -> ["setShortcut " ++ mn ++ " idx (" ++ (show ks) ++ ")"]) + (cIntToKeySequence ((read s) :: CInt))) + [] + ) restAttrs))) + in + (haskellCode, attrs) determineClassName :: String -> [Attribute] -> (Maybe (String, String, String), [Attribute]) determineClassName flClassName attrs = case findDrop attrs @@ -290,8 +291,8 @@ (maybe Nothing (\(c,cons) -> Just (derivedClass, c, cons)) (lookup derivedClass flClasses) , restAttrs) _ -> (maybe Nothing (\(c,cons) -> Just (flClassName, c, cons)) (lookup flClassName flClasses), attrs) -widgetTreeG :: Maybe String -> WidgetTree -> State TakenNames [String] -widgetTreeG menuName widgetTree = +widgetTreeG :: Maybe String -> [String] -> WidgetTree -> State TakenNames [String] +widgetTreeG menuName menuPath widgetTree = case widgetTree of (Group flClassName haskellId attrs trees) -> case (determineClassName flClassName attrs) of @@ -312,6 +313,7 @@ let (output, newNames) = runState (widgetTreeG Nothing + [] tree) takenNames' in (concatTakenNames takenNames' newNames, outputSoFar ++ output)) @@ -337,6 +339,7 @@ takenNames <- get let newName = haskellIdToName takenNames hsClassName haskellId modify (\ns -> concatTakenNames ns (TakenNames [newName])) + let (newLabel, attrsWithoutLabel) = menuLabel newName restAttrs (newNames, innerTreeOutput) <- get >>= \names -> return @@ -347,6 +350,7 @@ "Submenu" -> menuName; _ -> (Just newName) }) + ([newLabel] ++ menuPath) tree) takenNames' in (concatTakenNames takenNames' newNames, outputSoFar ++ output)) @@ -357,7 +361,7 @@ "Submenu" -> case menuName of Just mn -> - let (haskellCode, newAttrs) = menuItemCode mn newName restAttrs + let (haskellCode, newAttrs) = menuItemCode mn newName newLabel menuPath attrsWithoutLabel in haskellCode ++ [ @@ -369,16 +373,16 @@ innerTreeOutput _ -> (constructorG newFlClassName hsConstructor (Just newName) posSize) ++ - (map (attributeG newFlClassName newName) restAttrs) ++ + (map (attributeG newFlClassName newName) attrsWithoutLabel) ++ ["setMenu " ++ newName ++ " ([] :: [Ref MenuItem])"] ++ innerTreeOutput "MenuItem" -> (constructorG newFlClassName hsConstructor (Just newName) posSize) ++ - (map (attributeG newFlClassName newName) restAttrs) ++ + (map (attributeG newFlClassName newName) attrsWithoutLabel) ++ innerTreeOutput _ -> (constructorG newFlClassName hsConstructor (Just newName) posSize) ++ - (map (attributeG newFlClassName newName) restAttrs) ++ + (map (attributeG newFlClassName newName) attrsWithoutLabel) ++ ["setMenu " ++ newName ++ " ([] :: [Ref MenuItem])"] ++ innerTreeOutput ) @@ -400,7 +404,8 @@ "MenuItem" -> case menuName of Just mn -> - let (haskellCode, newAttrs) = menuItemCode mn newName restAttrs + let (label, attrsWithoutLabel) = menuLabel newName restAttrs + (haskellCode, newAttrs) = menuItemCode mn newName label menuPath attrsWithoutLabel in haskellCode ++ (map (attributeG newFlClassName newName) newAttrs) _ -> [] _ -> (constructorG newFlClassName hsConstructor (Just newName) posSize) ++ @@ -423,7 +428,7 @@ (_, FunctionArgs Nothing) -> "()" (_, FunctionArgs (Just args')) -> args' fName = haskellIdToName (TakenNames []) "" haskellId - fBody = filter (not . null) $ concatMap (\t -> evalState (widgetTreeG Nothing t) (TakenNames [fName])) + fBody = filter (not . null) $ concatMap (\t -> evalState (widgetTreeG Nothing [] t) (TakenNames [fName])) trees argumentNames = case findDrop attrs (\a -> case a of diff --git a/src/Graphics/UI/FLTK/LowLevel/FL.chs b/src/Graphics/UI/FLTK/LowLevel/FL.chs --- a/src/Graphics/UI/FLTK/LowLevel/FL.chs +++ b/src/Graphics/UI/FLTK/LowLevel/FL.chs @@ -120,6 +120,11 @@ setFontByFont, setFonts, setFontsWithString, + -- * File Descriptor Callbacks + addFd, + addFdWhen, + removeFd, + removeFdWhen, -- * Events event, eventShift, @@ -704,9 +709,41 @@ { } -> `Font' cToFont #} {# fun Fl_set_fonts_with_string as setFontsWithString { `String' } -> `Font' cToFont #} + +{# fun Fl_add_fd_with_when as addFdWhen' + { + `CInt', + `CInt', + id `FunPtr FDHandlerPrim' + } -> `()' #} + +addFdWhen :: CInt -> [FdWhen] -> FDHandler -> IO () +addFdWhen fd fdWhens handler = do + fPtr <- toFDHandlerPrim handler + addFdWhen' fd (fromIntegral . combine $ fdWhens) fPtr + +{# fun Fl_add_fd as addFd' + { + `CInt', + id `FunPtr FDHandlerPrim' + } -> `()' #} + +addFd :: CInt -> FDHandler -> IO () +addFd fd handler = do + fPtr <- toFDHandlerPrim handler + addFd' fd fPtr + +{# fun Fl_remove_fd_with_when as removeFdWhen' { `CInt', `CInt'} -> `()' #} +removeFdWhen :: CInt -> [FdWhen] -> IO () +removeFdWhen fd fdWhens = + removeFdWhen' fd (fromIntegral . combine $ fdWhens) + +{# fun Fl_remove_fd as removeFd' { `CInt' } -> `()' #} +removeFd :: CInt -> IO () +removeFd fd = removeFd' fd + {# fun Fl_get_boxtype as getBoxtype' { cFromEnum `Boxtype' } -> `FunPtr BoxDrawFPrim' id #} - getBoxtype :: Boxtype -> IO BoxDrawF getBoxtype bt = do wrappedFunPtr <- getBoxtype' bt diff --git a/src/Graphics/UI/FLTK/LowLevel/Fl_Enumerations.chs b/src/Graphics/UI/FLTK/LowLevel/Fl_Enumerations.chs --- a/src/Graphics/UI/FLTK/LowLevel/Fl_Enumerations.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Fl_Enumerations.chs @@ -511,7 +511,7 @@ #endc {#enum Event {} deriving (Show, Eq) #} {#enum When {} deriving (Show, Eq, Ord) #} -{#enum FdWhen {} deriving (Show, Eq) #} +{#enum FdWhen {} deriving (Show, Eq, Ord) #} {#enum TreeSort {} deriving (Show, Eq) #} {#enum TreeConnector {} deriving (Show, Eq) #} {#enum TreeSelect {} deriving (Show, Eq) #} diff --git a/src/Graphics/UI/FLTK/LowLevel/Fl_Types.chs b/src/Graphics/UI/FLTK/LowLevel/Fl_Types.chs --- a/src/Graphics/UI/FLTK/LowLevel/Fl_Types.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Fl_Types.chs @@ -14,7 +14,7 @@ import Debug.Trace import Control.Exception import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum) -#ifdef CALLSTACK_AVAILABLE +#if defined(CALLSTACK_AVAILABLE) || defined(HASCALLSTACK_AVAILABLE) import GHC.Stack #endif import qualified Data.ByteString as B @@ -287,6 +287,8 @@ type SharedImageHandler = FunPtr (CString -> CUChar -> CInt -> Ptr ()) type BoxDrawF = Rectangle -> Color -> IO () type BoxDrawFPrim = CInt -> CInt -> CInt -> CInt -> FlColor -> IO () +type FDHandlerPrim = CInt -> Ptr () -> IO () +type FDHandler = CInt -> IO () type TextModifyCb = Int -> Int -> Int -> Int -> String -> IO () type TextModifyCbPrim = CInt -> CInt -> CInt -> CInt -> Ptr CChar -> Ptr () -> IO () type TextPredeleteCb = BufferOffset -> Int -> IO () @@ -391,6 +393,8 @@ #ifdef CALLSTACK_AVAILABLE toRefPtr :: (?loc :: CallStack) => Ptr (Ptr a) -> IO (Ptr a) +#elif HASCALLSTACK_AVAILABLE +toRefPtr :: HasCallStack => Ptr (Ptr a) -> IO (Ptr a) #else toRefPtr :: Ptr (Ptr a) -> IO (Ptr a) #endif @@ -399,6 +403,8 @@ if (refPtr == nullPtr) #ifdef CALLSTACK_AVAILABLE then error $ "Ref does not exist. " ++ (showCallStack ?loc) +#elif HASCALLSTACK_AVAILABLE + then error $ "Ref does not exist. " ++ (prettyCallStack callStack) #else then error "Ref does not exist. " #endif @@ -406,6 +412,8 @@ #ifdef CALLSTACK_AVAILABLE withRef :: (?loc :: CallStack) => Ref a -> (Ptr b -> IO c) -> IO c +#elif HASCALLSTACK_AVAILABLE +withRef :: HasCallStack => Ref a -> (Ptr b -> IO c) -> IO c #else withRef :: Ref a -> (Ptr b -> IO c) -> IO c #endif diff --git a/src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs b/src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs --- a/src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs +++ b/src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs @@ -9,6 +9,11 @@ data Datatype a; \ Method :: (?loc :: CallStack, Match r ~ FindOp a a (Datatype ()), Op (Datatype ()) r a impl) => Ref a -> impl; \ Method aRef = (unsafePerformIO $ withRef aRef (\_ -> return ())) `seq` dispatch (undefined :: Datatype()) aRef +#elif HASCALLSTACK_AVAILABLE +#define MAKE_METHOD(Datatype, Method) \ +data Datatype a; \ +Method :: (HasCallStack, Match r ~ FindOp a 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; \ @@ -1547,7 +1552,7 @@ import Prelude hiding (round) import Graphics.UI.FLTK.LowLevel.Fl_Types import Graphics.UI.FLTK.LowLevel.Dispatch -#ifdef CALLSTACK_AVAILABLE +#if defined(CALLSTACK_AVAILABLE) || defined(HASCALLSTACK_AVAILABLE) import GHC.Stack import System.IO.Unsafe #endif diff --git a/src/Graphics/UI/FLTK/LowLevel/Utils.hs b/src/Graphics/UI/FLTK/LowLevel/Utils.hs --- a/src/Graphics/UI/FLTK/LowLevel/Utils.hs +++ b/src/Graphics/UI/FLTK/LowLevel/Utils.hs @@ -40,6 +40,8 @@ mkTextModifyCb :: TextModifyCbPrim -> IO (FunPtr TextModifyCbPrim) foreign import ccall "wrapper" mkTextPredeleteCb :: TextPredeleteCbPrim -> IO (FunPtr TextPredeleteCbPrim) +foreign import ccall "wrapper" + mkFDHandlerPrim :: FDHandlerPrim -> IO (FunPtr FDHandlerPrim) toCallbackPrim :: (Ref a -> IO ()) -> IO (FunPtr (Ptr () -> IO ())) @@ -167,6 +169,9 @@ \pos' nDeleted' _ -> f (BufferOffset (fromIntegral pos')) (fromIntegral nDeleted') ) + +toFDHandlerPrim :: FDHandler -> IO (FunPtr FDHandlerPrim) +toFDHandlerPrim f = mkFDHandlerPrim (\fd _ -> f fd) toUnfinishedStyleCbPrim :: UnfinishedStyleCb -> IO (FunPtr UnfinishedStyleCbPrim) toUnfinishedStyleCbPrim f =