diagrams-cairo 1.1.0.2 → 1.2
raw patch · 5 files changed
+180/−109 lines, 5 filesdep +pangodep +transformersdep ~cairodep ~diagrams-coredep ~diagrams-libnew-uploader
Dependencies added: pango, transformers
Dependency ranges changed: cairo, diagrams-core, diagrams-lib, lens, mtl, optparse-applicative
Files
- CHANGES.markdown +19/−2
- diagrams-cairo.cabal +8/−6
- src/Diagrams/Backend/Cairo/CmdLine.hs +2/−2
- src/Diagrams/Backend/Cairo/Internal.hs +134/−98
- src/Diagrams/Backend/Cairo/Text.hs +17/−1
CHANGES.markdown view
@@ -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) ------------------
diagrams-cairo.cabal view
@@ -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
src/Diagrams/Backend/Cairo/CmdLine.hs view
@@ -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
src/Diagrams/Backend/Cairo/Internal.hs view
@@ -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
src/Diagrams/Backend/Cairo/Text.hs view
@@ -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+-- (<https://github.com/diagrams/diagrams-cairo/issues/19>) 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