svgcairo-0.12.1/0000755000000000000000000000000011633370365011605 5ustar0000000000000000svgcairo-0.12.1/Setup.hs0000644000000000000000000000050411633370365013240 0ustar0000000000000000-- 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 import SetupWrapper ( setupWrapper ) main = setupWrapper "SetupMain.hs" svgcairo-0.12.1/SetupWrapper.hs0000644000000000000000000001427711633370365014615 0ustar0000000000000000-- 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) svgcairo-0.12.1/Gtk2HsSetup.hs0000644000000000000000000004545211633370365014276 0ustar0000000000000000{-# LANGUAGE CPP #-} #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 ) 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(..), 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 ) import Data.List (isPrefixOf, isSuffixOf, nub) import Data.Char (isAlpha) import qualified Data.Map as M import qualified Data.Set as S import Control.Applicative ((<$>)) -- 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 (("lib" ++ lib) `isPrefixOf`) dlls of dll:_ -> [dropExtension dll] _ -> if lib == "z" then [] else [lib] -- The following code is a big copy-and-paste job from the sources of -- Cabal 1.8 just to be able to fix a field in the package file. Yuck. installHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () installHook pkg_descr localbuildinfo _ flags = do let copyFlags = defaultCopyFlags { copyDistPref = installDistPref flags, copyDest = toFlag NoCopyDest, copyVerbosity = installVerbosity flags } install pkg_descr localbuildinfo copyFlags let registerFlags = defaultRegisterFlags { regDistPref = installDistPref flags, regInPlace = installInPlace flags, regPackageDB = installPackageDB flags, regVerbosity = installVerbosity flags } when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags registerHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () registerHook pkg_descr localbuildinfo _ flags = if hasLibs pkg_descr then register pkg_descr localbuildinfo flags else setupMessage verbosity "Package contains no library to register:" (packageId pkg_descr) where verbosity = fromFlag (regVerbosity flags) register :: PackageDescription -> LocalBuildInfo -> RegisterFlags -- ^Install in the user's database?; verbose -> IO () register pkg@PackageDescription { library = Just lib } lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags = do installedPkgInfoRaw <- generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref dllsInScope <- getSearchPath >>= (filterM doesDirectoryExist) >>= getDlls let libs = fixLibs dllsInScope (extraLibraries installedPkgInfoRaw) installedPkgInfo = installedPkgInfoRaw { extraGHCiLibraries = libs } -- Three different modes: case () of _ | modeGenerateRegFile -> die "Generate Reg File not supported" | modeGenerateRegScript -> die "Generate Reg Script not supported" | otherwise -> registerPackage verbosity installedPkgInfo pkg lbi inplace #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"] 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 "" . 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 :: [String] -> IO () checkGtk2hsBuildtools programs = do programInfos <- mapM (\ name -> do location <- programFindLocation (simpleProgram name) normal return (name, 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) svgcairo-0.12.1/SetupMain.hs0000644000000000000000000000076311633370365014054 0ustar0000000000000000-- 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", "gtk2hsTypeGen", "gtk2hsHookGenerator"] defaultMainWithHooks gtk2hsUserHooks svgcairo-0.12.1/svgcairo.cabal0000644000000000000000000000261611633370365014413 0ustar0000000000000000Name: svgcairo Version: 0.12.1 License: BSD3 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team Author: Duncan Coutts Maintainer: gtk2hs-users@lists.sourceforge.net Build-Type: Custom Cabal-Version: >= 1.8 Stability: provisional homepage: http://projects.haskell.org/gtk2hs/ bug-reports: http://hackage.haskell.org/trac/gtk2hs/ Synopsis: Binding to the libsvg-cairo library. Description: Svgcairo is used to render SVG with cairo. Category: Graphics Tested-With: GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1 x-Types-Forward: *Graphics.UI.GtkInternals x-Types-Destructor: objectUnrefFromMainloop Extra-Source-Files: svgcairo.h SetupWrapper.hs SetupMain.hs Gtk2HsSetup.hs Data-Dir: demo Data-Files: Makefile Svg2Png.hs SvgViewer.hs Source-Repository head type: darcs location: http://code.haskell.org/svgcairo Library build-depends: base == 4.*, mtl, glib == 0.12.*, cairo == 0.12.* build-tools: gtk2hsC2hs >= 0.13.5, gtk2hsTypeGen exposed-modules: Graphics.Rendering.Cairo.SVG extensions: ForeignFunctionInterface x-c2hs-Header: svgcairo.h pkgconfig-depends: librsvg-2.0 >= 2.16.0 svgcairo-0.12.1/svgcairo.h0000644000000000000000000000014011633370365013566 0ustar0000000000000000#include #include #include svgcairo-0.12.1/COPYING0000644000000000000000000000266711633370365012653 0ustar0000000000000000All content in this archive is under the BSD License (follows), except where explicitly noted otherwise. Copyright (c) Paolo Martini 2005, (c) Abraham Egnor 2003, 2004, (c) Aetion Technologies LLC 2004 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. svgcairo-0.12.1/Graphics/0000755000000000000000000000000011633370365013345 5ustar0000000000000000svgcairo-0.12.1/Graphics/Rendering/0000755000000000000000000000000011633370365015262 5ustar0000000000000000svgcairo-0.12.1/Graphics/Rendering/Cairo/0000755000000000000000000000000011633370365016317 5ustar0000000000000000svgcairo-0.12.1/Graphics/Rendering/Cairo/SVG.chs0000644000000000000000000001623211633370365017461 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Cairo.SVG -- Copyright : (c) 2005 Duncan Coutts, Paolo Martini -- License : BSD-style (see cairo/COPYRIGHT) -- -- Maintainer : gtk2hs-devel@lists.sourceforge.net -- Stability : experimental -- Portability : portable -- -- The SVG extension to the Cairo 2D graphics library. -- ----------------------------------------------------------------------------- module Graphics.Rendering.Cairo.SVG ( -- * Convenience API -- | These operations render an SVG image directly in the current 'Render' -- contect. Because they operate in the cairo 'Render' monad they are -- affected by the current transformation matrix. So it is possible, for -- example, to scale or rotate an SVG image. -- -- In the following example we scale an SVG image to a unit square: -- -- > let (width, height) = svgGetSize in -- > do scale (1/width) (1/height) -- > svgRender svg svgRenderFromFile, svgRenderFromHandle, svgRenderFromString, -- * Standard API -- | With this API there are seperate functions for loading the SVG and -- rendering it. This allows us to be more effecient in the case that an SVG -- image is used many times - since it can be loaded just once and rendered -- many times. With the convenience API above the SVG would be parsed and -- processed each time it is drawn. SVG, svgRender, svgGetSize, -- ** Block scoped versions -- | These versions of the SVG loading operations give temporary access -- to the 'SVG' object within the scope of the handler function. These -- operations guarantee that the resources for the SVG object are deallocated -- at the end of the handler block. If this form of resource allocation is -- too restrictive you can use the GC-managed versions below. -- -- These versions are ofen used in the following style: -- -- > withSvgFromFile "foo.svg" $ \svg -> do -- > ... -- > svgRender svg -- > ... withSvgFromFile, withSvgFromHandle, withSvgFromString, -- ** GC-managed versions -- | These versions of the SVG loading operations use the standard Haskell -- garbage collector to manage the resources associated with the 'SVG' object. -- As such they are more convenient to use but the GC cannot give -- strong guarantees about when the resources associated with the 'SVG' object -- will be released. In most circumstances this is not a problem, especially -- if the SVG files being used are not very big. svgNewFromFile, svgNewFromHandle, svgNewFromString, ) where import Control.Monad (when) import Foreign import Foreign.C import Control.Monad.Reader (ask, liftIO) import System.IO (Handle, openFile, IOMode(ReadMode), hGetBuf) import System.Glib.GError (GError(GError), checkGError) import System.Glib.GObject (GObject(..), GObjectClass(..), wrapNewGObject, unGObject, objectUnref) import Graphics.Rendering.Cairo.Internal (Render, bracketR) {# import Graphics.Rendering.Cairo.Types #} (Cairo(Cairo)) {# context lib="librsvg" prefix="rsvg_handle" #} --------------------- -- Types -- {# pointer *RsvgHandle as SVG foreign newtype #} mkSVG = (SVG, objectUnref) unSVG (SVG obj) = obj instance GObjectClass SVG where toGObject = GObject . castForeignPtr . unSVG unsafeCastGObject = SVG . castForeignPtr . unGObject --------------------- -- Basic API -- -- block scoped versions withSvgFromFile :: FilePath -> (SVG -> Render a) -> Render a withSvgFromFile file action = withSVG $ \svg -> do liftIO $ svgParseFromFile file svg action svg withSvgFromHandle :: Handle -> (SVG -> Render a) -> Render a withSvgFromHandle hnd action = withSVG $ \svg -> do liftIO $ svgParseFromHandle hnd svg action svg withSvgFromString :: String -> (SVG -> Render a) -> Render a withSvgFromString str action = withSVG $ \svg -> do liftIO $ svgParseFromString str svg action svg withSVG :: (SVG -> Render a) -> Render a withSVG = bracketR (do {# call g_type_init #} svgPtr <- {# call unsafe new #} svgPtr' <- newForeignPtr_ svgPtr return (SVG svgPtr')) (\(SVG fptr) -> withForeignPtr fptr $ \ptr -> {# call unsafe g_object_unref #} (castPtr ptr)) -- GC managed versions svgNewFromFile :: FilePath -> IO SVG svgNewFromFile file = do svg <- svgNew svgParseFromFile file svg return svg svgNewFromHandle :: Handle -> IO SVG svgNewFromHandle hnd = do svg <- svgNew svgParseFromHandle hnd svg return svg svgNewFromString :: String -> IO SVG svgNewFromString str = do svg <- svgNew svgParseFromString str svg return svg svgNew :: IO SVG svgNew = do {# call g_type_init #} wrapNewGObject mkSVG {# call unsafe new #} -- internal implementation svgParseFromFile :: FilePath -> SVG -> IO () svgParseFromFile file svg = do hnd <- openFile file ReadMode svgParseFromHandle hnd svg svgParseFromHandle :: Handle -> SVG -> IO () svgParseFromHandle hnd svg = allocaBytes 4096 $ \bufferPtr -> do let loop = do count <- hGetBuf hnd bufferPtr 4096 when (count > 0) (checkStatus $ {# call unsafe rsvg_handle_write #} svg (castPtr bufferPtr) (fromIntegral count)) when (count == 4096) loop loop checkStatus $ {# call unsafe rsvg_handle_close #} svg svgParseFromString :: String -> SVG -> IO () svgParseFromString str svg = do let loop "" = return () loop str = case splitAt 4096 str of (chunk, str') -> do withCStringLen chunk $ \(chunkPtr, len) -> checkStatus $ {# call unsafe rsvg_handle_write #} svg (castPtr chunkPtr) (fromIntegral len) loop str' loop str checkStatus $ {# call unsafe rsvg_handle_close #} svg -- actually render it -- | render an SVG file -- -- Returns @False@ if an error was detected. -- On librsvg before 2.22.3, @svgRender@ always returns @True@. svgRender :: SVG -> Render Bool svgRender svg = do cr <- ask ret <- liftIO $ {# call unsafe render_cairo #} svg cr #if ! LIBRSVG_CHECK_VERSION(2,22,3) return True #else return (ret /= 0) #endif -- | Get the width and height of the SVG image. -- svgGetSize :: SVG -> (Int, Int) -- ^ @(width, height)@ svgGetSize svg = unsafePerformIO $ allocaBytes {# sizeof RsvgDimensionData #} $ \dimentionsPtr -> do {# call unsafe get_dimensions #} svg dimentionsPtr width <- {# get RsvgDimensionData->width #} dimentionsPtr height <- {# get RsvgDimensionData->height #} dimentionsPtr return (fromIntegral width, fromIntegral height) --------------------- -- Convenience API -- svgRenderFromFile :: FilePath -> Render Bool svgRenderFromFile file = withSvgFromFile file svgRender svgRenderFromHandle :: Handle -> Render Bool svgRenderFromHandle hnd = withSvgFromHandle hnd svgRender svgRenderFromString :: String -> Render Bool svgRenderFromString str = withSvgFromString str svgRender --------------------- -- Utils -- checkStatus :: (Ptr (Ptr ()) -> IO CInt) -> IO () checkStatus action = checkGError (\ptr -> action ptr >> return ()) (\(GError domain code msg) -> fail ("svg cairo error: " ++ msg)) svgcairo-0.12.1/demo/0000755000000000000000000000000011633370365012531 5ustar0000000000000000svgcairo-0.12.1/demo/Svg2Png.hs0000644000000000000000000000073011633370365014353 0ustar0000000000000000import System.Environment (getArgs) import Graphics.Rendering.Cairo import Graphics.Rendering.Cairo.SVG main :: IO () main = do [inFile, outFile] <- getArgs svg <- svgNewFromFile inFile let (width, height) = svgGetSize svg withImageSurface FormatARGB32 width height $ \result -> do renderWith result $ do clear svgRender svg surfaceWriteToPNG result outFile clear :: Render () clear = do save setOperator OperatorClear paint restore svgcairo-0.12.1/demo/SvgViewer.hs0000644000000000000000000000171611633370365015013 0ustar0000000000000000import System.Environment (getArgs) import Graphics.UI.Gtk import Graphics.UI.Gtk.Gdk.EventM import Graphics.Rendering.Cairo import Graphics.Rendering.Cairo.SVG main :: IO () main = do (file:_) <- getArgs svg <- svgNewFromFile file let (width, height) = svgGetSize svg initGUI dia <- dialogNew dialogAddButton dia stockOk ResponseOk contain <- dialogGetUpper dia canvas <- drawingAreaNew onSizeRequest canvas $ return (Requisition width height) canvas `on` exposeEvent $ updateCanvas canvas svg boxPackStartDefaults contain canvas widgetShow canvas dialogRun dia return () updateCanvas :: DrawingArea -> SVG -> EventM EExpose Bool updateCanvas canvas svg = do win <- eventWindow liftIO $ do let (width, height) = svgGetSize svg (width', height') <- widgetGetSize canvas renderWithDrawable win $ do scale (realToFrac width' / realToFrac width) (realToFrac height' / realToFrac height) svgRender svg return True svgcairo-0.12.1/demo/Makefile0000644000000000000000000000042411633370365014171 0ustar0000000000000000 PROGS = svg2png svgviewer SOURCES = Svg2Png.hs SvgViewer.hs all : $(PROGS) svg2png : Svg2Png.hs $(HC_RULE) svgviewer : SvgViewer.hs $(HC_RULE) HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS) clean: rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS) rm -f *.png HC=ghc