diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs deleted file mode 100644 --- a/Gtk2HsSetup.hs +++ /dev/null @@ -1,486 +0,0 @@ -{-# LANGUAGE CPP #-} - -#define CABAL_VERSION_ENCODE(major, minor, micro) ( \ - ((major) * 10000) \ - + ((minor) * 100) \ - + ((micro) * 1)) - -#define CABAL_VERSION_CHECK(major,minor,micro) \ - (CABAL_VERSION >= CABAL_VERSION_ENCODE(major,minor,micro)) - --- now, this is bad, but Cabal doesn't seem to actually pass any information about --- its version to CPP, so guess the version depending on the version of GHC -#ifdef CABAL_VERSION_MINOR -#ifndef CABAL_VERSION_MAJOR -#define CABAL_VERSION_MAJOR 1 -#endif -#ifndef CABAL_VERSION_MICRO -#define CABAL_VERSION_MICRO 0 -#endif -#define CABAL_VERSION CABAL_VERSION_ENCODE( \ - CABAL_VERSION_MAJOR, \ - CABAL_VERSION_MINOR, \ - CABAL_VERSION_MICRO) -#else -#warning Setup.hs is guessing the version of Cabal. If compilation of Setup.hs fails use -DCABAL_VERSION_MINOR=x for Cabal version 1.x.0 when building (prefixed by --ghc-option= when using the 'cabal' command) -#if (__GLASGOW_HASKELL__ >= 612) -#define CABAL_VERSION CABAL_VERSION_ENCODE(1,8,0) -#else -#define CABAL_VERSION CABAL_VERSION_ENCODE(1,6,0) -#endif -#endif - --- | Build a Gtk2hs package. --- -module Gtk2HsSetup ( gtk2hsUserHooks, getPkgConfigPackages ) where - -import Distribution.Simple -import Distribution.Simple.PreProcess -import Distribution.InstalledPackageInfo ( importDirs, - showInstalledPackageInfo, - libraryDirs, - extraLibraries, - extraGHCiLibraries ) -import Distribution.Simple.PackageIndex ( -#if CABAL_VERSION_CHECK(1,8,0) - lookupInstalledPackageId -#else - lookupPackageId -#endif - ) -import Distribution.PackageDescription as PD ( PackageDescription(..), - updatePackageDescription, - BuildInfo(..), - emptyBuildInfo, allBuildInfo, - Library(..), - libModules, hasLibs) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), - InstallDirs(..), -#if CABAL_VERSION_CHECK(1,8,0) - componentPackageDeps, -#else - packageDeps, -#endif - absoluteInstallDirs) -import Distribution.Simple.Compiler ( Compiler(..) ) -import Distribution.Simple.Program ( - Program(..), ConfiguredProgram(..), - rawSystemProgramConf, rawSystemProgramStdoutConf, - c2hsProgram, pkgConfigProgram, requireProgram, ghcPkgProgram, - simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg) -import Distribution.ModuleName ( ModuleName, components, toFilePath ) -import Distribution.Simple.Utils -import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..), - defaultCopyFlags, ConfigFlags(configVerbosity), - fromFlag, toFlag, RegisterFlags(..), flagToMaybe, - fromFlagOrDefault, defaultRegisterFlags) -import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Install ( install ) -#if CABAL_VERSION_CHECK(1,8,0) -import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage ) -#else -import qualified Distribution.Simple.Register as Register ( register ) -#endif -import Distribution.Text ( simpleParse, display ) -import System.FilePath -import System.Directory ( doesFileExist ) -import Distribution.Version (Version(..)) -import Distribution.Verbosity -import Control.Monad (when, unless, filterM) -import Data.Maybe ( isJust, isNothing, fromMaybe, maybeToList ) -import Data.List (isPrefixOf, isSuffixOf, nub) -import Data.Char (isAlpha) -import qualified Data.Map as M -import qualified Data.Set as S - -import Control.Applicative ((<$>)) -import System.Directory (getDirectoryContents, doesDirectoryExist) - --- the name of the c2hs pre-compiled header file -precompFile = "precompchs.bin" - -gtk2hsUserHooks = simpleUserHooks { - hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal], - hookedPreProcessors = [("chs", ourC2hs)], - confHook = \pd cf -> - confHook simpleUserHooks pd cf >>= return . adjustLocalBuildInfo, - postConf = \args cf pd lbi -> do - genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi - postConf simpleUserHooks args cf pd lbi, - buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd -> - (buildHook simpleUserHooks) pd lbi uh bf, - copyHook = \pd lbi uh flags -> (copyHook simpleUserHooks) pd lbi uh flags >> - installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)), - instHook = \pd lbi uh flags -> -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) - installHook pd lbi uh flags >> - installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest, - regHook = registerHook -#else - instHook simpleUserHooks pd lbi uh flags >> - installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest -#endif - } - ------------------------------------------------------------------------------- --- Lots of stuff for windows ghci support ------------------------------------------------------------------------------- - -getDlls :: [FilePath] -> IO [FilePath] -getDlls dirs = filter ((== ".dll") . takeExtension) . concat <$> - mapM getDirectoryContents dirs - -fixLibs :: [FilePath] -> [String] -> [String] -fixLibs dlls = concatMap $ \ lib -> - case filter (("lib" ++ lib) `isPrefixOf`) dlls of - dll:_ -> [dropExtension dll] - _ -> if lib == "z" then [] else [lib] - --- The following code is a big copy-and-paste job from the sources of --- Cabal 1.8 just to be able to fix a field in the package file. Yuck. - -#if CABAL_VERSION_CHECK(1,8,0) - -installHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> InstallFlags -> IO () -installHook pkg_descr localbuildinfo _ flags = do - let copyFlags = defaultCopyFlags { - copyDistPref = installDistPref flags, - copyDest = toFlag NoCopyDest, - copyVerbosity = installVerbosity flags - } - install pkg_descr localbuildinfo copyFlags - let registerFlags = defaultRegisterFlags { - regDistPref = installDistPref flags, - regInPlace = installInPlace flags, - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } - when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags - -registerHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () -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 -- ^Install in the user's database?; verbose - -> IO () -register pkg@PackageDescription { library = Just lib } - lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags - = do - - installedPkgInfoRaw <- generateRegistrationInfo - verbosity pkg lib lbi clbi inplace distPref - - dllsInScope <- getSearchPath >>= (filterM doesDirectoryExist) >>= getDlls - let libs = fixLibs dllsInScope (extraLibraries installedPkgInfoRaw) - installedPkgInfo = installedPkgInfoRaw { - extraGHCiLibraries = libs } - - -- Three different modes: - case () of - _ | modeGenerateRegFile -> die "Generate Reg File not supported" - | modeGenerateRegScript -> die "Generate Reg Script not supported" - | otherwise -> registerPackage verbosity - installedPkgInfo pkg lbi inplace packageDb - - where - modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) - modeGenerateRegScript = fromFlag (regGenScript regFlags) - inplace = fromFlag (regInPlace regFlags) - packageDb = case flagToMaybe (regPackageDB regFlags) of - Just db -> db - Nothing -> registrationPackageDB (withPackageDB lbi) - distPref = fromFlag (regDistPref regFlags) - verbosity = fromFlag (regVerbosity regFlags) - -register _ _ regFlags = notice verbosity "No package to register" - where - verbosity = fromFlag (regVerbosity regFlags) - -#else -installHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> InstallFlags -> IO () -installHook pkg_descr localbuildinfo _ flags = do - let copyFlags = defaultCopyFlags { - copyDistPref = installDistPref flags, - copyInPlace = installInPlace flags, - copyUseWrapper = installUseWrapper flags, - copyDest = toFlag NoCopyDest, - copyVerbosity = installVerbosity flags - } - install pkg_descr localbuildinfo copyFlags - let registerFlags = defaultRegisterFlags { - regDistPref = installDistPref flags, - regInPlace = installInPlace flags, - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } - when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags - -registerHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () -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 -- ^Install in the user's database?; verbose - -> IO () -register pkg_descr lbi regFlags = do - let verbosity = fromFlag (regVerbosity regFlags) - warn verbosity "Cannot register ghci libraries with Cabal 1.6 (need 1.8)." - Register.register pkg_descr lbi regFlags - -#endif - ------------------------------------------------------------------------------- --- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later ------------------------------------------------------------------------------- - -adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo -adjustLocalBuildInfo lbi = - let extra = (Just libBi, []) - libBi = emptyBuildInfo { includeDirs = [ autogenModulesDir lbi - , buildDir lbi ] } - in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) } - ------------------------------------------------------------------------------- --- Processing .chs files with our local c2hs. ------------------------------------------------------------------------------- - -ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor -ourC2hs bi lbi = PreProcessor { - platformIndependent = False, - runPreProcessor = runC2HS bi lbi -} - -runC2HS :: BuildInfo -> LocalBuildInfo -> - (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO () -runC2HS bi lbi (inDir, inFile) (outDir, outFile) verbosity = do - -- have the header file name if we don't have the precompiled header yet - header <- case lookup "x-c2hs-header" (customFieldsBI bi) of - Just h -> return h - Nothing -> die ("Need x-c2hs-Header definition in the .cabal Library section "++ - "that sets the C header file to process .chs.pp files.") - - -- c2hs will output files in out dir, removing any leading path of the input file. - -- Thus, append the dir of the input file to the output dir. - let (outFileDir, newOutFile) = splitFileName outFile - let newOutDir = outDir outFileDir - -- additional .chi files might be needed that other packages have installed; - -- we assume that these are installed in the same place as .hi files - let chiDirs = [ dir | -#if CABAL_VERSION_CHECK(1,8,0) - ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi), - dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ] -#else - ipi <- packageDeps lbi, - dir <- maybe [] importDirs (lookupPackageId (installedPkgs lbi) ipi) ] -#endif - rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $ - map ("--include=" ++) (outDir:chiDirs) - ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] - ++ ["--output-dir=" ++ newOutDir, - "--output=" ++ newOutFile, - "--precomp=" ++ buildDir lbi precompFile, - header, inDir inFile] - -getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] -getCppOptions bi lbi - = nub $ - ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ [opt | opt@('-':c:_) <- (PD.cppOptions bi ++ PD.ccOptions bi), c `elem` "DIU"] - -installCHI :: PackageDescription -- ^information from the .cabal file - -> LocalBuildInfo -- ^information from the configure step - -> Verbosity -> CopyDest -- ^flags sent to copy or install - -> IO () -installCHI pkg@PD.PackageDescription { library = Just lib } lbi verbosity copydest = do - let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest - -- cannot use the recommended 'findModuleFiles' since it fails if there exists - -- a modules that does not have a .chi file - mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi]) - (map toFilePath -#if CABAL_VERSION_CHECK(1,8,0) - (PD.libModules lib) -#else - (PD.libModules pkg) -#endif - ) - let files = [ f | Just f <- mFiles ] -#if CABAL_VERSION_CHECK(1,8,0) - installOrdinaryFiles verbosity libPref files -#else - copyFiles verbosity libPref files -#endif - - -installCHI _ _ _ _ = return () - ------------------------------------------------------------------------------- --- Generating the type hierarchy and signal callback .hs files. ------------------------------------------------------------------------------- - -typeGenProgram :: Program -typeGenProgram = (simpleProgram "gtk2hsTypeGen") - -signalGenProgram :: Program -signalGenProgram = (simpleProgram "gtk2hsHookGenerator") - -c2hsLocal :: Program -c2hsLocal = (simpleProgram "gtk2hsC2hs") - -genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -genSynthezisedFiles verb pd lbi = do - - cPkgs <- getPkgConfigPackages verb lbi pd - - let xList = maybe [] (customFieldsBI . libBuildInfo) (library pd) - ++customFieldsPD pd - typeOpts :: String -> [ProgArg] - typeOpts tag = concat [ map (\val -> '-':'-':drop (length tag) field++'=':val) (words content) - | (field,content) <- xList, - tag `isPrefixOf` field, - field /= (tag++"file")] - ++ [ "--tag=" ++ tag - | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs - , let name' = filter isAlpha (display name) - , tag <- name' - : [ name' ++ "-" ++ show major ++ "." ++ show digit - | digit <- [0,2..minor] ] - ] - - signalsOpts :: [ProgArg] - signalsOpts = concat [ map (\val -> '-':'-':drop 10 field++'=':val) (words content) - | (field,content) <- xList, - "x-signals-" `isPrefixOf` field, - field /= "x-signals-file"] - - genFile :: Program -> [ProgArg] -> FilePath -> IO () - genFile prog args outFile = do - res <- rawSystemProgramStdoutConf verb prog (withPrograms lbi) args - rewriteFile outFile res - - (flip mapM_) (filter (\(tag,_) -> "x-types-" `isPrefixOf` tag && "file" `isSuffixOf` tag) xList) $ - \(fileTag, f) -> do - let tag = reverse (drop 4 (reverse fileTag)) - info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.") - genFile typeGenProgram (typeOpts tag) f - - case lookup "x-signals-file" xList of - Nothing -> return () - Just f -> do - info verb ("Ensuring that callback hooks in "++f++" are up-to-date.") - genFile signalGenProgram signalsOpts f - ---FIXME: Cabal should tell us the selected pkg-config package versions in the --- LocalBuildInfo or equivalent. --- In the mean time, ask pkg-config again. - -getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId] -getPkgConfigPackages verbosity lbi pkg = - sequence - [ do version <- pkgconfig ["--modversion", display pkgname] - case simpleParse version of - Nothing -> die $ "parsing output of pkg-config --modversion failed" - Just v -> return (PackageIdentifier pkgname v) - | Dependency pkgname _ <- concatMap pkgconfigDepends (allBuildInfo pkg) ] - where - pkgconfig = rawSystemProgramStdoutConf verbosity - pkgConfigProgram (withPrograms lbi) - ------------------------------------------------------------------------------- --- Dependency calculation amongst .chs files. ------------------------------------------------------------------------------- - --- Given all files of the package, find those that end in .chs and extract the --- .chs files they depend upon. Then return the PackageDescription with these --- files rearranged so that they are built in a sequence that files that are --- needed by other files are built first. -fixDeps :: PackageDescription -> IO PackageDescription -fixDeps pd@PD.PackageDescription { - PD.library = Just lib@PD.Library { - PD.exposedModules = expMods, - PD.libBuildInfo = bi@PD.BuildInfo { - PD.hsSourceDirs = srcDirs, - PD.otherModules = othMods - }}} = do - let findModule m = findFileWithExtension [".chs.pp",".chs"] srcDirs - (joinPath (components m)) - mExpFiles <- mapM findModule expMods - mOthFiles <- mapM findModule othMods - - -- tag all exposed files with True so we throw an error if we need to build - -- an exposed module before an internal modules (we cannot express this) - let modDeps = zipWith (ModDep True []) expMods mExpFiles++ - zipWith (ModDep False []) othMods mOthFiles - modDeps <- mapM extractDeps modDeps - let (expMods, othMods) = span mdExposed $ sortTopological modDeps - badOther = map (fromMaybe "" . mdLocation) $ - filter (not . mdExposed) expMods - unless (null badOther) $ - die ("internal chs modules "++intercalate "," badOther++ - " depend on exposed chs modules; cabal needs to build internal modules first") - return pd { PD.library = Just lib { - PD.exposedModules = map mdOriginal expMods, - PD.libBuildInfo = bi { PD.otherModules = map mdOriginal othMods } - }} - -data ModDep = ModDep { - mdExposed :: Bool, - mdRequires :: [ModuleName], - mdOriginal :: ModuleName, - mdLocation :: Maybe FilePath -} - -instance Show ModDep where - show x = show (mdLocation x) - -instance Eq ModDep where - ModDep { mdOriginal = m1 } == ModDep { mdOriginal = m2 } = m1==m2 -instance Ord ModDep where - compare ModDep { mdOriginal = m1 } ModDep { mdOriginal = m2 } = compare m1 m2 - --- Extract the dependencies of this file. This is intentionally rather naive as it --- ignores CPP conditionals. We just require everything which means that the --- existance of a .chs module may not depend on some CPP condition. -extractDeps :: ModDep -> IO ModDep -extractDeps md@ModDep { mdLocation = Nothing } = return md -extractDeps md@ModDep { mdLocation = Just f } = withUTF8FileContents f $ \con -> do - let findImports acc (('{':'#':xs):xxs) = case (dropWhile ((==) ' ') xs) of - ('i':'m':'p':'o':'r':'t':' ':ys) -> - case simpleParse (takeWhile ((/=) '#') ys) of - Just m -> findImports (m:acc) xxs - Nothing -> die ("cannot parse chs import in "++f++":\n"++ - "offending line is {#"++xs) - -- no more imports after the first non-import hook - _ -> return acc - findImports acc (_:xxs) = findImports acc xxs - findImports acc [] = return acc - mods <- findImports [] (lines con) - return md { mdRequires = mods } - --- Find a total order of the set of modules that are partially sorted by their --- dependencies on each other. The function returns the sorted list of modules --- together with a list of modules that are required but not supplied by this --- in the input set of modules. -sortTopological :: [ModDep] -> [ModDep] -sortTopological ms = reverse $ fst $ foldl visit ([], S.empty) (map mdOriginal ms) - where - set = M.fromList (map (\m -> (mdOriginal m, m)) ms) - visit (out,visited) m - | m `S.member` visited = (out,visited) - | otherwise = case m `M.lookup` set of - Nothing -> (out, m `S.insert` visited) - Just md -> (md:out', visited') - where - (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,7 @@ --- Setup file for a Gtk2Hs module. Contains only adjustments specific to this module, --- all Gtk2Hs-specific boilerplate is stored in Gtk2HsSetup.hs which should be kept --- identical across all modules. +-- Adjustments specific to this package, +-- all Gtk2Hs-specific boilerplate is kept in +-- gtk2hs-buildtools:Gtk2HsSetup +-- import Gtk2HsSetup ( gtk2hsUserHooks ) import Distribution.Simple ( defaultMainWithHooks ) diff --git a/System/Glib/Attributes.hs b/System/Glib/Attributes.hs --- a/System/Glib/Attributes.hs +++ b/System/Glib/Attributes.hs @@ -68,7 +68,7 @@ AttrOp(..), get, set, - + -- * Internal attribute constructors newNamedAttr, readNamedAttr, diff --git a/System/Glib/FFI.hs b/System/Glib/FFI.hs --- a/System/Glib/FFI.hs +++ b/System/Glib/FFI.hs @@ -27,45 +27,40 @@ -- module System.Glib.FFI ( - with, nullForeignPtr, maybeNull, newForeignPtr, withForeignPtrs, +#if MIN_VERSION_base(4,4,0) + unsafePerformIO, + unsafeForeignPtrToPtr, +#endif module Foreign, module Foreign.C ) where -import System.IO.Unsafe (unsafePerformIO) - -- We should almost certainly not be using the standard free function anywhere -- in the glib or gtk bindings, so we do not re-export it from this module. import Foreign.C -import qualified Foreign hiding (free) -import Foreign hiding (with, newForeignPtr, free -#if (__GLASGOW_HASKELL__<606) - , withObject -#endif - ) -#if (__GLASGOW_HASKELL__>=610) -import qualified Foreign.Concurrent + +#if MIN_VERSION_base(4,4,0) +import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr, newForeignPtr, free) +import System.IO.Unsafe (unsafePerformIO) + +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +#else +import Foreign hiding (newForeignPtr, free) #endif -with :: (Storable a) => a -> (Ptr a -> IO b) -> IO b -with = Foreign.with +import qualified Foreign.Concurrent -#if (__GLASGOW_HASKELL__>=610) newForeignPtr :: Ptr a -> FinalizerPtr a -> IO (ForeignPtr a) newForeignPtr p finalizer = Foreign.Concurrent.newForeignPtr p (mkFinalizer finalizer p) foreign import ccall "dynamic" mkFinalizer :: FinalizerPtr a -> Ptr a -> IO () -#else -newForeignPtr :: Ptr a -> FinalizerPtr a -> IO (ForeignPtr a) -newForeignPtr = flip Foreign.newForeignPtr -#endif nullForeignPtr :: ForeignPtr a nullForeignPtr = unsafePerformIO $ newForeignPtr_ nullPtr diff --git a/System/Glib/Flags.hs b/System/Glib/Flags.hs --- a/System/Glib/Flags.hs +++ b/System/Glib/Flags.hs @@ -34,7 +34,7 @@ import Data.Maybe (catMaybes) class (Enum a, Bounded a) => Flags a - + fromFlags :: Flags a => [a] -> Int fromFlags is = orNum 0 is where orNum n [] = n diff --git a/System/Glib/GDateTime.chs b/System/Glib/GDateTime.chs --- a/System/Glib/GDateTime.chs +++ b/System/Glib/GDateTime.chs @@ -6,7 +6,7 @@ -- -- Created: July 2007 -- --- Copyright (C) 2007 Peter Gavin +-- Copyright (C) 2007 Peter Gavin -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public @@ -104,7 +104,8 @@ peek ptr #if GLIB_CHECK_VERSION(2,12,0) -gTimeValFromISO8601 :: String +gTimeValFromISO8601 :: GlibString string + => string -> Maybe GTimeVal gTimeValFromISO8601 isoDate = unsafePerformIO $ withUTFString isoDate $ \cISODate -> @@ -114,8 +115,9 @@ then liftM Just $ peek ptr else return Nothing -gTimeValToISO8601 :: GTimeVal - -> String +gTimeValToISO8601 :: GlibString string + => GTimeVal + -> string gTimeValToISO8601 time = unsafePerformIO $ with time $ \ptr -> {# call g_time_val_to_iso8601 #} (castPtr ptr) >>= readUTFString @@ -234,7 +236,8 @@ peek ptr #endif -gDateParse :: String +gDateParse :: GlibString string + => string -> IO (Maybe GDate) gDateParse str = alloca $ \ptr -> diff --git a/System/Glib/GError.chs b/System/Glib/GError.chs --- a/System/Glib/GError.chs +++ b/System/Glib/GError.chs @@ -40,7 +40,7 @@ GErrorDomain, GErrorCode, GErrorMessage, - + -- * Catching GError exceptions -- | To catch GError exceptions thrown by Gtk2Hs functions use the -- catchGError* or handleGError* functions. They work in a similar way to @@ -58,14 +58,15 @@ -- particular error domain use 'catchGErrorJustDomain' \/ -- 'handleGErrorJustDomain' -- - catchGError, catchGErrorJust, catchGErrorJustDomain, - - handleGError, + handleGErrorJust, handleGErrorJustDomain, - + + -- ** Deprecated + catchGError, + handleGError, failOnGError, throwGError, @@ -89,20 +90,22 @@ import Foreign import Foreign.C import System.Glib.UTFString -#if HAVE_NEW_CONTROL_EXCEPTION -import Control.OldException -#else import Control.Exception -#endif - -import Data.Dynamic - -{# context lib="gtk" prefix ="gtk" #} +import Data.Typeable +import Data.Text (Text) +import qualified Data.Text as T (unpack) +import Prelude hiding (catch) -- | A GError consists of a domain, code and a human readable message. data GError = GError !GErrorDomain !GErrorCode !GErrorMessage deriving Typeable +instance Show GError where + show (GError _ _ msg) = T.unpack msg + +instance Exception GError + + type GQuark = {#type GQuark #} -- | A code used to identify the \'namespace\' of the error. Within each error @@ -120,8 +123,8 @@ type GErrorCode = Int -- | A human readable error message. -type GErrorMessage = String - +type GErrorMessage = Text + instance Storable GError where sizeOf _ = {#sizeof GError #} alignment _ = alignment (undefined:: GQuark) @@ -146,7 +149,7 @@ class Enum err => GErrorClass err where gerrorDomain :: err -> GErrorDomain -- ^ This must not use the value of its -- parameter so that it is safe to pass - -- 'undefined'. + -- 'undefined'. -- | Glib functions which report 'GError's take as a parameter a @GError -- **error@. Use this function to supply such a parameter. It checks if an @@ -184,11 +187,12 @@ -- | Use this if you need to explicitly throw a GError or re-throw an existing -- GError that you do not wish to handle. throwGError :: GError -> IO a -throwGError gerror = evaluate (throwDyn gerror) +throwGError = throw +{-# DEPRECATED throwGError "Use ordinary Control.Exception.throw" #-} -- | This will catch any GError exception. The handler function will receive the -- raw GError. This is probably only useful when you want to take some action --- that does not depend on which GError exception has occured, otherwise it +-- that does not depend on which GError exception has occurred, otherwise it -- would be better to use either 'catchGErrorJust' or 'catchGErrorJustDomain'. -- For example: -- @@ -196,11 +200,12 @@ -- > (do ... -- > ...) -- > (\(GError dom code msg) -> fail msg) --- +-- catchGError :: IO a -- ^ The computation to run -> (GError -> IO a) -- ^ Handler to invoke if an exception is raised -> IO a -catchGError action handler = catchDyn action handler +catchGError = catch +{-# DEPRECATED catchGError "Use ordinary Control.Exception.catch" #-} -- | This will catch just a specific GError exception. If you need to catch a -- range of related errors, 'catchGErrorJustDomain' is probably more @@ -209,17 +214,17 @@ -- > do image <- catchGErrorJust PixbufErrorCorruptImage -- > loadImage -- > (\errorMessage -> do log errorMessage --- > return mssingImagePlaceholder) +-- > return missingImagePlaceholder) -- catchGErrorJust :: GErrorClass err => err -- ^ The error to catch -> IO a -- ^ The computation to run -> (GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised -> IO a -catchGErrorJust code action handler = catchGError action handler' +catchGErrorJust code action handler = catch action handler' where handler' gerror@(GError domain code' msg) | fromIntegral domain == gerrorDomain code && code' == fromEnum code = handler msg - | otherwise = throwGError gerror + | otherwise = throw gerror -- | Catch all GErrors from a particular error domain. The handler function -- should just deal with one error enumeration type. If you need to catch @@ -238,27 +243,28 @@ -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised -> IO a catchGErrorJustDomain action (handler :: err -> GErrorMessage -> IO a) = - catchGError action handler' + catch action handler' where handler' gerror@(GError domain code msg) | fromIntegral domain == gerrorDomain (undefined::err) = handler (toEnum code) msg | otherwise = throwGError gerror --- | A verson of 'catchGError' with the arguments swapped around. +-- | A version of 'catchGError' with the arguments swapped around. -- -- > handleGError (\(GError dom code msg) -> ...) $ -- > ... --- +-- handleGError :: (GError -> IO a) -> IO a -> IO a -handleGError = flip catchGError +handleGError = handle +{-# DEPRECATED handleGError "Use ordinary Control.Exception.handle" #-} --- | A verson of 'handleGErrorJust' with the arguments swapped around. +-- | A version of 'handleGErrorJust' with the arguments swapped around. handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a handleGErrorJust code = flip (catchGErrorJust code) --- | A verson of 'handleGErrorJustDomain' with the arguments swapped around. +-- | A version of 'catchGErrorJustDomain' with the arguments swapped around. handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a handleGErrorJustDomain = flip catchGErrorJustDomain -- | Catch all GError exceptions and convert them into a general failure. failOnGError :: IO a -> IO a -failOnGError action = catchGError action (\(GError dom code msg) -> fail msg) +failOnGError action = catchGError action (\(GError dom code msg) -> fail (T.unpack msg)) diff --git a/System/Glib/GList.chs b/System/Glib/GList.chs --- a/System/Glib/GList.chs +++ b/System/Glib/GList.chs @@ -43,8 +43,8 @@ ) where import Foreign -import Control.Exception (bracket) -import Control.Monad (foldM) +import Control.Exception (bracket) +import Control.Monad (foldM) {# context lib="glib" prefix="g" #} @@ -58,7 +58,7 @@ readGList :: GList -> IO [Ptr a] readGList glist | glist==nullPtr = return [] - | otherwise = do + | otherwise = do x <- {#get GList->data#} glist glist' <- {#get GList->next#} glist xs <- readGList glist' @@ -74,16 +74,16 @@ extractList gl xs | gl==nullPtr = return xs | otherwise = do - x <- {#get GList.data#} gl - gl' <- {#call unsafe list_delete_link#} gl gl - extractList gl' (castPtr x:xs) + x <- {#get GList.data#} gl + gl' <- {#call unsafe list_delete_link#} gl gl + extractList gl' (castPtr x:xs) -- Turn a GSList into a list of pointers but don't destroy the list. -- readGSList :: GSList -> IO [Ptr a] readGSList gslist | gslist==nullPtr = return [] - | otherwise = do + | otherwise = do x <- {#get GSList->data#} gslist gslist' <- {#get GSList->next#} gslist xs <- readGSList gslist' @@ -94,7 +94,7 @@ fromGSList :: GSList -> IO [Ptr a] fromGSList gslist | gslist==nullPtr = return [] - | otherwise = do + | otherwise = do x <- {#get GSList->data#} gslist gslist' <- {#call unsafe slist_delete_link#} gslist gslist xs <- fromGSList gslist' @@ -108,10 +108,10 @@ where extractList gslist xs | gslist==nullPtr = return xs - | otherwise = do - x <- {#get GSList->data#} gslist - gslist' <- {#call unsafe slist_delete_link#} gslist gslist - extractList gslist' (castPtr x:xs) + | otherwise = do + x <- {#get GSList->data#} gslist + gslist' <- {#call unsafe slist_delete_link#} gslist gslist + extractList gslist' (castPtr x:xs) -- Turn a list of something into a GList. -- diff --git a/System/Glib/GObject.chs b/System/Glib/GObject.chs --- a/System/Glib/GObject.chs +++ b/System/Glib/GObject.chs @@ -40,7 +40,8 @@ #endif makeNewGObject, constructNewGObject, - + wrapNewGObject, + -- ** GType queries gTypeGObject, isA, @@ -60,6 +61,7 @@ import Control.Monad (liftM, when) import Data.IORef (newIORef, readIORef, writeIORef) +import qualified Data.Text as T (pack) import System.Glib.FFI import System.Glib.UTFString @@ -109,7 +111,7 @@ -- It should be used whenever a function returns a pointer to an existing -- 'GObject' (as opposed to a function that constructs a new object). -- --- * The first argument is the contructor of the specific object. +-- * The first argument is the constructor of the specific object. -- makeNewGObject :: GObjectClass obj @@ -126,25 +128,37 @@ {#pointer GDestroyNotify as DestroyNotify#} -foreign import ccall "wrapper" mkDestroyNotifyPtr :: IO () -> IO DestroyNotify - --- | This function wraps any object that does not --- derive from Object. The object is NOT reference, hence it should be used --- when a new object is created. Newly created 'GObject's have a reference --- count of one, hence don't need ref'ing. +-- | This function wraps any newly created objects that derives from +-- GInitiallyUnowned also known as objects with +-- \"floating-references\". The object will be refSink (for glib +-- versions >= 2.10). On non-floating objects, this function behaves +-- exactly the same as "makeNewGObject". -- -constructNewGObject :: GObjectClass obj => +constructNewGObject :: GObjectClass obj => (ForeignPtr obj -> obj, FinalizerPtr obj) -> IO (Ptr obj) -> IO obj constructNewGObject (constr, objectUnref) generator = do objPtr <- generator #if GLIB_CHECK_VERSION(2,10,0) - -- change the exisiting floating reference into a proper reference; + -- change the existing floating reference into a proper reference; -- the name is confusing, what the function does is ref,sink,unref objectRefSink objPtr #endif obj <- newForeignPtr objPtr objectUnref return $! constr obj +-- | This function wraps any newly created object that does not derived +-- from GInitiallyUnowned (that is a GObject with no floating +-- reference). Since newly created 'GObject's have a reference count of +-- one, they don't need ref'ing. +-- +wrapNewGObject :: GObjectClass obj => + (ForeignPtr obj -> obj, FinalizerPtr obj) -> IO (Ptr obj) -> IO obj +wrapNewGObject (constr, objectUnref) generator = do + objPtr <- generator + when (objPtr == nullPtr) (fail "wrapNewGObject: object is NULL") + obj <- newForeignPtr objPtr objectUnref + return $! constr obj + -- | Many methods in classes derived from GObject take a callback function and -- a destructor function which is called to free that callback function when -- it is no longer required. This constants is an address of a functions in @@ -159,7 +173,7 @@ uniqueCnt = unsafePerformIO $ newMVar 0 -- | Create a unique id based on the given string. -quarkFromString :: String -> IO Quark +quarkFromString :: GlibString string => string -> IO Quark quarkFromString name = withUTFString name {#call unsafe quark_from_string#} -- | Add an attribute to this object. @@ -172,9 +186,9 @@ objectCreateAttribute = do cnt <- modifyMVar uniqueCnt (\cnt -> return (cnt+1, cnt)) let propName = "Gtk2HsAttr"++show cnt - attr <- quarkFromString propName + attr <- quarkFromString $ T.pack propName return (newNamedAttr propName (objectGetAttributeUnsafe attr) - (objectSetAttribute attr)) + (objectSetAttribute attr)) -- | The address of a function freeing a 'StablePtr'. See 'destroyFunPtr'. foreign import ccall unsafe "&hs_free_stable_ptr" destroyStablePtr :: DestroyNotify @@ -187,13 +201,13 @@ objectSetAttribute attr obj (Just val) = do sPtr <- newStablePtr val {#call object_set_qdata_full#} (toGObject obj) attr (castStablePtrToPtr sPtr) - destroyStablePtr + destroyStablePtr -- | Get the value of an association. -- -- * Note that this function may crash the Haskell run-time since the -- returned type can be forced to be anything. See 'objectCreateAttribute' --- for a safe wrapper around this funciton. +-- for a safe wrapper around this function. -- objectGetAttributeUnsafe :: GObjectClass o => Quark -> o -> IO (Maybe a) objectGetAttributeUnsafe attr obj = do @@ -204,6 +218,10 @@ -- | Determine if this is an instance of a particular GTK type -- isA :: GObjectClass o => o -> GType -> Bool -isA obj gType = - typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr.unGObject.toGObject) obj) gType +isA obj gType = + typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr.unGObject.toGObject) obj) gType +-- at this point we would normally implement the notify signal handler; +-- I've moved this definition into the Object class of the gtk package +-- since there's a quite a bit of machinery missing here (generated signal +-- register functions and the problem of recursive modules) diff --git a/System/Glib/GParameter.hsc b/System/Glib/GParameter.hsc --- a/System/Glib/GParameter.hsc +++ b/System/Glib/GParameter.hsc @@ -6,7 +6,7 @@ -- Created: 29 March 2004 -- -- Copyright (c) 2004 Duncan Coutts --- +-- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either diff --git a/System/Glib/GString.chs b/System/Glib/GString.chs new file mode 100644 --- /dev/null +++ b/System/Glib/GString.chs @@ -0,0 +1,78 @@ +-- -*-haskell-*- +-- GIMP Toolkit (GTK) +-- +-- Author : Andreas Baldeau +-- +-- Created: 14 November 2010 +-- +-- Copyright (C) 2010 Andreas Baldeau +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- | +-- Maintainer : gtk2hs-users@lists.sourceforge.net +-- Stability : provisional +-- Portability : portable (depends on GHC) +-- +-- Defines functions to extract data from a GString. +-- +module System.Glib.GString ( + GString, + readGString, + readGStringByteString, + fromGString, + ) where + +import Foreign +import Control.Exception (bracket) +import Control.Monad (foldM) +import Data.ByteString (ByteString, packCStringLen) + +import System.Glib.FFI + +{# context lib="glib" prefix="g" #} + +{#pointer * GString#} + +-- methods + +-- Turn a GString into a String but don't destroy it. +-- +readGString :: GString -> IO (Maybe String) +readGString gstring + | gstring == nullPtr = return Nothing + | otherwise = do + gstr <- {#get GString->str#} gstring + len <- {#get GString->len#} gstring + fmap Just $ peekCStringLen (gstr, fromIntegral len) + +-- Turn a GString into a ByteString but don't destroy it. +-- +readGStringByteString :: GString -> IO (Maybe ByteString) +readGStringByteString gstring + | gstring == nullPtr = return Nothing + | otherwise = do + gstr <- {#get GString->str#} gstring + len <- {#get GString->len#} gstring + fmap Just $ packCStringLen (gstr, fromIntegral len) + +-- Turn a GList into a list of pointers (freeing the GList in the process). +-- +fromGString :: GString -> IO (Maybe String) +fromGString gstring + | gstring == nullPtr = return Nothing + | otherwise = do + gstr <- {#get GString->str#} gstring + len <- {#get GString->len#} gstring + str <- fmap Just $ peekCStringLen (gstr, fromIntegral len) + _ <- {#call unsafe string_free#} gstring $ fromBool True + return str + diff --git a/System/Glib/GType.chs b/System/Glib/GType.chs --- a/System/Glib/GType.chs +++ b/System/Glib/GType.chs @@ -13,7 +13,7 @@ -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. --- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU @@ -28,7 +28,8 @@ -- module System.Glib.GType ( GType, - typeInstanceIsA + typeInstanceIsA, + glibTypeInit, ) where import System.Glib.FFI @@ -45,3 +46,13 @@ typeInstanceIsA obj p = toBool $ unsafePerformIO ({#call unsafe g_type_check_instance_is_a#} obj p) + +-- | Prior to any use of the glib type/object system, @glibTypeInit@ has to +-- be called to initialise the system. +-- +-- Note that this is not needed for gtk applications using @initGUI@ since +-- that initialises everything itself. It is only needed for applications +-- using glib directly, without also using gtk. +-- +glibTypeInit :: IO () +glibTypeInit = {# call g_type_init #} diff --git a/System/Glib/GTypeConstants.hsc b/System/Glib/GTypeConstants.hsc --- a/System/Glib/GTypeConstants.hsc +++ b/System/Glib/GTypeConstants.hsc @@ -37,27 +37,27 @@ boxed ) where -import System.Glib.GType (GType) +import System.Glib.GType (GType) #include invalid, none, uint, int, uint64, int64, uchar, char, bool, enum, flags, pointer, float, double, string, object, boxed :: GType -invalid = #const G_TYPE_INVALID -none = #const G_TYPE_NONE -uint = #const G_TYPE_UINT -int = #const G_TYPE_INT -uint64 = #const G_TYPE_UINT64 -int64 = #const G_TYPE_INT64 -uchar = #const G_TYPE_UCHAR -char = #const G_TYPE_CHAR -bool = #const G_TYPE_BOOLEAN -enum = #const G_TYPE_ENUM -flags = #const G_TYPE_FLAGS -pointer = #const G_TYPE_POINTER -float = #const G_TYPE_FLOAT -double = #const G_TYPE_DOUBLE -string = #const G_TYPE_STRING -object = #const G_TYPE_OBJECT -boxed = #const G_TYPE_BOXED +invalid = #const G_TYPE_INVALID +none = #const G_TYPE_NONE +uint = #const G_TYPE_UINT +int = #const G_TYPE_INT +uint64 = #const G_TYPE_UINT64 +int64 = #const G_TYPE_INT64 +uchar = #const G_TYPE_UCHAR +char = #const G_TYPE_CHAR +bool = #const G_TYPE_BOOLEAN +enum = #const G_TYPE_ENUM +flags = #const G_TYPE_FLAGS +pointer = #const G_TYPE_POINTER +float = #const G_TYPE_FLOAT +double = #const G_TYPE_DOUBLE +string = #const G_TYPE_STRING +object = #const G_TYPE_OBJECT +boxed = #const G_TYPE_BOXED diff --git a/System/Glib/GValue.chs b/System/Glib/GValue.chs --- a/System/Glib/GValue.chs +++ b/System/Glib/GValue.chs @@ -35,7 +35,7 @@ ) where import System.Glib.FFI -import System.Glib.GType (GType) +import System.Glib.GType (GType) {# context lib="glib" prefix="g" #} diff --git a/System/Glib/GValueTypes.chs b/System/Glib/GValueTypes.chs --- a/System/Glib/GValueTypes.chs +++ b/System/Glib/GValueTypes.chs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- -*-haskell-*- -- GIMP Toolkit (GTK) GValueTypes -- @@ -51,6 +52,10 @@ valueGetString, valueSetMaybeString, valueGetMaybeString, + valueSetFilePath, + valueGetFilePath, + valueSetMaybeFilePath, + valueGetMaybeFilePath, valueSetBoxed, valueGetBoxed, valueSetGObject, @@ -59,12 +64,12 @@ valueGetMaybeGObject, ) where -import Control.Monad (liftM) +import Control.Monad (liftM) import System.Glib.FFI import System.Glib.Flags import System.Glib.UTFString -{#import System.Glib.GValue#} (GValue(GValue)) +{#import System.Glib.GValue#} (GValue(GValue)) import System.Glib.GObject {# context lib="glib" prefix="g" #} @@ -160,19 +165,19 @@ liftM (toFlags . fromIntegral) $ {# call unsafe value_get_flags #} gvalue -valueSetString :: GValue -> String -> IO () +valueSetString :: GlibString string => GValue -> string -> IO () valueSetString gvalue str = withUTFString str $ \strPtr -> {# call unsafe value_set_string #} gvalue strPtr -valueGetString :: GValue -> IO String +valueGetString :: GlibString string => GValue -> IO string valueGetString gvalue = do strPtr <- {# call unsafe value_get_string #} gvalue if strPtr == nullPtr then return "" else peekUTFString strPtr -valueSetMaybeString :: GValue -> Maybe String -> IO () +valueSetMaybeString :: GlibString string => GValue -> Maybe string -> IO () valueSetMaybeString gvalue (Just str) = withUTFString str $ \strPtr -> {# call unsafe value_set_string #} gvalue strPtr @@ -180,10 +185,35 @@ valueSetMaybeString gvalue Nothing = {# call unsafe value_set_static_string #} gvalue nullPtr -valueGetMaybeString :: GValue -> IO (Maybe String) +valueGetMaybeString :: GlibString string => GValue -> IO (Maybe string) valueGetMaybeString gvalue = {# call unsafe value_get_string #} gvalue >>= maybePeek peekUTFString + +valueSetFilePath :: GlibFilePath string => GValue -> string -> IO () +valueSetFilePath gvalue str = + withUTFFilePath str $ \strPtr -> + {# call unsafe value_set_string #} gvalue strPtr + +valueGetFilePath :: GlibFilePath string => GValue -> IO string +valueGetFilePath gvalue = do + strPtr <- {# call unsafe value_get_string #} gvalue + if strPtr == nullPtr + then return "" + else peekUTFFilePath strPtr + +valueSetMaybeFilePath :: GlibFilePath string => GValue -> Maybe string -> IO () +valueSetMaybeFilePath gvalue (Just str) = + withUTFFilePath str $ \strPtr -> + {# call unsafe value_set_string #} gvalue strPtr + +valueSetMaybeFilePath gvalue Nothing = + {# call unsafe value_set_static_string #} gvalue nullPtr + +valueGetMaybeFilePath :: GlibFilePath string => GValue -> IO (Maybe string) +valueGetMaybeFilePath gvalue = + {# call unsafe value_get_string #} gvalue + >>= maybePeek peekUTFFilePath valueSetBoxed :: (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GValue -> boxed -> IO () valueSetBoxed with gvalue boxed = diff --git a/System/Glib/MainLoop.chs b/System/Glib/MainLoop.chs --- a/System/Glib/MainLoop.chs +++ b/System/Glib/MainLoop.chs @@ -61,17 +61,17 @@ #endif ) where -import Control.Monad (liftM) +import Control.Monad (liftM) import System.Glib.FFI import System.Glib.Flags -import System.Glib.GObject (DestroyNotify, destroyFunPtr) +import System.Glib.GObject (DestroyNotify, destroyFunPtr) {#context lib="glib" prefix ="g"#} {#pointer SourceFunc#} -foreign import ccall "wrapper" mkSourceFunc :: IO {#type gint#} -> IO SourceFunc +foreign import ccall "wrapper" mkSourceFunc :: (Ptr () -> IO {#type gint#}) -> IO SourceFunc type HandlerId = {#type guint#} @@ -79,7 +79,7 @@ -- makeCallback :: IO {#type gint#} -> IO (SourceFunc, DestroyNotify) makeCallback fun = do - funPtr <- mkSourceFunc fun + funPtr <- mkSourceFunc (const fun) return (funPtr, destroyFunPtr) -- | Sets a function to be called at regular intervals, with the default @@ -142,13 +142,13 @@ -- | Flags representing a condition to watch for on a file descriptor. -- --- [@IOIn@] There is data to read. --- [@IOOut@] Data can be written (without blocking). --- [@IOPri@] There is urgent data to read. --- [@IOErr@] Error condition. --- [@IOHup@] Hung up (the connection has been broken, usually for +-- [@IOIn@] There is data to read. +-- [@IOOut@] Data can be written (without blocking). +-- [@IOPri@] There is urgent data to read. +-- [@IOErr@] Error condition. +-- [@IOHup@] Hung up (the connection has been broken, usually for -- pipes and sockets). --- [@IOInvalid@] Invalid request. The file descriptor is not open. +-- [@IOInvalid@] Invalid request. The file descriptor is not open. -- {# enum IOCondition { G_IO_IN as IOIn, @@ -290,7 +290,7 @@ -- waiting for a source to become ready, then dispatching the -- highest priority events sources that are ready. Note that even -- when @mayBlock@ is 'True', it is still possible for --- 'mainContextIteration' to return FALSE, since the the wait +-- 'mainContextIteration' to return 'False', since the the wait -- may be interrupted for other reasons than an event source -- becoming ready. mainContextIteration :: MainContext diff --git a/System/Glib/Properties.chs b/System/Glib/Properties.chs --- a/System/Glib/Properties.chs +++ b/System/Glib/Properties.chs @@ -49,7 +49,11 @@ objectSetPropertyString, objectGetPropertyString, objectSetPropertyMaybeString, - objectGetPropertyMaybeString, + objectGetPropertyMaybeString, + objectSetPropertyFilePath, + objectGetPropertyFilePath, + objectSetPropertyMaybeFilePath, + objectGetPropertyMaybeFilePath, objectSetPropertyBoxedOpaque, objectGetPropertyBoxedOpaque, objectSetPropertyBoxedStorable, @@ -61,33 +65,45 @@ newAttrFromIntProperty, readAttrFromIntProperty, newAttrFromUIntProperty, - newAttrFromCharProperty, + readAttrFromUIntProperty, writeAttrFromUIntProperty, + newAttrFromCharProperty, + readAttrFromCharProperty, newAttrFromBoolProperty, readAttrFromBoolProperty, newAttrFromFloatProperty, + readAttrFromFloatProperty, newAttrFromDoubleProperty, + readAttrFromDoubleProperty, newAttrFromEnumProperty, readAttrFromEnumProperty, writeAttrFromEnumProperty, newAttrFromFlagsProperty, + readAttrFromFlagsProperty, newAttrFromStringProperty, readAttrFromStringProperty, writeAttrFromStringProperty, newAttrFromMaybeStringProperty, readAttrFromMaybeStringProperty, writeAttrFromMaybeStringProperty, + newAttrFromFilePathProperty, + readAttrFromFilePathProperty, + writeAttrFromFilePathProperty, + newAttrFromMaybeFilePathProperty, + readAttrFromMaybeFilePathProperty, + writeAttrFromMaybeFilePathProperty, newAttrFromBoxedOpaqueProperty, readAttrFromBoxedOpaqueProperty, writeAttrFromBoxedOpaqueProperty, newAttrFromBoxedStorableProperty, + readAttrFromBoxedStorableProperty, newAttrFromObjectProperty, - writeAttrFromObjectProperty, readAttrFromObjectProperty, + writeAttrFromObjectProperty, newAttrFromMaybeObjectProperty, - writeAttrFromMaybeObjectProperty, readAttrFromMaybeObjectProperty, - + writeAttrFromMaybeObjectProperty, + -- TODO: do not export these once we dump the old TreeList API: objectGetPropertyInternal, objectSetPropertyInternal, @@ -96,14 +112,15 @@ import Control.Monad (liftM) import System.Glib.FFI -import System.Glib.Flags (Flags) +import System.Glib.UTFString +import System.Glib.Flags (Flags) {#import System.Glib.Types#} -{#import System.Glib.GValue#} (GValue(GValue), valueInit, allocaGValue) +{#import System.Glib.GValue#} (GValue(GValue), valueInit, allocaGValue) import qualified System.Glib.GTypeConstants as GType import System.Glib.GType import System.Glib.GValueTypes -import System.Glib.Attributes (Attr, ReadAttr, WriteAttr, ReadWriteAttr, - newNamedAttr, readNamedAttr, writeNamedAttr) +import System.Glib.Attributes (Attr, ReadAttr, WriteAttr, ReadWriteAttr, + newNamedAttr, readNamedAttr, writeNamedAttr) {# context lib="glib" prefix="g" #} @@ -189,18 +206,30 @@ objectGetPropertyDouble :: GObjectClass gobj => String -> gobj -> IO Double objectGetPropertyDouble = objectGetPropertyInternal GType.double valueGetDouble -objectSetPropertyString :: GObjectClass gobj => String -> gobj -> String -> IO () +objectSetPropertyString :: (GObjectClass gobj, GlibString string) => String -> gobj -> string -> IO () objectSetPropertyString = objectSetPropertyInternal GType.string valueSetString -objectGetPropertyString :: GObjectClass gobj => String -> gobj -> IO String +objectGetPropertyString :: (GObjectClass gobj, GlibString string) => String -> gobj -> IO string objectGetPropertyString = objectGetPropertyInternal GType.string valueGetString -objectSetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> Maybe String -> IO () +objectSetPropertyMaybeString :: (GObjectClass gobj, GlibString string) => String -> gobj -> Maybe string -> IO () objectSetPropertyMaybeString = objectSetPropertyInternal GType.string valueSetMaybeString -objectGetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> IO (Maybe String) +objectGetPropertyMaybeString :: (GObjectClass gobj, GlibString string) => String -> gobj -> IO (Maybe string) objectGetPropertyMaybeString = objectGetPropertyInternal GType.string valueGetMaybeString +objectSetPropertyFilePath :: (GObjectClass gobj, GlibFilePath string) => String -> gobj -> string -> IO () +objectSetPropertyFilePath = objectSetPropertyInternal GType.string valueSetFilePath + +objectGetPropertyFilePath :: (GObjectClass gobj, GlibFilePath string) => String -> gobj -> IO string +objectGetPropertyFilePath = objectGetPropertyInternal GType.string valueGetFilePath + +objectSetPropertyMaybeFilePath :: (GObjectClass gobj, GlibFilePath string) => String -> gobj -> Maybe string -> IO () +objectSetPropertyMaybeFilePath = objectSetPropertyInternal GType.string valueSetMaybeFilePath + +objectGetPropertyMaybeFilePath :: (GObjectClass gobj, GlibFilePath string) => String -> gobj -> IO (Maybe string) +objectGetPropertyMaybeFilePath = objectGetPropertyInternal GType.string valueGetMaybeFilePath + objectSetPropertyBoxedOpaque :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GType -> String -> gobj -> boxed -> IO () objectSetPropertyBoxedOpaque with gtype = objectSetPropertyInternal gtype (valueSetBoxed with) @@ -242,10 +271,18 @@ newAttrFromUIntProperty propName = newNamedAttr propName (objectGetPropertyUInt propName) (objectSetPropertyUInt propName) +readAttrFromUIntProperty :: GObjectClass gobj => String -> ReadAttr gobj Int +readAttrFromUIntProperty propName = + readNamedAttr propName (objectGetPropertyUInt propName) + newAttrFromCharProperty :: GObjectClass gobj => String -> Attr gobj Char newAttrFromCharProperty propName = newNamedAttr propName (objectGetPropertyChar propName) (objectSetPropertyChar propName) +readAttrFromCharProperty :: GObjectClass gobj => String -> ReadAttr gobj Char +readAttrFromCharProperty propName = + readNamedAttr propName (objectGetPropertyChar propName) + writeAttrFromUIntProperty :: GObjectClass gobj => String -> WriteAttr gobj Int writeAttrFromUIntProperty propName = writeNamedAttr propName (objectSetPropertyUInt propName) @@ -262,10 +299,18 @@ newAttrFromFloatProperty propName = newNamedAttr propName (objectGetPropertyFloat propName) (objectSetPropertyFloat propName) +readAttrFromFloatProperty :: GObjectClass gobj => String -> ReadAttr gobj Float +readAttrFromFloatProperty propName = + readNamedAttr propName (objectGetPropertyFloat propName) + newAttrFromDoubleProperty :: GObjectClass gobj => String -> Attr gobj Double newAttrFromDoubleProperty propName = newNamedAttr propName (objectGetPropertyDouble propName) (objectSetPropertyDouble propName) +readAttrFromDoubleProperty :: GObjectClass gobj => String -> ReadAttr gobj Double +readAttrFromDoubleProperty propName = + readNamedAttr propName (objectGetPropertyDouble propName) + newAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> Attr gobj enum newAttrFromEnumProperty propName gtype = newNamedAttr propName (objectGetPropertyEnum gtype propName) (objectSetPropertyEnum gtype propName) @@ -282,30 +327,58 @@ newAttrFromFlagsProperty propName gtype = newNamedAttr propName (objectGetPropertyFlags gtype propName) (objectSetPropertyFlags gtype propName) -newAttrFromStringProperty :: GObjectClass gobj => String -> Attr gobj String +readAttrFromFlagsProperty :: (GObjectClass gobj, Flags flag) => String -> GType -> ReadAttr gobj [flag] +readAttrFromFlagsProperty propName gtype = + readNamedAttr propName (objectGetPropertyFlags gtype propName) + +newAttrFromStringProperty :: (GObjectClass gobj, GlibString string) => String -> Attr gobj string newAttrFromStringProperty propName = newNamedAttr propName (objectGetPropertyString propName) (objectSetPropertyString propName) -readAttrFromStringProperty :: GObjectClass gobj => String -> ReadAttr gobj String +readAttrFromStringProperty :: (GObjectClass gobj, GlibString string) => String -> ReadAttr gobj string readAttrFromStringProperty propName = readNamedAttr propName (objectGetPropertyString propName) -writeAttrFromStringProperty :: GObjectClass gobj => String -> WriteAttr gobj String +writeAttrFromStringProperty :: (GObjectClass gobj, GlibString string) => String -> WriteAttr gobj string writeAttrFromStringProperty propName = writeNamedAttr propName (objectSetPropertyString propName) -newAttrFromMaybeStringProperty :: GObjectClass gobj => String -> Attr gobj (Maybe String) +newAttrFromMaybeStringProperty :: (GObjectClass gobj, GlibString string) => String -> Attr gobj (Maybe string) newAttrFromMaybeStringProperty propName = newNamedAttr propName (objectGetPropertyMaybeString propName) (objectSetPropertyMaybeString propName) -readAttrFromMaybeStringProperty :: GObjectClass gobj => String -> ReadAttr gobj (Maybe String) +readAttrFromMaybeStringProperty :: (GObjectClass gobj, GlibString string) => String -> ReadAttr gobj (Maybe string) readAttrFromMaybeStringProperty propName = readNamedAttr propName (objectGetPropertyMaybeString propName) -writeAttrFromMaybeStringProperty :: GObjectClass gobj => String -> WriteAttr gobj (Maybe String) +writeAttrFromMaybeStringProperty :: (GObjectClass gobj, GlibString string) => String -> WriteAttr gobj (Maybe string) writeAttrFromMaybeStringProperty propName = writeNamedAttr propName (objectSetPropertyMaybeString propName) +newAttrFromFilePathProperty :: (GObjectClass gobj, GlibFilePath string) => String -> Attr gobj string +newAttrFromFilePathProperty propName = + newNamedAttr propName (objectGetPropertyFilePath propName) (objectSetPropertyFilePath propName) + +readAttrFromFilePathProperty :: (GObjectClass gobj, GlibFilePath string) => String -> ReadAttr gobj string +readAttrFromFilePathProperty propName = + readNamedAttr propName (objectGetPropertyFilePath propName) + +writeAttrFromFilePathProperty :: (GObjectClass gobj, GlibFilePath string) => String -> WriteAttr gobj string +writeAttrFromFilePathProperty propName = + writeNamedAttr propName (objectSetPropertyFilePath propName) + +newAttrFromMaybeFilePathProperty :: (GObjectClass gobj, GlibFilePath string) => String -> Attr gobj (Maybe string) +newAttrFromMaybeFilePathProperty propName = + newNamedAttr propName (objectGetPropertyMaybeFilePath propName) (objectSetPropertyMaybeFilePath propName) + +readAttrFromMaybeFilePathProperty :: (GObjectClass gobj, GlibFilePath string) => String -> ReadAttr gobj (Maybe string) +readAttrFromMaybeFilePathProperty propName = + readNamedAttr propName (objectGetPropertyMaybeFilePath propName) + +writeAttrFromMaybeFilePathProperty :: (GObjectClass gobj, GlibFilePath string) => String -> WriteAttr gobj (Maybe string) +writeAttrFromMaybeFilePathProperty propName = + writeNamedAttr propName (objectSetPropertyMaybeFilePath propName) + newAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> Attr gobj boxed newAttrFromBoxedOpaqueProperty peek with propName gtype = newNamedAttr propName (objectGetPropertyBoxedOpaque peek gtype propName) (objectSetPropertyBoxedOpaque with gtype propName) @@ -322,6 +395,10 @@ newAttrFromBoxedStorableProperty propName gtype = newNamedAttr propName (objectGetPropertyBoxedStorable gtype propName) (objectSetPropertyBoxedStorable gtype propName) +readAttrFromBoxedStorableProperty :: (GObjectClass gobj, Storable boxed) => String -> GType -> ReadAttr gobj boxed +readAttrFromBoxedStorableProperty propName gtype = + readNamedAttr propName (objectGetPropertyBoxedStorable gtype propName) + newAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj gobj' gobj'' newAttrFromObjectProperty propName gtype = newNamedAttr propName (objectGetPropertyGObject gtype propName) (objectSetPropertyGObject gtype propName) @@ -337,7 +414,7 @@ newAttrFromMaybeObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj (Maybe gobj') (Maybe gobj'') newAttrFromMaybeObjectProperty propName gtype = newNamedAttr propName (objectGetPropertyMaybeGObject gtype propName) (objectSetPropertyMaybeGObject gtype propName) - + writeAttrFromMaybeObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> WriteAttr gobj (Maybe gobj') writeAttrFromMaybeObjectProperty propName gtype = writeNamedAttr propName (objectSetPropertyMaybeGObject gtype propName) diff --git a/System/Glib/Signals.chs b/System/Glib/Signals.chs --- a/System/Glib/Signals.chs +++ b/System/Glib/Signals.chs @@ -24,10 +24,10 @@ -- The object system in the second version of GTK is based on GObject from -- GLIB. This base class is rather primitive in that it only implements -- ref and unref methods (and others that are not interesting to us). If --- the marshall list mentions OBJECT it refers to an instance of this +-- the marshall list mentions OBJECT it refers to an instance of this -- GObject which is automatically wrapped with a ref and unref call. -- Structures which are not derived from GObject have to be passed as --- BOXED which gives the signal connect function a possiblity to do the +-- BOXED which gives the signal connect function a possibility to do the -- conversion into a proper ForeignPtr type. In special cases the signal -- connect function use a PTR type which will then be mangled in the -- user function directly. The latter is needed if a signal delivers a @@ -37,10 +37,12 @@ Signal(Signal), on, after, SignalName, + GSignalMatchType(..), ConnectAfter, ConnectId(ConnectId), signalDisconnect, signalBlock, + signalBlockMatched, signalUnblock, signalStopEmission, disconnect, @@ -53,7 +55,10 @@ #endif ) where +import Control.Monad (liftM) import System.Glib.FFI +import System.Glib.GType +import System.Glib.Flags {#import System.Glib.GObject#} #ifndef USE_GCLOSURE_SIGNALS_IMPL import Data.IORef @@ -102,13 +107,13 @@ type SignalName = String --- | The type of signal handler ids. If you ever need to 'disconnect' a signal --- handler then you will need to retain the 'ConnectId' you got when you --- registered it. +-- | The type of signal handler ids. If you ever need to use +-- 'signalDisconnect' to disconnect a signal handler then you will +-- need to retain the 'ConnectId' you got when you registered it. -- data GObjectClass o => ConnectId o = ConnectId {#type gulong#} o --- old name for backwards compatability +-- old name for backwards compatibility disconnect :: GObjectClass obj => ConnectId obj -> IO () disconnect = signalDisconnect {-# DEPRECATED disconnect "use signalDisconnect instead" #-} @@ -125,7 +130,7 @@ -- -- * Blocks a handler of an instance so it will not be called during any -- signal emissions unless it is unblocked again. Thus \"blocking\" a signal --- handler means to temporarily deactive it, a signal handler has to be +-- handler means to temporarily deactivate it, a signal handler has to be -- unblocked exactly the same amount of times it has been blocked before -- to become active again. -- @@ -133,7 +138,39 @@ signalBlock (ConnectId handler obj) = withForeignPtr ((unGObject.toGObject) obj) $ \objPtr -> {# call g_signal_handler_block #} (castPtr objPtr) handler - + +{# enum GSignalMatchType {underscoreToCase} deriving (Eq, Ord, Bounded) #} +instance Flags GSignalMatchType + +-- | Blocks all handlers on an instance that match a certain selection +-- criteria. The criteria mask is passed as a list of `GSignalMatchType` flags, +-- and the criteria values are passed as arguments. Passing at least one of +-- the `SignalMatchClosure`, `SignalMatchFunc` or `SignalMatchData` match flags +-- is required for successful matches. If no handlers were found, 0 is returned, +-- the number of blocked handlers otherwise. +signalBlockMatched :: GObjectClass obj + => obj + -> [GSignalMatchType] + -> SignalName + -> GType + -> Quark + -> Maybe GClosure + -> Maybe (Ptr ()) + -> Maybe (Ptr ()) + -> IO Int +signalBlockMatched obj mask sigName gType quark closure func userData = do + sigId <- withCString sigName $ \strPtr -> + {# call g_signal_lookup #} strPtr gType + liftM fromIntegral $ withForeignPtr (unGObject $ toGObject obj) $ \objPtr -> + {# call g_signal_handlers_block_matched #} + (castPtr objPtr) + (fromIntegral $ fromFlags mask) + sigId + quark + (maybe nullPtr (\(GClosure p) -> castPtr p) closure) + (maybe nullPtr id func) + (maybe nullPtr id userData) + -- | Unblock a specific signal handler. -- -- * Undoes the effect of a previous 'signalBlock' call. A blocked handler @@ -181,8 +218,8 @@ connectGeneric signal after obj user = do sptr <- newStablePtr user gclosurePtr <- gtk2hs_closure_new sptr - sigId <- - withCString signal $ \signalPtr -> + sigId <- + withCString signal $ \signalPtr -> withForeignPtr ((unGObject.toGObject) obj) $ \objPtr -> {# call g_signal_connect_closure #} (castPtr objPtr) @@ -198,16 +235,16 @@ {#pointer GClosureNotify#} -foreign import ccall "wrapper" mkDestructor :: IO () -> IO GClosureNotify - +foreign import ccall "wrapper" mkDestructor :: IO () -> IO GClosureNotify + mkFunPtrClosureNotify :: FunPtr a -> IO GClosureNotify -mkFunPtrClosureNotify hPtr = do - dRef <- newIORef nullFunPtr - dPtr <- mkDestructor $ do - freeHaskellFunPtr hPtr - dPtr <- readIORef dRef - freeHaskellFunPtr dPtr - writeIORef dRef dPtr +mkFunPtrClosureNotify hPtr = do + dRef <- newIORef nullFunPtr + dPtr <- mkDestructor $ do + freeHaskellFunPtr hPtr + dPtr <- readIORef dRef + freeHaskellFunPtr dPtr + writeIORef dRef dPtr return dPtr #endif diff --git a/System/Glib/StoreValue.hsc b/System/Glib/StoreValue.hsc --- a/System/Glib/StoreValue.hsc +++ b/System/Glib/StoreValue.hsc @@ -32,57 +32,53 @@ valueGetGenericValue, ) where -import Control.Monad (liftM) +import Control.Monad (liftM) +import Data.Text (Text) -#if HAVE_NEW_CONTROL_EXCEPTION -import Control.OldException -#else -import Control.Exception - (throw, Exception(AssertionFailed)) -#endif +import Control.Exception (throw, AssertionFailed(..)) #include import System.Glib.FFI -import System.Glib.GValue (GValue, valueInit, valueGetType) +import System.Glib.GValue (GValue, valueInit, valueGetType) import System.Glib.GValueTypes import qualified System.Glib.GTypeConstants as GType -import System.Glib.Types (GObject) +import System.Glib.Types (GObject) -- | A union with information about the currently stored type. -- -- * Internally used by "Graphics.UI.Gtk.TreeList.TreeModel". -- data GenericValue = GVuint Word - | GVint Int --- | GVuchar #{type guchar} --- | GVchar #{type gchar} - | GVboolean Bool - | GVenum Int - | GVflags Int --- | GVpointer (Ptr ()) - | GVfloat Float - | GVdouble Double - | GVstring (Maybe String) - | GVobject GObject --- | GVboxed (Ptr ()) + | GVint Int +-- | GVuchar #{type guchar} +-- | GVchar #{type gchar} + | GVboolean Bool + | GVenum Int + | GVflags Int +-- | GVpointer (Ptr ()) + | GVfloat Float + | GVdouble Double + | GVstring (Maybe Text) + | GVobject GObject +-- | GVboxed (Ptr ()) -- This is an enumeration of all GTypes that can be used in a TreeModel. -- data TMType = TMinvalid - | TMuint - | TMint --- | TMuchar --- | TMchar - | TMboolean - | TMenum - | TMflags --- | TMpointer - | TMfloat - | TMdouble - | TMstring - | TMobject --- | TMboxed + | TMuint + | TMint +-- | TMuchar +-- | TMchar + | TMboolean + | TMenum + | TMflags +-- | TMpointer + | TMfloat + | TMdouble + | TMstring + | TMobject +-- | TMboxed instance Enum TMType where fromEnum TMinvalid = #const G_TYPE_INVALID @@ -100,20 +96,20 @@ fromEnum TMobject = #const G_TYPE_OBJECT -- fromEnum TMboxed = #const G_TYPE_BOXED toEnum #{const G_TYPE_INVALID} = TMinvalid - toEnum #{const G_TYPE_UINT} = TMuint - toEnum #{const G_TYPE_INT} = TMint --- toEnum #{const G_TYPE_UCHAR} = TMuchar --- toEnum #{const G_TYPE_CHAR} = TMchar - toEnum #{const G_TYPE_BOOLEAN} = TMboolean - toEnum #{const G_TYPE_ENUM} = TMenum - toEnum #{const G_TYPE_FLAGS} = TMflags --- toEnum #{const G_TYPE_POINTER} = TMpointer - toEnum #{const G_TYPE_FLOAT} = TMfloat - toEnum #{const G_TYPE_DOUBLE} = TMdouble - toEnum #{const G_TYPE_STRING} = TMstring - toEnum #{const G_TYPE_OBJECT} = TMobject --- toEnum #{const G_TYPE_BOXED} = TMboxed - toEnum _ = + toEnum #{const G_TYPE_UINT} = TMuint + toEnum #{const G_TYPE_INT} = TMint +-- toEnum #{const G_TYPE_UCHAR} = TMuchar +-- toEnum #{const G_TYPE_CHAR} = TMchar + toEnum #{const G_TYPE_BOOLEAN} = TMboolean + toEnum #{const G_TYPE_ENUM} = TMenum + toEnum #{const G_TYPE_FLAGS} = TMflags +-- toEnum #{const G_TYPE_POINTER} = TMpointer + toEnum #{const G_TYPE_FLOAT} = TMfloat + toEnum #{const G_TYPE_DOUBLE} = TMdouble + toEnum #{const G_TYPE_STRING} = TMstring + toEnum #{const G_TYPE_OBJECT} = TMobject +-- toEnum #{const G_TYPE_BOXED} = TMboxed + toEnum _ = error "StoreValue.toEnum(TMType): no dynamic types allowed." valueSetGenericValue :: GValue -> GenericValue -> IO () @@ -144,18 +140,18 @@ valueGetGenericValue gvalue = do gtype <- valueGetType gvalue case (toEnum . fromIntegral) gtype of - TMinvalid -> throw $ AssertionFailed + TMinvalid -> throw $ AssertionFailed "StoreValue.valueGetGenericValue: invalid or unavailable value." - TMuint -> liftM GVuint $ valueGetUInt gvalue - TMint -> liftM GVint $ valueGetInt gvalue --- TMuchar -> liftM GVuchar $ valueGetUChar gvalue --- TMchar -> liftM GVchar $ valueGetChar gvalue - TMboolean -> liftM GVboolean $ valueGetBool gvalue - TMenum -> liftM (GVenum . fromIntegral) $ valueGetUInt gvalue - TMflags -> liftM (GVflags . fromIntegral) $ valueGetUInt gvalue --- TMpointer -> liftM GVpointer $ valueGetPointer gvalue - TMfloat -> liftM GVfloat $ valueGetFloat gvalue - TMdouble -> liftM GVdouble $ valueGetDouble gvalue - TMstring -> liftM GVstring $ valueGetMaybeString gvalue - TMobject -> liftM GVobject $ valueGetGObject gvalue --- TMboxed -> liftM GVpointer $ valueGetPointer gvalue + TMuint -> liftM GVuint $ valueGetUInt gvalue + TMint -> liftM GVint $ valueGetInt gvalue +-- TMuchar -> liftM GVuchar $ valueGetUChar gvalue +-- TMchar -> liftM GVchar $ valueGetChar gvalue + TMboolean -> liftM GVboolean $ valueGetBool gvalue + TMenum -> liftM (GVenum . fromIntegral) $ valueGetUInt gvalue + TMflags -> liftM (GVflags . fromIntegral) $ valueGetUInt gvalue +-- TMpointer -> liftM GVpointer $ valueGetPointer gvalue + TMfloat -> liftM GVfloat $ valueGetFloat gvalue + TMdouble -> liftM GVdouble $ valueGetDouble gvalue + TMstring -> liftM GVstring $ valueGetMaybeString gvalue + TMobject -> liftM GVobject $ valueGetGObject gvalue +-- TMboxed -> liftM GVpointer $ valueGetPointer gvalue diff --git a/System/Glib/Types.chs b/System/Glib/Types.chs --- a/System/Glib/Types.chs +++ b/System/Glib/Types.chs @@ -52,8 +52,6 @@ toGObject :: o -> GObject -- | Unchecked downcast. unsafeCastGObject :: GObject -> o - {-# INLINE toGObject #-} - {-# INLINE unsafeCastGObject #-} instance GObjectClass GObject where toGObject = id diff --git a/System/Glib/UTFString.hs b/System/Glib/UTFString.hs --- a/System/Glib/UTFString.hs +++ b/System/Glib/UTFString.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} -- GIMP Toolkit (GTK) UTF aware string marshalling -- -- Author : Axel Simon @@ -25,13 +28,7 @@ -- module System.Glib.UTFString ( - withUTFString, - withUTFStringLen, - newUTFString, - newUTFStringLen, - peekUTFString, - peekUTFStringLen, - maybePeekUTFString, + GlibString(..), readUTFString, readCString, withUTFStrings, @@ -41,177 +38,257 @@ peekUTFStringArray0, readUTFStringArray0, UTFCorrection, - genUTFOfs, ofsToUTF, - ofsFromUTF + ofsFromUTF, + + glibToString, + stringToGlib, + + DefaultGlibString, + + GlibFilePath(..), + withUTFFilePaths, + withUTFFilePathArray, + withUTFFilePathArray0, + peekUTFFilePathArray0, + readUTFFilePathArray0 ) where -import Control.Monad (liftM) +import Codec.Binary.UTF8.String +import Control.Applicative ((<$>)) +import Control.Monad (liftM) import Data.Char (ord, chr) import Data.Maybe (maybe) - +import Data.String (IsString) +import Data.Monoid (Monoid) import System.Glib.FFI +import qualified Data.Text as T (replace, length, pack, unpack, Text) +import qualified Data.Text.Foreign as T + (withCStringLen, peekCStringLen) +import Data.ByteString (useAsCString) +import Data.Text.Encoding (encodeUtf8) --- Define withUTFString to emit UTF-8. --- -withUTFString :: String -> (CString -> IO a) -> IO a -withUTFString hsStr = withCString (toUTF hsStr) +class (IsString s, Monoid s, Show s) => GlibString s where + -- | Like 'withCString' but using the UTF-8 encoding. + -- + withUTFString :: s -> (CString -> IO a) -> IO a --- Define withUTFStringLen to emit UTF-8. --- -withUTFStringLen :: String -> (CStringLen -> IO a) -> IO a -withUTFStringLen hsStr = withCStringLen (toUTF hsStr) + -- | Like 'withCStringLen' but using the UTF-8 encoding. + -- + withUTFStringLen :: s -> (CStringLen -> IO a) -> IO a --- Define newUTFString to emit UTF-8. --- -newUTFString :: String -> IO CString -newUTFString = newCString . toUTF + -- | Like 'peekCString' but using the UTF-8 encoding. + -- + peekUTFString :: CString -> IO s --- Define newUTFStringLen to emit UTF-8. --- -newUTFStringLen :: String -> IO CStringLen -newUTFStringLen = newCStringLen . toUTF + -- | Like 'maybePeek' 'peekCString' but using the UTF-8 encoding to retrieve + -- UTF-8 from a 'CString' which may be the 'nullPtr'. + -- + maybePeekUTFString :: CString -> IO (Maybe s) --- Define peekUTFString to retrieve UTF-8. --- -peekUTFString :: CString -> IO String -peekUTFString strPtr = liftM fromUTF $ peekCString strPtr + -- | Like 'peekCStringLen' but using the UTF-8 encoding. + -- + peekUTFStringLen :: CStringLen -> IO s --- Define maybePeekUTFString to retrieve UTF-8 from a ptr which is maybe null. --- -maybePeekUTFString :: CString -> IO (Maybe String) -maybePeekUTFString strPtr = liftM (maybe Nothing (Just . fromUTF)) $ maybePeek peekCString strPtr + -- | Like 'newCString' but using the UTF-8 encoding. + -- + newUTFString :: s -> IO CString --- Define peekUTFStringLen to retrieve UTF-8. --- -peekUTFStringLen :: CStringLen -> IO String -peekUTFStringLen strPtr = liftM fromUTF $ peekCStringLen strPtr + -- | Like Define newUTFStringLen to emit UTF-8. + -- + newUTFStringLen :: s -> IO CStringLen --- like peekUTFString but then frees the string using g_free + -- | Create a list of offset corrections. + -- + genUTFOfs :: s -> UTFCorrection + + -- | Length of the string in characters + -- + stringLength :: s -> Int + + -- Escape percent signs (used in MessageDialog) + unPrintf :: s -> s + +-- GTK+ has a lot of asserts that the ptr is not NULL even if the length is 0 +-- Until they fix this we need to fudge pointer values to keep the noise level +-- in the logs. +noNullPtrs :: CStringLen -> CStringLen +noNullPtrs (p, 0) | p == nullPtr = (plusPtr p 1, 0) +noNullPtrs s = s + +instance GlibString [Char] where + withUTFString = withCAString . encodeString + withUTFStringLen s f = withCAStringLen (encodeString s) (f . noNullPtrs) + peekUTFString = liftM decodeString . peekCAString + maybePeekUTFString = liftM (maybe Nothing (Just . decodeString)) . maybePeek peekCAString + peekUTFStringLen = liftM decodeString . peekCAStringLen + newUTFString = newCAString . encodeString + newUTFStringLen = newCAStringLen . encodeString + genUTFOfs str = UTFCorrection (gUO 0 str) + where + gUO n [] = [] + gUO n (x:xs) | ord x<=0x007F = gUO (n+1) xs + | ord x<=0x07FF = n:gUO (n+1) xs + | ord x<=0xFFFF = n:n:gUO (n+1) xs + | otherwise = n:n:n:gUO (n+1) xs + stringLength = length + unPrintf s = s >>= replace + where + replace '%' = "%%" + replace c = return c + +foreign import ccall unsafe "string.h strlen" c_strlen + :: CString -> IO CSize + +instance GlibString T.Text where + withUTFString = useAsCString . encodeUtf8 + withUTFStringLen s f = T.withCStringLen s (f . noNullPtrs) + peekUTFString s = do + len <- c_strlen s + T.peekCStringLen (s, fromIntegral len) + maybePeekUTFString = maybePeek peekUTFString + peekUTFStringLen = T.peekCStringLen + newUTFString = newUTFString . T.unpack -- TODO optimize + newUTFStringLen = newUTFStringLen . T.unpack -- TODO optimize + genUTFOfs = genUTFOfs . T.unpack -- TODO optimize + stringLength = T.length + unPrintf = T.replace "%" "%%" + +glibToString :: T.Text -> String +glibToString = T.unpack + +stringToGlib :: String -> T.Text +stringToGlib = T.pack + +-- | Like like 'peekUTFString' but then frees the string using g_free -- -readUTFString :: CString -> IO String +readUTFString :: GlibString s => CString -> IO s readUTFString strPtr = do str <- peekUTFString strPtr g_free strPtr return str --- like peekCString but then frees the string using g_free +-- | Like 'peekCString' but then frees the string using @g_free@. -- readCString :: CString -> IO String readCString strPtr = do - str <- peekCString strPtr + str <- peekCAString strPtr g_free strPtr return str foreign import ccall unsafe "g_free" g_free :: Ptr a -> IO () --- Temporarily allocate a list of UTF-8 Strings. +-- | Temporarily allocate a list of UTF-8 'CString's. -- -withUTFStrings :: [String] -> ([CString] -> IO a) -> IO a +withUTFStrings :: GlibString s => [s] -> ([CString] -> IO a) -> IO a withUTFStrings hsStrs = withUTFStrings' hsStrs [] - where withUTFStrings' :: [String] -> [CString] -> ([CString] -> IO a) -> IO a + where withUTFStrings' :: GlibString s => [s] -> [CString] -> ([CString] -> IO a) -> IO a withUTFStrings' [] cs body = body (reverse cs) withUTFStrings' (s:ss) cs body = withUTFString s $ \c -> withUTFStrings' ss (c:cs) body --- Temporarily allocate an array of UTF-8 Strings. +-- | Temporarily allocate an array of UTF-8 encoded 'CString's. -- -withUTFStringArray :: [String] -> (Ptr CString -> IO a) -> IO a +withUTFStringArray :: GlibString s => [s] -> (Ptr CString -> IO a) -> IO a withUTFStringArray hsStr body = withUTFStrings hsStr $ \cStrs -> do withArray cStrs body --- Temporarily allocate a null-terminated array of UTF-8 Strings. +-- | Temporarily allocate a null-terminated array of UTF-8 encoded 'CString's. -- -withUTFStringArray0 :: [String] -> (Ptr CString -> IO a) -> IO a +withUTFStringArray0 :: GlibString s => [s] -> (Ptr CString -> IO a) -> IO a withUTFStringArray0 hsStr body = withUTFStrings hsStr $ \cStrs -> do withArray0 nullPtr cStrs body --- Convert an array of UTF-8 strings of the given length to a list of Haskell --- strings. +-- | Convert an array (of the given length) of UTF-8 encoded 'CString's to a +-- list of Haskell 'String's. -- -peekUTFStringArray :: Int -> Ptr CString -> IO [String] +peekUTFStringArray :: GlibString s => Int -> Ptr CString -> IO [s] peekUTFStringArray len cStrArr = do cStrs <- peekArray len cStrArr mapM peekUTFString cStrs --- Convert a null-terminated array of UTF-8 strings to a list of Haskell --- strings. +-- | Convert a null-terminated array of UTF-8 encoded 'CString's to a list of +-- Haskell 'String's. -- -peekUTFStringArray0 :: Ptr CString -> IO [String] +peekUTFStringArray0 :: GlibString s => Ptr CString -> IO [s] peekUTFStringArray0 cStrArr = do cStrs <- peekArray0 nullPtr cStrArr mapM peekUTFString cStrs --- Like peekUTFStringArray0 but then free the string array using g_strfreev -readUTFStringArray0 :: Ptr CString -> IO [String] -readUTFStringArray0 cStrArr = do +-- | Like 'peekUTFStringArray0' but then free the string array including all +-- strings. +-- +-- To be used when functions indicate that their return value should be freed +-- with @g_strfreev@. +-- +readUTFStringArray0 :: GlibString s => Ptr CString -> IO [s] +readUTFStringArray0 cStrArr | cStrArr == nullPtr = return [] + | otherwise = do cStrs <- peekArray0 nullPtr cStrArr + strings <- mapM peekUTFString cStrs g_strfreev cStrArr - mapM peekUTFString cStrs + return strings foreign import ccall unsafe "g_strfreev" g_strfreev :: Ptr a -> IO () --- Convert Unicode characters to UTF-8. --- -toUTF :: String -> String -toUTF [] = [] -toUTF (x:xs) | ord x<=0x007F = x:toUTF xs - | ord x<=0x07FF = chr (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)): - chr (0x80 .|. (ord x .&. 0x3F)): - toUTF xs - | otherwise = chr (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)): - chr (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)): - chr (0x80 .|. (ord x .&. 0x3F)): - toUTF xs - --- Convert UTF-8 to Unicode. --- -fromUTF :: String -> String -fromUTF [] = [] -fromUTF (all@(x:xs)) | ord x<=0x7F = x:fromUTF xs - | ord x<=0xBF = err - | ord x<=0xDF = twoBytes all - | ord x<=0xEF = threeBytes all - | otherwise = err - where - twoBytes (x1:x2:xs) = chr (((ord x1 .&. 0x1F) `shift` 6) .|. - (ord x2 .&. 0x3F)):fromUTF xs - twoBytes _ = error "fromUTF: illegal two byte sequence" - - threeBytes (x1:x2:x3:xs) = chr (((ord x1 .&. 0x0F) `shift` 12) .|. - ((ord x2 .&. 0x3F) `shift` 6) .|. - (ord x3 .&. 0x3F)):fromUTF xs - threeBytes _ = error "fromUTF: illegal three byte sequence" - - err = error "fromUTF: illegal UTF-8 character" - --- Offset correction for String to UTF8 mapping. +-- | Offset correction for String to UTF8 mapping. -- newtype UTFCorrection = UTFCorrection [Int] deriving Show --- Create a list of offset corrections. -genUTFOfs :: String -> UTFCorrection -genUTFOfs str = UTFCorrection (gUO 0 str) - where - gUO n [] = [] - gUO n (x:xs) | ord x<=0x007F = gUO (n+1) xs - | ord x<=0x07FF = n:gUO (n+1) xs - | otherwise = n:n:gUO (n+1) xs - ofsToUTF :: Int -> UTFCorrection -> Int ofsToUTF n (UTFCorrection oc) = oTU oc where oTU [] = n oTU (x:xs) | n<=x = n - | otherwise = 1+oTU xs + | otherwise = 1+oTU xs ofsFromUTF :: Int -> UTFCorrection -> Int ofsFromUTF n (UTFCorrection oc) = oFU n oc where oFU n [] = n oFU n (x:xs) | n<=x = n - | otherwise = oFU (n-1) xs + | otherwise = oFU (n-1) xs + +type DefaultGlibString = T.Text + +class fp ~ FilePath => GlibFilePath fp where + withUTFFilePath :: fp -> (CString -> IO a) -> IO a + peekUTFFilePath :: CString -> IO fp + +instance GlibFilePath FilePath where + withUTFFilePath = withUTFString . T.pack + peekUTFFilePath f = T.unpack <$> peekUTFString f + +withUTFFilePaths :: GlibFilePath fp => [fp] -> ([CString] -> IO a) -> IO a +withUTFFilePaths hsStrs = withUTFFilePath' hsStrs [] + where withUTFFilePath' :: GlibFilePath fp => [fp] -> [CString] -> ([CString] -> IO a) -> IO a + withUTFFilePath' [] cs body = body (reverse cs) + withUTFFilePath' (fp:fps) cs body = withUTFFilePath fp $ \c -> + withUTFFilePath' fps (c:cs) body + +withUTFFilePathArray :: GlibFilePath fp => [fp] -> (Ptr CString -> IO a) -> IO a +withUTFFilePathArray hsFP body = + withUTFFilePaths hsFP $ \cStrs -> do + withArray cStrs body + +withUTFFilePathArray0 :: GlibFilePath fp => [fp] -> (Ptr CString -> IO a) -> IO a +withUTFFilePathArray0 hsFP body = + withUTFFilePaths hsFP $ \cStrs -> do + withArray0 nullPtr cStrs body + +peekUTFFilePathArray0 :: GlibFilePath fp => Ptr CString -> IO [fp] +peekUTFFilePathArray0 cStrArr = do + cStrs <- peekArray0 nullPtr cStrArr + mapM peekUTFFilePath cStrs + +readUTFFilePathArray0 :: GlibFilePath fp => Ptr CString -> IO [fp] +readUTFFilePathArray0 cStrArr | cStrArr == nullPtr = return [] + | otherwise = do + cStrs <- peekArray0 nullPtr cStrArr + fps <- mapM peekUTFFilePath cStrs + g_strfreev cStrArr + return fps diff --git a/System/Glib/Utils.chs b/System/Glib/Utils.chs --- a/System/Glib/Utils.chs +++ b/System/Glib/Utils.chs @@ -11,7 +11,7 @@ -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. --- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU @@ -44,7 +44,7 @@ -- returns the result of 'getProgramName' (which may be 'Nothing' if -- 'setProgramName' has also not been performed). -- -getApplicationName :: IO (Maybe String) +getApplicationName :: GlibString string => IO (Maybe string) getApplicationName = {#call unsafe get_application_name #} >>= maybePeek peekUTFString -- | @@ -60,7 +60,7 @@ -- The application name will be used in contexts such as error messages, or -- when displaying an application's name in the task list. -- -setApplicationName :: String -> IO () +setApplicationName :: GlibString string => string -> IO () setApplicationName = flip withUTFString {#call unsafe set_application_name #} -- | @@ -68,7 +68,7 @@ -- with 'getApplicationName'. If you are using GDK or GTK+, the program name -- is set in 'initGUI' to the last component of argv[0]. -- -getProgramName :: IO (Maybe String) +getProgramName :: GlibString string => IO (Maybe string) getProgramName = {#call unsafe get_prgname #} >>= maybePeek peekUTFString -- | @@ -76,5 +76,5 @@ -- with 'setApplicationName'. Note that for thread-safety reasons this -- computation can only be performed once. -- -setProgramName :: String -> IO () +setProgramName :: GlibString string => string -> IO () setProgramName = flip withUTFString {#call unsafe set_prgname #} diff --git a/System/Glib/hsgclosure.c b/System/Glib/hsgclosure.c --- a/System/Glib/hsgclosure.c +++ b/System/Glib/hsgclosure.c @@ -85,7 +85,7 @@ #endif guint i; - WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: about to run callback=%p, n_param_values=%d", hc->callback, n_param_values)); + WHEN_DEBUG(g_debug("gtk2hs_closure_marshal(%p): about to run callback, n_param_values=%d", hc->callback, n_param_values)); #ifdef GHC_RTS_USES_CAPABILITY cap = rts_lock(); #else @@ -96,29 +96,38 @@ /* construct the function call */ for (i = 0; i < n_param_values; i++) { - WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: param_values[%d]=%s :: %s", + WHEN_DEBUG(g_debug("gtk2hs_closure_marshal(%p): param_values[%d]=%s :: %s", + hc->callback, i, g_strdup_value_contents(¶m_values[i]), g_type_name(G_VALUE_TYPE(¶m_values[i])))); call = rts_apply(CAP call, gtk2hs_value_as_haskellobj(CAP ¶m_values[i])); } - WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: about to rts_evalIO")); + WHEN_DEBUG(g_debug("gtk2hs_closure_marshal(%p): about to rts_evalIO", hc->callback)); /* perform the call */ + #if __GLASGOW_HASKELL__>=704 + rts_evalIO(&cap, rts_apply(CAP (HaskellObj)runIO_closure, call),&ret); + #else cap=rts_evalIO(CAP rts_apply(CAP (HaskellObj)runIO_closure, call),&ret); - - WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: about to rts_checkSchedStatus")); + #endif + + WHEN_DEBUG(g_debug("gtk2hs_closure_marshal(%p): about to rts_checkSchedStatus", hc->callback)); /* barf if anything went wrong */ /* TODO: pass a sensible value for call site so we get better error messages */ - /* or perhaps we can propogate any error? */ + /* or perhaps we can propagate any error? */ rts_checkSchedStatus("gtk2hs_closure_marshal", cap); + WHEN_DEBUG(g_debug("gtk2hs_closure_marshal(%p): ret=%p", hc->callback, ret)); if (return_value) { - WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: return_value :: %s", + WHEN_DEBUG(g_debug("gtk2hs_closure_marshal(%p): return_value :: %s, ret=%p, UNTAG_CLOSURE(ret)=%p", + hc->callback, /* g_strdup_value_contents(return_value), */ - g_type_name(G_VALUE_TYPE(return_value)))); + g_type_name(G_VALUE_TYPE(return_value)), + ret, + UNTAG_CLOSURE(ret))); gtk2hs_value_from_haskellobj(return_value, ret); } @@ -127,7 +136,7 @@ #else rts_unlock(); #endif - WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: done running callback")); + WHEN_DEBUG(g_debug("gtk2hs_closure_marshal(%p): done running callback", hc->callback)); } GClosure * @@ -163,7 +172,11 @@ else break; case G_TYPE_CHAR: +#if GLIB_CHECK_VERSION(2,31,0) + return rts_mkChar(CAP g_value_get_schar(value)); +#else return rts_mkChar(CAP g_value_get_char(value)); +#endif case G_TYPE_UCHAR: return rts_mkChar(CAP g_value_get_uchar(value)); case G_TYPE_BOOLEAN: @@ -194,8 +207,8 @@ return rts_mkPtr(CAP g_value_get_pointer(value)); case G_TYPE_BOXED: return rts_mkPtr(CAP g_value_get_boxed(value)); -/* case G_TYPE_PARAM: - return g_value_get_param(value); */ + case G_TYPE_PARAM: + return rts_mkPtr(CAP g_value_get_param(value)); case G_TYPE_OBJECT: return rts_mkPtr(CAP g_value_get_object(value)); } @@ -220,10 +233,18 @@ } return; case G_TYPE_CHAR: +#if GLIB_CHECK_VERSION(2,31,0) + g_value_set_schar(value, rts_getChar(obj)); +#else g_value_set_char(value, rts_getChar(obj)); +#endif return; case G_TYPE_UCHAR: +#if GLIB_CHECK_VERSION(2,31,0) + g_value_set_schar(value, rts_getChar(obj)); +#else g_value_set_char(value, rts_getChar(obj)); +#endif return; case G_TYPE_BOOLEAN: g_value_set_boolean(value, rts_getBool(obj)); diff --git a/glib.cabal b/glib.cabal --- a/glib.cabal +++ b/glib.cabal @@ -1,47 +1,55 @@ +cabal-version: 2.2 Name: glib -Version: 0.11.2 -License: LGPL-2.1 +Version: 0.13.12.0 +License: LGPL-2.1-only License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team Author: Axel Simon, Duncan Coutts -Maintainer: gtk2hs-users@sourceforge.net +Maintainer: gtk2hs-users@lists.sourceforge.net Build-Type: Custom -Cabal-Version: >= 1.6.0 Stability: stable -homepage: http://www.haskell.org/gtk2hs/ -bug-reports: http://hackage.haskell.org/trac/gtk2hs/ +homepage: http://projects.haskell.org/gtk2hs/ +bug-reports: https://github.com/gtk2hs/gtk2hs/issues Synopsis: Binding to the GLIB library for Gtk2Hs. -Description: The GNU Library is a collection of C data structures and utility - function for dealing with Unicode. This package only binds as - much functionality as required to support the packages that +Description: GLib is a collection of C data structures and utility functions + for the GObject system, main loop implementation, for strings and + common data structures dealing with Unicode. This package only binds + as much functionality as required to support the packages that wrap libraries that are themselves based on GLib. Category: System -Tested-With: GHC == 6.10.4 +Tested-With: GHC == 9.12.2, GHC == 9.10.1, GHC == 9.8.4, GHC == 9.6.6, GHC == 9.4.8, GHC == 9.2.8, GHC==9.0.2, GHC==8.10.7 Extra-Source-Files: - Gtk2HsSetup.hs System/Glib/hsgclosure.c System/Glib/hsgclosure.h Source-Repository head - type: darcs - location: http://code.haskell.org/gtk2hs/ + type: git + location: https://github.com/gtk2hs/gtk2hs subdir: glib Flag closure_signals Description: Connect to signals using the Duncan way. +custom-setup + setup-depends: base >= 4.6 && < 5, + Cabal >= 3.0 && < 3.15, + gtk2hs-buildtools >= 0.13.2.0 && < 0.14 Library build-depends: base >= 4 && < 5, - containers, haskell98 - build-tools: gtk2hsC2hs - cpp-options: -DHAVE_NEW_CONTROL_EXCEPTION + utf8-string >= 0.2 && < 1.1, + bytestring >= 0.9.1.10 && < 0.13, + text >= 1.0.0.0 && < 2.2, + containers < 0.8 + cpp-options: -U__BLOCKS__ -DGLIB_DISABLE_DEPRECATION_WARNINGS + if os(darwin) || os(freebsd) + cpp-options: -D_Nullable= -D_Nonnull= -D_Noreturn= -D__attribute__(x)= if flag(closure_signals) cpp-options: -DUSE_GCLOSURE_SIGNALS_IMPL c-sources: System/Glib/hsgclosure.c include-dirs: System/Glib - exposed-modules: + exposed-modules: System.Glib System.Glib.GError System.Glib.Properties @@ -57,11 +65,13 @@ System.Glib.UTFString System.Glib.Types System.Glib.GList + System.Glib.GString System.Glib.GType System.Glib.GTypeConstants System.Glib.GValue System.Glib.GValueTypes System.Glib.GParameter - extensions: ForeignFunctionInterface + default-language: Haskell98 + default-extensions: ForeignFunctionInterface x-c2hs-Header: glib-object.h pkgconfig-depends: glib-2.0, gobject-2.0