diagrams-cairo 1.3.0.5 → 1.3.0.6
raw patch · 4 files changed
+185/−36 lines, 4 filesdep +arraydep ~lens
Dependencies added: array
Dependency ranges changed: lens
Files
- CHANGELOG.md +6/−0
- diagrams-cairo.cabal +4/−2
- src/Diagrams/Backend/Cairo/Internal.hs +105/−34
- src/Diagrams/Backend/Cairo/Text.hs +70/−0
CHANGELOG.md view
@@ -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`
diagrams-cairo.cabal view
@@ -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,
src/Diagrams/Backend/Cairo/Internal.hs view
@@ -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
+ src/Diagrams/Backend/Cairo/Text.hs view
@@ -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