diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,12 +1,29 @@ +1.2 (27 May 2014) +----------------- + +* **New features** + + - Much improved text support using the `pango` library instead of + cairo's "toy" text API. + + - Support for linear and radial gradients on strokes and fills. + +* **Dependency/version changes + + - Allow `opt-parse-applicative-0.9` + - Allow `lens-4.2` + - Allow `mtl-2.2` + - Allow `transformers-0.4` + 1.1.0.2 (19 March 2014) ---------------------- - - Allow `lens-4.1` +- Allow `lens-4.1` 1.1.0.1 (18 March 2014) ----------------------- - - Allow `optparse-applicative-0.8` +- Allow `optparse-applicative-0.8` 1.1 (8 March 2014) ------------------ diff --git a/diagrams-cairo.cabal b/diagrams-cairo.cabal --- a/diagrams-cairo.cabal +++ b/diagrams-cairo.cabal @@ -1,5 +1,5 @@ Name: diagrams-cairo -Version: 1.1.0.2 +Version: 1.2 Synopsis: Cairo backend for diagrams drawing EDSL Description: A full-featured backend for rendering diagrams using the cairo rendering engine. @@ -49,25 +49,27 @@ Diagrams.Backend.Cairo.Text Hs-source-dirs: src Build-depends: base >= 4.2 && < 4.8, - mtl >= 2.0 && < 2.2, + mtl >= 2.0 && < 2.3, process, directory, filepath, old-time, time, - diagrams-core >= 1.0 && < 1.2, - diagrams-lib >= 1.0.1 && < 1.2, + diagrams-core >= 1.2 && < 1.3, + diagrams-lib >= 1.2 && < 1.3, cairo >= 0.12.4 && < 0.13, + pango >= 0.12.5 && < 0.13, colour, split >= 0.1.2 && < 0.3, containers >= 0.3 && < 0.6, - lens >= 3.8 && < 4.2, + lens >= 3.8 && < 4.3, data-default-class >= 0.0.1 && < 0.1, statestack >= 0.2 && < 0.3, JuicyPixels >= 3.1.3.2 && < 3.2, vector >= 0.10.0 && < 0.11, bytestring >= 0.9 && < 0.11, - optparse-applicative >= 0.7 && < 0.9, + optparse-applicative >= 0.7 && < 0.10, + transformers >= 0.3 && <0.5, hashable >= 1.1 && < 1.3 if impl(ghc < 7.6) Build-depends: ghc-prim diff --git a/src/Diagrams/Backend/Cairo/CmdLine.hs b/src/Diagrams/Backend/Cairo/CmdLine.hs --- a/src/Diagrams/Backend/Cairo/CmdLine.hs +++ b/src/Diagrams/Backend/Cairo/CmdLine.hs @@ -92,8 +92,8 @@ import Control.Lens ((^.), Lens', makeLenses) -import Diagrams.Prelude hiding (width, height, interval, Image, (<>) - , option) +import Diagrams.Prelude hiding (width, height, interval, (<>) + ,option) import Diagrams.Backend.Cairo import Diagrams.Backend.Cairo.Ptr (renderForeignPtrOpaque) import Diagrams.Backend.CmdLine diff --git a/src/Diagrams/Backend/Cairo/Internal.hs b/src/Diagrams/Backend/Cairo/Internal.hs --- a/src/Diagrams/Backend/Cairo/Internal.hs +++ b/src/Diagrams/Backend/Cairo/Internal.hs @@ -38,33 +38,35 @@ ----------------------------------------------------------------------------- module Diagrams.Backend.Cairo.Internal where -import Diagrams.Core.Compile (RNode (..), RTree, toRTree) +import Diagrams.Core.Compile import Diagrams.Core.Transform -import Diagrams.Prelude hiding (opacity, view) +import Diagrams.Prelude hiding (font, opacity, view) import Diagrams.TwoD.Adjust (adjustDia2D, setDefault2DAttributes) -import Diagrams.TwoD.Image import Diagrams.TwoD.Path (Clip (Clip), getFillRule) -import Diagrams.TwoD.Size (requiredScaleT) -import Diagrams.TwoD.Text +import Diagrams.TwoD.Size (requiredScaleT, sizePair) +import Diagrams.TwoD.Text hiding (font) import qualified Graphics.Rendering.Cairo as C import qualified Graphics.Rendering.Cairo.Matrix as CM +import qualified Graphics.Rendering.Pango as P import Control.Exception (try) import Control.Lens hiding (transform, ( # )) import Control.Monad (when) +import Control.Monad.IO.Class import qualified Control.Monad.StateStack as SS -import Control.Monad.Trans (lift, liftIO) +import Control.Monad.Trans (lift) import Data.Default.Class import qualified Data.Foldable as F -import Data.Hashable (Hashable(..)) +import Data.Hashable (Hashable (..)) import Data.List (isSuffixOf) import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Tree import Data.Typeable import GHC.Generics (Generic) +import System.IO.Unsafe -- | This data declaration is simply used as a token to distinguish -- the cairo backend: (1) when calling functions where the type @@ -144,40 +146,25 @@ } deriving (Show) - doRender _ (CairoOptions file size out _) (C r) = (renderIO, r') - where r' = runRenderM r - renderIO = do - let surfaceF s = C.renderWith s r' - - -- Everything except Dims is arbitrary. The backend - -- should have first run 'adjustDia' to update the - -- final size of the diagram with explicit dimensions, - -- so normally we would only expect to get Dims anyway. - (w,h) = case size of - Width w' -> (w',w') - Height h' -> (h',h') - Dims w' h' -> (w',h') - Absolute -> (100,100) - - case out of - PNG -> - C.withImageSurface C.FormatARGB32 (round w) (round h) $ \surface -> do - surfaceF surface - C.surfaceWriteToPNG surface file - PS -> C.withPSSurface file w h surfaceF - PDF -> C.withPDFSurface file w h surfaceF - SVG -> C.withSVGSurface file w h surfaceF - RenderOnly -> return () - - -- renderData :: Monoid' m => b -> QDiagram b v m -> Render b v - renderData _ = renderRTree . toRTree + renderRTree _ opts t = (renderIO, r) + where + r = runRenderM .runC . toRender $ t + renderIO = do + let surfaceF s = C.renderWith s r + (w,h) = sizePair (opts^.cairoSizeSpec) + case opts^.cairoOutputType of + PNG -> + C.withImageSurface C.FormatARGB32 (round w) (round h) $ \surface -> do + surfaceF surface + C.surfaceWriteToPNG surface (opts^.cairoFileName) + PS -> C.withPSSurface (opts^.cairoFileName) w h surfaceF + PDF -> C.withPDFSurface (opts^.cairoFileName) w h surfaceF + SVG -> C.withSVGSurface (opts^.cairoFileName) w h surfaceF + RenderOnly -> return () adjustDia c opts d = if _cairoBypassAdjust opts - then (opts, d # setDefault2DAttributes) - else adjustDia2D _cairoSizeSpec - setCairoSizeSpec - c opts (d # reflectY) - where setCairoSizeSpec sz o = o { _cairoSizeSpec = sz } + then (opts, mempty, d # setDefault2DAttributes) + else adjustDia2D cairoSizeSpec c opts (d # reflectY) runC :: Render Cairo R2 -> RenderM () runC (C r) = r @@ -194,20 +181,15 @@ out `hashWithSalt` adj -renderRTree :: RTree Cairo R2 a -> Render Cairo R2 -renderRTree (Node (RPrim accTr p) _) = render Cairo (transform accTr p) -renderRTree (Node (RStyle sty) ts) = C $ do +toRender :: RTree Cairo R2 a -> Render Cairo R2 +toRender (Node (RPrim p) _) = render Cairo p +toRender (Node (RStyle sty) rs) = C $ do save cairoStyle sty accumStyle %= (<> sty) - runC $ F.foldMap renderRTree ts - restore -renderRTree (Node (RFrozenTr tr) ts) = C $ do - save - liftC $ cairoTransf tr - runC $ F.foldMap renderRTree ts + runC $ F.foldMap toRender rs restore -renderRTree (Node _ ts) = F.foldMap renderRTree ts +toRender (Node _ rs) = F.foldMap toRender rs cairoFileName :: Lens' (Options Cairo R2) String cairoFileName = lens (\(CairoOptions {_cairoFileName = f}) -> f) @@ -242,7 +224,6 @@ cairoStyle s = sequence_ . catMaybes $ [ handle clip - , handle fSize , handle lFillRule , handle lWidth , handle lCap @@ -252,22 +233,21 @@ where handle :: AttributeClass a => (a -> RenderM ()) -> Maybe (RenderM ()) handle f = f `fmap` getAttr s clip = mapM_ (\p -> cairoPath p >> liftC C.clip) . op Clip - fSize = liftC . C.setFontSize . getFontSize lFillRule = liftC . C.setFillRule . fromFillRule . getFillRule - lWidth = liftC . C.setLineWidth . getLineWidth + lWidth = liftC . C.setLineWidth . fromOutput . getLineWidth lCap = liftC . C.setLineCap . fromLineCap . getLineCap lJoin = liftC . C.setLineJoin . fromLineJoin . getLineJoin lDashing (getDashing -> Dashing ds offs) = - liftC $ C.setDash ds offs + liftC $ C.setDash (map fromOutput ds) (fromOutput offs) -fromFontSlant :: FontSlant -> C.FontSlant -fromFontSlant FontSlantNormal = C.FontSlantNormal -fromFontSlant FontSlantItalic = C.FontSlantItalic -fromFontSlant FontSlantOblique = C.FontSlantOblique +fromFontSlant :: FontSlant -> P.FontStyle +fromFontSlant FontSlantNormal = P.StyleNormal +fromFontSlant FontSlantItalic = P.StyleItalic +fromFontSlant FontSlantOblique = P.StyleOblique -fromFontWeight :: FontWeight -> C.FontWeight -fromFontWeight FontWeightNormal = C.FontWeightNormal -fromFontWeight FontWeightBold = C.FontWeightBold +fromFontWeight :: FontWeight -> P.Weight +fromFontWeight FontWeightNormal = P.WeightNormal +fromFontWeight FontWeightBold = P.WeightBold -- | Apply the opacity from a style to a given color. applyOpacity :: Color c => c -> Style v -> AlphaColour Double @@ -325,13 +305,12 @@ instance Renderable (Path R2) Cairo where render _ p = C $ do cairoPath p - - f <- getStyleAttrib (toAlphaColour . getFillColor) - s <- getStyleAttrib (toAlphaColour . getLineColor) + f <- getStyleAttrib getFillTexture + s <- getStyleAttrib getLineTexture ign <- use ignoreFill - setSourceColor f + setTexture f when (isJust f && not ign) $ liftC C.fillPreserve - setSourceColor s + setTexture s liftC C.stroke -- Add a path to the Cairo context, without stroking or filling it. @@ -345,19 +324,54 @@ liftC $ uncurry C.moveTo p renderC tr +addStop :: MonadIO m => C.Pattern -> GradientStop -> m () +addStop p s = C.patternAddColorStopRGBA p (s^.stopFraction) r g b a + where + (r,g,b,a) = colorToSRGBA (s^.stopColor) + +cairoSpreadMethod :: SpreadMethod -> C.Extend +cairoSpreadMethod GradPad = C.ExtendPad +cairoSpreadMethod GradReflect = C.ExtendReflect +cairoSpreadMethod GradRepeat = C.ExtendRepeat + -- XXX should handle opacity in a more straightforward way, using -- cairo's built-in support for transparency? See also -- https://github.com/diagrams/diagrams-cairo/issues/15 . -setSourceColor :: Maybe (AlphaColour Double) -> RenderM () -setSourceColor Nothing = return () -setSourceColor (Just c) = do +setTexture :: Maybe Texture -> RenderM () +setTexture Nothing = return () +setTexture (Just (SC (SomeColor c))) = do o <- fromMaybe 1 <$> getStyleAttrib getOpacity liftC (C.setSourceRGBA r g b (o*a)) where (r,g,b,a) = colorToSRGBA c +setTexture (Just (LG g)) = liftC $ + C.withLinearPattern x0 y0 x1 y1 $ \pat -> do + mapM_ (addStop pat) (g^.lGradStops) + C.patternSetMatrix pat m + C.patternSetExtend pat (cairoSpreadMethod (g^.lGradSpreadMethod)) + C.setSource pat + where + m = CM.Matrix a1 a2 b1 b2 c1 c2 + [[a1, a2], [b1, b2], [c1, c2]] = matrixHomRep (inv (g^.lGradTrans)) + (x0, y0) = unp2 (g^.lGradStart) + (x1, y1) = unp2 (g^.lGradEnd) +setTexture (Just (RG g)) = liftC $ + C.withRadialPattern x0 y0 r0 x1 y1 r1 $ \pat -> do + mapM_ (addStop pat) (g^.rGradStops) + C.patternSetMatrix pat m + C.patternSetExtend pat (cairoSpreadMethod (g^.rGradSpreadMethod)) + C.setSource pat + where + m = CM.Matrix a1 a2 b1 b2 c1 c2 + [[a1, a2], [b1, b2], [c1, c2]] = matrixHomRep (inv (g^.rGradTrans)) + (r0, r1) = ((g^.rGradRadius0), (g^.rGradRadius1)) + (x0', y0') = unp2 (g^.rGradCenter0) + (x1', y1') = unp2 (g^.rGradCenter1) + (x0, y0, x1, y1) = (x0' * (r1-r0) / r1, y0' * (r1-r0) / r1, x1' ,y1') -- Can only do PNG files at the moment... -instance Renderable Image Cairo where - render _ (Image file sz tr) = C . liftC $ do +instance Renderable (DImage External) Cairo where + render _ (DImage path w h tr) = C . liftC $ do + let ImageRef file = path if ".png" `isSuffixOf` file then do C.save @@ -366,11 +380,12 @@ :: IO (Either IOError C.Surface)) case pngSurfChk of Right pngSurf -> do - w <- C.imageSurfaceGetWidth pngSurf - h <- C.imageSurfaceGetHeight pngSurf - cairoTransf $ requiredScaleT sz (fromIntegral w, fromIntegral h) - C.setSourceSurface pngSurf (-fromIntegral w / 2) - (-fromIntegral h / 2) + w' <- C.imageSurfaceGetWidth pngSurf + h' <- C.imageSurfaceGetHeight pngSurf + let sz = Dims (fromIntegral w) (fromIntegral h) + cairoTransf $ requiredScaleT sz (fromIntegral w', fromIntegral h') + C.setSourceSurface pngSurf (-fromIntegral w' / 2) + (-fromIntegral h' / 2) Left _ -> liftIO . putStrLn $ "Warning: can't read image file <" ++ file ++ ">" @@ -382,30 +397,51 @@ , " images in .png format. Ignoring <" ++ file ++ ">." ] --- see http://www.cairographics.org/tutorial/#L1understandingtext +if' :: Monad m => (a -> m ()) -> Maybe a -> m () +if' = maybe (return ()) + instance Renderable Text Cairo where - render _ (Text tr al str) = C $ do - ff <- fromMaybe "" <$> getStyleAttrib getFont - fs <- fromMaybe C.FontSlantNormal <$> getStyleAttrib (fromFontSlant . getFontSlant) - fw <- fromMaybe C.FontWeightNormal <$> getStyleAttrib (fromFontWeight . getFontWeight) - f <- getStyleAttrib (toAlphaColour . getFillColor) + render _ (Text tt tn al str) = C $ do + let tr = tn <> reflectionY + ff <- getStyleAttrib getFont + fs <- getStyleAttrib (fromFontSlant . getFontSlant) + fw <- getStyleAttrib (fromFontWeight . getFontWeight) + isLocal <- fromMaybe True <$> getStyleAttrib getFontSizeIsLocal + size <- getStyleAttrib (fromOutput . getFontSize) + let fSize | size == Nothing = Nothing + | isLocal = (avgScale tt *) <$> size + | otherwise = size + f <- getStyleAttrib getFillTexture save - setSourceColor f + setTexture f + layout <- liftC $ do + layout <- P.createLayout str + cairoTransf tr + P.createLayout str + ref <- liftC. liftIO $ do + font <- P.fontDescriptionNew + if' (P.fontDescriptionSetFamily font) ff + if' (P.fontDescriptionSetStyle font) fs + if' (P.fontDescriptionSetWeight font) fw + if' (P.fontDescriptionSetSize font) fSize + P.layoutSetFontDescription layout $ Just font + -- XXX should use reflection font matrix here instead? + case al of + BoxAlignedText xt yt -> do + (_,P.PangoRectangle _ _ w h) <- P.layoutGetExtents layout + return $ r2 ((lerp 0 w xt), (lerp h 0 yt)) + BaselineText -> do + baseline <- P.layoutIterGetBaseline =<< P.layoutGetIter layout + return $ r2 (0, baseline) + -- Uncomment the lines below to draw a rectangle at the extent of each Text + -- let (w, h) = unr2 $ ref ^* 2 -- XXX Debugging + -- cairoPath $ rect w h -- XXX Debugging liftC $ do - C.selectFontFace ff fs fw - -- XXX should use reflection font matrix here instead? - cairoTransf (tr <> reflectionY) - (refX, refY) <- case al of - BoxAlignedText xt yt -> do - tExt <- C.textExtents str - fExt <- C.fontExtents - let l = C.textExtentsXbearing tExt - r = C.textExtentsXadvance tExt - b = C.fontExtentsDescent fExt - t = C.fontExtentsAscent fExt - return (lerp l r xt, lerp (-b) t yt) - BaselineText -> return (0, 0) - cairoTransf (moveOriginBy (r2 (refX, -refY)) mempty) - C.showText str - C.newPath + -- C.setLineWidth 0.5 -- XXX Debugging + -- C.stroke -- XXX Debugging + -- C.newPath -- XXX Debugging + cairoTransf $ moveOriginBy ref mempty + P.updateLayout layout + P.showLayout layout + C.newPath restore diff --git a/src/Diagrams/Backend/Cairo/Text.hs b/src/Diagrams/Backend/Cairo/Text.hs --- a/src/Diagrams/Backend/Cairo/Text.hs +++ b/src/Diagrams/Backend/Cairo/Text.hs @@ -22,7 +22,23 @@ -- This works because there are instances of 'HasStyle' and 'Monoid' for -- @'Style' v@. -- ------------------------------------------------------------------------------ +-- NOTE that this module has a couple significant caveats: +-- +-- * There are some known bugs +-- () which +-- are not easily fixable (they are probably bugs in cairo itself, +-- but since we are using the \"toy text API\" they will never be +-- fixed). +-- +-- * The functions in this module will only +-- work with text whose font size is measured in @Local@ units. +-- +-- This module should thus be considered experimental/unsupported; if +-- it works for you, great, but if not you are probably out of luck. +-- See the @SVGFonts@ package for better-supported ways to accomplish +-- similar things. +-- +------------------------------------------------------------------------------- module Diagrams.Backend.Cairo.Text ( -- * Primitives