glib 0.12.5.4 → 0.13.12.0
raw patch · 24 files changed
Files
- Gtk2HsSetup.hs +0/−464
- Setup.hs +6/−8
- SetupMain.hs +0/−12
- SetupWrapper.hs +0/−164
- System/Glib/Attributes.hs +1/−1
- System/Glib/Flags.hs +1/−1
- System/Glib/GDateTime.chs +8/−5
- System/Glib/GError.chs +17/−15
- System/Glib/GList.chs +12/−12
- System/Glib/GObject.chs +13/−12
- System/Glib/GParameter.hsc +1/−1
- System/Glib/GString.chs +16/−4
- System/Glib/GType.chs +1/−1
- System/Glib/GTypeConstants.hsc +18/−18
- System/Glib/GValue.chs +1/−1
- System/Glib/GValueTypes.chs +36/−6
- System/Glib/MainLoop.chs +9/−9
- System/Glib/Properties.chs +97/−20
- System/Glib/Signals.chs +47/−10
- System/Glib/StoreValue.hsc +57/−56
- System/Glib/UTFString.hs +160/−60
- System/Glib/Utils.chs +5/−5
- System/Glib/hsgclosure.c +13/−1
- glib.cabal +23/−14
− Gtk2HsSetup.hs
@@ -1,464 +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, stripPrefix, nub, tails )-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- dll:_ -> [dropExtension dll]- _ -> if lib == "z" then [] else [lib]- where- 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@(library -> Just lib )- lbi@(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-#if CABAL_VERSION_CHECK(1,10,0)- packageDbs-#else- packageDb-#endif-- where- modeGenerateRegFile = isJust (flagToMaybe (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)--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 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-- 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----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 "<no file>" . 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)
Setup.hs view
@@ -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
− SetupMain.hs
@@ -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
− SetupWrapper.hs
@@ -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 (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----- 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) <- 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
System/Glib/Attributes.hs view
@@ -68,7 +68,7 @@ AttrOp(..), get, set,- + -- * Internal attribute constructors newNamedAttr, readNamedAttr,
System/Glib/Flags.hs view
@@ -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
System/Glib/GDateTime.chs view
@@ -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 ->
System/Glib/GError.chs view
@@ -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@@ -60,10 +60,10 @@ -- catchGErrorJust, catchGErrorJustDomain,- + handleGErrorJust, handleGErrorJustDomain,- + -- ** Deprecated catchGError, handleGError,@@ -92,6 +92,8 @@ import System.Glib.UTFString import Control.Exception 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.@@ -99,7 +101,7 @@ deriving Typeable instance Show GError where- show (GError _ _ msg) = msg+ show (GError _ _ msg) = T.unpack msg instance Exception GError @@ -121,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)@@ -147,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@@ -190,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: --@@ -198,7 +200,7 @@ -- > (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@@ -212,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@@ -246,23 +248,23 @@ | 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 = 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 -- | 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))
System/Glib/GList.chs view
@@ -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. --
System/Glib/GObject.chs view
@@ -41,7 +41,7 @@ makeNewGObject, constructNewGObject, wrapNewGObject,- + -- ** GType queries gTypeGObject, isA,@@ -61,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@@ -110,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@@ -133,12 +134,12 @@ -- 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@@ -150,7 +151,7 @@ -- reference). Since newly created 'GObject's have a reference count of -- one, they don't need ref'ing. ---wrapNewGObject :: GObjectClass obj => +wrapNewGObject :: GObjectClass obj => (ForeignPtr obj -> obj, FinalizerPtr obj) -> IO (Ptr obj) -> IO obj wrapNewGObject (constr, objectUnref) generator = do objPtr <- generator@@ -172,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.@@ -185,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@@ -200,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@@ -217,8 +218,8 @@ -- | 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
System/Glib/GParameter.hsc view
@@ -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
System/Glib/GString.chs view
@@ -27,12 +27,14 @@ module System.Glib.GString ( GString, readGString,+ readGStringByteString, fromGString, ) where import Foreign-import Control.Exception (bracket)-import Control.Monad (foldM)+import Control.Exception (bracket)+import Control.Monad (foldM)+import Data.ByteString (ByteString, packCStringLen) import System.Glib.FFI @@ -47,17 +49,27 @@ 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) +-- 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+ | otherwise = do gstr <- {#get GString->str#} gstring len <- {#get GString->len#} gstring str <- fmap Just $ peekCStringLen (gstr, fromIntegral len)
System/Glib/GType.chs view
@@ -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
System/Glib/GTypeConstants.hsc view
@@ -37,27 +37,27 @@ boxed ) where -import System.Glib.GType (GType)+import System.Glib.GType (GType) #include<glib-object.h> 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
System/Glib/GValue.chs view
@@ -35,7 +35,7 @@ ) where import System.Glib.FFI-import System.Glib.GType (GType)+import System.Glib.GType (GType) {# context lib="glib" prefix="g" #}
System/Glib/GValueTypes.chs view
@@ -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 =
System/Glib/MainLoop.chs view
@@ -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
System/Glib/Properties.chs view
@@ -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)
System/Glib/Signals.chs view
@@ -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)
System/Glib/StoreValue.hsc view
@@ -32,52 +32,53 @@ valueGetGenericValue, ) where -import Control.Monad (liftM)+import Control.Monad (liftM)+import Data.Text (Text) import Control.Exception (throw, AssertionFailed(..)) #include<glib-object.h> 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@@ -95,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 ()@@ -139,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
System/Glib/UTFString.hs view
@@ -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,57 +38,131 @@ peekUTFStringArray0, readUTFStringArray0, UTFCorrection,- genUTFOfs, ofsToUTF,- ofsFromUTF+ ofsFromUTF,++ glibToString,+ stringToGlib,++ DefaultGlibString,++ GlibFilePath(..),+ withUTFFilePaths,+ withUTFFilePathArray,+ withUTFFilePathArray0,+ peekUTFFilePathArray0,+ readUTFFilePathArray0 ) where 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) --- | Like 'withCString' but using the UTF-8 encoding.----withUTFString :: String -> (CString -> IO a) -> IO a-withUTFString = withCAString . encodeString+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 --- | Like 'withCStringLen' but using the UTF-8 encoding.----withUTFStringLen :: String -> (CStringLen -> IO a) -> IO a-withUTFStringLen = withCAStringLen . encodeString+ -- | Like 'withCStringLen' but using the UTF-8 encoding.+ --+ withUTFStringLen :: s -> (CStringLen -> IO a) -> IO a --- | Like 'newCString' but using the UTF-8 encoding.----newUTFString :: String -> IO CString-newUTFString = newCAString . encodeString+ -- | Like 'peekCString' but using the UTF-8 encoding.+ --+ peekUTFString :: CString -> IO s --- | Like Define newUTFStringLen to emit UTF-8.----newUTFStringLen :: String -> IO CStringLen-newUTFStringLen = newCAStringLen . encodeString+ -- | 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) --- | Like 'peekCString' but using the UTF-8 encoding.----peekUTFString :: CString -> IO String-peekUTFString = liftM decodeString . peekCAString+ -- | Like 'peekCStringLen' but using the UTF-8 encoding.+ --+ peekUTFStringLen :: CStringLen -> IO s --- | 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 = liftM (maybe Nothing (Just . decodeString)) . maybePeek peekCAString+ -- | Like 'newCString' but using the UTF-8 encoding.+ --+ newUTFString :: s -> IO CString --- | Like 'peekCStringLen' but using the UTF-8 encoding.----peekUTFStringLen :: CStringLen -> IO String-peekUTFStringLen = liftM decodeString . peekCAStringLen+ -- | Like Define newUTFStringLen to emit UTF-8.+ --+ newUTFStringLen :: s -> IO CStringLen + -- | 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@@ -110,23 +181,23 @@ -- | 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 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 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@@ -134,7 +205,7 @@ -- | 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@@ -142,7 +213,7 @@ -- | 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@@ -153,7 +224,7 @@ -- To be used when functions indicate that their return value should be freed -- with @g_strfreev@. ---readUTFStringArray0 :: Ptr CString -> IO [String]+readUTFStringArray0 :: GlibString s => Ptr CString -> IO [s] readUTFStringArray0 cStrArr | cStrArr == nullPtr = return [] | otherwise = do cStrs <- peekArray0 nullPtr cStrArr@@ -168,27 +239,56 @@ -- 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- | ord x<=0xFFFF = n:n:gUO (n+1) xs- | otherwise = n: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
System/Glib/Utils.chs view
@@ -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 #}
System/Glib/hsgclosure.c view
@@ -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)); @@ -172,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:@@ -229,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));
glib.cabal view
@@ -1,24 +1,24 @@+cabal-version: 2.2 Name: glib-Version: 0.12.5.4-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.8 Stability: stable homepage: http://projects.haskell.org/gtk2hs/-bug-reports: http://hackage.haskell.org/trac/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 == 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 @@ -30,18 +30,26 @@ 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,- containers- build-tools: gtk2hsC2hs >= 0.13.8+ 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@@ -63,6 +71,7 @@ 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