Add Cairo.Text module

Add `textLineBoundedIO`, `textVisualBoundedIO`.

These were removed in 6efe08a, because they used the toy text API, and
rendering now uses Pango.  The versions added in this commit take a Text
value, not a String.  This lets us place the origin according to
Alignment, and apply non-uniform scales.

Further usability testing is needed.  Making Text values could be more
convenient, and I'm not sure how passing the Style around works with
different output resolutions.

src/Diagrams/Backend/Cairo/Internal.hs

@@ -397,43 +397,51 @@ 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

@@ -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