diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs deleted file mode 100644 --- a/Gtk2HsSetup.hs +++ /dev/null @@ -1,501 +0,0 @@ -{-# LANGUAGE CPP, ViewPatterns #-} - -#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. --- -module Gtk2HsSetup ( - gtk2hsUserHooks, - getPkgConfigPackages, - checkGtk2hsBuildtools, - typeGenProgram, - signalGenProgram, - c2hsLocal - ) where - -import Distribution.Simple -import Distribution.Simple.PreProcess -import Distribution.InstalledPackageInfo ( importDirs, - showInstalledPackageInfo, - libraryDirs, - extraLibraries, - extraGHCiLibraries ) -import Distribution.Simple.PackageIndex ( lookupInstalledPackageId ) -import Distribution.PackageDescription as PD ( PackageDescription(..), - updatePackageDescription, - BuildInfo(..), - emptyBuildInfo, allBuildInfo, - Library(..), - libModules, hasLibs) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(withPackageDB, buildDir, localPkgDescr, installedPkgs, withPrograms), - InstallDirs(..), - componentPackageDeps, - absoluteInstallDirs) -import Distribution.Simple.Compiler ( Compiler(..) ) -import Distribution.Simple.Program ( - Program(..), ConfiguredProgram(..), - rawSystemProgramConf, rawSystemProgramStdoutConf, programName, programPath, - c2hsProgram, pkgConfigProgram, gccProgram, 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 ) -import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage ) -import Distribution.Text ( simpleParse, display ) -import System.FilePath -import System.Exit (exitFailure) -import System.Directory ( doesFileExist, getDirectoryContents, doesDirectoryExist ) -import Distribution.Version (Version(..)) -import Distribution.Verbosity -import Control.Monad (when, unless, filterM, liftM, forM, forM_) -import Data.Maybe ( isJust, isNothing, fromMaybe, maybeToList, catMaybes ) -import Data.List (isPrefixOf, isSuffixOf, nub, minimumBy, stripPrefix, tails ) -import Data.Ord as Ord (comparing) -import Data.Char (isAlpha, isNumber) -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Compiler (compilerVersion) - -import Control.Applicative ((<$>)) - -#if CABAL_VERSION_CHECK(1,17,0) -import Distribution.Simple.Program.Find ( defaultProgramSearchPath ) -onDefaultSearchPath f a b = f a b defaultProgramSearchPath -libraryConfig lbi = case [clbi | (LBI.CLibName, clbi, _) <- LBI.componentsConfigs lbi] of - [clbi] -> Just clbi - _ -> Nothing -#else -onDefaultSearchPath = id -libraryConfig = LBI.libraryConfig -#endif - --- the name of the c2hs pre-compiled header file -precompFile = "precompchs.bin" - -gtk2hsUserHooks = simpleUserHooks { - hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal], - hookedPreProcessors = [("chs", ourC2hs)], - confHook = \pd cf -> - (fmap adjustLocalBuildInfo (confHook simpleUserHooks pd cf)), - 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 (isLib lib) dlls of - dlls@(_:_) -> [dropExtension (pickDll dlls)] - _ -> if lib == "z" then [] else [lib] - where - -- If there are several .dll files matching the one we're after then we - -- just have to guess. For example for recent Windows cairo builds we get - -- libcairo-2.dll libcairo-gobject-2.dll libcairo-script-interpreter-2.dll - -- Our heuristic is to pick the one with the shortest name. - -- Yes this is a hack but the proper solution is hard: we would need to - -- parse the .a file and see which .dll file(s) it needed to link to. - pickDll = minimumBy (Ord.comparing length) - isLib lib dll = - case stripPrefix ("lib"++lib) dll of - Just ('.':_) -> True - Just ('-':n:_) | isNumber n -> True - _ -> False - --- 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. - -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 regFlags - = do - let clbi = LBI.getComponentLocalBuildInfo lbi LBI.CLibName - - 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 -> writeRegistrationFile installedPkgInfo - | modeGenerateRegScript -> die "Generate Reg Script not supported" - | otherwise -> registerPackage verbosity - installedPkgInfo pkg lbi inplace -#if CABAL_VERSION_CHECK(1,10,0) - packageDbs -#else - packageDb -#endif - - where - modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) - regFile = fromMaybe (display (packageId pkg) <.> "conf") - (fromFlag (regGenPkgConf regFlags)) - modeGenerateRegScript = fromFlag (regGenScript regFlags) - inplace = fromFlag (regInPlace regFlags) - packageDbs = nub $ withPackageDB lbi - ++ maybeToList (flagToMaybe (regPackageDB regFlags)) - packageDb = registrationPackageDB packageDbs - distPref = fromFlag (regDistPref regFlags) - verbosity = fromFlag (regVerbosity regFlags) - - writeRegistrationFile installedPkgInfo = do - notice verbosity ("Creating package registration file: " ++ regFile) - writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) - -register _ _ regFlags = notice verbosity "No package to register" - where - verbosity = fromFlag (regVerbosity regFlags) - - ------------------------------------------------------------------------------- --- 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 | - ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi), - dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ] - (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, - "--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"] - ++ ["-D__GLASGOW_HASKELL__="++show (ghcDefine . ghcVersion . compilerId $ LBI.compiler lbi)] - where - ghcDefine (v1:v2:_) = v1 * 100 + v2 - ghcDefine _ = __GLASGOW_HASKELL__ - - ghcVersion :: CompilerId -> [Int] --- This version is nicer, but we need to know the Cabal version that includes the new CompilerId --- #if CABAL_VERSION_CHECK(1,19,2) --- ghcVersion (CompilerId GHC v _) = versionBranch v --- ghcVersion (CompilerId _ _ (Just c)) = ghcVersion c --- #else --- ghcVersion (CompilerId GHC v) = versionBranch v --- #endif --- ghcVersion _ = [] --- This version should work fine for now - ghcVersion = concat . take 1 . map (read . (++"]") . takeWhile (/=']')) . catMaybes - . map (stripPrefix "CompilerId GHC (Version {versionBranch = ") . tails . show - -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] . toFilePath) - (PD.libModules lib) - - let files = [ f | Just f <- mFiles ] - installOrdinaryFiles verbosity libPref files - - -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") { - 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 - 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 maj ++ "." ++ show d2 - | (maj, d2) <- [(maj, d2) | maj <- [0..(major-1)], d2 <- [0,2..20]] - ++ [(major, d2) | d2 <- [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 - - forM_ (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 - - writeFile "gtk2hs_macros.h" $ generateMacros cPkgs - --- Based on Cabal/Distribution/Simple/Build/Macros.hs -generateMacros :: [PackageId] -> String -generateMacros cPkgs = concat $ - "/* DO NOT EDIT: This file is automatically generated by Gtk2HsSetup.hs */\n\n" : - [ concat - ["/* package ",display pkgid," */\n" - ,"#define VERSION_",pkgname," ",show (display version),"\n" - ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - | pkgid@(PackageIdentifier name version) <- cPkgs - , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - pkgname = map fixchar (display name) - ] - where fixchar '-' = '_' - fixchar '.' = '_' - fixchar c = c - ---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) - --- Check user whether install gtk2hs-buildtools correctly. -checkGtk2hsBuildtools :: [Program] -> IO () -checkGtk2hsBuildtools programs = do - programInfos <- mapM (\ prog -> do - location <- onDefaultSearchPath programFindLocation prog normal - return (programName prog, location) - ) programs - let printError name = do - putStrLn $ "Cannot find " ++ name ++ "\n" - ++ "Please install `gtk2hs-buildtools` first and check that the install directory is in your PATH (e.g. HOME/.cabal/bin)." - exitFailure - forM_ programInfos $ \ (name, location) -> - when (isNothing location) (printError name) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,10 +1,8 @@ --- Standard setup file for a Gtk2Hs module. +-- Adjustments specific to this package, +-- all Gtk2Hs-specific boilerplate is kept in +-- gtk2hs-buildtools:Gtk2HsSetup -- --- 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 - -import SetupWrapper ( setupWrapper ) +import Gtk2HsSetup ( gtk2hsUserHooks ) +import Distribution.Simple ( defaultMainWithHooks ) -main = setupWrapper "SetupMain.hs" +main = defaultMainWithHooks gtk2hsUserHooks diff --git a/SetupMain.hs b/SetupMain.hs deleted file mode 100644 --- a/SetupMain.hs +++ /dev/null @@ -1,12 +0,0 @@ --- 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, - typeGenProgram, signalGenProgram, c2hsLocal) -import Distribution.Simple ( defaultMainWithHooks ) - -main = do - checkGtk2hsBuildtools [c2hsLocal] - defaultMainWithHooks gtk2hsUserHooks diff --git a/SetupWrapper.hs b/SetupWrapper.hs deleted file mode 100644 --- a/SetupWrapper.hs +++ /dev/null @@ -1,164 +0,0 @@ --- 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 (configCompilerEx) -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 - - --- moreRecentFile is implemented in Distribution.Simple.Utils, but only in --- Cabal >= 1.18. For backwards-compatibility, we implement a copy with a new --- name here. Some desirable alternate strategies don't work: --- * We can't use CPP to check which version of Cabal we're up against because --- this is the file that's generating the macros for doing that. --- * We can't use the name moreRecentFiles and use --- import D.S.U hiding (moreRecentFiles) --- because on old GHC's (and according to the Report) hiding a name that --- doesn't exist is an error. -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) - -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) <- configCompilerEx (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 diff --git a/System/Glib/GError.chs b/System/Glib/GError.chs --- a/System/Glib/GError.chs +++ b/System/Glib/GError.chs @@ -149,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 @@ -192,7 +192,7 @@ -- | 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: -- @@ -214,7 +214,7 @@ -- > 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 @@ -248,7 +248,7 @@ | 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) -> ...) $ -- > ... @@ -257,11 +257,11 @@ 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 'catchGErrorJustDomain' 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 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 @@ -111,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 @@ -139,7 +139,7 @@ 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 @@ -188,7 +188,7 @@ let propName = "Gtk2HsAttr"++show cnt 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 @@ -201,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 @@ -219,7 +219,7 @@ -- isA :: GObjectClass o => o -> GType -> Bool isA obj gType = - typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr.unGObject.toGObject) 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 diff --git a/System/Glib/GString.chs b/System/Glib/GString.chs --- a/System/Glib/GString.chs +++ b/System/Glib/GString.chs @@ -49,7 +49,7 @@ readGString :: GString -> IO (Maybe String) readGString gstring | gstring == nullPtr = return Nothing - | otherwise = do + | otherwise = do gstr <- {#get GString->str#} gstring len <- {#get GString->len#} gstring fmap Just $ peekCStringLen (gstr, fromIntegral len) @@ -69,7 +69,7 @@ fromGString :: GString -> IO (Maybe String) fromGString gstring | gstring == nullPtr = return Nothing - | otherwise = do + | otherwise = do gstr <- {#get GString->str#} gstring len <- {#get GString->len#} gstring str <- fmap Just $ peekCStringLen (gstr, fromIntegral len) 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 @@ -64,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" #} diff --git a/System/Glib/MainLoop.chs b/System/Glib/MainLoop.chs --- a/System/Glib/MainLoop.chs +++ b/System/Glib/MainLoop.chs @@ -61,11 +61,11 @@ #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"#} @@ -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 @@ -65,16 +65,21 @@ newAttrFromIntProperty, readAttrFromIntProperty, newAttrFromUIntProperty, - newAttrFromCharProperty, + readAttrFromUIntProperty, writeAttrFromUIntProperty, + newAttrFromCharProperty, + readAttrFromCharProperty, newAttrFromBoolProperty, readAttrFromBoolProperty, newAttrFromFloatProperty, + readAttrFromFloatProperty, newAttrFromDoubleProperty, + readAttrFromDoubleProperty, newAttrFromEnumProperty, readAttrFromEnumProperty, writeAttrFromEnumProperty, newAttrFromFlagsProperty, + readAttrFromFlagsProperty, newAttrFromStringProperty, readAttrFromStringProperty, writeAttrFromStringProperty, @@ -91,12 +96,13 @@ 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, @@ -107,14 +113,14 @@ import System.Glib.FFI import System.Glib.UTFString -import System.Glib.Flags (Flags) +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" #} @@ -265,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) @@ -285,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) @@ -305,6 +327,10 @@ newAttrFromFlagsProperty propName gtype = newNamedAttr propName (objectGetPropertyFlags gtype propName) (objectSetPropertyFlags gtype propName) +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) @@ -368,6 +394,10 @@ newAttrFromBoxedStorableProperty :: (GObjectClass gobj, Storable boxed) => String -> GType -> Attr gobj boxed 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 = diff --git a/System/Glib/Signals.chs b/System/Glib/Signals.chs --- a/System/Glib/Signals.chs +++ b/System/Glib/Signals.chs @@ -27,7 +27,7 @@ -- 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,6 +138,38 @@ 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. -- diff --git a/System/Glib/StoreValue.hsc b/System/Glib/StoreValue.hsc --- a/System/Glib/StoreValue.hsc +++ b/System/Glib/StoreValue.hsc @@ -32,7 +32,7 @@ valueGetGenericValue, ) where -import Control.Monad (liftM) +import Control.Monad (liftM) import Data.Text (Text) import Control.Exception (throw, AssertionFailed(..)) @@ -40,45 +40,45 @@ #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 Text) - | 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 @@ -97,19 +97,19 @@ -- 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_INT} = TMint -- toEnum #{const G_TYPE_UCHAR} = TMuchar --- toEnum #{const G_TYPE_CHAR} = TMchar +-- 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_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_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 () @@ -140,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/UTFString.hs b/System/Glib/UTFString.hs --- a/System/Glib/UTFString.hs +++ b/System/Glib/UTFString.hs @@ -109,9 +109,16 @@ -- 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 = withCAStringLen . 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 @@ -135,7 +142,7 @@ instance GlibString T.Text where withUTFString = useAsCString . encodeUtf8 - withUTFStringLen = T.withCStringLen + withUTFStringLen s f = T.withCStringLen s (f . noNullPtrs) peekUTFString s = do len <- c_strlen s T.peekCStringLen (s, fromIntegral len) diff --git a/System/Glib/hsgclosure.c b/System/Glib/hsgclosure.c --- a/System/Glib/hsgclosure.c +++ b/System/Glib/hsgclosure.c @@ -117,7 +117,7 @@ /* 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)); diff --git a/glib.cabal b/glib.cabal --- a/glib.cabal +++ b/glib.cabal @@ -1,12 +1,12 @@ +cabal-version: 2.2 Name: glib -Version: 0.13.0.6 -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@lists.sourceforge.net Build-Type: Custom -Cabal-Version: >= 1.18 Stability: stable homepage: http://projects.haskell.org/gtk2hs/ bug-reports: https://github.com/gtk2hs/gtk2hs/issues @@ -17,9 +17,8 @@ as much functionality as required to support the packages that wrap libraries that are themselves based on GLib. Category: System -Tested-With: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.1 +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: - SetupWrapper.hs SetupMain.hs Gtk2HsSetup.hs System/Glib/hsgclosure.c System/Glib/hsgclosure.h @@ -31,15 +30,20 @@ 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, - utf8-string >= 0.2 && < 0.4, - bytestring >= 0.9.1.10 && < 0.11, - text >= 1.0.0.0 && < 1.3, - containers - build-tools: gtk2hsC2hs >= 0.13.12 - cpp-options: -U__BLOCKS__ -D__attribute__(A)= + 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