fltkhs 0.4.0.7 → 0.4.0.8
raw patch · 11 files changed
+145/−67 lines, 11 filessetup-changed
Files
- README.md +1/−1
- Setup.hs +7/−2
- c-src/Fl_C.h +12/−0
- configure.ac +4/−6
- fltkhs.cabal +6/−3
- src/Fluid/Generate.hs +56/−51
- src/Graphics/UI/FLTK/LowLevel/FL.chs +38/−1
- src/Graphics/UI/FLTK/LowLevel/Fl_Enumerations.chs +1/−1
- src/Graphics/UI/FLTK/LowLevel/Fl_Types.chs +9/−1
- src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs +6/−1
- src/Graphics/UI/FLTK/LowLevel/Utils.hs +5/−0
README.md view
@@ -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
Setup.hs view
@@ -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")
c-src/Fl_C.h view
@@ -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);
configure.ac view
@@ -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
fltkhs.cabal view
@@ -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
src/Fluid/Generate.hs view
@@ -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
src/Graphics/UI/FLTK/LowLevel/FL.chs view
@@ -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
src/Graphics/UI/FLTK/LowLevel/Fl_Enumerations.chs view
@@ -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) #}
src/Graphics/UI/FLTK/LowLevel/Fl_Types.chs view
@@ -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
src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs view
@@ -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
src/Graphics/UI/FLTK/LowLevel/Utils.hs view
@@ -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 =