diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +## [v1.3.0.6](https://github.com/diagrams/diagrams-cairo/tree/v1.3.0.6) (2016-05-01) + +- allow `lens-4.14` + +[Full Changelog](https://github.com/diagrams/diagrams-cairo/compare/v1.3.0.5...v1.3.0.6) + ## [v1.3.0.5](https://github.com/diagrams/diagrams-cairo/tree/v1.3.0.5) (2015-09-29) - Allow `optparse-applicative-0.12` 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.3.0.5 +Version: 1.3.0.6 Synopsis: Cairo backend for diagrams drawing EDSL Description: A full-featured backend for rendering diagrams using the cairo rendering engine. @@ -51,6 +51,7 @@ Diagrams.Backend.Cairo.Internal Diagrams.Backend.Cairo.List Diagrams.Backend.Cairo.Ptr + Diagrams.Backend.Cairo.Text Hs-source-dirs: src Build-depends: base >= 4.2 && < 4.9, mtl >= 2.0 && < 2.3, @@ -62,11 +63,12 @@ colour, split >= 0.1.2 && < 0.3, containers >= 0.3 && < 0.6, - lens >= 3.8 && < 4.14, + lens >= 3.8 && < 4.15, data-default-class >= 0.0.1 && < 0.1, statestack >= 0.2 && < 0.3, JuicyPixels >= 3.1.3.2 && < 3.3, vector >= 0.10.0 && < 0.12, + array >= 0.4.0 && < 0.6, bytestring >= 0.9 && < 0.11, optparse-applicative >= 0.10 && < 0.13, transformers >= 0.3 && <0.5, 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 @@ -9,6 +9,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | @@ -51,6 +52,10 @@ import qualified Graphics.Rendering.Cairo.Matrix as CM import qualified Graphics.Rendering.Pango as P +import Codec.Picture +import Codec.Picture.Types (convertImage, promoteImage, packPixel) + + import Control.Exception (try) import Control.Monad (when) import Control.Monad.IO.Class @@ -62,6 +67,9 @@ import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Tree import Data.Typeable +import qualified Data.Array.MArray as MA +import Data.Word (Word32) +import Data.Bits (rotateL, (.&.)) import GHC.Generics (Generic) -- | This data declaration is simply used as a token to distinguish @@ -393,47 +401,110 @@ , " images in .png format. Ignoring <" ++ file ++ ">." ] +-- Copied from Rasterific backend. This function should probably be in JuicyPixels! +toImageRGBA8 :: DynamicImage -> Image PixelRGBA8 +toImageRGBA8 (ImageRGBA8 i) = i +toImageRGBA8 (ImageRGB8 i) = promoteImage i +toImageRGBA8 (ImageYCbCr8 i) = promoteImage (convertImage i :: Image PixelRGB8) +toImageRGBA8 (ImageY8 i) = promoteImage i +toImageRGBA8 (ImageYA8 i) = promoteImage i +toImageRGBA8 (ImageCMYK8 i) = promoteImage (convertImage i :: Image PixelRGB8) +toImageRGBA8 _ = error "Unsupported Pixel type" + +instance Renderable (DImage Double Embedded) Cairo where + -- render _ (DImage path w h tr) = + render _ (DImage iD _w _h tr) = C . liftC $ do + C.save + cairoTransf (tr <> reflectionY) + + let fmt = C.FormatARGB32 + dataSurf <- liftIO $ C.createImageSurface fmt w h + + surData :: C.SurfaceData Int Word32 + <- liftIO $ C.imageSurfaceGetPixels dataSurf + + stride <- C.imageSurfaceGetStride dataSurf + + _ <- forMOf imageIPixels img $ \(x, y, px) -> do + let p = y * (stride`div`4) + x + liftIO . MA.writeArray surData p $ toARGB px + return px + + C.surfaceMarkDirty dataSurf + + w' <- C.imageSurfaceGetWidth dataSurf + h' <- C.imageSurfaceGetHeight dataSurf + let sz = fromIntegral <$> dims2D w h + cairoTransf $ requiredScaling sz (fromIntegral <$> V2 w' h') + C.setSourceSurface dataSurf (-fromIntegral w' / 2) + (-fromIntegral h' / 2) + + C.paint + C.restore + where + ImageRaster dImg = iD + img@(Image w h _) = toImageRGBA8 dImg + + +{-# INLINE toARGB #-} +-- Actually the name should be toBGRA, since that's the component order used by Cairo. +-- Really, what's happening here is just a swap of the R and B channels. +-- It seems a lot like this is dependent on endianness; perhaps we should handle this... +toARGB :: PixelRGBA8 -> Word32 +toARGB px = ga + rotateL rb 16 + where rgba = packPixel px + rb = rgba .&. 0x00FF00FF + ga = rgba .&. 0xFF00FF00 + if' :: Monad m => (a -> m ()) -> Maybe a -> m () if' = maybe (return ()) instance Renderable (Text Double) Cairo where - render _ (Text tt al str) = C $ do - let tr = tt <> reflectionY - ff <- getStyleAttrib getFont - fs <- getStyleAttrib (fromFontSlant . getFontSlant) - fw <- getStyleAttrib (fromFontWeight . getFontWeight) - size' <- getStyleAttrib getFontSize - f <- getStyleAttrib getFillTexture + render _ txt = C $ do save - setTexture f - layout <- liftC $ do - 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) size' - 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 (w * xt, h * (1 - yt)) - BaselineText -> do - baseline <- P.layoutIterGetBaseline =<< P.layoutGetIter layout - return $ r2 (0, baseline) + setTexture =<< getStyleAttrib getFillTexture + sty <- use accumStyle + layout <- liftC $ layoutStyledText sty txt -- 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.setLineWidth 0.5 -- XXX Debugging - -- C.stroke -- XXX Debugging - -- C.newPath -- XXX Debugging - let t = moveOriginBy ref mempty :: T2 Double - cairoTransf t - P.updateLayout layout - P.showLayout layout - C.newPath + -- C.setLineWidth 0.5 -- XXX Debugging + -- C.stroke -- XXX Debugging + -- C.newPath -- XXX Debugging + P.showLayout layout + C.newPath restore + +layoutStyledText :: Style V2 Double -> Text Double -> C.Render P.PangoLayout +layoutStyledText sty (Text tt al str) = + let tr = tt <> reflectionY + styAttr :: AttributeClass a => (a -> b) -> Maybe b + styAttr f = fmap f $ getAttr sty + ff = styAttr getFont + fs = styAttr fromFontSlant + fw = styAttr fromFontWeight + size' = styAttr getFontSize + in do + cairoTransf tr -- non-uniform scale + layout <- P.createLayout str + -- set font, including size + liftIO $ do + font <- P.fontDescriptionNew + if' (P.fontDescriptionSetFamily font) ff + if' (P.fontDescriptionSetStyle font) fs + if' (P.fontDescriptionSetWeight font) fw + if' (P.fontDescriptionSetSize font) size' + P.layoutSetFontDescription layout $ Just font + -- geometric translation + ref <- liftIO $ case al of + BoxAlignedText xt yt -> do + (_,P.PangoRectangle _ _ w h) <- P.layoutGetExtents layout + return $ r2 (w * xt, h * (1 - yt)) + BaselineText -> do + baseline <- P.layoutIterGetBaseline =<< P.layoutGetIter layout + return $ r2 (0, baseline) + let t = moveOriginBy ref mempty :: T2 Double + cairoTransf t + P.updateLayout layout + return layout diff --git a/src/Diagrams/Backend/Cairo/Text.hs b/src/Diagrams/Backend/Cairo/Text.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/Cairo/Text.hs @@ -0,0 +1,70 @@ +-- | +-- Module : Diagrams.Backend.Cairo.Text +-- Copyright : (c) 2015 Diagrams-cairo team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- This module provides convenience functions for querying information +-- from cairo. In particular, this provides utilities for information +-- about fonts, and creating text primitives with bounds based on the +-- font being used. To render text with automatically determined +-- envelopes, use 'textLineBounded', 'textLineBoundedIO', +-- 'textVisualBounded', or 'textVisualBoundedIO'. +-- +-- Many of these functions take a 'Style' 'V2' 'Double' parameter, +-- determining the style to apply to the text before rendering / +-- querying information about the text. These 'Style' 'V2' 'Double' +-- parameters can be created a variety of ways, but the most direct +-- will likely be by applying style-transforming functions such as +-- 'font', 'fontSize', 'fontSlant', and 'fontWeight' to 'mempty'. +-- This works because there are instances of 'HasStyle' and 'Monoid' +-- for @'Style' v@. + +module Diagrams.Backend.Cairo.Text + ( + -- | These create diagrams instantiated with extent-based envelopes. + textLineBoundedIO + , textVisualBoundedIO + + -- * Utilities + , queryCairo, unsafeCairo + ) where + +import Diagrams.Backend.Cairo.Internal +import qualified Diagrams.BoundingBox as BB +import Diagrams.Prelude hiding (height, view) +import Diagrams.TwoD.Text hiding (font) + +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Pango as P + +import System.IO.Unsafe + +-- | Executes a cairo action on a dummy, zero-size image surface, in order to +-- query things like font information. +queryCairo :: C.Render a -> IO a +queryCairo c = C.withImageSurface C.FormatA1 0 0 (`C.renderWith` c) + +-- | Unsafely invokes 'queryCairo' using 'unsafePerformIO'. +unsafeCairo :: C.Render a -> a +unsafeCairo = unsafePerformIO . queryCairo + +-- | Creates text diagrams with their envelopes set such that using +-- @'vcat' . map ('textLineBounded' style)@ stacks them in the way that +-- the font designer intended. Pango refers to this as logical extents. +textLineBoundedIO :: Style V2 Double -> Text Double -> IO (Diagram Cairo) +textLineBoundedIO = textLineIO fst + +-- | Creates a text diagram with its envelope set to enclose the glyphs of the text, +-- including leading (though not trailing) whitespace. +textVisualBoundedIO :: Style V2 Double -> Text Double -> IO (Diagram Cairo) +textVisualBoundedIO = textLineIO snd + +-- | Abstract common code from @textLineBoundedIO@ and @textVisualBoundedIO@ +-- textLineIO :: ((a,a) -> a) -> Style V2 Double -> Text Double -> IO (Diagram Cairo) +textLineIO :: ((P.PangoRectangle,P.PangoRectangle) -> P.PangoRectangle) -> Style V2 Double -> Text Double -> IO (Diagram Cairo) +textLineIO pick sty txt = do + layout <- queryCairo $ layoutStyledText sty txt + P.PangoRectangle x y w h <- pick <$> P.layoutGetExtents layout + let bb = BB.fromCorners (mkP2 x y) (mkP2 (x + w) (y + h)) + return $ mkQD (Prim txt) (getEnvelope bb) mempty mempty mempty