diff --git a/Graphics/Rendering/Cairo.hs b/Graphics/Rendering/Cairo.hs --- a/Graphics/Rendering/Cairo.hs +++ b/Graphics/Rendering/Cairo.hs @@ -273,6 +273,7 @@ , liftIO , version , versionString + , CairoString -- * Types @@ -334,6 +335,7 @@ import Graphics.Rendering.Cairo.Internal (imageSurfaceCreateFromPNG) import Graphics.Rendering.Cairo.Types +import Graphics.Rendering.Cairo.Internal.Utilities (CairoString(..)) import qualified Graphics.Rendering.Cairo.Internal as Internal import Graphics.Rendering.Cairo.Internal (Render(..), bracketR) @@ -937,7 +939,8 @@ -- * See 'showText' for why you should use Gtk functions. -- textPath :: - String -- ^ - + CairoString string + => string -- ^ - -> Render () textPath = liftRender1 Internal.textPath @@ -1330,7 +1333,8 @@ -- text layout library in addition to cairo. -- selectFontFace :: - String -- ^ @family@ - a font family name + CairoString string + => string -- ^ @family@ - a font family name -> FontSlant -- ^ @slant@ - the slant for the font -> FontWeight -- ^ @weight@ - the weight of the font -> Render () @@ -1392,7 +1396,8 @@ -- applications. -- showText :: - String -- ^ a string of text + CairoString string + => string -- ^ a string of text -> Render () showText = liftRender1 Internal.showText @@ -1415,7 +1420,8 @@ -- 'textExtentsYadvance' values. -- textExtents :: - String -- ^ a string of text + CairoString string + => string -- ^ a string of text -> Render TextExtents textExtents = liftRender1 Internal.textExtents 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 @@ -17,8 +17,9 @@ import Foreign import Foreign.C +import Data.Text -import Graphics.Rendering.Cairo.Internal.Utilities (withUTFString) +import Graphics.Rendering.Cairo.Internal.Utilities (CairoString(..)) {#context lib="cairo" prefix="cairo"#} @@ -31,7 +32,11 @@ {#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', withUTFString* `String' } -> `()'#} +textPath :: CairoString string => Cairo -> string -> IO () +textPath c string = + withUTFString string $ \string' -> + {# call text_path #} + c 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,18 +15,37 @@ {#import Graphics.Rendering.Cairo.Types#} -import Graphics.Rendering.Cairo.Internal.Utilities (withUTFString) +import Graphics.Rendering.Cairo.Internal.Utilities (CairoString(..)) import Foreign import Foreign.C {#context lib="cairo" prefix="cairo"#} -{#fun select_font_face as selectFontFace { unCairo `Cairo', `String', cFromEnum `FontSlant', cFromEnum `FontWeight' } -> `()'#} +selectFontFace :: CairoString string => Cairo -> string -> FontSlant -> FontWeight -> IO () +selectFontFace c string slant weight = + withUTFString string $ \string' -> + {# call select_font_face #} + c string' (cFromEnum slant) (cFromEnum weight) + {#fun set_font_size as setFontSize { unCairo `Cairo', `Double' } -> `()'#} {#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', withUTFString* `String' } -> `()'#} + +showText :: CairoString string => Cairo -> string -> IO () +showText c string = + withUTFString string $ \string' -> + {# call show_text #} + c string' + {#fun font_extents as fontExtents { unCairo `Cairo', alloca- `FontExtents' peek* } -> `()'#} -{#fun text_extents as textExtents { unCairo `Cairo', withUTFString* `String', alloca- `TextExtents' peek* } -> `()'#} + +textExtents :: CairoString string => Cairo -> string -> IO TextExtents +textExtents c string = + withUTFString string $ \string' -> + alloca $ \result -> do + {# call text_extents #} + c string' result + peek result + 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Cairo.Internal.Utilities @@ -23,6 +24,8 @@ import Codec.Binary.UTF8.String import Data.Char (ord, chr) +import Data.Text (Text) +import qualified Data.Text.Foreign as T (withCStringLen) {#context lib="cairo" prefix="cairo"#} @@ -30,5 +33,11 @@ {#fun pure version as version {} -> `Int'#} {#fun pure version_string as versionString {} -> `String'#} -withUTFString :: String -> (CString -> IO a) -> IO a -withUTFString = withCAString . encodeString +class CairoString s where + withUTFString :: s -> (CString -> IO a) -> IO a + +instance CairoString [Char] where + withUTFString = withCAString . encodeString + +instance CairoString Text where + withUTFString s f = T.withCStringLen s (f . fst) diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs --- a/Gtk2HsSetup.hs +++ b/Gtk2HsSetup.hs @@ -6,9 +6,9 @@ -- | Build a Gtk2hs package. -- -module Gtk2HsSetup ( - gtk2hsUserHooks, - getPkgConfigPackages, +module Gtk2HsSetup ( + gtk2hsUserHooks, + getPkgConfigPackages, checkGtk2hsBuildtools, typeGenProgram, signalGenProgram, @@ -162,9 +162,9 @@ register :: PackageDescription -> LocalBuildInfo -> RegisterFlags -- ^Install in the user's database?; verbose -> IO () -register pkg@(library -> Just lib ) - lbi@(libraryConfig -> Just clbi) regFlags +register pkg@PackageDescription { library = Just lib } lbi regFlags = do + let clbi = LBI.getComponentLocalBuildInfo lbi LBI.CLibName installedPkgInfoRaw <- generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref @@ -176,7 +176,7 @@ -- Three different modes: case () of - _ | modeGenerateRegFile -> die "Generate Reg File not supported" + _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo | modeGenerateRegScript -> die "Generate Reg Script not supported" | otherwise -> registerPackage verbosity installedPkgInfo pkg lbi inplace @@ -188,6 +188,8 @@ where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) + regFile = fromMaybe (display (packageId pkg) <.> "conf") + (fromFlag (regGenPkgConf regFlags)) modeGenerateRegScript = fromFlag (regGenScript regFlags) inplace = fromFlag (regInPlace regFlags) packageDbs = nub $ withPackageDB lbi @@ -196,6 +198,10 @@ distPref = fromFlag (regDistPref regFlags) verbosity = fromFlag (regVerbosity regFlags) + writeRegistrationFile installedPkgInfo = do + notice verbosity ("Creating package registration file: " ++ regFile) + writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) + register _ _ regFlags = notice verbosity "No package to register" where verbosity = fromFlag (regVerbosity regFlags) @@ -283,11 +289,11 @@ -- 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 () ------------------------------------------------------------------------------ @@ -313,13 +319,12 @@ 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) + typeOpts tag = concat [ map (\val -> '-':'-':drop (length tag) field ++ '=':val) (words content) | (field,content) <- xList, tag `isPrefixOf` field, field /= (tag++"file")] @@ -327,8 +332,9 @@ | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs , let name' = filter isAlpha (display name) , tag <- name' - : [ name' ++ "-" ++ show major ++ "." ++ show digit - | digit <- [0,2..minor] ] + :[ name' ++ "-" ++ show maj ++ "." ++ show d2 + | (maj, d2) <- [(maj, d2) | maj <- [0..(major-1)], d2 <- [0,2..20]] + ++ [(major, d2) | d2 <- [0,2..minor]] ] ] signalsOpts :: [ProgArg] @@ -354,6 +360,29 @@ info verb ("Ensuring that callback hooks in "++f++" are up-to-date.") genFile signalGenProgram signalsOpts f + writeFile "gtk2hs_macros.h" $ generateMacros cPkgs + +-- Based on Cabal/Distribution/Simple/Build/Macros.hs +generateMacros :: [PackageId] -> String +generateMacros cPkgs = concat $ + "/* DO NOT EDIT: This file is automatically generated by Gtk2HsSetup.hs */\n\n" : + [ concat + ["/* package ",display pkgid," */\n" + ,"#define VERSION_",pkgname," ",show (display version),"\n" + ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + | pkgid@(PackageIdentifier name version) <- cPkgs + , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + pkgname = map fixchar (display name) + ] + where fixchar '-' = '_' + fixchar '.' = '_' + fixchar c = c + --FIXME: Cabal should tell us the selected pkg-config package versions in the -- LocalBuildInfo or equivalent. -- In the mean time, ask pkg-config again. @@ -424,14 +453,14 @@ -- 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. +-- 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 + 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 @@ -465,8 +494,8 @@ return (programName prog, location) ) programs let printError name = do - putStrLn $ "Cannot find " ++ name ++ "\n" + 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) + when (isNothing location) (printError name) diff --git a/SetupWrapper.hs b/SetupWrapper.hs --- a/SetupWrapper.hs +++ b/SetupWrapper.hs @@ -9,7 +9,7 @@ import Distribution.Simple.Program import Distribution.Simple.Compiler import Distribution.Simple.BuildPaths (exeExtension) -import Distribution.Simple.Configure (configCompiler) +import Distribution.Simple.Configure (configCompilerEx) import Distribution.Simple.GHC (getInstalledPackages) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Version @@ -115,7 +115,7 @@ when outOfDate $ do debug verbosity "Setup script is out of date, compiling..." - (comp, conf) <- configCompiler (Just GHC) Nothing Nothing + (comp, _, conf) <- configCompilerEx (Just GHC) Nothing Nothing defaultProgramConfiguration verbosity cabalLibVersion <- cabalLibVersionToUse comp conf let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion diff --git a/cairo.cabal b/cairo.cabal --- a/cairo.cabal +++ b/cairo.cabal @@ -1,5 +1,5 @@ Name: cairo -Version: 0.12.5.3 +Version: 0.13.0.0 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 @@ -9,7 +9,7 @@ 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 Cairo library. Description: Cairo is a library to render high quality vector graphics. There exist various backends that allows rendering to Gtk windows, PDF, @@ -47,8 +47,9 @@ Library build-depends: base >= 4 && < 5, utf8-string >= 0.2 && < 0.4, + text >= 0.11.0.6 && < 1.2, bytestring, mtl, array - build-tools: gtk2hsC2hs >= 0.13.8 + build-tools: gtk2hsC2hs >= 0.13.11 exposed-modules: Graphics.Rendering.Cairo Graphics.Rendering.Cairo.Matrix Graphics.Rendering.Cairo.Types