diff --git a/Graphics/Rendering/Cairo.hs b/Graphics/Rendering/Cairo.hs --- a/Graphics/Rendering/Cairo.hs +++ b/Graphics/Rendering/Cairo.hs @@ -65,6 +65,9 @@ , restore , status , withTargetSurface + , pushGroup + , pushGroupWithContent + , popGroupToSource , setSourceRGB , setSourceRGBA , setSource @@ -123,6 +126,7 @@ , withRGBPattern , withRGBAPattern , withPatternForSurface + , withGroupPattern , withLinearPattern , withRadialPattern , patternAddColorStopRGB @@ -355,7 +359,44 @@ context <- ask surface <- liftIO $ Internal.getTarget context f surface - + +-- | Like @pushGroupWithContent ContentColorAlpha@, but more convenient. +pushGroup :: Render () +pushGroup = liftRender0 Internal.pushGroup + +-- | Temporarily redirects drawing to an intermediate surface known as a group. +-- The redirection lasts until the group is completed by a call to +-- 'withGroupPattern' or 'popGroupToSource'. These calls provide the result of +-- any drawing to the group as a pattern (either as an explicit object, or set +-- as the source pattern). This group functionality can be convenient for +-- performing intermediate compositing. One common use of a group is to render +-- objects as opaque within the group (so that they occlude each other), and +-- then blend the result with translucence onto the destination. +-- +-- Groups can be nested arbitrarily deeply by making balanced calls to +-- 'pushGroupWithContent' and 'withGroupPattern'. As a side effect, +-- 'pushGroupWithContent' calls 'save' and 'withGroupPattern' calls 'restore', +-- so that any changes to the graphics state will not be visible outside the +-- group. +-- +-- As an example, here is how one might fill and stroke a path with +-- translucence, but without any portion of the fill being visible under the +-- stroke: +-- +-- > pushGroup +-- > setSource fillPattern +-- > fillPreserve +-- > setSource strokePattern +-- > stroke +-- > popGroupToSource +-- > paintWithAlpha alpha +pushGroupWithContent :: Content -> Render () +pushGroupWithContent = liftRender1 Internal.pushGroupWithContent + +-- | Like @withGroupPattern setSource@, but more convenient. +popGroupToSource :: Render () +popGroupToSource = liftRender0 Internal.popGroupToSource + -- | Sets the source pattern within the context to an opaque color. This opaque -- color will then be used for any subsequent drawing operation until a new source -- pattern is set. @@ -764,7 +805,7 @@ -- path to connect the current point to the beginning of the arc. -- -- Angles are measured in radians. An angle of 0 is in the direction of the --- positive X axis (in user-space). An angle of @pi@ radians (90 degrees) is in +-- positive X axis (in user-space). An angle of @pi/2@ radians (90 degrees) is in -- the direction of the positive Y axis (in user-space). Angles increase in the -- direction from the positive X axis toward the positive Y axis. So with the -- default transformation matrix, angles increase in a clockwise direction. @@ -971,6 +1012,21 @@ fail =<< Internal.statusToString status) (\pattern -> f pattern) +-- | Pop the current group from the group stack and use it as a pattern. The +-- group should be populated first by calling 'pushGroup' or +-- 'pushGroupWithContent' and doing some drawing operations. This also calls +-- 'restore' to balance the 'save' called in 'pushGroup'. +withGroupPattern :: (Pattern -> Render a) -- ^ a nested render action using the pattern + -> Render a +withGroupPattern f = do + context <- ask + bracketR (Internal.popGroup context) + (\pattern -> do status <- Internal.patternStatus pattern + liftIO $ Internal.patternDestroy pattern + unless (status == StatusSuccess) $ + fail =<< Internal.statusToString status) + f + -- | Create a new linear gradient 'Pattern' along the line defined by @(x0, y0)@ -- and @(x1, y1)@. Before using the gradient pattern, a number of color stops -- should be defined using 'patternAddColorStopRGB' and 'patternAddColorStopRGBA'. @@ -1728,7 +1784,7 @@ -- | An array that stores the raw pixel data of an image 'Surface'. -- -data Ix i => SurfaceData i e = SurfaceData !Surface +data SurfaceData i e = SurfaceData !Surface {-# UNPACK #-} !(Ptr e) !(i,i) {-# UNPACK #-} !Int diff --git a/Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs b/Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs --- a/Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs +++ b/Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs @@ -27,6 +27,10 @@ {#fun restore { unCairo `Cairo' } -> `()' #} {#fun status as status { unCairo `Cairo' } -> `Status' cToEnum#} {#fun get_target as getTarget { unCairo `Cairo' } -> `Surface' mkSurface*#} +{#fun push_group as ^ { unCairo `Cairo' } -> `()' #} +{#fun push_group_with_content as ^ { unCairo `Cairo', cFromEnum `Content' } -> `()' #} +{#fun pop_group as ^ { unCairo `Cairo' } -> `Pattern' Pattern #} +{#fun pop_group_to_source as ^ { unCairo `Cairo' } -> `()' #} {#fun set_source_rgb as setSourceRGB { unCairo `Cairo', `Double', `Double', `Double' } -> `()'#} {#fun set_source_rgba as setSourceRGBA { unCairo `Cairo', `Double', `Double', `Double', `Double' } -> `()'#} {#fun set_source as setSource { unCairo `Cairo', unPattern `Pattern' } -> `()'#} diff --git a/Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs b/Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs --- a/Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs +++ b/Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs @@ -18,6 +18,8 @@ import Foreign import Foreign.C +import Graphics.Rendering.Cairo.Internal.Utilities (withUTFString) + {#context lib="cairo" prefix="cairo"#} {#fun get_current_point as getCurrentPoint { unCairo `Cairo', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `()'#} @@ -29,7 +31,7 @@ {#fun line_to as lineTo { unCairo `Cairo', `Double', `Double' } -> `()'#} {#fun move_to as moveTo { unCairo `Cairo', `Double', `Double' } -> `()'#} {#fun rectangle as rectangle { unCairo `Cairo', `Double', `Double', `Double', `Double' } -> `()'#} -{#fun text_path as textPath { unCairo `Cairo', withCString* `String' } -> `()'#} +{#fun text_path as textPath { unCairo `Cairo', withUTFString* `String' } -> `()'#} {#fun rel_curve_to as relCurveTo { unCairo `Cairo', `Double', `Double', `Double', `Double', `Double', `Double' } -> `()'#} {#fun rel_line_to as relLineTo { unCairo `Cairo', `Double', `Double' } -> `()'#} {#fun rel_move_to as relMoveTo { unCairo `Cairo', `Double', `Double' } -> `()'#} diff --git a/Graphics/Rendering/Cairo/Internal/Drawing/Text.chs b/Graphics/Rendering/Cairo/Internal/Drawing/Text.chs --- a/Graphics/Rendering/Cairo/Internal/Drawing/Text.chs +++ b/Graphics/Rendering/Cairo/Internal/Drawing/Text.chs @@ -15,6 +15,7 @@ {#import Graphics.Rendering.Cairo.Types#} +import Graphics.Rendering.Cairo.Internal.Utilities (withUTFString) import Foreign import Foreign.C @@ -26,6 +27,6 @@ {#fun set_font_matrix as setFontMatrix { unCairo `Cairo', `Matrix' } -> `()'#} {#fun get_font_matrix as getFontMatrix { unCairo `Cairo', alloca- `Matrix' peek*} -> `()'#} {#fun set_font_options as setFontOptions { unCairo `Cairo', withFontOptions* `FontOptions' } -> `()'#} -{#fun show_text as showText { unCairo `Cairo', withCString* `String' } -> `()'#} +{#fun show_text as showText { unCairo `Cairo', withUTFString* `String' } -> `()'#} {#fun font_extents as fontExtents { unCairo `Cairo', alloca- `FontExtents' peek* } -> `()'#} -{#fun text_extents as textExtents { unCairo `Cairo', withCString* `String', alloca- `TextExtents' peek* } -> `()'#} +{#fun text_extents as textExtents { unCairo `Cairo', withUTFString* `String', alloca- `TextExtents' peek* } -> `()'#} diff --git a/Graphics/Rendering/Cairo/Internal/Surfaces/PDF.chs b/Graphics/Rendering/Cairo/Internal/Surfaces/PDF.chs --- a/Graphics/Rendering/Cairo/Internal/Surfaces/PDF.chs +++ b/Graphics/Rendering/Cairo/Internal/Surfaces/PDF.chs @@ -23,7 +23,7 @@ #ifdef CAIRO_HAS_PDF_SURFACE -{#fun pdf_surface_create as pdfSurfaceCreate { withCString* `FilePath', `Double', `Double' } -> `Surface' mkSurface*#} +{#fun pdf_surface_create as pdfSurfaceCreate { withCAString* `FilePath', `Double', `Double' } -> `Surface' mkSurface*#} #if CAIRO_CHECK_VERSION(1,2,0) {#fun pdf_surface_set_size as pdfSurfaceSetSize { withSurface* `Surface', `Double', `Double' } -> `()'#} diff --git a/Graphics/Rendering/Cairo/Internal/Surfaces/PNG.chs b/Graphics/Rendering/Cairo/Internal/Surfaces/PNG.chs --- a/Graphics/Rendering/Cairo/Internal/Surfaces/PNG.chs +++ b/Graphics/Rendering/Cairo/Internal/Surfaces/PNG.chs @@ -25,10 +25,10 @@ imageSurfaceCreateFromPNG :: FilePath -> IO Surface imageSurfaceCreateFromPNG filename = - withCString filename $ \filenamePtr -> + withCAString filename $ \filenamePtr -> {#call unsafe image_surface_create_from_png#} filenamePtr >>= mkSurface -{#fun surface_write_to_png as surfaceWriteToPNG { withSurface* `Surface', withCString* `FilePath' } -> `Status' cToEnum#} +{#fun surface_write_to_png as surfaceWriteToPNG { withSurface* `Surface', withCAString* `FilePath' } -> `Status' cToEnum#} #endif diff --git a/Graphics/Rendering/Cairo/Internal/Surfaces/PS.chs b/Graphics/Rendering/Cairo/Internal/Surfaces/PS.chs --- a/Graphics/Rendering/Cairo/Internal/Surfaces/PS.chs +++ b/Graphics/Rendering/Cairo/Internal/Surfaces/PS.chs @@ -23,7 +23,7 @@ #ifdef CAIRO_HAS_PS_SURFACE -{#fun ps_surface_create as psSurfaceCreate { withCString* `FilePath', `Double', `Double' } -> `Surface' mkSurface*#} +{#fun ps_surface_create as psSurfaceCreate { withCAString* `FilePath', `Double', `Double' } -> `Surface' mkSurface*#} #if CAIRO_CHECK_VERSION(1,2,0) {#fun cairo_ps_surface_set_size as psSurfaceSetSize { withSurface* `Surface', `Double', `Double' } -> `()'#} diff --git a/Graphics/Rendering/Cairo/Internal/Surfaces/SVG.chs b/Graphics/Rendering/Cairo/Internal/Surfaces/SVG.chs --- a/Graphics/Rendering/Cairo/Internal/Surfaces/SVG.chs +++ b/Graphics/Rendering/Cairo/Internal/Surfaces/SVG.chs @@ -23,6 +23,6 @@ #ifdef CAIRO_HAS_SVG_SURFACE -{#fun svg_surface_create as svgSurfaceCreate { withCString* `FilePath', `Double', `Double' } -> `Surface' mkSurface*#} +{#fun svg_surface_create as svgSurfaceCreate { withCAString* `FilePath', `Double', `Double' } -> `Surface' mkSurface*#} #endif diff --git a/Graphics/Rendering/Cairo/Internal/Utilities.chs b/Graphics/Rendering/Cairo/Internal/Utilities.chs --- a/Graphics/Rendering/Cairo/Internal/Utilities.chs +++ b/Graphics/Rendering/Cairo/Internal/Utilities.chs @@ -18,8 +18,31 @@ import Foreign import Foreign.C +import Data.Char (ord, chr) + {#context lib="cairo" prefix="cairo"#} {#fun status_to_string as statusToString { cFromEnum `Status' } -> `String'#} {#fun pure version as version {} -> `Int'#} {#fun pure version_string as versionString {} -> `String'#} + +-- These functions taken from System/Glib/UTFString.hs +-- Copyright (c) 1999..2002 Axel Simon + +-- Define withUTFString to emit UTF-8. +-- +withUTFString :: String -> (CString -> IO a) -> IO a +withUTFString hsStr = withCAString (toUTF hsStr) + where + -- Convert Unicode characters to UTF-8. + -- + toUTF :: String -> String + toUTF [] = [] + toUTF (x:xs) | ord x<=0x007F = x:toUTF xs + | ord x<=0x07FF = chr (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)): + chr (0x80 .|. (ord x .&. 0x3F)): + toUTF xs + | otherwise = chr (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)): + chr (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)): + chr (0x80 .|. (ord x .&. 0x3F)): + toUTF xs diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs --- a/Gtk2HsSetup.hs +++ b/Gtk2HsSetup.hs @@ -1,37 +1,7 @@ {-# LANGUAGE CPP #-} -#define CABAL_VERSION_ENCODE(major, minor, micro) ( \ - ((major) * 10000) \ - + ((minor) * 100) \ - + ((micro) * 1)) - -#define CABAL_VERSION_CHECK(major,minor,micro) \ - (CABAL_VERSION >= CABAL_VERSION_ENCODE(major,minor,micro)) - --- now, this is bad, but Cabal doesn't seem to actually pass any information about --- its version to CPP, so guess the version depending on the version of GHC -#ifdef CABAL_VERSION_MINOR -#ifndef CABAL_VERSION_MAJOR -#define CABAL_VERSION_MAJOR 1 -#endif -#ifndef CABAL_VERSION_MICRO -#define CABAL_VERSION_MICRO 0 -#endif -#define CABAL_VERSION CABAL_VERSION_ENCODE( \ - CABAL_VERSION_MAJOR, \ - CABAL_VERSION_MINOR, \ - CABAL_VERSION_MICRO) -#else -#warning Setup.hs is guessing the version of Cabal. If compilation of Setup.hs fails use -DCABAL_VERSION_MINOR=x for Cabal version 1.x.0 when building (prefixed by --ghc-option= when using the 'cabal' command) -#if (__GLASGOW_HASKELL__ >= 700) -#define CABAL_VERSION CABAL_VERSION_ENCODE(1,10,0) -#else -#if (__GLASGOW_HASKELL__ >= 612) -#define CABAL_VERSION CABAL_VERSION_ENCODE(1,8,0) -#else -#define CABAL_VERSION CABAL_VERSION_ENCODE(1,6,0) -#endif -#endif +#ifndef CABAL_VERSION_CHECK +#error This module has to be compiled via the Setup.hs program which generates the gtk2hs-macros.h file #endif -- | Build a Gtk2hs package. @@ -49,13 +19,7 @@ libraryDirs, extraLibraries, extraGHCiLibraries ) -import Distribution.Simple.PackageIndex ( -#if CABAL_VERSION_CHECK(1,8,0) - lookupInstalledPackageId -#else - lookupPackageId -#endif - ) +import Distribution.Simple.PackageIndex ( lookupInstalledPackageId ) import Distribution.PackageDescription as PD ( PackageDescription(..), updatePackageDescription, BuildInfo(..), @@ -64,17 +28,13 @@ libModules, hasLibs) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), InstallDirs(..), -#if CABAL_VERSION_CHECK(1,8,0) componentPackageDeps, -#else - packageDeps, -#endif absoluteInstallDirs) import Distribution.Simple.Compiler ( Compiler(..) ) import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), - rawSystemProgramConf, rawSystemProgramStdoutConf, programName, - c2hsProgram, pkgConfigProgram, requireProgram, ghcPkgProgram, + rawSystemProgramConf, rawSystemProgramStdoutConf, programName, programPath, + c2hsProgram, pkgConfigProgram, gccProgram, requireProgram, ghcPkgProgram, simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg) import Distribution.ModuleName ( ModuleName, components, toFilePath ) import Distribution.Simple.Utils @@ -84,11 +44,7 @@ fromFlagOrDefault, defaultRegisterFlags) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Install ( install ) -#if CABAL_VERSION_CHECK(1,8,0) import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage ) -#else -import qualified Distribution.Simple.Register as Register ( register ) -#endif import Distribution.Text ( simpleParse, display ) import System.FilePath import System.Exit (exitFailure) @@ -147,8 +103,6 @@ -- The following code is a big copy-and-paste job from the sources of -- Cabal 1.8 just to be able to fix a field in the package file. Yuck. -#if CABAL_VERSION_CHECK(1,8,0) - installHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () installHook pkg_descr localbuildinfo _ flags = do @@ -195,19 +149,20 @@ _ | modeGenerateRegFile -> die "Generate Reg File not supported" | modeGenerateRegScript -> die "Generate Reg Script not supported" | otherwise -> registerPackage verbosity + installedPkgInfo pkg lbi inplace #if CABAL_VERSION_CHECK(1,10,0) - installedPkgInfo pkg lbi inplace [packageDb] + packageDbs #else - installedPkgInfo pkg lbi inplace packageDb + packageDb #endif where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) modeGenerateRegScript = fromFlag (regGenScript regFlags) inplace = fromFlag (regInPlace regFlags) - packageDb = case flagToMaybe (regPackageDB regFlags) of - Just db -> db - Nothing -> registrationPackageDB (withPackageDB lbi) + packageDbs = nub $ withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + packageDb = registrationPackageDB packageDbs distPref = fromFlag (regDistPref regFlags) verbosity = fromFlag (regVerbosity regFlags) @@ -215,45 +170,7 @@ where verbosity = fromFlag (regVerbosity regFlags) -#else -installHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> InstallFlags -> IO () -installHook pkg_descr localbuildinfo _ flags = do - let copyFlags = defaultCopyFlags { - copyDistPref = installDistPref flags, - copyInPlace = installInPlace flags, - copyUseWrapper = installUseWrapper flags, - copyDest = toFlag NoCopyDest, - copyVerbosity = installVerbosity flags - } - install pkg_descr localbuildinfo copyFlags - let registerFlags = defaultRegisterFlags { - regDistPref = installDistPref flags, - regInPlace = installInPlace flags, - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } - when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags -registerHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () -registerHook pkg_descr localbuildinfo _ flags = - if hasLibs pkg_descr - then register pkg_descr localbuildinfo flags - else setupMessage verbosity - "Package contains no library to register:" (packageId pkg_descr) - where verbosity = fromFlag (regVerbosity flags) - -register :: PackageDescription -> LocalBuildInfo - -> RegisterFlags -- ^Install in the user's database?; verbose - -> IO () -register pkg_descr lbi regFlags = do - let verbosity = fromFlag (regVerbosity regFlags) - warn verbosity "Cannot register ghci libraries with Cabal 1.6 (need 1.8)." - Register.register pkg_descr lbi regFlags - -#endif - ------------------------------------------------------------------------------ -- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later ------------------------------------------------------------------------------ @@ -291,15 +208,12 @@ -- additional .chi files might be needed that other packages have installed; -- we assume that these are installed in the same place as .hi files let chiDirs = [ dir | -#if CABAL_VERSION_CHECK(1,8,0) ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi), dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ] -#else - ipi <- packageDeps lbi, - dir <- maybe [] importDirs (lookupPackageId (installedPkgs lbi) ipi) ] -#endif + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $ map ("--include=" ++) (outDir:chiDirs) + ++ [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] ++ ["--output-dir=" ++ newOutDir, "--output=" ++ newOutFile, @@ -321,18 +235,10 @@ -- cannot use the recommended 'findModuleFiles' since it fails if there exists -- a modules that does not have a .chi file mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi] . toFilePath) -#if CABAL_VERSION_CHECK(1,8,0) (PD.libModules lib) -#else - (PD.libModules pkg) -#endif let files = [ f | Just f <- mFiles ] -#if CABAL_VERSION_CHECK(1,8,0) installOrdinaryFiles verbosity libPref files -#else - copyFiles verbosity libPref files -#endif installCHI _ _ _ _ = return () @@ -348,7 +254,15 @@ signalGenProgram = simpleProgram "gtk2hsHookGenerator" c2hsLocal :: Program -c2hsLocal = simpleProgram "gtk2hsC2hs" +c2hsLocal = (simpleProgram "gtk2hsC2hs") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "gtk2hsC2hs --version" gives a string like: + -- C->Haskell Compiler, version 0.13.4 (gtk2hs branch) "Bin IO", 13 Nov 2004 + case words str of + (_:_:_:ver:_) -> ver + _ -> "" + } + genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () genSynthezisedFiles verb pd lbi = do diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,10 +1,10 @@ --- Setup file for a Gtk2Hs module. Contains only adjustments specific to this module, --- all Gtk2Hs-specific boilerplate is stored in Gtk2HsSetup.hs which should be kept --- identical across all modules. -import Gtk2HsSetup ( gtk2hsUserHooks, checkGtk2hsBuildtools ) -import Distribution.Simple ( defaultMainWithHooks ) +-- Standard setup file for a Gtk2Hs module. +-- +-- See also: +-- * SetupMain.hs : the real Setup script for this package +-- * Gtk2HsSetup.hs : Gtk2Hs-specific boilerplate +-- * SetupWrapper.hs : wrapper for compat with various ghc/cabal versions -main = do - checkGtk2hsBuildtools ["gtk2hsC2hs"] - defaultMainWithHooks gtk2hsUserHooks - +import SetupWrapper ( setupWrapper ) + +main = setupWrapper "SetupMain.hs" diff --git a/SetupMain.hs b/SetupMain.hs new file mode 100644 --- /dev/null +++ b/SetupMain.hs @@ -0,0 +1,12 @@ +-- The real Setup file for a Gtk2Hs package (invoked via the SetupWrapper). +-- It contains only adjustments specific to this package, +-- all Gtk2Hs-specific boilerplate is kept in Gtk2HsSetup.hs +-- which should be kept identical across all packages. +-- +import Gtk2HsSetup ( gtk2hsUserHooks, checkGtk2hsBuildtools ) +import Distribution.Simple ( defaultMainWithHooks ) + +main = do + checkGtk2hsBuildtools ["gtk2hsC2hs"] + defaultMainWithHooks gtk2hsUserHooks + diff --git a/SetupWrapper.hs b/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/SetupWrapper.hs @@ -0,0 +1,155 @@ +-- A wrapper script for Cabal Setup.hs scripts. Allows compiling the real Setup +-- conditionally depending on the Cabal version. + +module SetupWrapper (setupWrapper) where + +import Distribution.Package +import Distribution.Compiler +import Distribution.Simple.Utils +import Distribution.Simple.Program +import Distribution.Simple.Compiler +import Distribution.Simple.BuildPaths (exeExtension) +import Distribution.Simple.Configure (configCompiler) +import Distribution.Simple.GHC (getInstalledPackages) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Version +import Distribution.Verbosity +import Distribution.Text + +import System.Environment +import System.Process +import System.Exit +import System.FilePath +import System.Directory +import qualified Control.Exception as Exception +import System.IO.Error (isDoesNotExistError) + +import Data.List +import Data.Char +import Control.Monad + + +setupWrapper :: FilePath -> IO () +setupWrapper setupHsFile = do + args <- getArgs + createDirectoryIfMissingVerbose verbosity True setupDir + compileSetupExecutable + invokeSetupScript args + + where + setupDir = "dist/setup-wrapper" + setupVersionFile = setupDir "setup" <.> "version" + setupProgFile = setupDir "setup" <.> exeExtension + setupMacroFile = setupDir "wrapper-macros.h" + + useCabalVersion = Version [1,8] [] + usePackageDB = [GlobalPackageDB, UserPackageDB] + verbosity = normal + + cabalLibVersionToUse comp conf = do + savedVersion <- savedCabalVersion + case savedVersion of + Just version + -> return version + _ -> do version <- installedCabalVersion comp conf + writeFile setupVersionFile (show version ++ "\n") + return version + + savedCabalVersion = do + versionString <- readFile setupVersionFile + `Exception.catch` \e -> if isDoesNotExistError e + then return "" + else Exception.throwIO e + case reads versionString of + [(version,s)] | all isSpace s -> return (Just version) + _ -> return Nothing + + installedCabalVersion comp conf = do + index <- getInstalledPackages verbosity usePackageDB conf + + let cabalDep = Dependency (PackageName "Cabal") + (orLaterVersion useCabalVersion) + case PackageIndex.lookupDependency index cabalDep of + [] -> die $ "The package requires Cabal library version " + ++ display useCabalVersion + ++ " but no suitable version is installed." + pkgs -> return $ bestVersion (map fst pkgs) + where + bestVersion = maximumBy (comparing preference) + preference version = (sameVersion, sameMajorVersion + ,stableVersion, latestVersion) + where + sameVersion = version == cabalVersion + sameMajorVersion = majorVersion version == majorVersion cabalVersion + majorVersion = take 2 . versionBranch + stableVersion = case versionBranch version of + (_:x:_) -> even x + _ -> False + latestVersion = version + + -- | If the Setup.hs is out of date wrt the executable then recompile it. + -- Currently this is GHC only. It should really be generalised. + -- + compileSetupExecutable = do + setupHsNewer <- setupHsFile `moreRecentFile` setupProgFile + cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile + let outOfDate = setupHsNewer || cabalVersionNewer + when outOfDate $ do + debug verbosity "Setup script is out of date, compiling..." + + (comp, conf) <- configCompiler (Just GHC) Nothing Nothing + defaultProgramConfiguration verbosity + cabalLibVersion <- cabalLibVersionToUse comp conf + let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion + debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion + + writeFile setupMacroFile (generateVersionMacro cabalLibVersion) + + rawSystemProgramConf verbosity ghcProgram conf $ + ["--make", setupHsFile, "-o", setupProgFile] + ++ ghcPackageDbOptions usePackageDB + ++ ["-package", display cabalPkgid + ,"-cpp", "-optP-include", "-optP" ++ setupMacroFile + ,"-odir", setupDir, "-hidir", setupDir] + where + + ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error "internal error: unexpected package db stack" + + generateVersionMacro :: Version -> String + generateVersionMacro version = + concat + ["/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" + ,"#define CABAL_VERSION_CHECK(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + + invokeSetupScript :: [String] -> IO () + invokeSetupScript args = do + info verbosity $ unwords (setupProgFile : args) + process <- runProcess (currentDir setupProgFile) args + Nothing Nothing + Nothing Nothing Nothing + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode + +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) diff --git a/cairo.cabal b/cairo.cabal --- a/cairo.cabal +++ b/cairo.cabal @@ -1,23 +1,23 @@ Name: cairo -Version: 0.12.0 +Version: 0.12.1 License: BSD3 License-file: COPYRIGHT Copyright: (c) 2001-2010 The Gtk2Hs Team, (c) Paolo Martini 2005, (c) Abraham Egnor 2003, 2004, (c) Aetion Technologies LLC 2004 Author: Axel Simon, Duncan Coutts -Maintainer: gtk2hs-users@sourceforge.net +Maintainer: gtk2hs-users@lists.sourceforge.net Build-Type: Custom -Cabal-Version: >= 1.6.0 +Cabal-Version: >= 1.8 Stability: stable -homepage: http://www.haskell.org/gtk2hs/ +homepage: http://projects.haskell.org/gtk2hs/ bug-reports: http://hackage.haskell.org/trac/gtk2hs/ Synopsis: Binding to the Cairo library. Description: Cairo is a library to render high quality vector graphics. There exist various backends that allows rendering to Gtk windows, PDF, PS, PNG and SVG documents, amongst others. Category: Graphics -Tested-With: GHC == 6.10.4 +Tested-With: GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1 extra-source-files: cairo-gtk2hs.h - Gtk2HsSetup.hs + SetupWrapper.hs SetupMain.hs Gtk2HsSetup.hs Data-Dir: demo Data-Files: cairo-clock-icon.png @@ -46,8 +46,8 @@ Library build-depends: base >= 4 && < 5, - bytestring, mtl, haskell98, array - build-tools: gtk2hsC2hs + bytestring, mtl, array + build-tools: gtk2hsC2hs >= 0.13.5 exposed-modules: Graphics.Rendering.Cairo Graphics.Rendering.Cairo.Matrix Graphics.Rendering.Cairo.Types diff --git a/demo/Clock.hs b/demo/Clock.hs --- a/demo/Clock.hs +++ b/demo/Clock.hs @@ -13,7 +13,6 @@ import Graphics.Rendering.Cairo import Graphics.UI.Gtk import Graphics.UI.Gtk.Gdk.EventM -import System.Glib (handleGError, GError(..)) import System.Time import Control.Monad (when) import Data.Maybe (isJust) @@ -283,8 +282,7 @@ windowSetPosition window WinPosCenterAlways widgetSetAppPaintable window True - handleGError (\_ -> return ()) $ - windowSetIconFromFile window "cairo-clock-icon.png" + windowSetIconFromFile window "cairo-clock-icon.png" windowSetTitle window "Gtk2Hs Cairo Clock" windowSetDefaultSize window initialSize initialSize windowSetGeometryHints window (Just window)