diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs --- a/Gtk2HsSetup.hs +++ b/Gtk2HsSetup.hs @@ -1,37 +1,7 @@ {-# 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__ >= 700) -#define CABAL_VERSION CABAL_VERSION_ENCODE(1,10,0) -#else -#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 +#ifndef CABAL_VERSION_CHECK +#error This module has to be compiled via the Setup.hs program which generates the gtk2hs-macros.h file #endif -- | Build a Gtk2hs package. @@ -49,13 +19,7 @@ libraryDirs, extraLibraries, extraGHCiLibraries ) -import Distribution.Simple.PackageIndex ( -#if CABAL_VERSION_CHECK(1,8,0) - lookupInstalledPackageId -#else - lookupPackageId -#endif - ) +import Distribution.Simple.PackageIndex ( lookupInstalledPackageId ) import Distribution.PackageDescription as PD ( PackageDescription(..), updatePackageDescription, BuildInfo(..), @@ -64,17 +28,13 @@ 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, programName, - c2hsProgram, pkgConfigProgram, requireProgram, ghcPkgProgram, + rawSystemProgramConf, rawSystemProgramStdoutConf, programName, programPath, + c2hsProgram, pkgConfigProgram, gccProgram, requireProgram, ghcPkgProgram, simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg) import Distribution.ModuleName ( ModuleName, components, toFilePath ) import Distribution.Simple.Utils @@ -84,11 +44,7 @@ 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.Exit (exitFailure) @@ -147,8 +103,6 @@ -- 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 @@ -195,19 +149,20 @@ _ | modeGenerateRegFile -> die "Generate Reg File not supported" | modeGenerateRegScript -> die "Generate Reg Script not supported" | otherwise -> registerPackage verbosity + installedPkgInfo pkg lbi inplace #if CABAL_VERSION_CHECK(1,10,0) - installedPkgInfo pkg lbi inplace [packageDb] + packageDbs #else - installedPkgInfo pkg lbi inplace packageDb + packageDb #endif 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) + packageDbs = nub $ withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + packageDb = registrationPackageDB packageDbs distPref = fromFlag (regDistPref regFlags) verbosity = fromFlag (regVerbosity regFlags) @@ -215,45 +170,7 @@ 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 ------------------------------------------------------------------------------ @@ -291,15 +208,12 @@ -- 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 + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $ map ("--include=" ++) (outDir:chiDirs) + ++ [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] ++ ["--output-dir=" ++ newOutDir, "--output=" ++ newOutFile, @@ -321,18 +235,10 @@ -- 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] . 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 () @@ -348,7 +254,15 @@ signalGenProgram = simpleProgram "gtk2hsHookGenerator" c2hsLocal :: Program -c2hsLocal = simpleProgram "gtk2hsC2hs" +c2hsLocal = (simpleProgram "gtk2hsC2hs") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "gtk2hsC2hs --version" gives a string like: + -- C->Haskell Compiler, version 0.13.4 (gtk2hs branch) "Bin IO", 13 Nov 2004 + case words str of + (_:_:_:ver:_) -> ver + _ -> "" + } + genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () genSynthezisedFiles verb pd lbi = do diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,9 +1,10 @@ --- 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. -import Gtk2HsSetup ( gtk2hsUserHooks, checkGtk2hsBuildtools ) -import Distribution.Simple ( defaultMainWithHooks ) +-- Standard setup file for a Gtk2Hs module. +-- +-- See also: +-- * SetupMain.hs : the real Setup script for this package +-- * Gtk2HsSetup.hs : Gtk2Hs-specific boilerplate +-- * SetupWrapper.hs : wrapper for compat with various ghc/cabal versions -main = do - checkGtk2hsBuildtools ["gtk2hsC2hs"] - defaultMainWithHooks gtk2hsUserHooks +import SetupWrapper ( setupWrapper ) + +main = setupWrapper "SetupMain.hs" diff --git a/SetupMain.hs b/SetupMain.hs new file mode 100644 --- /dev/null +++ b/SetupMain.hs @@ -0,0 +1,11 @@ +-- The real Setup file for a Gtk2Hs package (invoked via the SetupWrapper). +-- It contains only adjustments specific to this package, +-- all Gtk2Hs-specific boilerplate is kept in Gtk2HsSetup.hs +-- which should be kept identical across all packages. +-- +import Gtk2HsSetup ( gtk2hsUserHooks, checkGtk2hsBuildtools ) +import Distribution.Simple ( defaultMainWithHooks ) + +main = do + checkGtk2hsBuildtools ["gtk2hsC2hs"] + defaultMainWithHooks gtk2hsUserHooks diff --git a/SetupWrapper.hs b/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/SetupWrapper.hs @@ -0,0 +1,155 @@ +-- A wrapper script for Cabal Setup.hs scripts. Allows compiling the real Setup +-- conditionally depending on the Cabal version. + +module SetupWrapper (setupWrapper) where + +import Distribution.Package +import Distribution.Compiler +import Distribution.Simple.Utils +import Distribution.Simple.Program +import Distribution.Simple.Compiler +import Distribution.Simple.BuildPaths (exeExtension) +import Distribution.Simple.Configure (configCompiler) +import Distribution.Simple.GHC (getInstalledPackages) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Version +import Distribution.Verbosity +import Distribution.Text + +import System.Environment +import System.Process +import System.Exit +import System.FilePath +import System.Directory +import qualified Control.Exception as Exception +import System.IO.Error (isDoesNotExistError) + +import Data.List +import Data.Char +import Control.Monad + + +setupWrapper :: FilePath -> IO () +setupWrapper setupHsFile = do + args <- getArgs + createDirectoryIfMissingVerbose verbosity True setupDir + compileSetupExecutable + invokeSetupScript args + + where + setupDir = "dist/setup-wrapper" + setupVersionFile = setupDir "setup" <.> "version" + setupProgFile = setupDir "setup" <.> exeExtension + setupMacroFile = setupDir "wrapper-macros.h" + + useCabalVersion = Version [1,8] [] + usePackageDB = [GlobalPackageDB, UserPackageDB] + verbosity = normal + + cabalLibVersionToUse comp conf = do + savedVersion <- savedCabalVersion + case savedVersion of + Just version + -> return version + _ -> do version <- installedCabalVersion comp conf + writeFile setupVersionFile (show version ++ "\n") + return version + + savedCabalVersion = do + versionString <- readFile setupVersionFile + `Exception.catch` \e -> if isDoesNotExistError e + then return "" + else Exception.throwIO e + case reads versionString of + [(version,s)] | all isSpace s -> return (Just version) + _ -> return Nothing + + installedCabalVersion comp conf = do + index <- getInstalledPackages verbosity usePackageDB conf + + let cabalDep = Dependency (PackageName "Cabal") + (orLaterVersion useCabalVersion) + case PackageIndex.lookupDependency index cabalDep of + [] -> die $ "The package requires Cabal library version " + ++ display useCabalVersion + ++ " but no suitable version is installed." + pkgs -> return $ bestVersion (map fst pkgs) + where + bestVersion = maximumBy (comparing preference) + preference version = (sameVersion, sameMajorVersion + ,stableVersion, latestVersion) + where + sameVersion = version == cabalVersion + sameMajorVersion = majorVersion version == majorVersion cabalVersion + majorVersion = take 2 . versionBranch + stableVersion = case versionBranch version of + (_:x:_) -> even x + _ -> False + latestVersion = version + + -- | If the Setup.hs is out of date wrt the executable then recompile it. + -- Currently this is GHC only. It should really be generalised. + -- + compileSetupExecutable = do + setupHsNewer <- setupHsFile `moreRecentFile` setupProgFile + cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile + let outOfDate = setupHsNewer || cabalVersionNewer + when outOfDate $ do + debug verbosity "Setup script is out of date, compiling..." + + (comp, conf) <- configCompiler (Just GHC) Nothing Nothing + defaultProgramConfiguration verbosity + cabalLibVersion <- cabalLibVersionToUse comp conf + let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion + debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion + + writeFile setupMacroFile (generateVersionMacro cabalLibVersion) + + rawSystemProgramConf verbosity ghcProgram conf $ + ["--make", setupHsFile, "-o", setupProgFile] + ++ ghcPackageDbOptions usePackageDB + ++ ["-package", display cabalPkgid + ,"-cpp", "-optP-include", "-optP" ++ setupMacroFile + ,"-odir", setupDir, "-hidir", setupDir] + where + + ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error "internal error: unexpected package db stack" + + generateVersionMacro :: Version -> String + generateVersionMacro version = + concat + ["/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" + ,"#define CABAL_VERSION_CHECK(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + + invokeSetupScript :: [String] -> IO () + invokeSetupScript args = do + info verbosity $ unwords (setupProgFile : args) + process <- runProcess (currentDir setupProgFile) args + Nothing Nothing + Nothing Nothing Nothing + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode + +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) 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/GError.chs b/System/Glib/GError.chs --- a/System/Glib/GError.chs +++ b/System/Glib/GError.chs @@ -58,14 +58,15 @@ -- particular error domain use 'catchGErrorJustDomain' \/ -- 'handleGErrorJustDomain' -- - catchGError, catchGErrorJust, catchGErrorJustDomain, - handleGError, handleGErrorJust, handleGErrorJustDomain, + -- ** Deprecated + catchGError, + handleGError, failOnGError, throwGError, @@ -89,20 +90,20 @@ 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 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) = msg + +instance Exception GError + + type GQuark = {#type GQuark #} -- | A code used to identify the \'namespace\' of the error. Within each error @@ -184,7 +185,8 @@ -- | 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 @@ -200,7 +202,8 @@ 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 @@ -215,11 +218,11 @@ -> 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,7 +241,7 @@ -> (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 @@ -249,13 +252,14 @@ -- > ... -- 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. 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 verson of 'catchGErrorJustDomain' with the arguments swapped around. handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a handleGErrorJustDomain = flip catchGErrorJustDomain 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,64 @@ +-- -*-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, + fromGString, + ) where + +import Foreign +import Control.Exception (bracket) +import Control.Monad (foldM) + +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 + maybePeek peekCString gstr + +-- 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 + str <- maybePeek peekCString gstr + _ <- {#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 @@ -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/StoreValue.hsc b/System/Glib/StoreValue.hsc --- a/System/Glib/StoreValue.hsc +++ b/System/Glib/StoreValue.hsc @@ -34,12 +34,7 @@ import Control.Monad (liftM) -#if HAVE_NEW_CONTROL_EXCEPTION -import Control.OldException -#else -import Control.Exception - (throw, Exception(AssertionFailed)) -#endif +import Control.Exception (throw, AssertionFailed(..)) #include 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 @@ -52,42 +52,43 @@ import System.Glib.FFI --- Define withUTFString to emit UTF-8. +-- | Like 'withCString' but using the UTF-8 encoding. -- withUTFString :: String -> (CString -> IO a) -> IO a -withUTFString hsStr = withCString (toUTF hsStr) +withUTFString hsStr = withCAString (toUTF hsStr) --- Define withUTFStringLen to emit UTF-8. +-- | Like 'withCStringLen' but using the UTF-8 encoding. -- withUTFStringLen :: String -> (CStringLen -> IO a) -> IO a -withUTFStringLen hsStr = withCStringLen (toUTF hsStr) +withUTFStringLen hsStr = withCAStringLen (toUTF hsStr) --- Define newUTFString to emit UTF-8. +-- | Like 'newCString' but using the UTF-8 encoding. -- newUTFString :: String -> IO CString -newUTFString = newCString . toUTF +newUTFString = newCAString . toUTF --- Define newUTFStringLen to emit UTF-8. +-- | Like Define newUTFStringLen to emit UTF-8. -- newUTFStringLen :: String -> IO CStringLen -newUTFStringLen = newCStringLen . toUTF +newUTFStringLen = newCAStringLen . toUTF --- Define peekUTFString to retrieve UTF-8. +-- | Like 'peekCString' but using the UTF-8 encoding. -- peekUTFString :: CString -> IO String -peekUTFString strPtr = liftM fromUTF $ peekCString strPtr +peekUTFString strPtr = liftM fromUTF $ peekCAString strPtr --- Define maybePeekUTFString to retrieve UTF-8 from a ptr which is maybe null. +-- | 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 String) -maybePeekUTFString strPtr = liftM (maybe Nothing (Just . fromUTF)) $ maybePeek peekCString strPtr +maybePeekUTFString strPtr = liftM (maybe Nothing (Just . fromUTF)) $ maybePeek peekCAString strPtr --- Define peekUTFStringLen to retrieve UTF-8. +-- | Like 'peekCStringLen' but using the UTF-8 encoding. -- peekUTFStringLen :: CStringLen -> IO String -peekUTFStringLen strPtr = liftM fromUTF $ peekCStringLen strPtr +peekUTFStringLen strPtr = liftM fromUTF $ peekCAStringLen strPtr --- like peekUTFString but then frees the string using g_free +-- | Like like 'peekUTFString' but then frees the string using g_free -- readUTFString :: CString -> IO String readUTFString strPtr = do @@ -95,18 +96,18 @@ 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 hsStrs = withUTFStrings' hsStrs [] @@ -115,40 +116,41 @@ 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 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 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 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 cStrArr = do cStrs <- peekArray0 nullPtr cStrArr mapM peekUTFString cStrs --- Like 'peekUTFStringArray0' but then free the string array including all strings. +-- | 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\". +-- with @g_strfreev@. -- readUTFStringArray0 :: Ptr CString -> IO [String] readUTFStringArray0 cStrArr | cStrArr == nullPtr = return [] @@ -161,8 +163,10 @@ foreign import ccall unsafe "g_strfreev" g_strfreev :: Ptr a -> IO () --- Convert Unicode characters to UTF-8. +-- | Encode a Haskell Unicode String as UTF-8 -- +-- You should think of this as it it had type @String -> [Word8]@ +-- toUTF :: String -> String toUTF [] = [] toUTF (x:xs) | ord x<=0x007F = x:toUTF xs @@ -174,8 +178,10 @@ chr (0x80 .|. (ord x .&. 0x3F)): toUTF xs --- Convert UTF-8 to Unicode. +-- | Decode a UTF-8 string into a Haskell Unicode String. -- +-- You should think of this as it it had type @[Word8] -> String@ +-- fromUTF :: String -> String fromUTF [] = [] fromUTF (all@(x:xs)) | ord x<=0x7F = x:fromUTF xs @@ -195,11 +201,12 @@ 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. +-- | Create a list of offset corrections. +-- genUTFOfs :: String -> UTFCorrection genUTFOfs str = UTFCorrection (gUO 0 str) where 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,34 @@ /* 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 */ cap=rts_evalIO(CAP rts_apply(CAP (HaskellObj)runIO_closure, call),&ret); - WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: about to rts_checkSchedStatus")); + 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? */ 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 +132,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 * diff --git a/glib.cabal b/glib.cabal --- a/glib.cabal +++ b/glib.cabal @@ -1,14 +1,14 @@ Name: glib -Version: 0.12.0 +Version: 0.12.1 License: LGPL-2.1 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 +Cabal-Version: >= 1.8 Stability: stable -homepage: http://www.haskell.org/gtk2hs/ +homepage: http://projects.haskell.org/gtk2hs/ bug-reports: http://hackage.haskell.org/trac/gtk2hs/ Synopsis: Binding to the GLIB library for Gtk2Hs. Description: The GNU Library is a collection of C data structures and utility @@ -16,9 +16,9 @@ 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 == 6.10.4, GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1 Extra-Source-Files: - Gtk2HsSetup.hs + SetupWrapper.hs SetupMain.hs Gtk2HsSetup.hs System/Glib/hsgclosure.c System/Glib/hsgclosure.h @@ -33,9 +33,8 @@ Library build-depends: base >= 4 && < 5, - containers, haskell98 - build-tools: gtk2hsC2hs - cpp-options: -DHAVE_NEW_CONTROL_EXCEPTION + containers + build-tools: gtk2hsC2hs >= 0.13.5 if flag(closure_signals) cpp-options: -DUSE_GCLOSURE_SIGNALS_IMPL c-sources: System/Glib/hsgclosure.c @@ -57,6 +56,7 @@ System.Glib.UTFString System.Glib.Types System.Glib.GList + System.Glib.GString System.Glib.GType System.Glib.GTypeConstants System.Glib.GValue